41c0f8f · rowtype-yoga/purescript-native

CONTRIBUTING.md+1−1

compare with golang

unifiedsplit

@@ -12,7 +12,7 @@ Please follow the following guidelines:

12

13- Add at least a test to `examples/passing/` and possibly to `examples/failing`.

14- Build the binaries and libs with `stack build`

15−- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests.

15+- Run the test suite with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests.

16- Build the core libraries by running the script in `core-tests`.

17

18## Code Review

CONTRIBUTORS.md+1

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

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

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

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

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

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

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

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

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

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

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

README.md+1−1

@@ -17,7 +17,7 @@ A small strongly typed programming language with expressive types that compiles

17## Resources

18

19- [PureScript book](https://leanpub.com/purescript/read)

20−- [Wiki](http://wiki.purescript.org)

20+- [Documentation](https://github.com/purescript/documentation)

21- [Try PureScript](http://try.purescript.org)

22- [Pursuit Package Index](http://pursuit.purescript.org/)

23

appveyor.yml+4−1

@@ -3,6 +3,7 @@ version: '{build}'

3environment:

4 # Keep the path as short as possible, just in case.

5 STACK_ROOT: c:\s

6+ STACK_VER: 1.2.0

6 RELEASE_USER: purescript

7 RELEASE_USER: purescript

7 RELEASE_REPO: purescript

8 RELEASE_REPO: purescript

8cache:

9cache:

@@ -15,7 +16,9 @@ install:

15- ps: |

16- ps: |

16 New-Item -ItemType Directory -Force -Path C:\tools

17 New-Item -ItemType Directory -Force -Path C:\tools

17 $env:Path += ";C:\tools"

18 $env:Path += ";C:\tools"

19+ $stackRelease = "stack-$env:STACK_VER-windows-x86_64"

20+ $downloadUrl = "https://github.com/commercialhaskell/stack/releases/download/v$env:STACK_VER/$stackRelease.zip"

18− (New-Object Net.WebClient).DownloadFile('https://www.stackage.org/stack/windows-x86_64', 'c:\tools\stack.zip')

21+ (New-Object Net.WebClient).DownloadFile($downloadUrl, 'c:\tools\stack.zip')

19 pushd c:\tools

22 pushd c:\tools

20 7z x c:\tools\stack.zip stack.exe

23 7z x c:\tools\stack.zip stack.exe

21 popd

24 popd

examples/docs/src/TypeClassWithFunDeps.pursnew file+5

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

1+

2+module TypeClassWithFunDeps where

3+

4+class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where

5+ aMember :: a

examples/failing/2434.pursnew file+5

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

1+-- @shouldFailWith ErrorParsingModule

2+module Main where

3+

4+x :: Char

5+x = '\x10000'

examples/failing/RowInInstanceNotDetermined0.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

3+

4+import Prelude

5+

6+-- no fundeps

7+class C a b

8+instance c :: C Unit {}

9+

examples/failing/RowInInstanceNotDetermined1.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

3+

4+import Prelude

5+

6+-- `c` not mentioned in any fundeps

7+class C a b c | a -> b

8+instance c :: C Unit Unit {}

9+

examples/failing/RowInInstanceNotDetermined2.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

3+

4+import Prelude

5+

6+-- `b` isn't determined by anything that `b` doesn't determine

7+class C a b | a -> b, b -> a

8+instance c :: C Unit {}

9+

examples/passing/2438.pursnew file+8

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

1+module Main where

2+

3+import Control.Monad.Eff.Console (log)

4+

5+done :: String

6+done = {"𝌆": "Done"}."𝌆"

7+

8+main = log done

examples/passing/RowInInstanceHeadDetermined.pursnew file+40

@@ -0,0 +1,40 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console (log)

5+

6+data Empty = Empty

7+data Cons = Cons

8+

9+

10+-- simple case

11+class Simple a b | a -> b where c :: a -> b

12+instance simple0 :: Simple Empty {} where c _ = {}

13+instance simple1 :: Simple Cons {foo :: Cons} where c cons = {foo: cons}

14+

15+

16+-- simple transitive example

17+class Transitive a b c | a -> b, b -> c where d :: a -> c

18+instance transitive :: Transitive Empty {} {} where d _ = {}

19+

20+

21+-- transitive example with cycles

22+class Cyclic a b c d | a -> b, b -> a

23+ , a -> c

24+ , c -> d, d -> c

25+instance cyclic :: Cyclic Empty Empty {} {}

26+

27+

28+-- Determined cycle

29+class DeterminedCycle a b c | a -> b

30+ , b -> c, c -> b

31+instance determinedCycle :: DeterminedCycle Empty {} {}

32+

33+

34+-- multiple determiners

35+class MultipleDeterminers a b c d | a b -> c d

36+instance multipleDeterminers :: MultipleDeterminers Empty Empty {} {}

37+

38+

39+main = log "Done"

40+

examples/passing/SolvingIsSymbol.pursnew file+13

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

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

6+

7+-- Here we import as alias of reflectSymbol without importing Data.Symbol. However,

8+-- Data.Symbol should be implicitly imported as we have an instance of IsSymbol solved.

9+import SolvingIsSymbol.Lib (literalSymbol, libReflectSymbol)

10+

11+main = do

12+ let lit = libReflectSymbol literalSymbol

13+ when (lit == "literal") (log "Done")

examples/passing/SolvingIsSymbol/Lib.pursnew file+10

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

1+module SolvingIsSymbol.Lib where

2+

3+import Data.Symbol

4+

5+literalSymbol :: SProxy "literal"

6+literalSymbol = SProxy

7+

8+libReflectSymbol :: forall s. IsSymbol s => SProxy s -> String

9+libReflectSymbol = reflectSymbol

10+

examples/passing/StringEscapes.purs+15−6

@@ -1,17 +1,26 @@

1module Main where

2

3−import Prelude ((==), bind)

3+import Prelude ((==), (/=), (<>), bind)

4−import Test.Assert (assert)

4+import Test.Assert (assert, assert')

5import Control.Monad.Eff.Console (log)

6

7singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C"

8hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0"

9decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0"

10surrogatePair = "\xD834\xDF06" == "\x1D306"

11+highSurrogate = "\xD834"

12+lowSurrogate = "\xDF06"

13+loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306"

14+outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834"

15+replacement = "\xFFFD"

16+notReplacing = replacement /= highSurrogate

11

17

12main = do

18main = do

13− assert singleCharacter

19+ assert' "single-character escape sequences" singleCharacter

14− assert hex

20+ assert' "hex escape sequences" hex

15− assert decimal

21+ assert' "decimal escape sequences" decimal

16− assert surrogatePair

22+ assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair

23+ assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates

24+ assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates

25+ -- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing

17 log "Done"

26 log "Done"

examples/warning/2140.pursnew file+5

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

1+-- @shouldWarnWith ShadowedTypeVar

2+module Main where

3+

4+class Test a where

5+ f :: (forall a. a -> a) -> a -> a

hierarchy/Main.hs+2−1

@@ -25,6 +25,7 @@ import Data.List (intercalate,nub,sort)

25import Data.Foldable (for_)

26import Data.Version (showVersion)

27import Data.Monoid ((<>))

28+import qualified Data.Text as T

28

29

29import Options.Applicative (Parser)

30import Options.Applicative (Parser)

30import qualified Options.Applicative as Opts

31import qualified Options.Applicative as Opts

@@ -56,7 +57,7 @@ instance Ord SuperMap where

56 getCls = either id snd

57 getCls = either id snd

57

58

58runModuleName :: P.ModuleName -> String

59runModuleName :: P.ModuleName -> String

59−runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)

60+runModuleName (P.ModuleName pns) = intercalate "_" ((T.unpack . P.runProperName) `map` pns)

60

61

61readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])

62readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])

62readInput paths = do

63readInput paths = do

psc-bundle/Main.hs+2−2

@@ -20,7 +20,7 @@ import System.FilePath (takeDirectory)

20import System.FilePath.Glob (glob)

21import System.Exit (exitFailure)

22import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)

23−import System.IO.UTF8 (readUTF8File)

23+import System.IO.UTF8 (readUTF8File, writeUTF8File)

24import System.Directory (createDirectoryIfMissing)

25

26import Language.PureScript.Bundle

@@ -110,7 +110,7 @@ main = do

110 case optionsOutputFile opts of

111 Just outputFile -> do

112 createDirectoryIfMissing True (takeDirectory outputFile)

113− writeFile outputFile js

113+ writeUTF8File outputFile js

114 Nothing -> putStrLn js

115 where

116 infoModList = Opts.fullDesc <> headerInfo <> footerInfo

psc-docs/Main.hs+5−4

@@ -8,6 +8,7 @@ import Control.Arrow (first, second)

8import Control.Category ((>>>))

9import Control.Monad.Writer

10import Data.Text (Text)

11+import qualified Data.Text as T

11import Data.Function (on)

12import Data.Function (on)

12import Data.List

13import Data.List

13import Data.Maybe (fromMaybe)

14import Data.Maybe (fromMaybe)

@@ -82,12 +83,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

82 where

83 where

83 guardMissing [] = return ()

84 guardMissing [] = return ()

84 guardMissing [mn] = do

85 guardMissing [mn] = do

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

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

86 exitFailure

87 exitFailure

87 guardMissing mns = do

88 guardMissing mns = do

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

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

89 forM_ mns $ \mn ->

90 forM_ mns $ \mn ->

90− hPutStrLn stderr (" * " ++ P.runModuleName mn)

91+ hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn))

91 exitFailure

92 exitFailure

92

93

93 successOrExit :: Either P.MultipleErrors a -> IO a

94 successOrExit :: Either P.MultipleErrors a -> IO a

@@ -186,11 +187,11 @@ parseItem :: String -> DocgenOutputItem

186parseItem s = case elemIndex ':' s of

187parseItem s = case elemIndex ':' s of

187 Just i ->

188 Just i ->

188 s # splitAt i

189 s # splitAt i

189− >>> first P.moduleNameFromString

190+ >>> first (P.moduleNameFromString . T.pack)

190 >>> second (drop 1)

191 >>> second (drop 1)

191 >>> IToFile

192 >>> IToFile

192 Nothing ->

193 Nothing ->

193− IToStdOut (P.moduleNameFromString s)

194+ IToStdOut (P.moduleNameFromString (T.pack s))

194

195

195 where

196 where

196 infixr 1 #

197 infixr 1 #

psc-docs/Tags.hs+3−1

@@ -1,9 +1,11 @@

1module Tags where

2

3+import Control.Arrow (first)

4+import qualified Data.Text as T

3import qualified Language.PureScript as P

5import qualified Language.PureScript as P

4

6

5tags :: P.Module -> [(String, Int)]

7tags :: P.Module -> [(String, Int)]

6−tags = concatMap dtags . P.exportedDeclarations

8+tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations

7 where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d

9 where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d

8 where tag name = (name, line)

10 where tag name = (name, line)

9 line = P.sourcePosLine $ P.spanStart sp

11 line = P.sourcePosLine $ P.spanStart sp

psc-ide-client/Main.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2module Main where

1module Main where

3

2

4import Prelude ()

3import Prelude ()

psc-ide-server/Main.hs+31−11

@@ -30,6 +30,7 @@ import qualified Data.Text.IO as T

30import qualified Data.ByteString.Lazy.Char8 as BS8

31import Data.Version (showVersion)

32import Language.PureScript.Ide

33+import Language.PureScript.Ide.Command

33import Language.PureScript.Ide.Util

34import Language.PureScript.Ide.Util

34import Language.PureScript.Ide.Error

35import Language.PureScript.Ide.Error

35import Language.PureScript.Ide.Types

36import Language.PureScript.Ide.Types

@@ -41,10 +42,10 @@ import Network.Socket hiding (PortNumber, Type,

41import Options.Applicative (ParseError (..))

42import Options.Applicative (ParseError (..))

42import qualified Options.Applicative as Opts

43import qualified Options.Applicative as Opts

43import System.Directory

44import System.Directory

45+import System.Info as SysInfo

44import System.FilePath

46import System.FilePath

45import System.IO hiding (putStrLn, print)

47import System.IO hiding (putStrLn, print)

46import System.IO.Error (isEOFError)

48import System.IO.Error (isEOFError)

47−

48import qualified Paths_purescript as Paths

49import qualified Paths_purescript as Paths

49

50

50listenOnLocalhost :: PortNumber -> IO Socket

51listenOnLocalhost :: PortNumber -> IO Socket

@@ -66,12 +67,15 @@ data Options = Options

66 , optionsOutputPath :: FilePath

67 , optionsOutputPath :: FilePath

67 , optionsPort :: PortNumber

68 , optionsPort :: PortNumber

68 , optionsNoWatch :: Bool

69 , optionsNoWatch :: Bool

70+ , optionsPolling :: Bool

69 , optionsDebug :: Bool

71 , optionsDebug :: Bool

70− }

72+ , optionsLoglevel :: IdeLogLevel

73+ } deriving (Show)

71

74

72main :: IO ()

75main :: IO ()

73main = do

76main = do

74− Options dir globs outputPath port noWatch debug <- Opts.execParser opts

77+ opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts

78+ when debug (putText "Parsed Options:" *> print opts')

75 maybe (pure ()) setCurrentDirectory dir

79 maybe (pure ()) setCurrentDirectory dir

76 ideState <- newTVarIO emptyIdeState

80 ideState <- newTVarIO emptyIdeState

77 cwd <- getCurrentDirectory

81 cwd <- getCurrentDirectory

@@ -84,9 +88,9 @@ main = do

84 putText "psc-ide needs you to compile your project (for example by running pulp build)"

88 putText "psc-ide needs you to compile your project (for example by running pulp build)"

85

89

86 unless noWatch $

90 unless noWatch $

87− void (forkFinally (watcher ideState fullOutputPath) print)

91+ void (forkFinally (watcher polling ideState fullOutputPath) print)

88−

92+ -- TODO: deprecate and get rid of `debug`

89− let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs}

93+ let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs}

90 env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}

94 env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}

91 startServer port env

95 startServer port env

92 where

96 where

@@ -98,19 +102,32 @@ main = do

98 <*> (fromIntegral <$>

102 <*> (fromIntegral <$>

99 Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))

103 Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))

100 <*> Opts.switch (Opts.long "no-watch")

104 <*> Opts.switch (Opts.long "no-watch")

105+ <*> flipIfWindows (Opts.switch (Opts.long "polling"))

101 <*> Opts.switch (Opts.long "debug")

106 <*> Opts.switch (Opts.long "debug")

107+ <*> (parseLogLevel <$> Opts.strOption

108+ (Opts.long "log-level"

109+ `mappend` Opts.value ""

110+ `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))

102 opts = Opts.info (version <*> Opts.helper <*> parser) mempty

111 opts = Opts.info (version <*> Opts.helper <*> parser) mempty

112+ parseLogLevel s = case s of

113+ "debug" -> LogDebug

114+ "perf" -> LogPerf

115+ "all" -> LogAll

116+ "none" -> LogNone

117+ _ -> LogDefault

103 version = Opts.abortOption

118 version = Opts.abortOption

104 (InfoMsg (showVersion Paths.version))

119 (InfoMsg (showVersion Paths.version))

105 (Opts.long "version" `mappend` Opts.help "Show the version number")

120 (Opts.long "version" `mappend` Opts.help "Show the version number")

106

121

122+ -- polling is the default on Windows and the flag turns it off. See

123+ -- #2209 and #2414 for explanations

124+ flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)

125+

107startServer :: PortNumber -> IdeEnvironment -> IO ()

126startServer :: PortNumber -> IdeEnvironment -> IO ()

108startServer port env = withSocketsDo $ do

127startServer port env = withSocketsDo $ do

109 sock <- listenOnLocalhost port

128 sock <- listenOnLocalhost port

110− runLogger (runReaderT (forever (loop sock)) env)

129+ runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)

111 where

130 where

112− runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))

113−

114 loop :: (Ide m, MonadLogger m) => Socket -> m ()

131 loop :: (Ide m, MonadLogger m) => Socket -> m ()

115 loop sock = do

132 loop sock = do

116 accepted <- runExceptT $ acceptCommand sock

133 accepted <- runExceptT $ acceptCommand sock

@@ -119,7 +136,11 @@ startServer port env = withSocketsDo $ do

119 Right (cmd, h) -> do

136 Right (cmd, h) -> do

120 case decodeT cmd of

137 case decodeT cmd of

121 Just cmd' -> do

138 Just cmd' -> do

139+ let message duration =

140+ "Command " <> commandName cmd'

141+ <> " took "

142+ <> displayTimeSpec duration

122− result <- runExceptT (handleCommand cmd')

143+ result <- logPerf message (runExceptT (handleCommand cmd'))

123 -- $(logDebug) ("Answer was: " <> T.pack (show result))

144 -- $(logDebug) ("Answer was: " <> T.pack (show result))

124 liftIO (hFlush stdout)

145 liftIO (hFlush stdout)

125 case result of

146 case result of

@@ -132,7 +153,6 @@ startServer port env = withSocketsDo $ do

132 hFlush stdout

153 hFlush stdout

133 liftIO (hClose h)

154 liftIO (hClose h)

134

155

135−

136acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)

156acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)

137 => Socket -> m (Text, Handle)

157 => Socket -> m (Text, Handle)

138acceptCommand sock = do

158acceptCommand sock = do

psc-ide-server/README.md+4−1

@@ -22,7 +22,10 @@ It supports the following options:

22- `--output-directory`: Specify where to look for compiled output inside your

23 project directory. Defaults to `output/`, relative to either the current

24 directory or the directory specified by `-d`.

25−- `--debug`: Enables some logging meant for debugging

25+- `--polling`: Uses polling instead of file system events to watch the externs

26+ files. This flag is reversed on Windows and polling is the default.

27+- `--debug`: DEPRECATED: use --log-level="debug"

28+- `--log-level`: Can be set to one of "all", "none", "debug" and "perf"

26- `--no-watch`: Disables the filewatcher

29- `--no-watch`: Disables the filewatcher

27- `--version`: Output psc-ide version

30- `--version`: Output psc-ide version

28

31

purescript.cabal+5−2

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

1name: purescript

2−version: 0.10.2

2+version: 0.10.3

3cabal-version: >=1.8

4build-type: Simple

5license: BSD3

@@ -50,6 +50,7 @@ extra-source-files: examples/passing/*.purs

50 , examples/passing/ResolvableScopeConflict2/*.purs

51 , examples/passing/ResolvableScopeConflict3/*.purs

52 , examples/passing/ShadowedModuleName/*.purs

53+ , examples/passing/SolvingIsSymbol/*.purs

53 , examples/passing/TransitiveImport/*.purs

54 , examples/passing/TransitiveImport/*.purs

54 , examples/passing/TypeOperators/*.purs

55 , examples/passing/TypeOperators/*.purs

55 , examples/passing/TypeWithoutParens/*.purs

56 , examples/passing/TypeWithoutParens/*.purs

@@ -292,8 +293,9 @@ library

292 Language.PureScript.Ide.Conversions

293 Language.PureScript.Ide.Conversions

293 Language.PureScript.Ide.Externs

294 Language.PureScript.Ide.Externs

294 Language.PureScript.Ide.Error

295 Language.PureScript.Ide.Error

295− Language.PureScript.Ide.Imports

296 Language.PureScript.Ide.Filter

297+ Language.PureScript.Ide.Imports

298+ Language.PureScript.Ide.Logging

297 Language.PureScript.Ide.Matcher

299 Language.PureScript.Ide.Matcher

298 Language.PureScript.Ide.Pursuit

300 Language.PureScript.Ide.Pursuit

299 Language.PureScript.Ide.Rebuild

301 Language.PureScript.Ide.Rebuild

@@ -333,6 +335,7 @@ library

333 PatternSynonyms

335 PatternSynonyms

334 RankNTypes

336 RankNTypes

335 RecordWildCards

337 RecordWildCards

338+ OverloadedStrings

336 ScopedTypeVariables

339 ScopedTypeVariables

337 TupleSections

340 TupleSections

338 ViewPatterns

341 ViewPatterns

src/Control/Monad/Supply/Class.hs+3−2

@@ -12,6 +12,7 @@ import Prelude.Compat

12import Control.Monad.Supply

13import Control.Monad.State

14import Control.Monad.Writer

15+import Data.Text (Text, pack)

15

16

16class Monad m => MonadSupply m where

17class Monad m => MonadSupply m where

17 fresh :: m Integer

18 fresh :: m Integer

@@ -31,5 +32,5 @@ instance Monad m => MonadSupply (SupplyT m) where

31instance MonadSupply m => MonadSupply (StateT s m)

32instance MonadSupply m => MonadSupply (StateT s m)

32instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)

33instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)

33

34

34−freshName :: MonadSupply m => m String

35+freshName :: MonadSupply m => m Text

35−freshName = fmap (('$' :) . show) fresh

36+freshName = fmap (("$" <> ) . pack . show) fresh

src/Language/PureScript/AST/Declarations.hs+20−18

@@ -11,6 +11,7 @@ import Control.Monad.Identity

11

12import Data.Aeson.TH

13import qualified Data.Map as M

14+import Data.Text (Text)

14

15

15import Language.PureScript.AST.Binders

16import Language.PureScript.AST.Binders

16import Language.PureScript.AST.Literals

17import Language.PureScript.AST.Literals

@@ -47,7 +48,7 @@ data SimpleErrorMessage

47 | UnnecessaryFFIModule ModuleName FilePath

48 | UnnecessaryFFIModule ModuleName FilePath

48 | MissingFFIImplementations ModuleName [Ident]

49 | MissingFFIImplementations ModuleName [Ident]

49 | UnusedFFIImplementations ModuleName [Ident]

50 | UnusedFFIImplementations ModuleName [Ident]

50− | InvalidFFIIdentifier ModuleName String

51+ | InvalidFFIIdentifier ModuleName Text

51 | CannotGetFileInfo FilePath

52 | CannotGetFileInfo FilePath

52 | CannotReadFile FilePath

53 | CannotReadFile FilePath

53 | CannotWriteFile FilePath

54 | CannotWriteFile FilePath

@@ -68,7 +69,7 @@ data SimpleErrorMessage

68 | DeclConflict Name Name

69 | DeclConflict Name Name

69 | ExportConflict (Qualified Name) (Qualified Name)

70 | ExportConflict (Qualified Name) (Qualified Name)

70 | DuplicateModule ModuleName [SourceSpan]

71 | DuplicateModule ModuleName [SourceSpan]

71− | DuplicateTypeArgument String

72+ | DuplicateTypeArgument Text

72 | InvalidDoBind

73 | InvalidDoBind

73 | InvalidDoLet

74 | InvalidDoLet

74 | CycleInDeclaration Ident

75 | CycleInDeclaration Ident

@@ -89,7 +90,7 @@ data SimpleErrorMessage

89 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

90 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

90 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

91 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

91 | CannotFindDerivingType (ProperName 'TypeName)

92 | CannotFindDerivingType (ProperName 'TypeName)

92− | DuplicateLabel String (Maybe Expr)

93+ | DuplicateLabel Text (Maybe Expr)

93 | DuplicateValueDeclaration Ident

94 | DuplicateValueDeclaration Ident

94 | ArgListLengthsDiffer Ident

95 | ArgListLengthsDiffer Ident

95 | OverlappingArgNames (Maybe Ident)

96 | OverlappingArgNames (Maybe Ident)

@@ -98,8 +99,8 @@ data SimpleErrorMessage

98 | ExpectedType Type Kind

99 | ExpectedType Type Kind

99 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

100 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

100 | ExprDoesNotHaveType Expr Type

101 | ExprDoesNotHaveType Expr Type

101− | PropertyIsMissing String

102+ | PropertyIsMissing Text

102− | AdditionalProperty String

103+ | AdditionalProperty Text

103 | TypeSynonymInstance

104 | TypeSynonymInstance

104 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

105 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

105 | InvalidNewtype (ProperName 'TypeName)

106 | InvalidNewtype (ProperName 'TypeName)

@@ -107,10 +108,10 @@ data SimpleErrorMessage

107 | TransitiveExportError DeclarationRef [DeclarationRef]

108 | TransitiveExportError DeclarationRef [DeclarationRef]

108 | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

109 | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

109 | ShadowedName Ident

110 | ShadowedName Ident

110− | ShadowedTypeVar String

111+ | ShadowedTypeVar Text

111− | UnusedTypeVar String

112+ | UnusedTypeVar Text

112 | WildcardInferredType Type Context

113 | WildcardInferredType Type Context

113− | HoleInferredType String Type Context TypeSearch

114+ | HoleInferredType Text Type Context TypeSearch

114 | MissingTypeDeclaration Ident Type

115 | MissingTypeDeclaration Ident Type

115 | OverlappingPattern [[Binder]] Bool

116 | OverlappingPattern [[Binder]] Bool

116 | IncompleteExhaustivityCheck

117 | IncompleteExhaustivityCheck

@@ -124,7 +125,7 @@ data SimpleErrorMessage

124 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

125 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

125 | DuplicateImportRef Name

126 | DuplicateImportRef Name

126 | DuplicateExportRef Name

127 | DuplicateExportRef Name

127− | IntOutOfRange Integer String Integer Integer

128+ | IntOutOfRange Integer Text Integer Integer

128 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

129 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

129 | ImplicitImport ModuleName [DeclarationRef]

130 | ImplicitImport ModuleName [DeclarationRef]

130 | HidingImport ModuleName [DeclarationRef]

131 | HidingImport ModuleName [DeclarationRef]

@@ -144,7 +145,7 @@ data ErrorMessageHint

144 | ErrorInModule ModuleName

145 | ErrorInModule ModuleName

145 | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

146 | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

146 | ErrorInSubsumption Type Type

147 | ErrorInSubsumption Type Type

147− | ErrorCheckingAccessor Expr String

148+ | ErrorCheckingAccessor Expr Text

148 | ErrorCheckingType Expr Type

149 | ErrorCheckingType Expr Type

149 | ErrorCheckingKind Type

150 | ErrorCheckingKind Type

150 | ErrorCheckingGuard

151 | ErrorCheckingGuard

@@ -153,10 +154,11 @@ data ErrorMessageHint

153 | ErrorInDataConstructor (ProperName 'ConstructorName)

154 | ErrorInDataConstructor (ProperName 'ConstructorName)

154 | ErrorInTypeConstructor (ProperName 'TypeName)

155 | ErrorInTypeConstructor (ProperName 'TypeName)

155 | ErrorInBindingGroup [Ident]

156 | ErrorInBindingGroup [Ident]

156− | ErrorInDataBindingGroup

157+ | ErrorInDataBindingGroup [ProperName 'TypeName]

157 | ErrorInTypeSynonym (ProperName 'TypeName)

158 | ErrorInTypeSynonym (ProperName 'TypeName)

158 | ErrorInValueDeclaration Ident

159 | ErrorInValueDeclaration Ident

159 | ErrorInTypeDeclaration Ident

160 | ErrorInTypeDeclaration Ident

161+ | ErrorInTypeClassDeclaration (ProperName 'ClassName)

160 | ErrorInForeignImport Ident

162 | ErrorInForeignImport Ident

161 | ErrorSolvingConstraint Constraint

163 | ErrorSolvingConstraint Constraint

162 | PositionedError SourceSpan

164 | PositionedError SourceSpan

@@ -349,7 +351,7 @@ data Declaration

349 -- |

351 -- |

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

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

351 --

353 --

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

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

353 -- |

355 -- |

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

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

355 --

357 --

@@ -357,7 +359,7 @@ data Declaration

357 -- |

359 -- |

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

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

359 --

361 --

360− | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type

362+ | TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type

361 -- |

363 -- |

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

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

363 --

365 --

@@ -389,7 +391,7 @@ data Declaration

389 -- |

391 -- |

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

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

391 --

393 --

392− | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]

394+ | TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]

393 -- |

395 -- |

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

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

395 -- declarations)

397 -- declarations)

@@ -547,11 +549,11 @@ data Expr

547 -- Anonymous arguments will be removed during desugaring and expanded

549 -- Anonymous arguments will be removed during desugaring and expanded

548 -- into a lambda that reads a property from a record.

550 -- into a lambda that reads a property from a record.

549 --

551 --

550− | Accessor String Expr

552+ | Accessor Text Expr

551 -- |

553 -- |

552 -- Partial record update

554 -- Partial record update

553 --

555 --

554− | ObjectUpdate Expr [(String, Expr)]

556+ | ObjectUpdate Expr [(Text, Expr)]

555 -- |

557 -- |

556 -- Function introduction

558 -- Function introduction

557 --

559 --

@@ -607,7 +609,7 @@ data Expr

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

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

608 --

610 --

609 | TypeClassDictionary Constraint

611 | TypeClassDictionary Constraint

610− (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

612+ (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))

611 [ErrorMessageHint]

613 [ErrorMessageHint]

612 -- |

614 -- |

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

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

@@ -624,7 +626,7 @@ data Expr

624 -- |

626 -- |

625 -- A typed hole that will be turned into a hint/error duing typechecking

627 -- A typed hole that will be turned into a hint/error duing typechecking

626 --

628 --

627− | Hole String

629+ | Hole Text

628 -- |

630 -- |

629 -- A value with source position information

631 -- A value with source position information

630 --

632 --

src/Language/PureScript/AST/Literals.hs+3−2

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

4module Language.PureScript.AST.Literals where

5

6import Prelude.Compat

7+import Data.Text (Text)

7

8

8-- |

9-- |

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

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

@@ -17,7 +18,7 @@ data Literal a

17 -- |

18 -- |

18 -- A string literal

19 -- A string literal

19 --

20 --

20− | StringLiteral String

21+ | StringLiteral Text

21 -- |

22 -- |

22 -- A character literal

23 -- A character literal

23 --

24 --

@@ -33,5 +34,5 @@ data Literal a

33 -- |

34 -- |

34 -- An object literal

35 -- An object literal

35 --

36 --

36− | ObjectLiteral [(String, a)]

37+ | ObjectLiteral [(Text, a)]

37 deriving (Eq, Ord, Show, Functor)

38 deriving (Eq, Ord, Show, Functor)

src/Language/PureScript/AST/Operators.hs−2

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3-- |

1-- |

4-- Operators fixity and associativity

2-- Operators fixity and associativity

5--

3--

src/Language/PureScript/AST/SourcePos.hs+10−9

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3-- |

1-- |

4-- Source position information

2-- Source position information

5--

3--

@@ -9,6 +7,9 @@ import Prelude.Compat

9

7

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

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

11import qualified Data.Aeson as A

9import qualified Data.Aeson as A

10+import Data.Monoid

11+import qualified Data.Text as T

12+import Data.Text (Text)

12

13

13-- |

14-- |

14-- Source position information

15-- Source position information

@@ -24,10 +25,10 @@ data SourcePos = SourcePos

24 , sourcePosColumn :: Int

25 , sourcePosColumn :: Int

25 } deriving (Show, Eq, Ord)

26 } deriving (Show, Eq, Ord)

26

27

27−displaySourcePos :: SourcePos -> String

28+displaySourcePos :: SourcePos -> Text

28displaySourcePos sp =

29displaySourcePos sp =

29− "line " ++ show (sourcePosLine sp) ++

30+ "line " <> T.pack (show (sourcePosLine sp)) <>

30− ", column " ++ show (sourcePosColumn sp)

31+ ", column " <> T.pack (show (sourcePosColumn sp))

31

32

32instance A.ToJSON SourcePos where

33instance A.ToJSON SourcePos where

33 toJSON SourcePos{..} =

34 toJSON SourcePos{..} =

@@ -52,14 +53,14 @@ data SourceSpan = SourceSpan

52 , spanEnd :: SourcePos

53 , spanEnd :: SourcePos

53 } deriving (Show, Eq, Ord)

54 } deriving (Show, Eq, Ord)

54

55

55−displayStartEndPos :: SourceSpan -> String

56+displayStartEndPos :: SourceSpan -> Text

56displayStartEndPos sp =

57displayStartEndPos sp =

57− displaySourcePos (spanStart sp) ++ " - " ++

58+ displaySourcePos (spanStart sp) <> " - " <>

58 displaySourcePos (spanEnd sp)

59 displaySourcePos (spanEnd sp)

59

60

60−displaySourceSpan :: SourceSpan -> String

61+displaySourceSpan :: SourceSpan -> Text

61displaySourceSpan sp =

62displaySourceSpan sp =

62− spanName sp ++ " " ++

63+ T.pack (spanName sp) <> " " <>

63 displayStartEndPos sp

64 displayStartEndPos sp

64

65

65instance A.ToJSON SourceSpan where

66instance A.ToJSON SourceSpan where

src/Language/PureScript/Bundle.hs+2

@@ -534,6 +534,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p

534 where

535 squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) []

536 squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)

537+ squash JSAnnotSpace = JSAnnot (TokenPn 0 0 2) []

537

538

538 splat (CommentA pos s) = CommentA (keepCol pos) s

539 splat (CommentA pos s) = CommentA (keepCol pos) s

539 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w

540 splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w

@@ -589,6 +590,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p

589

590

590 appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]

591 appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]

591 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])

592 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])

593+ appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a]

592

594

593 runMain :: String -> [JSStatement]

595 runMain :: String -> [JSStatement]

594 runMain mn =

596 runMain mn =

src/Language/PureScript/CodeGen/JS.hs+25−23

@@ -10,16 +10,18 @@ module Language.PureScript.CodeGen.JS

10import Prelude.Compat

11

12import Control.Arrow ((&&&))

13−import Control.Monad (replicateM, forM, void)

13+import Control.Monad (forM, replicateM, void)

14−import Control.Monad.Error.Class (MonadError(..))

14+import Control.Monad.Except (MonadError, throwError)

15import Control.Monad.Reader (MonadReader, asks)

16import Control.Monad.Supply.Class

17

18import Data.List ((\\), delete, intersect, nub)

19−import Data.Maybe (isNothing, fromMaybe)

20import qualified Data.Foldable as F

19import qualified Data.Foldable as F

21import qualified Data.Map as M

20import qualified Data.Map as M

21+import Data.Maybe (fromMaybe, isNothing)

22+import Data.Monoid ((<>))

23+import Data.Text (Text)

22−import qualified Data.Traversable as T

24+import qualified Data.Text as T

23

25

24import Language.PureScript.AST.SourcePos

26import Language.PureScript.AST.SourcePos

25import Language.PureScript.CodeGen.JS.AST as AST

27import Language.PureScript.CodeGen.JS.AST as AST

@@ -51,10 +53,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

51 rethrow (addHint (ErrorInModule mn)) $ do

53 rethrow (addHint (ErrorInModule mn)) $ do

52 let usedNames = concatMap getNames decls

54 let usedNames = concatMap getNames decls

53 let mnLookup = renameImports usedNames imps

55 let mnLookup = renameImports usedNames imps

54− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps

56+ jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps

55 let decls' = renameModules mnLookup decls

57 let decls' = renameModules mnLookup decls

56 jsDecls <- mapM bindToJs decls'

58 jsDecls <- mapM bindToJs decls'

57− optimized <- T.traverse (T.traverse optimize) jsDecls

59+ optimized <- traverse (traverse optimize) jsDecls

58 F.traverse_ (F.traverse_ checkIntegers) optimized

60 F.traverse_ (F.traverse_ checkIntegers) optimized

59 comments <- not <$> asks optionsNoComments

61 comments <- not <$> asks optionsNoComments

60 let strict = JSStringLiteral Nothing "use strict"

62 let strict = JSStringLiteral Nothing "use strict"

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

94

96

95 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

97 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

96 freshModuleName i mn'@(ModuleName pns) used =

98 freshModuleName i mn'@(ModuleName pns) used =

97− let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]

99+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]

98 in if Ident (runModuleName newName) `elem` used

100 in if Ident (runModuleName newName) `elem` used

99 then freshModuleName (i + 1) mn' used

101 then freshModuleName (i + 1) mn' used

100 else newName

102 else newName

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

106 importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS

108 importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS

107 importToJs mnLookup mn' = do

109 importToJs mnLookup mn' = do

108 let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

110 let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

109− let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." </> runModuleName mn')]

111+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (T.pack (".." </> T.unpack (runModuleName mn')))]

110 withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

112 withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

111

113

112 -- |

114 -- |

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

177 accessor (Ident prop) = accessorString prop

179 accessor (Ident prop) = accessorString prop

178 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

180 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

179

181

180− accessorString :: String -> JS -> JS

182+ accessorString :: Text -> JS -> JS

181 accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

183 accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

182 | otherwise = JSAccessor Nothing prop

184 | otherwise = JSAccessor Nothing prop

183

185

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

234 then foreignIdent ident

236 then foreignIdent ident

235 else varToJs qi

237 else varToJs qi

236 valueToJs' (Var (_, _, _, Just IsForeign) ident) =

238 valueToJs' (Var (_, _, _, Just IsForeign) ident) =

237− error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident

239+ internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)

238 valueToJs' (Var _ ident) = return $ varToJs ident

240 valueToJs' (Var _ ident) = return $ varToJs ident

239 valueToJs' (Case (maybeSpan, _, _, _) values binders) = do

241 valueToJs' (Case (maybeSpan, _, _, _) values binders) = do

240 vals <- mapM valueToJs values

242 vals <- mapM valueToJs values

@@ -263,14 +265,14 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

263 , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn

265 , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn

264 ]

266 ]

265

267

266− iife :: String -> [JS] -> JS

268+ iife :: Text -> [JS] -> JS

267 iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []

269 iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []

268

270

269 literalToValueJS :: Literal (Expr Ann) -> m JS

271 literalToValueJS :: Literal (Expr Ann) -> m JS

270 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)

272 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)

271 literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)

273 literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)

272 literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s

274 literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s

273− literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]

275+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (T.singleton c)

274 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b

276 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b

275 literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs

277 literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs

276 literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps

278 literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps

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

278 -- |

280 -- |

279 -- Shallow copy an object.

281 -- Shallow copy an object.

280 --

282 --

281− extendObj :: JS -> [(String, JS)] -> m JS

283+ extendObj :: JS -> [(Text, JS)] -> m JS

282 extendObj obj sts = do

284 extendObj obj sts = do

283 newObj <- freshName

285 newObj <- freshName

284 key <- freshName

286 key <- freshName

@@ -331,20 +333,20 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

331 return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))

333 return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))

332 []

334 []

333 where

335 where

334− go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

336+ go :: [Text] -> [JS] -> [Binder Ann] -> m [JS]

335 go _ done [] = return done

337 go _ done [] = return done

336 go (v:vs) done' (b:bs) = do

338 go (v:vs) done' (b:bs) = do

337 done'' <- go vs done' bs

339 done'' <- go vs done' bs

338 binderToJs v done'' b

340 binderToJs v done'' b

339 go _ _ _ = internalError "Invalid arguments to bindersToJs"

341 go _ _ _ = internalError "Invalid arguments to bindersToJs"

340

342

341− failedPatternError :: [String] -> JS

343+ failedPatternError :: [Text] -> JS

342 failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]

344 failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]

343

345

344− failedPatternMessage :: String

346+ failedPatternMessage :: Text

345− failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

347+ failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": "

346

348

347− valueError :: String -> JS -> JS

349+ valueError :: Text -> JS -> JS

348 valueError _ l@(JSNumericLiteral _ _) = l

350 valueError _ l@(JSNumericLiteral _ _) = l

349 valueError _ l@(JSStringLiteral _ _) = l

351 valueError _ l@(JSStringLiteral _ _) = l

350 valueError _ l@(JSBooleanLiteral _ _) = l

352 valueError _ l@(JSBooleanLiteral _ _) = l

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

357 return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing

359 return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing

358 guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v

360 guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v

359

361

360− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]

362+ binderToJs :: Text -> [JS] -> Binder Ann -> m [JS]

361 binderToJs s done binder =

363 binderToJs s done binder =

362 let (ss, _, _, _) = extractBinderAnn binder in

364 let (ss, _, _, _) = extractBinderAnn binder in

363 traverse (withPos ss) =<< binderToJs' s done binder

365 traverse (withPos ss) =<< binderToJs' s done binder

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

366 -- Generate code in the simplified Javascript intermediate representation for a pattern match

368 -- Generate code in the simplified Javascript intermediate representation for a pattern match

367 -- binder.

369 -- binder.

368 --

370 --

369− binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]

371+ binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS]

370 binderToJs' _ done NullBinder{} = return done

372 binderToJs' _ done NullBinder{} = return done

371 binderToJs' varName done (LiteralBinder _ l) =

373 binderToJs' varName done (LiteralBinder _ l) =

372 literalToBinderJS varName done l

374 literalToBinderJS varName done l

@@ -396,11 +398,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

396 js <- binderToJs varName done binder

398 js <- binderToJs varName done binder

397 return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)

399 return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)

398

400

399− literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]

401+ literalToBinderJS :: Text -> [JS] -> Literal (Binder Ann) -> m [JS]

400 literalToBinderJS varName done (NumericLiteral num) =

402 literalToBinderJS varName done (NumericLiteral num) =

401 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]

403 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]

402 literalToBinderJS varName done (CharLiteral c) =

404 literalToBinderJS varName done (CharLiteral c) =

403− return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]

405+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (T.singleton c))) (JSBlock Nothing done) Nothing]

404 literalToBinderJS varName done (StringLiteral str) =

406 literalToBinderJS varName done (StringLiteral str) =

405 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]

407 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]

406 literalToBinderJS varName done (BooleanLiteral True) =

408 literalToBinderJS varName done (BooleanLiteral True) =

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

409 return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]

411 return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]

410 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

412 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

411 where

413 where

412− go :: [JS] -> [(String, Binder Ann)] -> m [JS]

414+ go :: [JS] -> [(Text, Binder Ann)] -> m [JS]

413 go done' [] = return done'

415 go done' [] = return done'

414 go done' ((prop, binder):bs') = do

416 go done' ((prop, binder):bs') = do

415 propVar <- freshName

417 propVar <- freshName

src/Language/PureScript/CodeGen/JS/AST.hs+15−13

@@ -5,7 +5,9 @@ module Language.PureScript.CodeGen.JS.AST where

5

6import Prelude.Compat

7

8−import Control.Monad.Identity

8+import Control.Monad ((>=>))

9+import Control.Monad.Identity (Identity(..), runIdentity)

10+import Data.Text (Text)

9

11

10import Language.PureScript.AST (SourceSpan(..))

12import Language.PureScript.AST (SourceSpan(..))

11import Language.PureScript.Comments

13import Language.PureScript.Comments

@@ -130,7 +132,7 @@ data JS

130 -- |

132 -- |

131 -- A string literal

133 -- A string literal

132 --

134 --

133− | JSStringLiteral (Maybe SourceSpan) String

135+ | JSStringLiteral (Maybe SourceSpan) Text

134 -- |

136 -- |

135 -- A boolean literal

137 -- A boolean literal

136 --

138 --

@@ -154,15 +156,15 @@ data JS

154 -- |

156 -- |

155 -- An object literal

157 -- An object literal

156 --

158 --

157− | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]

159+ | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)]

158 -- |

160 -- |

159 -- An object property accessor expression

161 -- An object property accessor expression

160 --

162 --

161− | JSAccessor (Maybe SourceSpan) String JS

163+ | JSAccessor (Maybe SourceSpan) Text JS

162 -- |

164 -- |

163 -- A function introduction (optional name, arguments, body)

165 -- A function introduction (optional name, arguments, body)

164 --

166 --

165− | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS

167+ | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS

166 -- |

168 -- |

167 -- Function application

169 -- Function application

168 --

170 --

@@ -170,7 +172,7 @@ data JS

170 -- |

172 -- |

171 -- Variable

173 -- Variable

172 --

174 --

173− | JSVar (Maybe SourceSpan) String

175+ | JSVar (Maybe SourceSpan) Text

174 -- |

176 -- |

175 -- Conditional expression

177 -- Conditional expression

176 --

178 --

@@ -182,7 +184,7 @@ data JS

182 -- |

184 -- |

183 -- A variable introduction and optional initialization

185 -- A variable introduction and optional initialization

184 --

186 --

185− | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)

187+ | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS)

186 -- |

188 -- |

187 -- A variable assignment

189 -- A variable assignment

188 --

190 --

@@ -194,11 +196,11 @@ data JS

194 -- |

196 -- |

195 -- For loop

197 -- For loop

196 --

198 --

197− | JSFor (Maybe SourceSpan) String JS JS JS

199+ | JSFor (Maybe SourceSpan) Text JS JS JS

198 -- |

200 -- |

199 -- ForIn loop

201 -- ForIn loop

200 --

202 --

201− | JSForIn (Maybe SourceSpan) String JS JS

203+ | JSForIn (Maybe SourceSpan) Text JS JS

202 -- |

204 -- |

203 -- If-then-else statement

205 -- If-then-else statement

204 --

206 --

@@ -222,19 +224,19 @@ data JS

222 -- |

224 -- |

223 -- Labelled statement

225 -- Labelled statement

224 --

226 --

225− | JSLabel (Maybe SourceSpan) String JS

227+ | JSLabel (Maybe SourceSpan) Text JS

226 -- |

228 -- |

227 -- Break statement

229 -- Break statement

228 --

230 --

229− | JSBreak (Maybe SourceSpan) String

231+ | JSBreak (Maybe SourceSpan) Text

230 -- |

232 -- |

231 -- Continue statement

233 -- Continue statement

232 --

234 --

233− | JSContinue (Maybe SourceSpan) String

235+ | JSContinue (Maybe SourceSpan) Text

234 -- |

236 -- |

235 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

237 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

236 --

238 --

237− | JSRaw (Maybe SourceSpan) String

239+ | JSRaw (Maybe SourceSpan) Text

238 -- |

240 -- |

239 -- Commented Javascript

241 -- Commented Javascript

240 --

242 --

src/Language/PureScript/CodeGen/JS/Common.hs+46−44

@@ -6,15 +6,17 @@ module Language.PureScript.CodeGen.JS.Common where

6import Prelude.Compat

7

8import Data.Char

9−import Data.List (intercalate)

9+import Data.Monoid ((<>))

10+import Data.Text (Text)

11+import qualified Data.Text as T

10

12

11import Language.PureScript.Crash

13import Language.PureScript.Crash

12import Language.PureScript.Names

14import Language.PureScript.Names

13

15

14−moduleNameToJs :: ModuleName -> String

16+moduleNameToJs :: ModuleName -> Text

15moduleNameToJs (ModuleName pns) =

17moduleNameToJs (ModuleName pns) =

16− let name = intercalate "_" (runProperName `map` pns)

18+ let name = T.intercalate "_" (runProperName `map` pns)

17− in if nameIsJsBuiltIn name then "$$" ++ name else name

19+ in if nameIsJsBuiltIn name then "$$" <> name else name

18

20

19-- |

21-- |

20-- Convert an Ident into a valid Javascript identifier:

22-- Convert an Ident into a valid Javascript identifier:

@@ -25,62 +27,62 @@ moduleNameToJs (ModuleName pns) =

25--

27--

26-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

28-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

27--

29--

28−identToJs :: Ident -> String

30+identToJs :: Ident -> Text

29identToJs (Ident name) = properToJs name

31identToJs (Ident name) = properToJs name

30identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

32identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"

31

33

32−properToJs :: String -> String

34+properToJs :: Text -> Text

33properToJs name

35properToJs name

34− | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name

36+ | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name

35− | otherwise = concatMap identCharToString name

37+ | otherwise = T.concatMap identCharToText name

36

38

37-- |

39-- |

38-- Test if a string is a valid JS identifier without escaping.

40-- Test if a string is a valid JS identifier without escaping.

39--

41--

40−identNeedsEscaping :: String -> Bool

42+identNeedsEscaping :: Text -> Bool

41−identNeedsEscaping s = s /= identToJs (Ident s) || null s

43+identNeedsEscaping s = s /= properToJs s || T.null s

42

44

43-- |

45-- |

44-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

46-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

45-- ordinal value.

47-- ordinal value.

46--

48--

47−identCharToString :: Char -> String

49+identCharToText :: Char -> Text

48−identCharToString c | isAlphaNum c = [c]

50+identCharToText c | isAlphaNum c = T.singleton c

49−identCharToString '_' = "_"

51+identCharToText '_' = "_"

50−identCharToString '.' = "$dot"

52+identCharToText '.' = "$dot"

51−identCharToString '$' = "$dollar"

53+identCharToText '$' = "$dollar"

52−identCharToString '~' = "$tilde"

54+identCharToText '~' = "$tilde"

53−identCharToString '=' = "$eq"

55+identCharToText '=' = "$eq"

54−identCharToString '<' = "$less"

56+identCharToText '<' = "$less"

55−identCharToString '>' = "$greater"

57+identCharToText '>' = "$greater"

56−identCharToString '!' = "$bang"

58+identCharToText '!' = "$bang"

57−identCharToString '#' = "$hash"

59+identCharToText '#' = "$hash"

58−identCharToString '%' = "$percent"

60+identCharToText '%' = "$percent"

59−identCharToString '^' = "$up"

61+identCharToText '^' = "$up"

60−identCharToString '&' = "$amp"

62+identCharToText '&' = "$amp"

61−identCharToString '|' = "$bar"

63+identCharToText '|' = "$bar"

62−identCharToString '*' = "$times"

64+identCharToText '*' = "$times"

63−identCharToString '/' = "$div"

65+identCharToText '/' = "$div"

64−identCharToString '+' = "$plus"

66+identCharToText '+' = "$plus"

65−identCharToString '-' = "$minus"

67+identCharToText '-' = "$minus"

66−identCharToString ':' = "$colon"

68+identCharToText ':' = "$colon"

67−identCharToString '\\' = "$bslash"

69+identCharToText '\\' = "$bslash"

68−identCharToString '?' = "$qmark"

70+identCharToText '?' = "$qmark"

69−identCharToString '@' = "$at"

71+identCharToText '@' = "$at"

70−identCharToString '\'' = "$prime"

72+identCharToText '\'' = "$prime"

71−identCharToString c = '$' : show (ord c)

73+identCharToText c = '$' `T.cons` T.pack (show (ord c))

72

74

73-- |

75-- |

74-- Checks whether an identifier name is reserved in Javascript.

76-- Checks whether an identifier name is reserved in Javascript.

75--

77--

76−nameIsJsReserved :: String -> Bool

78+nameIsJsReserved :: Text -> Bool

77nameIsJsReserved name =

79nameIsJsReserved name =

78 name `elem` jsAnyReserved

80 name `elem` jsAnyReserved

79

81

80-- |

82-- |

81-- Checks whether a name matches a built-in value in Javascript.

83-- Checks whether a name matches a built-in value in Javascript.

82--

84--

83−nameIsJsBuiltIn :: String -> Bool

85+nameIsJsBuiltIn :: Text -> Bool

84nameIsJsBuiltIn name =

86nameIsJsBuiltIn name =

85 name `elem`

87 name `elem`

86 [ "arguments"

88 [ "arguments"

@@ -138,7 +140,7 @@ nameIsJsBuiltIn name =

138 , "WeakSet"

140 , "WeakSet"

139 ]

141 ]

140

142

141−jsAnyReserved :: [String]

143+jsAnyReserved :: [Text]

142jsAnyReserved =

144jsAnyReserved =

143 concat

145 concat

144 [ jsKeywords

146 [ jsKeywords

@@ -149,7 +151,7 @@ jsAnyReserved =

149 , jsLiterals

151 , jsLiterals

150 ]

152 ]

151

153

152−jsKeywords :: [String]

154+jsKeywords :: [Text]

153jsKeywords =

155jsKeywords =

154 [ "break"

156 [ "break"

155 , "case"

157 , "case"

@@ -185,7 +187,7 @@ jsKeywords =

185 , "with"

187 , "with"

186 ]

188 ]

187

189

188−jsSometimesReserved :: [String]

190+jsSometimesReserved :: [Text]

189jsSometimesReserved =

191jsSometimesReserved =

190 [ "await"

192 [ "await"

191 , "let"

193 , "let"

@@ -193,11 +195,11 @@ jsSometimesReserved =

193 , "yield"

195 , "yield"

194 ]

196 ]

195

197

196−jsFutureReserved :: [String]

198+jsFutureReserved :: [Text]

197jsFutureReserved =

199jsFutureReserved =

198 [ "enum" ]

200 [ "enum" ]

199

201

200−jsFutureReservedStrict :: [String]

202+jsFutureReservedStrict :: [Text]

201jsFutureReservedStrict =

203jsFutureReservedStrict =

202 [ "implements"

204 [ "implements"

203 , "interface"

205 , "interface"

@@ -207,7 +209,7 @@ jsFutureReservedStrict =

207 , "public"

209 , "public"

208 ]

210 ]

209

211

210−jsOldReserved :: [String]

212+jsOldReserved :: [Text]

211jsOldReserved =

213jsOldReserved =

212 [ "abstract"

214 [ "abstract"

213 , "boolean"

215 , "boolean"

@@ -227,7 +229,7 @@ jsOldReserved =

227 , "volatile"

229 , "volatile"

228 ]

230 ]

229

231

230−jsLiterals :: [String]

232+jsLiterals :: [Text]

231jsLiterals =

233jsLiterals =

232 [ "null"

234 [ "null"

233 , "true"

235 , "true"

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+12−10

@@ -5,27 +5,29 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where

5

6import Prelude.Compat

7

8+import Data.Text (Text)

9+import Data.List (foldl')

8import Data.Maybe (fromMaybe)

10import Data.Maybe (fromMaybe)

9

11

10import Language.PureScript.Crash

12import Language.PureScript.Crash

11import Language.PureScript.CodeGen.JS.AST

13import Language.PureScript.CodeGen.JS.AST

12

14

13applyAll :: [a -> a] -> a -> a

15applyAll :: [a -> a] -> a -> a

14−applyAll = foldl1 (.)

16+applyAll = foldl' (.) id

15

17

16−replaceIdent :: String -> JS -> JS -> JS

18+replaceIdent :: Text -> JS -> JS -> JS

17replaceIdent var1 js = everywhereOnJS replace

19replaceIdent var1 js = everywhereOnJS replace

18 where

20 where

19 replace (JSVar _ var2) | var1 == var2 = js

21 replace (JSVar _ var2) | var1 == var2 = js

20 replace other = other

22 replace other = other

21

23

22−replaceIdents :: [(String, JS)] -> JS -> JS

24+replaceIdents :: [(Text, JS)] -> JS -> JS

23replaceIdents vars = everywhereOnJS replace

25replaceIdents vars = everywhereOnJS replace

24 where

26 where

25 replace v@(JSVar _ var) = fromMaybe v $ lookup var vars

27 replace v@(JSVar _ var) = fromMaybe v $ lookup var vars

26 replace other = other

28 replace other = other

27

29

28−isReassigned :: String -> JS -> Bool

30+isReassigned :: Text -> JS -> Bool

29isReassigned var1 = everythingOnJS (||) check

31isReassigned var1 = everythingOnJS (||) check

30 where

32 where

31 check :: JS -> Bool

33 check :: JS -> Bool

@@ -42,7 +44,7 @@ isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (

42 variablesOf (JSVar _ var) = [var]

44 variablesOf (JSVar _ var) = [var]

43 variablesOf _ = []

45 variablesOf _ = []

44

46

45−isUsed :: String -> JS -> Bool

47+isUsed :: Text -> JS -> Bool

46isUsed var1 = everythingOnJS (||) check

48isUsed var1 = everythingOnJS (||) check

47 where

49 where

48 check :: JS -> Bool

50 check :: JS -> Bool

@@ -50,13 +52,13 @@ isUsed var1 = everythingOnJS (||) check

50 check (JSAssignment _ target _) | var1 == targetVariable target = True

52 check (JSAssignment _ target _) | var1 == targetVariable target = True

51 check _ = False

53 check _ = False

52

54

53−targetVariable :: JS -> String

55+targetVariable :: JS -> Text

54targetVariable (JSVar _ var) = var

56targetVariable (JSVar _ var) = var

55targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

57targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

56targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

58targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

57targetVariable _ = internalError "Invalid argument to targetVariable"

59targetVariable _ = internalError "Invalid argument to targetVariable"

58

60

59−isUpdated :: String -> JS -> Bool

61+isUpdated :: Text -> JS -> Bool

60isUpdated var1 = everythingOnJS (||) check

62isUpdated var1 = everythingOnJS (||) check

61 where

63 where

62 check :: JS -> Bool

64 check :: JS -> Bool

@@ -67,16 +69,16 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

67removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

69removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

68removeFromBlock _ js = js

70removeFromBlock _ js = js

69

71

70−isFn :: (String, String) -> JS -> Bool

72+isFn :: (Text, Text) -> JS -> Bool

71isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =

73isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =

72 x == fnName && y == moduleName

74 x == fnName && y == moduleName

73isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =

75isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =

74 x == fnName && y == moduleName

76 x == fnName && y == moduleName

75isFn _ _ = False

77isFn _ _ = False

76

78

77−isDict :: (String, String) -> JS -> Bool

79+isDict :: (Text, Text) -> JS -> Bool

78isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName

80isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName

79isDict _ _ = False

81isDict _ _ = False

80

82

81−isDict' :: [(String, String)] -> JS -> Bool

83+isDict' :: [(Text, Text)] -> JS -> Bool

82isDict' xs js = any (`isDict` js) xs

84isDict' xs js = any (`isDict` js) xs

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+51−48

@@ -16,6 +16,9 @@ import Prelude.Compat

16import Control.Monad.Supply.Class (MonadSupply, freshName)

17

18import Data.Maybe (fromMaybe)

19+import Data.Monoid ((<>))

20+import Data.Text (Text)

21+import qualified Data.Text as T

19

22

20import Language.PureScript.CodeGen.JS.AST

23import Language.PureScript.CodeGen.JS.AST

21import Language.PureScript.CodeGen.JS.Optimizer.Common

24import Language.PureScript.CodeGen.JS.Optimizer.Common

@@ -164,25 +167,25 @@ inlineCommonOperators = applyAll $

164 ] ++

167 ] ++

165 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

168 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

166 where

169 where

167− binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS

170+ binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS

168 binary dict fns op = everywhereOnJS convert

171 binary dict fns op = everywhereOnJS convert

169 where

172 where

170 convert :: JS -> JS

173 convert :: JS -> JS

171 convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y

174 convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y

172 convert other = other

175 convert other = other

173− binary' :: String -> String -> BinaryOperator -> JS -> JS

176+ binary' :: Text -> Text -> BinaryOperator -> JS -> JS

174 binary' moduleName opString op = everywhereOnJS convert

177 binary' moduleName opString op = everywhereOnJS convert

175 where

178 where

176 convert :: JS -> JS

179 convert :: JS -> JS

177 convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y

180 convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y

178 convert other = other

181 convert other = other

179− unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS

182+ unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS

180 unary dicts fns op = everywhereOnJS convert

183 unary dicts fns op = everywhereOnJS convert

181 where

184 where

182 convert :: JS -> JS

185 convert :: JS -> JS

183 convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x

186 convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x

184 convert other = other

187 convert other = other

185− unary' :: String -> String -> UnaryOperator -> JS -> JS

188+ unary' :: Text -> Text -> UnaryOperator -> JS -> JS

186 unary' moduleName fnName op = everywhereOnJS convert

189 unary' moduleName fnName op = everywhereOnJS convert

187 where

190 where

188 convert :: JS -> JS

191 convert :: JS -> JS

@@ -203,14 +206,14 @@ inlineCommonOperators = applyAll $

203 Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)

206 Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)

204 Nothing -> orig

207 Nothing -> orig

205 convert other = other

208 convert other = other

206− collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

209+ collectArgs :: Int -> [Text] -> JS -> Maybe ([Text], [JS])

207 collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

210 collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

208 collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

211 collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

209 collectArgs _ _ _ = Nothing

212 collectArgs _ _ _ = Nothing

210

213

211− isNFn :: String -> Int -> JS -> Bool

214+ isNFn :: Text -> Int -> JS -> Bool

212− isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)

215+ isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))

213− isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix ++ show n)

216+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))

214 isNFn _ _ _ = False

217 isNFn _ _ _ = False

215

218

216 runFn :: Int -> JS -> JS

219 runFn :: Int -> JS -> JS

@@ -231,11 +234,11 @@ inlineCommonOperators = applyAll $

231 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

234 convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y

232 convert other = other

235 convert other = other

233

236

234− isModFn :: (String, String) -> JS -> Bool

237+ isModFn :: (Text, Text) -> JS -> Bool

235 isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

238 isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

236 isModFn _ _ = False

239 isModFn _ _ = False

237

240

238− isModFnWithDict :: (String, String) -> JS -> Bool

241+ isModFnWithDict :: (Text, Text) -> JS -> Bool

239 isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'

242 isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'

240 isModFnWithDict _ _ = False

243 isModFnWithDict _ _ = False

241

244

@@ -260,115 +263,115 @@ inlineFnComposition = everywhereOnJSTopDownM convert

260 isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn

263 isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn

261 isFnComposeFlipped :: JS -> JS -> Bool

264 isFnComposeFlipped :: JS -> JS -> Bool

262 isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn

265 isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn

263− fnCompose :: (String, String)

266+ fnCompose :: (Text, Text)

264 fnCompose = (C.controlSemigroupoid, C.compose)

267 fnCompose = (C.controlSemigroupoid, C.compose)

265− fnComposeFlipped :: (String, String)

268+ fnComposeFlipped :: (Text, Text)

266 fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

269 fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

267

270

268−semiringNumber :: (String, String)

271+semiringNumber :: (Text, Text)

269semiringNumber = (C.dataSemiring, C.semiringNumber)

272semiringNumber = (C.dataSemiring, C.semiringNumber)

270

273

271−semiringInt :: (String, String)

274+semiringInt :: (Text, Text)

272semiringInt = (C.dataSemiring, C.semiringInt)

275semiringInt = (C.dataSemiring, C.semiringInt)

273

276

274−ringNumber :: (String, String)

277+ringNumber :: (Text, Text)

275ringNumber = (C.dataRing, C.ringNumber)

278ringNumber = (C.dataRing, C.ringNumber)

276

279

277−ringInt :: (String, String)

280+ringInt :: (Text, Text)

278ringInt = (C.dataRing, C.ringInt)

281ringInt = (C.dataRing, C.ringInt)

279

282

280−euclideanRingNumber :: (String, String)

283+euclideanRingNumber :: (Text, Text)

281euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

284euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

282

285

283−euclideanRingInt :: (String, String)

286+euclideanRingInt :: (Text, Text)

284euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)

287euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)

285

288

286−eqNumber :: (String, String)

289+eqNumber :: (Text, Text)

287eqNumber = (C.dataEq, C.eqNumber)

290eqNumber = (C.dataEq, C.eqNumber)

288

291

289−eqInt :: (String, String)

292+eqInt :: (Text, Text)

290eqInt = (C.dataEq, C.eqInt)

293eqInt = (C.dataEq, C.eqInt)

291

294

292−eqString :: (String, String)

295+eqString :: (Text, Text)

293eqString = (C.dataEq, C.eqString)

296eqString = (C.dataEq, C.eqString)

294

297

295−eqChar :: (String, String)

298+eqChar :: (Text, Text)

296eqChar = (C.dataEq, C.eqChar)

299eqChar = (C.dataEq, C.eqChar)

297

300

298−eqBoolean :: (String, String)

301+eqBoolean :: (Text, Text)

299eqBoolean = (C.dataEq, C.eqBoolean)

302eqBoolean = (C.dataEq, C.eqBoolean)

300

303

301−ordBoolean :: (String, String)

304+ordBoolean :: (Text, Text)

302ordBoolean = (C.dataOrd, C.ordBoolean)

305ordBoolean = (C.dataOrd, C.ordBoolean)

303

306

304−ordNumber :: (String, String)

307+ordNumber :: (Text, Text)

305ordNumber = (C.dataOrd, C.ordNumber)

308ordNumber = (C.dataOrd, C.ordNumber)

306

309

307−ordInt :: (String, String)

310+ordInt :: (Text, Text)

308ordInt = (C.dataOrd, C.ordInt)

311ordInt = (C.dataOrd, C.ordInt)

309

312

310−ordString :: (String, String)

313+ordString :: (Text, Text)

311ordString = (C.dataOrd, C.ordString)

314ordString = (C.dataOrd, C.ordString)

312

315

313−ordChar :: (String, String)

316+ordChar :: (Text, Text)

314ordChar = (C.dataOrd, C.ordChar)

317ordChar = (C.dataOrd, C.ordChar)

315

318

316−semigroupString :: (String, String)

319+semigroupString :: (Text, Text)

317semigroupString = (C.dataSemigroup, C.semigroupString)

320semigroupString = (C.dataSemigroup, C.semigroupString)

318

321

319−boundedBoolean :: (String, String)

322+boundedBoolean :: (Text, Text)

320boundedBoolean = (C.dataBounded, C.boundedBoolean)

323boundedBoolean = (C.dataBounded, C.boundedBoolean)

321

324

322−heytingAlgebraBoolean :: (String, String)

325+heytingAlgebraBoolean :: (Text, Text)

323heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

326heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

324

327

325−semigroupoidFn :: (String, String)

328+semigroupoidFn :: (Text, Text)

326semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

329semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

327

330

328−opAdd :: (String, String)

331+opAdd :: (Text, Text)

329opAdd = (C.dataSemiring, C.add)

332opAdd = (C.dataSemiring, C.add)

330

333

331−opMul :: (String, String)

334+opMul :: (Text, Text)

332opMul = (C.dataSemiring, C.mul)

335opMul = (C.dataSemiring, C.mul)

333

336

334−opEq :: (String, String)

337+opEq :: (Text, Text)

335opEq = (C.dataEq, C.eq)

338opEq = (C.dataEq, C.eq)

336

339

337−opNotEq :: (String, String)

340+opNotEq :: (Text, Text)

338opNotEq = (C.dataEq, C.notEq)

341opNotEq = (C.dataEq, C.notEq)

339

342

340−opLessThan :: (String, String)

343+opLessThan :: (Text, Text)

341opLessThan = (C.dataOrd, C.lessThan)

344opLessThan = (C.dataOrd, C.lessThan)

342

345

343−opLessThanOrEq :: (String, String)

346+opLessThanOrEq :: (Text, Text)

344opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

347opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

345

348

346−opGreaterThan :: (String, String)

349+opGreaterThan :: (Text, Text)

347opGreaterThan = (C.dataOrd, C.greaterThan)

350opGreaterThan = (C.dataOrd, C.greaterThan)

348

351

349−opGreaterThanOrEq :: (String, String)

352+opGreaterThanOrEq :: (Text, Text)

350opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

353opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

351

354

352−opAppend :: (String, String)

355+opAppend :: (Text, Text)

353opAppend = (C.dataSemigroup, C.append)

356opAppend = (C.dataSemigroup, C.append)

354

357

355−opSub :: (String, String)

358+opSub :: (Text, Text)

356opSub = (C.dataRing, C.sub)

359opSub = (C.dataRing, C.sub)

357

360

358−opNegate :: (String, String)

361+opNegate :: (Text, Text)

359opNegate = (C.dataRing, C.negate)

362opNegate = (C.dataRing, C.negate)

360

363

361−opDiv :: (String, String)

364+opDiv :: (Text, Text)

362opDiv = (C.dataEuclideanRing, C.div)

365opDiv = (C.dataEuclideanRing, C.div)

363

366

364−opMod :: (String, String)

367+opMod :: (Text, Text)

365opMod = (C.dataEuclideanRing, C.mod)

368opMod = (C.dataEuclideanRing, C.mod)

366

369

367−opConj :: (String, String)

370+opConj :: (Text, Text)

368opConj = (C.dataHeytingAlgebra, C.conj)

371opConj = (C.dataHeytingAlgebra, C.conj)

369

372

370−opDisj :: (String, String)

373+opDisj :: (Text, Text)

371opDisj = (C.dataHeytingAlgebra, C.disj)

374opDisj = (C.dataHeytingAlgebra, C.disj)

372

375

373−opNot :: (String, String)

376+opNot :: (Text, Text)

374opNot = (C.dataHeytingAlgebra, C.not)

377opNot = (C.dataHeytingAlgebra, C.not)

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+12−11

@@ -5,7 +5,8 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where

5

6import Prelude.Compat

7

8−import Data.Monoid

8+import Data.Text (Text)

9+import Data.Monoid ((<>), getAny, Any(..))

9

10

10import Language.PureScript.Options

11import Language.PureScript.Options

11import Language.PureScript.CodeGen.JS.AST

12import Language.PureScript.CodeGen.JS.AST

@@ -20,14 +21,14 @@ tco opts | optionsNoTco opts = id

20tco' :: JS -> JS

21tco' :: JS -> JS

21tco' = everywhereOnJS convert

22tco' = everywhereOnJS convert

22 where

23 where

23− tcoLabel :: String

24+ tcoLabel :: Text

24 tcoLabel = "tco"

25 tcoLabel = "tco"

25

26

26− tcoVar :: String -> String

27+ tcoVar :: Text -> Text

27− tcoVar arg = "__tco_" ++ arg

28+ tcoVar arg = "__tco_" <> arg

28

29

29− copyVar :: String -> String

30+ copyVar :: Text -> Text

30− copyVar arg = "__copy_" ++ arg

31+ copyVar arg = "__copy_" <> arg

31

32

32 convert :: JS -> JS

33 convert :: JS -> JS

33 convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =

34 convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =

@@ -42,7 +43,7 @@ tco' = everywhereOnJS convert

42 | otherwise -> js

43 | otherwise -> js

43 convert js = js

44 convert js = js

44

45

45− collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

46+ collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS)

46 collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =

47 collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =

47 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body

48 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body

48 collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =

49 collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =

@@ -53,7 +54,7 @@ tco' = everywhereOnJS convert

53 (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))

54 (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))

54 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

55 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

55

56

56− isTailCall :: String -> JS -> Bool

57+ isTailCall :: Text -> JS -> Bool

57 isTailCall ident js =

58 isTailCall ident js =

58 let

59 let

59 numSelfCalls = everythingOnJS (+) countSelfCalls js

60 numSelfCalls = everythingOnJS (+) countSelfCalls js

@@ -81,7 +82,7 @@ tco' = everywhereOnJS convert

81 countSelfCallsWithFnArgs :: JS -> Int

82 countSelfCallsWithFnArgs :: JS -> Int

82 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

83 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

83

84

84− toLoop :: String -> [String] -> JS -> JS

85+ toLoop :: Text -> [Text] -> JS -> JS

85 toLoop ident allArgs js = JSBlock rootSS $

86 toLoop ident allArgs js = JSBlock rootSS $

86 map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++

87 map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++

87 [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]

88 [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]

@@ -103,12 +104,12 @@ tco' = everywhereOnJS convert

103 collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

104 collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

104 collectSelfCallArgs allArgumentValues _ = allArgumentValues

105 collectSelfCallArgs allArgumentValues _ = allArgumentValues

105

106

106− isSelfCall :: String -> JS -> Bool

107+ isSelfCall :: Text -> JS -> Bool

107 isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

108 isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

108 isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

109 isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

109 isSelfCall _ _ = False

110 isSelfCall _ _ = False

110

111

111− isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

112+ isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool

112 isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

113 isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

113 isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

114 isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

114 isSelfCallWithFnArgs _ _ _ = False

115 isSelfCallWithFnArgs _ _ _ = False

src/Language/PureScript/Comments.hs+3−2

@@ -6,12 +6,13 @@

6module Language.PureScript.Comments where

7

8import Prelude.Compat

9+import Data.Text (Text)

9

10

10import Data.Aeson.TH

11import Data.Aeson.TH

11

12

12data Comment

13data Comment

13− = LineComment String

14+ = LineComment Text

14− | BlockComment String

15+ | BlockComment Text

15 deriving (Show, Eq, Ord)

16 deriving (Show, Eq, Ord)

16

17

17$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

18$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

src/Language/PureScript/Constants.hs+128−123

@@ -2,326 +2,331 @@

2module Language.PureScript.Constants where

3

4import Prelude.Compat

5−

5+import Data.Text (Text)

6import Language.PureScript.Names

7

8-- Operators

9

10−($) :: String

10+($) :: Text

11($) = "$"

12

13−apply :: String

13+apply :: Text

14apply = "apply"

15

16−(#) :: String

16+(#) :: Text

17(#) = "#"

18

19−applyFlipped :: String

19+applyFlipped :: Text

20applyFlipped = "applyFlipped"

21

22−(<>) :: String

22+(<>) :: Text

23(<>) = "<>"

24

25−(++) :: String

25+(++) :: Text

26(++) = "++"

27

28−append :: String

28+append :: Text

29append = "append"

30

31−(>>=) :: String

31+(>>=) :: Text

32(>>=) = ">>="

33

34−bind :: String

34+bind :: Text

35bind = "bind"

36

37−(+) :: String

37+(+) :: Text

38(+) = "+"

39

40−add :: String

40+add :: Text

41add = "add"

42

43−(-) :: String

43+(-) :: Text

44(-) = "-"

45

46−sub :: String

46+sub :: Text

47sub = "sub"

48

49−(*) :: String

49+(*) :: Text

50(*) = "*"

51

52−mul :: String

52+mul :: Text

53mul = "mul"

54

55−(/) :: String

55+(/) :: Text

56(/) = "/"

57

58−div :: String

58+div :: Text

59div = "div"

60

61−(%) :: String

61+(%) :: Text

62(%) = "%"

63

64−mod :: String

64+mod :: Text

65mod = "mod"

66

67−(<) :: String

67+(<) :: Text

68(<) = "<"

69

70−lessThan :: String

70+lessThan :: Text

71lessThan = "lessThan"

72

73−(>) :: String

73+(>) :: Text

74(>) = ">"

75

76−greaterThan :: String

76+greaterThan :: Text

77greaterThan = "greaterThan"

78

79−(<=) :: String

79+(<=) :: Text

80(<=) = "<="

81

82−lessThanOrEq :: String

82+lessThanOrEq :: Text

83lessThanOrEq = "lessThanOrEq"

84

85−(>=) :: String

85+(>=) :: Text

86(>=) = ">="

87

88−greaterThanOrEq :: String

88+greaterThanOrEq :: Text

89greaterThanOrEq = "greaterThanOrEq"

90

91−(==) :: String

91+(==) :: Text

92(==) = "=="

93

94−eq :: String

94+eq :: Text

95eq = "eq"

96

97−(/=) :: String

97+(/=) :: Text

98(/=) = "/="

99

100−notEq :: String

100+notEq :: Text

101notEq = "notEq"

102

103−compare :: String

103+compare :: Text

104compare = "compare"

105

106−(&&) :: String

106+(&&) :: Text

107(&&) = "&&"

108

109−conj :: String

109+conj :: Text

110conj = "conj"

111

112−(||) :: String

112+(||) :: Text

113(||) = "||"

114

115−disj :: String

115+disj :: Text

116disj = "disj"

117

118−unsafeIndex :: String

118+unsafeIndex :: Text

119unsafeIndex = "unsafeIndex"

120

121−or :: String

121+or :: Text

122or = "or"

123

124−and :: String

124+and :: Text

125and = "and"

126

127−xor :: String

127+xor :: Text

128xor = "xor"

129

130−(<<<) :: String

130+(<<<) :: Text

131(<<<) = "<<<"

132

133−compose :: String

133+compose :: Text

134compose = "compose"

135

136−(>>>) :: String

136+(>>>) :: Text

137(>>>) = ">>>"

138

139−composeFlipped :: String

139+composeFlipped :: Text

140composeFlipped = "composeFlipped"

141

142-- Functions

143

144−negate :: String

144+negate :: Text

145negate = "negate"

146

147−not :: String

147+not :: Text

148not = "not"

149

150−shl :: String

150+shl :: Text

151shl = "shl"

152

153−shr :: String

153+shr :: Text

154shr = "shr"

155

156−zshr :: String

156+zshr :: Text

157zshr = "zshr"

158

159−complement :: String

159+complement :: Text

160complement = "complement"

161

162-- Prelude Values

163

164−zero :: String

164+zero :: Text

165zero = "zero"

166

167−one :: String

167+one :: Text

168one = "one"

169

170−bottom :: String

170+bottom :: Text

171bottom = "bottom"

172

173−top :: String

173+top :: Text

174top = "top"

175

176−return :: String

176+return :: Text

177return = "return"

178

179−pure' :: String

179+pure' :: Text

180pure' = "pure"

181

182−returnEscaped :: String

182+returnEscaped :: Text

183returnEscaped = "$return"

184

185−untilE :: String

185+untilE :: Text

186untilE = "untilE"

187

188−whileE :: String

188+whileE :: Text

189whileE = "whileE"

190

191−runST :: String

191+runST :: Text

192runST = "runST"

193

194−stRefValue :: String

194+stRefValue :: Text

195stRefValue = "value"

196

197−newSTRef :: String

197+newSTRef :: Text

198newSTRef = "newSTRef"

199

200−readSTRef :: String

200+readSTRef :: Text

201readSTRef = "readSTRef"

202

203−writeSTRef :: String

203+writeSTRef :: Text

204writeSTRef = "writeSTRef"

205

206−modifySTRef :: String

206+modifySTRef :: Text

207modifySTRef = "modifySTRef"

208

209−mkFn :: String

209+mkFn :: Text

210mkFn = "mkFn"

211

212−runFn :: String

212+runFn :: Text

213runFn = "runFn"

214

215−unit :: String

215+unit :: Text

216unit = "unit"

217

218-- Prim values

219

220−undefined :: String

220+undefined :: Text

221undefined = "undefined"

222

223-- Type Class Dictionary Names

224

225−monadEffDictionary :: String

225+monadEffDictionary :: Text

226monadEffDictionary = "monadEff"

227

228−applicativeEffDictionary :: String

228+applicativeEffDictionary :: Text

229applicativeEffDictionary = "applicativeEff"

230

231−bindEffDictionary :: String

231+bindEffDictionary :: Text

232bindEffDictionary = "bindEff"

233

234−semiringNumber :: String

234+semiringNumber :: Text

235semiringNumber = "semiringNumber"

236

237−semiringInt :: String

237+semiringInt :: Text

238semiringInt = "semiringInt"

239

240−ringNumber :: String

240+ringNumber :: Text

241ringNumber = "ringNumber"

242

243−ringInt :: String

243+ringInt :: Text

244ringInt = "ringInt"

245

246−moduloSemiringNumber :: String

246+moduloSemiringNumber :: Text

247moduloSemiringNumber = "moduloSemiringNumber"

248

249−moduloSemiringInt :: String

249+moduloSemiringInt :: Text

250moduloSemiringInt = "moduloSemiringInt"

251

252−euclideanRingNumber :: String

252+euclideanRingNumber :: Text

253euclideanRingNumber = "euclideanRingNumber"

254

255−euclideanRingInt :: String

255+euclideanRingInt :: Text

256euclideanRingInt = "euclideanRingInt"

257

258−ordBoolean :: String

258+ordBoolean :: Text

259ordBoolean = "ordBoolean"

260

261−ordNumber :: String

261+ordNumber :: Text

262ordNumber = "ordNumber"

263

264−ordInt :: String

264+ordInt :: Text

265ordInt = "ordInt"

266

267−ordString :: String

267+ordString :: Text

268ordString = "ordString"

269

270−ordChar :: String

270+ordChar :: Text

271ordChar = "ordChar"

272

273−eqNumber :: String

273+eqNumber :: Text

274eqNumber = "eqNumber"

275

276−eqInt :: String

276+eqInt :: Text

277eqInt = "eqInt"

278

279−eqString :: String

279+eqString :: Text

280eqString = "eqString"

281

282−eqChar :: String

282+eqChar :: Text

283eqChar = "eqChar"

284

285−eqBoolean :: String

285+eqBoolean :: Text

286eqBoolean = "eqBoolean"

287

288−boundedBoolean :: String

288+boundedBoolean :: Text

289boundedBoolean = "boundedBoolean"

290

291−booleanAlgebraBoolean :: String

291+booleanAlgebraBoolean :: Text

292booleanAlgebraBoolean = "booleanAlgebraBoolean"

293

294−heytingAlgebraBoolean :: String

294+heytingAlgebraBoolean :: Text

295heytingAlgebraBoolean = "heytingAlgebraBoolean"

296

297−semigroupString :: String

297+semigroupString :: Text

298semigroupString = "semigroupString"

299

300−semigroupoidFn :: String

300+semigroupoidFn :: Text

301semigroupoidFn = "semigroupoidFn"

302

303-- Generic Deriving

304

305−generic :: String

305+generic :: Text

306generic = "Generic"

307

308−toSpine :: String

308+toSpine :: Text

309toSpine = "toSpine"

310

311−fromSpine :: String

311+fromSpine :: Text

312fromSpine = "fromSpine"

313

314−toSignature :: String

314+toSignature :: Text

315toSignature = "toSignature"

316

317+-- IsSymbol class

318+

319+pattern IsSymbol :: Qualified (ProperName 'ClassName)

320+pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol")

321+

317-- Main module

322-- Main module

318

323

319−main :: String

324+main :: Text

320main = "main"

325main = "main"

321

326

322-- Prim

327-- Prim

323

328

324−partial :: String

329+partial :: Text

325partial = "Partial"

330partial = "Partial"

326

331

327pattern Partial :: Qualified (ProperName 'ClassName)

332pattern Partial :: Qualified (ProperName 'ClassName)

@@ -332,67 +337,67 @@ pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fa

332

337

333-- Code Generation

338-- Code Generation

334

339

335−__superclass_ :: String

340+__superclass_ :: Text

336__superclass_ = "__superclass_"

341__superclass_ = "__superclass_"

337

342

338−__unused :: String

343+__unused :: Text

339__unused = "__unused"

344__unused = "__unused"

340

345

341-- Modules

346-- Modules

342

347

343−prim :: String

348+prim :: Text

344prim = "Prim"

349prim = "Prim"

345

350

346−prelude :: String

351+prelude :: Text

347prelude = "Prelude"

352prelude = "Prelude"

348

353

349−dataArray :: String

354+dataArray :: Text

350dataArray = "Data_Array"

355dataArray = "Data_Array"

351

356

352−eff :: String

357+eff :: Text

353eff = "Control_Monad_Eff"

358eff = "Control_Monad_Eff"

354

359

355−st :: String

360+st :: Text

356st = "Control_Monad_ST"

361st = "Control_Monad_ST"

357

362

358−controlApplicative :: String

363+controlApplicative :: Text

359controlApplicative = "Control_Applicative"

364controlApplicative = "Control_Applicative"

360

365

361−controlSemigroupoid :: String

366+controlSemigroupoid :: Text

362controlSemigroupoid = "Control_Semigroupoid"

367controlSemigroupoid = "Control_Semigroupoid"

363

368

364−controlBind :: String

369+controlBind :: Text

365controlBind = "Control_Bind"

370controlBind = "Control_Bind"

366

371

367−dataBounded :: String

372+dataBounded :: Text

368dataBounded = "Data_Bounded"

373dataBounded = "Data_Bounded"

369

374

370−dataSemigroup :: String

375+dataSemigroup :: Text

371dataSemigroup = "Data_Semigroup"

376dataSemigroup = "Data_Semigroup"

372

377

373−dataHeytingAlgebra :: String

378+dataHeytingAlgebra :: Text

374dataHeytingAlgebra = "Data_HeytingAlgebra"

379dataHeytingAlgebra = "Data_HeytingAlgebra"

375

380

376−dataEq :: String

381+dataEq :: Text

377dataEq = "Data_Eq"

382dataEq = "Data_Eq"

378

383

379−dataOrd :: String

384+dataOrd :: Text

380dataOrd = "Data_Ord"

385dataOrd = "Data_Ord"

381

386

382−dataSemiring :: String

387+dataSemiring :: Text

383dataSemiring = "Data_Semiring"

388dataSemiring = "Data_Semiring"

384

389

385−dataRing :: String

390+dataRing :: Text

386dataRing = "Data_Ring"

391dataRing = "Data_Ring"

387

392

388−dataEuclideanRing :: String

393+dataEuclideanRing :: Text

389dataEuclideanRing = "Data_EuclideanRing"

394dataEuclideanRing = "Data_EuclideanRing"

390

395

391−dataFunction :: String

396+dataFunction :: Text

392dataFunction = "Data_Function"

397dataFunction = "Data_Function"

393

398

394−dataFunctionUncurried :: String

399+dataFunctionUncurried :: Text

395dataFunctionUncurried = "Data_Function_Uncurried"

400dataFunctionUncurried = "Data_Function_Uncurried"

396

401

397−dataIntBits :: String

402+dataIntBits :: Text

398dataIntBits = "Data_Int_Bits"

403dataIntBits = "Data_Int_Bits"

src/Language/PureScript/CoreFn/Desugar.hs+9−1

@@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals

13import Language.PureScript.AST.SourcePos

14import Language.PureScript.AST.Traversals

15import Language.PureScript.Comments

16+import qualified Language.PureScript.Constants as C

16import Language.PureScript.CoreFn.Ann

17import Language.PureScript.CoreFn.Ann

17import Language.PureScript.CoreFn.Binders

18import Language.PureScript.CoreFn.Binders

18import Language.PureScript.CoreFn.Expr

19import Language.PureScript.CoreFn.Expr

@@ -110,7 +111,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

110 exprToCoreFn ss com (Just ty) v

111 exprToCoreFn ss com (Just ty) v

111 exprToCoreFn ss com ty (A.Let ds v) =

112 exprToCoreFn ss com ty (A.Let ds v) =

112 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

113 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

113− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =

114+ exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) =

115+ exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit)

116+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) =

114 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

117 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

115 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

118 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

116 in foldl (App (ss, com, Nothing, Nothing)) ctor args

119 in foldl (App (ss, com, Nothing, Nothing)) ctor args

@@ -209,6 +212,11 @@ findQualModules decls =

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

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

210 fqValues (A.Var q) = getQual' q

213 fqValues (A.Var q) = getQual' q

211 fqValues (A.Constructor q) = getQual' q

214 fqValues (A.Constructor q) = getQual' q

215+ -- IsSymbol instances for literal symbols are automatically solved and the type

216+ -- class dictionaries are built inline instead of having a named instance defined

217+ -- and imported. We therefore need to import the IsSymbol constructor from

218+ -- Data.Symbol if it hasn't already been imported.

219+ fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol

212 fqValues _ = []

220 fqValues _ = []

213

221

214 fqBinders :: A.Binder -> [ModuleName]

222 fqBinders :: A.Binder -> [ModuleName]

src/Language/PureScript/CoreFn/Expr.hs+3−2

@@ -6,6 +6,7 @@ module Language.PureScript.CoreFn.Expr where

6import Prelude.Compat

7

8import Control.Arrow ((***))

9+import Data.Text (Text)

9

10

10import Language.PureScript.AST.Literals

11import Language.PureScript.AST.Literals

11import Language.PureScript.CoreFn.Binders

12import Language.PureScript.CoreFn.Binders

@@ -26,11 +27,11 @@ data Expr a

26 -- |

27 -- |

27 -- A record property accessor

28 -- A record property accessor

28 --

29 --

29− | Accessor a String (Expr a)

30+ | Accessor a Text (Expr a)

30 -- |

31 -- |

31 -- Partial record update

32 -- Partial record update

32 --

33 --

33− | ObjectUpdate a (Expr a) [(String, Expr a)]

34+ | ObjectUpdate a (Expr a) [(Text, Expr a)]

34 -- |

35 -- |

35 -- Function introduction

36 -- Function introduction

36 --

37 --

src/Language/PureScript/CoreFn/ToJSON.hs+13−11

@@ -1,3 +1,4 @@

1+{-# LANGUAGE NoOverloadedStrings #-}

1-- |

2-- |

2-- Dump the core functional representation in JSON format for consumption

3-- Dump the core functional representation in JSON format for consumption

3-- by third-party code generators

4-- by third-party code generators

@@ -10,7 +11,8 @@ import Prelude.Compat

10

11

11import Data.Aeson

12import Data.Aeson

12import Data.Version (Version, showVersion)

13import Data.Version (Version, showVersion)

13−import Data.Text (pack)

14+import Data.Text (Text)

15+import qualified Data.Text as T

14

16

15import Language.PureScript.AST.Literals

17import Language.PureScript.AST.Literals

16import Language.PureScript.CoreFn

18import Language.PureScript.CoreFn

@@ -31,26 +33,26 @@ identToJSON = toJSON . runIdent

31properNameToJSON :: ProperName a -> Value

33properNameToJSON :: ProperName a -> Value

32properNameToJSON = toJSON . runProperName

34properNameToJSON = toJSON . runProperName

33

35

34−qualifiedToJSON :: (a -> String) -> Qualified a -> Value

36+qualifiedToJSON :: (a -> Text) -> Qualified a -> Value

35qualifiedToJSON f = toJSON . showQualified f

37qualifiedToJSON f = toJSON . showQualified f

36

38

37moduleNameToJSON :: ModuleName -> Value

39moduleNameToJSON :: ModuleName -> Value

38moduleNameToJSON = toJSON . runModuleName

40moduleNameToJSON = toJSON . runModuleName

39

41

40moduleToJSON :: Version -> Module a -> Value

42moduleToJSON :: Version -> Module a -> Value

41−moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)

43+moduleToJSON v m = object [ T.pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)

42− , pack "exports" .= map identToJSON (moduleExports m)

44+ , T.pack "exports" .= map identToJSON (moduleExports m)

43− , pack "foreign" .= map (identToJSON . fst) (moduleForeign m)

45+ , T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m)

44− , pack "decls" .= map bindToJSON (moduleDecls m)

46+ , T.pack "decls" .= map bindToJSON (moduleDecls m)

45− , pack "builtWith" .= toJSON (showVersion v)

47+ , T.pack "builtWith" .= toJSON (showVersion v)

46 ]

48 ]

47

49

48bindToJSON :: Bind a -> Value

50bindToJSON :: Bind a -> Value

49−bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]

51+bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]

50−bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs

52+bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs

51

53

52−recordToJSON :: (a -> Value) -> [(String, a)] -> Value

54+recordToJSON :: (a -> Value) -> [(Text, a)] -> Value

53−recordToJSON f = object . map (\(label, a) -> pack label .= f a)

55+recordToJSON f = object . map (\(label, a) -> label .= f a)

54

56

55exprToJSON :: Expr a -> Value

57exprToJSON :: Expr a -> Value

56exprToJSON (Var _ i) = toJSON ( "Var"

58exprToJSON (Var _ i) = toJSON ( "Var"

src/Language/PureScript/Docs/AsMarkdown.hs+3−2

@@ -14,6 +14,7 @@ import Control.Monad.Writer (Writer, tell, execWriter)

14

15import Data.Foldable (for_)

16import Data.List (partition)

17+import qualified Data.Text as T

17

18

18import Language.PureScript.Docs.RenderedCode

19import Language.PureScript.Docs.RenderedCode

19import Language.PureScript.Docs.Types

20import Language.PureScript.Docs.Types

@@ -37,13 +38,13 @@ modulesAsMarkdown = mapM_ moduleAsMarkdown

37

38

38moduleAsMarkdown :: Module -> Docs

39moduleAsMarkdown :: Module -> Docs

39moduleAsMarkdown Module{..} = do

40moduleAsMarkdown Module{..} = do

40− headerLevel 2 $ "Module " ++ P.runModuleName modName

41+ headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName)

41 spacer

42 spacer

42 for_ modComments tell'

43 for_ modComments tell'

43 mapM_ (declAsMarkdown modName) modDeclarations

44 mapM_ (declAsMarkdown modName) modDeclarations

44 spacer

45 spacer

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

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

46− headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"

47+ headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":"

47 spacer

48 spacer

48 mapM_ (declAsMarkdown mn) decls

49 mapM_ (declAsMarkdown mn) decls

49

50

src/Language/PureScript/Docs/Convert.hs+2−3

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3-- | Functions for converting PureScript ASTs into values of the data types

1-- | Functions for converting PureScript ASTs into values of the data types

4-- from Language.PureScript.Docs.

2-- from Language.PureScript.Docs.

5

3

@@ -18,6 +16,7 @@ import Control.Monad.Error.Class (MonadError)

18import Control.Monad.State (runStateT)

16import Control.Monad.State (runStateT)

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

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

20import qualified Data.Map as Map

18import qualified Data.Map as Map

19+import qualified Data.Text as T

21

20

22import Language.PureScript.Docs.Convert.ReExports (updateReExports)

21import Language.PureScript.Docs.Convert.ReExports (updateReExports)

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

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

@@ -170,7 +169,7 @@ insertValueTypes env m =

170

169

171runParser :: P.TokenParser a -> String -> Either String a

170runParser :: P.TokenParser a -> String -> Either String a

172runParser p s = either (Left . show) Right $ do

171runParser p s = either (Left . show) Right $ do

173− ts <- P.lex "" s

172+ ts <- P.lex "" (T.pack s)

174 P.runTokenParser "" (p <* eof) ts

173 P.runTokenParser "" (p <* eof) ts

175

174

176-- |

175-- |

src/Language/PureScript/Docs/Convert/ReExports.hs+16−15

@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports

4

5import Prelude.Compat

6

7−import Control.Arrow ((&&&), second)

7+import Control.Arrow ((&&&), first, second)

8import Control.Monad

9import Control.Monad.Reader.Class (MonadReader, ask)

10import Control.Monad.State.Class (MonadState, gets, modify)

@@ -16,6 +16,7 @@ import Data.Map (Map)

16import Data.Maybe (mapMaybe)

17import Data.Monoid ((<>))

18import qualified Data.Map as Map

19+import qualified Data.Text as T

19

20

20import Language.PureScript.Docs.Types

21import Language.PureScript.Docs.Types

21import qualified Language.PureScript as P

22import qualified Language.PureScript as P

@@ -52,7 +53,7 @@ updateReExports env order = execState action

52 Just v' ->

53 Just v' ->

53 pure v'

54 pure v'

54 Nothing ->

55 Nothing ->

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

56+ internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))

56

57

57-- |

58-- |

58-- Collect all of the re-exported declarations for a single module.

59-- Collect all of the re-exported declarations for a single module.

@@ -69,7 +70,7 @@ getReExports ::

69getReExports env mn =

70getReExports env mn =

70 case Map.lookup mn env of

71 case Map.lookup mn env of

71 Nothing ->

72 Nothing ->

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

73+ internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))

73 Just (_, imports, exports) -> do

74 Just (_, imports, exports) -> do

74 allExports <- runReaderT (collectDeclarations imports exports) mn

75 allExports <- runReaderT (collectDeclarations imports exports) mn

75 pure (filter notLocal allExports)

76 pure (filter notLocal allExports)

@@ -188,7 +189,7 @@ lookupValueDeclaration importedFrom ident = do

188 decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom

189 decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom

189 let

190 let

190 rs =

191 rs =

191− filter (\d -> declTitle d == P.showIdent ident

192+ filter (\d -> declTitle d == T.unpack (P.showIdent ident)

192 && (isValue d || isValueAlias d)) decls

193 && (isValue d || isValueAlias d)) decls

193 errOther other =

194 errOther other =

194 internalErrorInModule

195 internalErrorInModule

@@ -214,7 +215,7 @@ lookupValueDeclaration importedFrom ident = do

214 (declChildren d))

215 (declChildren d))

215

216

216 matchesIdent cdecl =

217 matchesIdent cdecl =

217− cdeclTitle cdecl == P.showIdent ident

218+ cdeclTitle cdecl == T.unpack (P.showIdent ident)

218

219

219 matchesAndIsTypeClassMember =

220 matchesAndIsTypeClassMember =

220 uncurry (&&) . (matchesIdent &&& isTypeClassMember)

221 uncurry (&&) . (matchesIdent &&& isTypeClassMember)

@@ -238,7 +239,7 @@ lookupValueOpDeclaration

238 -> m (P.ModuleName, [Declaration])

239 -> m (P.ModuleName, [Declaration])

239lookupValueOpDeclaration importedFrom op = do

240lookupValueOpDeclaration importedFrom op = do

240 decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom

241 decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom

241− case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of

242+ case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of

242 [d] ->

243 [d] ->

243 pure (importedFrom, [d])

244 pure (importedFrom, [d])

244 other ->

245 other ->

@@ -258,7 +259,7 @@ lookupTypeDeclaration ::

258lookupTypeDeclaration importedFrom ty = do

259lookupTypeDeclaration importedFrom ty = do

259 decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom

260 decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom

260 let

261 let

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

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

262 case ds of

263 case ds of

263 [d] ->

264 [d] ->

264 pure (importedFrom, [d])

265 pure (importedFrom, [d])

@@ -274,7 +275,7 @@ lookupTypeOpDeclaration

274lookupTypeOpDeclaration importedFrom tyOp = do

275lookupTypeOpDeclaration importedFrom tyOp = do

275 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

276 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

276 let

277 let

277− ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls

278+ ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls

278 case ds of

279 case ds of

279 [d] ->

280 [d] ->

280 pure (importedFrom, [d])

281 pure (importedFrom, [d])

@@ -290,7 +291,7 @@ lookupTypeClassDeclaration

290lookupTypeClassDeclaration importedFrom tyClass = do

291lookupTypeClassDeclaration importedFrom tyClass = do

291 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

292 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

292 let

293 let

293− ds = filter (\d -> declTitle d == P.runProperName tyClass

294+ ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass)

294 && isTypeClass d)

295 && isTypeClass d)

295 decls

296 decls

296 case ds of

297 case ds of

@@ -317,7 +318,7 @@ lookupModuleDeclarations definedIn moduleName = do

317 Nothing ->

318 Nothing ->

318 internalErrorInModule

319 internalErrorInModule

319 (definedIn ++ ": module missing: "

320 (definedIn ++ ": module missing: "

320− ++ P.runModuleName moduleName)

321+ ++ T.unpack (P.runModuleName moduleName))

321 Just mdl ->

322 Just mdl ->

322 pure (allDeclarations mdl)

323 pure (allDeclarations mdl)

323

324

@@ -447,7 +448,7 @@ filterDataConstructors

447 -> Map P.ModuleName [Declaration]

448 -> Map P.ModuleName [Declaration]

449 -> Map P.ModuleName [Declaration]

449filterDataConstructors =

450filterDataConstructors =

450− filterExportedChildren isDataConstructor P.runProperName

451+ filterExportedChildren isDataConstructor (T.unpack . P.runProperName)

451

452

452-- |

453-- |

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

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

@@ -459,7 +460,7 @@ filterTypeClassMembers

459 -> Map P.ModuleName [Declaration]

460 -> Map P.ModuleName [Declaration]

461 -> Map P.ModuleName [Declaration]

461filterTypeClassMembers =

462filterTypeClassMembers =

462− filterExportedChildren isTypeClassMember P.showIdent

463+ filterExportedChildren isTypeClassMember (T.unpack . P.showIdent)

463

464

464filterExportedChildren

465filterExportedChildren

465 :: (Functor f)

466 :: (Functor f)

@@ -492,7 +493,7 @@ internalErrorInModule

492internalErrorInModule msg = do

493internalErrorInModule msg = do

493 mn <- ask

494 mn <- ask

494 internalError

495 internalError

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

496+ ("while collecting re-exports for module: " ++ T.unpack (P.runModuleName mn) ++

496 ", " ++ msg)

497 ", " ++ msg)

497

498

498-- |

499-- |

@@ -502,8 +503,8 @@ internalErrorInModule msg = do

502typeClassConstraintFor :: Declaration -> Maybe P.Constraint

503typeClassConstraintFor :: Declaration -> Maybe P.Constraint

503typeClassConstraintFor Declaration{..} =

504typeClassConstraintFor Declaration{..} =

504 case declInfo of

505 case declInfo of

505− TypeClassDeclaration tyArgs _ ->

506+ TypeClassDeclaration tyArgs _ _ ->

506− Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)

507+ Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing)

507 _ ->

508 _ ->

508 Nothing

509 Nothing

509 where

510 where

src/Language/PureScript/Docs/Convert/Single.hs+40−17

@@ -5,16 +5,24 @@ module Language.PureScript.Docs.Convert.Single

5

6import Prelude.Compat

7

8+import Control.Arrow (first)

8import Control.Category ((>>>))

9import Control.Category ((>>>))

9import Control.Monad

10import Control.Monad

10

11

12+import Data.Bifunctor (bimap)

11import Data.Either

13import Data.Either

12import Data.List (nub)

14import Data.List (nub)

13import Data.Maybe (mapMaybe)

15import Data.Maybe (mapMaybe)

16+import Data.Monoid ((<>))

17+import Data.Text (Text)

18+import qualified Data.Text as T

19+import qualified Data.Vector as V

14

20

15import Language.PureScript.Docs.Types

21import Language.PureScript.Docs.Types

16import qualified Language.PureScript as P

22import qualified Language.PureScript as P

17

23

24+-- TODO (Christoph): Get rid of the T.unpack s

25+

18-- |

26-- |

19-- Convert a single Module, but ignore re-exports; any re-exported types or

27-- Convert a single Module, but ignore re-exports; any re-exported types or

20-- values will not appear in the result.

28-- values will not appear in the result.

@@ -75,7 +83,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

75 augmentWith (AugmentChild child) d =

83 augmentWith (AugmentChild child) d =

76 d { declChildren = declChildren d ++ [child] }

84 d { declChildren = declChildren d ++ [child] }

77

85

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

86+getDeclarationTitle :: P.Declaration -> Maybe Text

79getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

87getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

80getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

88getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

81getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

89getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

@@ -83,25 +91,25 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName nam

83getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

91getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

84getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)

92getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)

85getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

93getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

86−getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)

94+getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " <> P.showOp op)

87getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)

95getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)

88getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

96getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

89getDeclarationTitle _ = Nothing

97getDeclarationTitle _ = Nothing

90

98

91-- | Create a basic Declaration value.

99-- | Create a basic Declaration value.

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

100+mkDeclaration :: Text -> DeclarationInfo -> Declaration

93mkDeclaration title info =

101mkDeclaration title info =

94− Declaration { declTitle = title

102+ Declaration { declTitle = T.unpack title

95 , declComments = Nothing

103 , declComments = Nothing

96 , declSourceSpan = Nothing

104 , declSourceSpan = Nothing

97 , declChildren = []

105 , declChildren = []

98 , declInfo = info

106 , declInfo = info

99 }

107 }

100

108

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

109+basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration

102basicDeclaration title info = Just $ Right $ mkDeclaration title info

110basicDeclaration title info = Just $ Right $ mkDeclaration title info

103

111

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

112+convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration

105convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

113convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

106 basicDeclaration title (ValueDeclaration ty)

114 basicDeclaration title (ValueDeclaration ty)

107convertDeclaration P.ValueDeclaration{} title =

115convertDeclaration P.ValueDeclaration{} title =

@@ -113,27 +121,42 @@ convertDeclaration (P.ExternDeclaration _ ty) title =

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

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

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

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

115 where

123 where

116− info = DataDeclaration dtype args

124+ info = DataDeclaration dtype (map (first T.unpack) args)

117 children = map convertCtor ctors

125 children = map convertCtor ctors

118 convertCtor (ctor', tys) =

126 convertCtor (ctor', tys) =

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

127+ ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys)

120convertDeclaration (P.ExternDataDeclaration _ kind') title =

128convertDeclaration (P.ExternDataDeclaration _ kind') title =

121 basicDeclaration title (ExternDataDeclaration kind')

129 basicDeclaration title (ExternDataDeclaration kind')

122convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

130convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

123− basicDeclaration title (TypeSynonymDeclaration args ty)

131+ basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)

124−convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info

132+convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =

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

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

126 where

134 where

127− info = TypeClassDeclaration args implies

135+ info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps')

128 children = map convertClassMember ds

136 children = map convertClassMember ds

129 convertClassMember (P.PositionedDeclaration _ _ d) =

137 convertClassMember (P.PositionedDeclaration _ _ d) =

130 convertClassMember d

138 convertClassMember d

131 convertClassMember (P.TypeDeclaration ident' ty) =

139 convertClassMember (P.TypeDeclaration ident' ty) =

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

140+ ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty)

133 convertClassMember _ =

141 convertClassMember _ =

134 P.internalError "convertDeclaration: Invalid argument to convertClassMember."

142 P.internalError "convertDeclaration: Invalid argument to convertClassMember."

143+ fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps

144+ where

145+ argsVec = V.fromList (map fst args)

146+ getArg i =

147+ maybe

148+ (P.internalError $ unlines

149+ [ "convertDeclaration: Functional dependency index"

150+ , show i

151+ , "is bigger than arguments list"

152+ , show (map fst args)

153+ , "Functional dependencies are"

154+ , show fundeps

155+ ]

156+ ) id $ argsVec V.!? i

157+ toArgs from to = (map getArg from, map getArg to)

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

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

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

159+ Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl))

137 where

160 where

138 classNameString = unQual className

161 classNameString = unQual className

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

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

@@ -142,7 +165,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

142 extractProperNames (P.TypeConstructor n) = [unQual n]

165 extractProperNames (P.TypeConstructor n) = [unQual n]

143 extractProperNames _ = []

166 extractProperNames _ = []

144

167

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

168+ childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp)

146 classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys

169 classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys

147convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =

170convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =

148 Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))

171 Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))

@@ -174,8 +197,8 @@ convertComments cs = do

174 pure (unlines docs)

197 pure (unlines docs)

175

198

176 where

199 where

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

200+ toLines (P.LineComment s) = [T.unpack s]

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

201+ toLines (P.BlockComment s) = lines (T.unpack s)

179

202

180 stripPipe s' =

203 stripPipe s' =

181 case dropWhile (== ' ') s' of

204 case dropWhile (== ' ') s' of

@@ -196,5 +219,5 @@ collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

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

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

197collectBookmarks' m =

220collectBookmarks' m =

198 map (P.getModuleName m, )

221 map (P.getModuleName m, )

199− (mapMaybe getDeclarationTitle

222+ (mapMaybe (fmap T.unpack . getDeclarationTitle)

200 (P.exportedDeclarations m))

223 (P.exportedDeclarations m))

src/Language/PureScript/Docs/Render.hs+24−10

@@ -13,12 +13,16 @@ import Prelude.Compat

13

14import Data.Maybe (maybeToList)

15import Data.Monoid ((<>))

16+import qualified Data.Text as T

17+import Data.Text (Text)

16

18

17import Language.PureScript.Docs.RenderedCode

19import Language.PureScript.Docs.RenderedCode

18import Language.PureScript.Docs.Types

20import Language.PureScript.Docs.Types

19import Language.PureScript.Docs.Utils.MonoidExtras

21import Language.PureScript.Docs.Utils.MonoidExtras

20import qualified Language.PureScript as P

22import qualified Language.PureScript as P

21

23

24+-- TODO (Christoph): get rid of T.unpack's

25+

22renderDeclaration :: Declaration -> RenderedCode

26renderDeclaration :: Declaration -> RenderedCode

23renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions

27renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions

24

28

@@ -31,7 +35,7 @@ renderDeclarationWithOptions opts Declaration{..} =

31 , renderType' ty

35 , renderType' ty

32 ]

36 ]

33 DataDeclaration dtype args ->

37 DataDeclaration dtype args ->

34− [ keyword (P.showDataDeclType dtype)

38+ [ keyword (T.unpack (P.showDataDeclType dtype))

35 , renderType' (typeApp declTitle args)

39 , renderType' (typeApp declTitle args)

36 ]

40 ]

37 ExternDataDeclaration kind' ->

41 ExternDataDeclaration kind' ->

@@ -46,10 +50,11 @@ renderDeclarationWithOptions opts Declaration{..} =

46 , syntax "="

50 , syntax "="

47 , renderType' ty

51 , renderType' ty

48 ]

52 ]

49− TypeClassDeclaration args implies ->

53+ TypeClassDeclaration args implies fundeps ->

50 [ keywordClass ]

54 [ keywordClass ]

51 ++ maybeToList superclasses

55 ++ maybeToList superclasses

52 ++ [renderType' (typeApp declTitle args)]

56 ++ [renderType' (typeApp declTitle args)]

57+ ++ fundepsList

53 ++ [keywordWhere | any isTypeClassMember declChildren]

58 ++ [keywordWhere | any isTypeClassMember declChildren]

54

59

55 where

60 where

@@ -60,6 +65,15 @@ renderDeclarationWithOptions opts Declaration{..} =

60 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

65 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

61 <> syntax ")" <> sp <> syntax "<="

66 <> syntax ")" <> sp <> syntax "<="

62

67

68+ fundepsList =

69+ [syntax "|" | not (null fundeps)]

70+ ++ [mintersperse

71+ (syntax "," <> sp)

72+ [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]

73+ ]

74+ where

75+ idents = mintersperse sp . map ident

76+

63 AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

77 AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

64 [ keywordFixity associativity

78 [ keywordFixity associativity

65 , syntax $ show precedence

79 , syntax $ show precedence

@@ -74,15 +88,15 @@ renderDeclarationWithOptions opts Declaration{..} =

74

88

75 renderQualAlias :: FixityAlias -> String

89 renderQualAlias :: FixityAlias -> String

76 renderQualAlias (P.Qualified mn alias)

90 renderQualAlias (P.Qualified mn alias)

77− | mn == currentModule opts = renderAlias id alias

91+ | mn == currentModule opts = T.unpack (renderAlias id alias)

78− | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias

92+ | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias)

79

93

80 renderAlias

94 renderAlias

81− :: (forall a. (a -> String) -> a -> String)

95+ :: (forall a. (a -> Text) -> a -> Text)

82 -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))

96 -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))

83− -> String

97+ -> Text

84 renderAlias f

98 renderAlias f

85− = either (("type " ++) . f P.runProperName)

99+ = either (("type " <>) . f P.runProperName)

86 $ either (f P.runIdent) (f P.runProperName)

100 $ either (f P.runIdent) (f P.runProperName)

87

101

88 -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)

102 -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)

@@ -133,7 +147,7 @@ renderConstraintsWithOptions opts constraints

133 (map (renderConstraintWithOptions opts) constraints)

147 (map (renderConstraintWithOptions opts) constraints)

134

148

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

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

136−notQualified = P.Qualified Nothing . P.ProperName

150+notQualified = P.Qualified Nothing . P.ProperName . T.pack

137

151

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

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

139typeApp title typeArgs =

153typeApp title typeArgs =

@@ -142,5 +156,5 @@ typeApp title typeArgs =

142 (map toTypeVar typeArgs)

156 (map toTypeVar typeArgs)

143

157

144toTypeVar :: (String, Maybe P.Kind) -> P.Type

158toTypeVar :: (String, Maybe P.Kind) -> P.Type

145−toTypeVar (s, Nothing) = P.TypeVar s

159+toTypeVar (s, Nothing) = P.TypeVar (T.pack s)

146−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k

160+toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k

src/Language/PureScript/Docs/RenderedCode/Render.hs+11−7

@@ -14,8 +14,10 @@ import Prelude.Compat

14

15import Data.Maybe (fromMaybe)

16import Data.Monoid ((<>))

17+import qualified Data.Text as T

18+import Data.Text (Text)

17

19

18−import Control.Arrow ((<+>))

20+import Control.Arrow ((<+>), first)

19import Control.PatternArrows as PA

21import Control.PatternArrows as PA

20

22

21import Language.PureScript.Crash

23import Language.PureScript.Crash

@@ -33,7 +35,7 @@ typeLiterals = mkPattern match

33 match TypeWildcard{} =

35 match TypeWildcard{} =

34 Just (syntax "_")

36 Just (syntax "_")

35 match (TypeVar var) =

37 match (TypeVar var) =

36− Just (ident var)

38+ Just (ident (T.unpack var))

37 match (PrettyPrintObject row) =

39 match (PrettyPrintObject row) =

38 Just $ mintersperse sp

40 Just $ mintersperse sp

39 [ syntax "{"

41 [ syntax "{"

@@ -41,7 +43,7 @@ typeLiterals = mkPattern match

41 , syntax "}"

43 , syntax "}"

42 ]

44 ]

43 match (TypeConstructor (Qualified mn name)) =

45 match (TypeConstructor (Qualified mn name)) =

44− Just (ctor (runProperName name) (maybeToContainingModule mn))

46+ Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn))

45 match REmpty =

47 match REmpty =

46 Just (syntax "()")

48 Just (syntax "()")

47 match row@RCons{} =

49 match row@RCons{} =

@@ -49,7 +51,7 @@ typeLiterals = mkPattern match

49 match (BinaryNoParensType op l r) =

51 match (BinaryNoParensType op l r) =

50 Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r

52 Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r

51 match (TypeOp (Qualified mn op)) =

53 match (TypeOp (Qualified mn op)) =

52− Just (ident' (runOpName op) (maybeToContainingModule mn))

54+ Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn))

53 match _ =

55 match _ =

54 Nothing

56 Nothing

55

57

@@ -74,8 +76,10 @@ renderConstraints deps ty =

74-- Render code representing a Row

76-- Render code representing a Row

75--

77--

76renderRow :: Type -> RenderedCode

78renderRow :: Type -> RenderedCode

77−renderRow = uncurry renderRow' . rowToList

79+renderRow = uncurry renderRow' . convertString . rowToList

78 where

80 where

81+ convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type)

82+ convertString = first (map (first T.unpack))

79 renderRow' h t = renderHead h <> renderTail t

83 renderRow' h t = renderHead h <> renderTail t

80

84

81renderHead :: [(String, Type)] -> RenderedCode

85renderHead :: [(String, Type)] -> RenderedCode

@@ -144,7 +148,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

144forall_ :: Pattern () Type ([String], Type)

148forall_ :: Pattern () Type ([String], Type)

145forall_ = mkPattern match

149forall_ = mkPattern match

146 where

150 where

147− match (PrettyPrintForAll idents ty) = Just (idents, ty)

151+ match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)

148 match _ = Nothing

152 match _ = Nothing

149

153

150insertPlaceholders :: RenderTypeOptions -> Type -> Type

154insertPlaceholders :: RenderTypeOptions -> Type -> Type

@@ -176,7 +180,7 @@ preprocessType opts = dePrim . insertPlaceholders opts

176-- Render code representing a Kind

180-- Render code representing a Kind

177--

181--

178renderKind :: Kind -> RenderedCode

182renderKind :: Kind -> RenderedCode

179−renderKind = kind . prettyPrintKind

183+renderKind = kind . T.unpack . prettyPrintKind

180

184

181-- |

185-- |

182-- Render code representing a Type, as it should appear inside parentheses

186-- Render code representing a Type, as it should appear inside parentheses

src/Language/PureScript/Docs/RenderedCode/Types.hs+2−2

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE OverloadedStrings #-}

3

2

4-- | Data types and functions for representing a simplified form of PureScript

3-- | Data types and functions for representing a simplified form of PureScript

5-- code, intended for use in e.g. HTML documentation.

4-- code, intended for use in e.g. HTML documentation.

@@ -38,6 +37,7 @@ import Control.Monad.Error.Class (MonadError(..))

38

37

39import Data.Aeson.BetterErrors

38import Data.Aeson.BetterErrors

40import qualified Data.Aeson as A

39import qualified Data.Aeson as A

40+import qualified Data.Text as T

41

42import qualified Language.PureScript as P

43

@@ -103,7 +103,7 @@ instance A.ToJSON ContainingModule where

103

104asContainingModule :: Parse e ContainingModule

105asContainingModule =

106− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString)

106+ maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString)

107

108-- |

109-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious

src/Language/PureScript/Docs/Types.hs+13−9

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3module Language.PureScript.Docs.Types

1module Language.PureScript.Docs.Types

4 ( module Language.PureScript.Docs.Types

2 ( module Language.PureScript.Docs.Types

5 , module ReExports

3 , module ReExports

@@ -122,10 +120,10 @@ data DeclarationInfo

122 | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type

120 | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type

123

121

124 -- |

122 -- |

125− -- A type class, with its type arguments and its superclasses. Instances and

123+ -- A type class, with its type arguments, its superclasses and functional

126− -- members are represented as child declarations.

124+ -- dependencies. Instances and members are represented as child declarations.

127 --

125 --

128− | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

126+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])]

129

127

130 -- |

128 -- |

131 -- An operator alias declaration, with the member the alias is for and the

129 -- An operator alias declaration, with the member the alias is for and the

@@ -141,7 +139,7 @@ declInfoToString (ValueDeclaration _) = "value"

141declInfoToString (DataDeclaration _ _) = "data"

139declInfoToString (DataDeclaration _ _) = "data"

142declInfoToString (ExternDataDeclaration _) = "externData"

140declInfoToString (ExternDataDeclaration _) = "externData"

143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

141declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

144−declInfoToString (TypeClassDeclaration _ _) = "typeClass"

142+declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

145declInfoToString (AliasDeclaration _ _) = "alias"

143declInfoToString (AliasDeclaration _ _) = "alias"

146

144

147isTypeClass :: Declaration -> Bool

145isTypeClass :: Declaration -> Bool

@@ -352,7 +350,7 @@ parseVersion' str =

352

350

353asModule :: Parse PackageError Module

351asModule :: Parse PackageError Module

354asModule =

352asModule =

355− Module <$> key "name" (P.moduleNameFromString <$> asString)

353+ Module <$> key "name" (P.moduleNameFromString <$> asText)

356 <*> key "comments" (perhaps asString)

354 <*> key "comments" (perhaps asString)

357 <*> key "declarations" (eachInArray asDeclaration)

355 <*> key "declarations" (eachInArray asDeclaration)

358 <*> key "reExports" (eachInArray asReExport)

356 <*> key "reExports" (eachInArray asReExport)

@@ -413,6 +411,7 @@ asDeclarationInfo = do

413 "typeClass" ->

411 "typeClass" ->

414 TypeClassDeclaration <$> key "arguments" asTypeArguments

412 TypeClassDeclaration <$> key "arguments" asTypeArguments

415 <*> key "superclasses" (eachInArray asConstraint)

413 <*> key "superclasses" (eachInArray asConstraint)

414+ <*> keyOrDefault "fundeps" [] asFunDeps

416 "alias" ->

415 "alias" ->

417 AliasDeclaration <$> key "fixity" asFixity

416 AliasDeclaration <$> key "fixity" asFixity

418 <*> key "alias" asFixityAlias

417 <*> key "alias" asFixityAlias

@@ -430,6 +429,11 @@ asKind = fromAesonParser

430asType :: Parse e P.Type

429asType :: Parse e P.Type

431asType = fromAesonParser

430asType = fromAesonParser

432

431

432+asFunDeps :: Parse PackageError [([String], [String])]

433+asFunDeps = eachInArray asFunDep

434+ where

435+ asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString)

436+

433asDataDeclType :: Parse PackageError P.DataDeclType

437asDataDeclType :: Parse PackageError P.DataDeclType

434asDataDeclType =

438asDataDeclType =

435 withString $ \s -> case s of

439 withString $ \s -> case s of

@@ -478,7 +482,7 @@ asBookmarks = eachInArray asBookmark

478

482

479asBookmark :: Parse BowerError Bookmark

483asBookmark :: Parse BowerError Bookmark

480asBookmark =

484asBookmark =

481− asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

485+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)

482 <*> nth 1 asString)

486 <*> nth 1 asString)

483

487

484asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

488asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

@@ -556,7 +560,7 @@ instance A.ToJSON DeclarationInfo where

556 DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]

560 DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]

557 ExternDataDeclaration kind -> ["kind" .= kind]

561 ExternDataDeclaration kind -> ["kind" .= kind]

558 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

562 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

559− TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

563+ TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]

560 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

564 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

561

565

562instance A.ToJSON ChildDeclarationInfo where

566instance A.ToJSON ChildDeclarationInfo where

src/Language/PureScript/Environment.hs+62−11

@@ -1,4 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3

2

4module Language.PureScript.Environment where

3module Language.PureScript.Environment where

@@ -6,10 +5,14 @@ module Language.PureScript.Environment where

6import Prelude.Compat

5import Prelude.Compat

7

6

8import Data.Aeson.TH

7import Data.Aeson.TH

9−import Data.Maybe (fromMaybe)

10import qualified Data.Aeson as A

8import qualified Data.Aeson as A

11import qualified Data.Map as M

9import qualified Data.Map as M

10+import qualified Data.Set as S

11+import Data.Maybe (fromMaybe)

12+import Data.Text (Text)

12import qualified Data.Text as T

13import qualified Data.Text as T

14+import Data.List (nub)

15+import qualified Data.Graph as G

13

16

14import Language.PureScript.Crash

17import Language.PureScript.Crash

15import Language.PureScript.Kinds

18import Language.PureScript.Kinds

@@ -27,9 +30,9 @@ data Environment = Environment

27 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

30 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

28 -- ^ Data constructors currently in scope, along with their associated type

31 -- ^ Data constructors currently in scope, along with their associated type

29 -- constructor name, argument types and return type.

32 -- constructor name, argument types and return type.

30− , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)

33+ , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)

31 -- ^ Type synonyms currently in scope

34 -- ^ Type synonyms currently in scope

32− , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

35+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))

33 -- ^ Available type class dictionaries

36 -- ^ Available type class dictionaries

34 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

37 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

35 -- ^ Type classes

38 -- ^ Type classes

@@ -37,7 +40,7 @@ data Environment = Environment

37

40

38-- | Information about a type class

41-- | Information about a type class

39data TypeClassData = TypeClassData

42data TypeClassData = TypeClassData

40− { typeClassArguments :: [(String, Maybe Kind)]

43+ { typeClassArguments :: [(Text, Maybe Kind)]

41 -- ^ A list of type argument names, and their kinds, where kind annotations

44 -- ^ A list of type argument names, and their kinds, where kind annotations

42 -- were provided.

45 -- were provided.

43 , typeClassMembers :: [(Ident, Type)]

46 , typeClassMembers :: [(Ident, Type)]

@@ -48,6 +51,10 @@ data TypeClassData = TypeClassData

48 -- are considered bound in the types appearing in these constraints.

51 -- are considered bound in the types appearing in these constraints.

49 , typeClassDependencies :: [FunctionalDependency]

52 , typeClassDependencies :: [FunctionalDependency]

50 -- ^ A list of functional dependencies for the type arguments of this class.

53 -- ^ A list of functional dependencies for the type arguments of this class.

54+ , typeClassDeterminedArguments :: S.Set Int

55+ -- ^ A set of indexes of type argument that are fully determined by other

56+ -- arguments via functional dependencies. This can be computed from both

57+ -- typeClassArguments and typeClassDependencies.

51 } deriving Show

58 } deriving Show

52

59

53-- | A functional dependency indicates a relationship between two sets of

60-- | A functional dependency indicates a relationship between two sets of

@@ -65,6 +72,50 @@ data FunctionalDependency = FunctionalDependency

65initEnvironment :: Environment

72initEnvironment :: Environment

66initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

73initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

67

74

75+-- |

76+-- A constructor for TypeClassData that computes which type class arguments are fully determined.

77+-- Fully determined means that this argument cannot be used when selecting a type class instance.

78+--

79+-- An example of the difference between determined and fully determined would be with the class:

80+-- ```class C a b c | a -> b, b -> a, b -> c```

81+-- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other.

82+-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is

83+-- fully determined by `a` and `b`.

84+--

85+-- Define a graph of type class arguments with edges being fundep determiners to determined.

86+-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.

87+-- An argument is not fully determined otherwise.

88+--

89+-- The way we compute this is by saying: an argument X is fully determined if there are arguments that

90+-- determine X that X does not determine. This is the same thing: everything X determines includes everything

91+-- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC.

92+makeTypeClassData

93+ :: [(Text, Maybe Kind)]

94+ -> [(Ident, Type)]

95+ -> [Constraint]

96+ -> [FunctionalDependency]

97+ -> TypeClassData

98+makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs

99+ where

100+ -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined

101+ contributingDeps = M.fromListWith (++) $ do

102+ fd <- deps

103+ src <- fdDeterminers fd

104+ (src, fdDetermined fd) : map (, []) (fdDetermined fd)

105+

106+ -- here we build a graph of which arguments determine other arguments

107+ (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)

108+

109+ -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to

110+ isFunDepDetermined arg = case fromKey arg of

111+ Nothing -> False -- not mentioned in fundeps

112+ Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v

113+ varContributesTo = G.reachable depGraph v

114+ in any (\r -> not (r `elem` varContributesTo)) contributesToVar

115+

116+ -- find all the arguments that are determined

117+ determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]

118+

68-- |

119-- |

69-- The visibility of a name in scope

120-- The visibility of a name in scope

70--

121--

@@ -105,7 +156,7 @@ data TypeKind

105 -- |

156 -- |

106 -- Data type

157 -- Data type

107 --

158 --

108− = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

159+ = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

109 -- |

160 -- |

110 -- Type synonym

161 -- Type synonym

111 --

162 --

@@ -138,7 +189,7 @@ data DataDeclType

138 | Newtype

189 | Newtype

139 deriving (Show, Eq, Ord)

190 deriving (Show, Eq, Ord)

140

191

141−showDataDeclType :: DataDeclType -> String

192+showDataDeclType :: DataDeclType -> Text

142showDataDeclType Data = "data"

193showDataDeclType Data = "data"

143showDataDeclType Newtype = "newtype"

194showDataDeclType Newtype = "newtype"

144

195

@@ -155,13 +206,13 @@ instance A.FromJSON DataDeclType where

155-- |

206-- |

156-- Construct a ProperName in the Prim module

207-- Construct a ProperName in the Prim module

157--

208--

158−primName :: String -> Qualified (ProperName a)

209+primName :: Text -> Qualified (ProperName a)

159primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

210primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

160

211

161-- |

212-- |

162-- Construct a type in the Prim module

213-- Construct a type in the Prim module

163--

214--

164−primTy :: String -> Type

215+primTy :: Text -> Type

165primTy = TypeConstructor . primName

216primTy = TypeConstructor . primName

166

217

167-- |

218-- |

@@ -264,8 +315,8 @@ primTypes =

264primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

315primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

265primClasses =

316primClasses =

266 M.fromList

317 M.fromList

267− [ (primName "Partial", (TypeClassData [] [] [] []))

318+ [ (primName "Partial", (makeTypeClassData [] [] [] []))

268− , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] []))

319+ , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] []))

269 ]

320 ]

270

321

271-- |

322-- |

src/Language/PureScript/Errors.hs+151−142

@@ -18,10 +18,12 @@ import Data.Char (isSpace)

18import Data.Either (lefts, rights)

19import Data.Foldable (fold)

20import Data.Functor.Identity (Identity(..))

21−import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

21+import Data.List (transpose, nub, nubBy, sortBy, partition)

22import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

23import Data.Ord (comparing)

24import qualified Data.Map as M

25+import qualified Data.Text as T

26+import Data.Text (Text)

25

27

26import Language.PureScript.AST

28import Language.PureScript.AST

27import Language.PureScript.Crash

29import Language.PureScript.Crash

@@ -43,7 +45,7 @@ import qualified Text.PrettyPrint.Boxes as Box

43import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

45import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

44import Text.Parsec.Error (Message(..))

46import Text.Parsec.Error (Message(..))

45

47

46−newtype ErrorSuggestion = ErrorSuggestion String

48+newtype ErrorSuggestion = ErrorSuggestion Text

47

49

48-- | Get the source span for an error

50-- | Get the source span for an error

49errorSpan :: ErrorMessage -> Maybe SourceSpan

51errorSpan :: ErrorMessage -> Maybe SourceSpan

@@ -73,7 +75,7 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt

73-- |

75-- |

74-- Get the error code for a particular error type

76-- Get the error code for a particular error type

75--

77--

76−errorCode :: ErrorMessage -> String

78+errorCode :: ErrorMessage -> Text

77errorCode em = case unwrapErrorMessage em of

79errorCode em = case unwrapErrorMessage em of

78 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

80 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

79 ErrorParsingModule{} -> "ErrorParsingModule"

81 ErrorParsingModule{} -> "ErrorParsingModule"

@@ -245,7 +247,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

245 case M.lookup s (umSkolemMap m) of

247 case M.lookup s (umSkolemMap m) of

246 Nothing -> do

248 Nothing -> do

247 let s' = umNextIndex m

249 let s' = umNextIndex m

248− put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }

250+ put $ m { umSkolemMap = M.insert s (T.unpack name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }

249 return (Skolem name s' sko ss)

251 return (Skolem name s' sko ss)

250 Just (_, s', _) -> return (Skolem name s' sko ss)

252 Just (_, s', _) -> return (Skolem name s' sko ss)

251 replaceTypes other = return other

253 replaceTypes other = return other

@@ -287,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

287 gTypeSearch (TSBefore env) = pure (TSBefore env)

289 gTypeSearch (TSBefore env) = pure (TSBefore env)

288 gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result

290 gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result

289

291

290−wikiUri :: ErrorMessage -> String

292+wikiUri :: ErrorMessage -> Text

291−wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

293+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e

292

294

293-- TODO Other possible suggestions:

295-- TODO Other possible suggestions:

294-- WildcardInferredType - source span not small enough

296-- WildcardInferredType - source span not small enough

@@ -304,19 +306,19 @@ errorSuggestion err =

304 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

306 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

305 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

307 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

306 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

308 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

307− MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty

309+ MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty)

308− WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty

310+ WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty)

309 _ -> Nothing

311 _ -> Nothing

310 where

312 where

311 emptySuggestion = Just $ ErrorSuggestion ""

313 emptySuggestion = Just $ ErrorSuggestion ""

312 suggest = Just . ErrorSuggestion

314 suggest = Just . ErrorSuggestion

313

315

314− importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String

316+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text

315 importSuggestion mn refs qual =

317 importSuggestion mn refs qual =

316− "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual

318+ "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual

317

319

318− qstr :: Maybe ModuleName -> String

320+ qstr :: Maybe ModuleName -> Text

319− qstr (Just mn) = " as " ++ runModuleName mn

321+ qstr (Just mn) = " as " <> runModuleName mn

320 qstr Nothing = ""

322 qstr Nothing = ""

321

323

322suggestionSpan :: ErrorMessage -> Maybe SourceSpan

324suggestionSpan :: ErrorMessage -> Maybe SourceSpan

@@ -330,7 +332,7 @@ suggestionSpan e =

330 MissingTypeDeclaration{} -> startOnly ss

332 MissingTypeDeclaration{} -> startOnly ss

331 _ -> ss

333 _ -> ss

332

334

333−showSuggestion :: SimpleErrorMessage -> String

335+showSuggestion :: SimpleErrorMessage -> Text

334showSuggestion suggestion = case errorSuggestion suggestion of

336showSuggestion suggestion = case errorSuggestion suggestion of

335 Just (ErrorSuggestion x) -> x

337 Just (ErrorSuggestion x) -> x

336 _ -> ""

338 _ -> ""

@@ -343,10 +345,10 @@ ansiColorReset :: String

343ansiColorReset =

345ansiColorReset =

344 ANSI.setSGRCode [ANSI.Reset]

346 ANSI.setSGRCode [ANSI.Reset]

345

347

346−colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String

348+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text

347colorCode codeColor code = case codeColor of

349colorCode codeColor code = case codeColor of

348 Nothing -> code

350 Nothing -> code

349− Just cc -> concat [ansiColor cc, code, ansiColorReset]

351+ Just cc -> T.pack (ansiColor cc) <> code <> T.pack ansiColorReset

350

352

351colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box

353colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box

352colorCodeBox codeColor b = case codeColor of

354colorCodeBox codeColor b = case codeColor of

@@ -403,8 +405,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

403 ] ++

405 ] ++

404 maybe [] (return . Box.moveDown 1) typeInformation ++

406 maybe [] (return . Box.moveDown 1) typeInformation ++

405 [ Box.moveDown 1 $ paras

407 [ Box.moveDown 1 $ paras

406− [ line $ "See " ++ wikiUri e ++ " for more information, "

408+ [ line $ "See " <> wikiUri e <> " for more information, "

407− , line $ "or to contribute content related to this " ++ levelText ++ "."

409+ , line $ "or to contribute content related to this " <> levelText <> "."

408 ]

410 ]

409 | showWiki

411 | showWiki

410 ]

412 ]

@@ -420,59 +422,59 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

420 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box

422 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box

421 skolemInfo (name, s, ss) =

423 skolemInfo (name, s, ss) =

422 paras $

424 paras $

423− line (markCode (name ++ show s) ++ " is a rigid type variable")

425+ line (markCode (T.pack (name <> show s)) <> " is a rigid type variable")

424− : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss

426+ : foldMap (return . line . (" bound at " <>) . displayStartEndPos) ss

425

427

426 unknownInfo :: Int -> Box.Box

428 unknownInfo :: Int -> Box.Box

427− unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type"

429+ unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"

428

430

429 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

431 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

430 renderSimpleErrorMessage (CannotGetFileInfo path) =

432 renderSimpleErrorMessage (CannotGetFileInfo path) =

431 paras [ line "Unable to read file info: "

433 paras [ line "Unable to read file info: "

432− , indent . line $ path

434+ , indent . lineS $ path

433 ]

435 ]

434 renderSimpleErrorMessage (CannotReadFile path) =

436 renderSimpleErrorMessage (CannotReadFile path) =

435 paras [ line "Unable to read file: "

437 paras [ line "Unable to read file: "

436− , indent . line $ path

438+ , indent . lineS $ path

437 ]

439 ]

438 renderSimpleErrorMessage (CannotWriteFile path) =

440 renderSimpleErrorMessage (CannotWriteFile path) =

439 paras [ line "Unable to write file: "

441 paras [ line "Unable to write file: "

440− , indent . line $ path

442+ , indent . lineS $ path

441 ]

443 ]

442 renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =

444 renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =

443 paras $ [ line "Unable to parse foreign module:"

445 paras $ [ line "Unable to parse foreign module:"

444− , indent . line $ path

446+ , indent . lineS $ path

445 ] ++

447 ] ++

446− map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))

448+ map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra))

447 renderSimpleErrorMessage (ErrorParsingModule err) =

449 renderSimpleErrorMessage (ErrorParsingModule err) =

448 paras [ line "Unable to parse module: "

450 paras [ line "Unable to parse module: "

449 , prettyPrintParseError err

451 , prettyPrintParseError err

450 ]

452 ]

451 renderSimpleErrorMessage (MissingFFIModule mn) =

453 renderSimpleErrorMessage (MissingFFIModule mn) =

452− line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing."

454+ line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing."

453 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

455 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

454− paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": "

456+ paras [ line $ "An unnecessary foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": "

455− , indent . line $ path

457+ , indent . lineS $ path

456− , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

458+ , line $ "Module " <> markCode (runModuleName mn) <> " does not contain any foreign import declarations, so a foreign module is not necessary."

457 ]

459 ]

458 renderSimpleErrorMessage (MissingFFIImplementations mn idents) =

460 renderSimpleErrorMessage (MissingFFIImplementations mn idents) =

459− paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": "

461+ paras [ line $ "The following values are not defined in the foreign module for module " <> markCode (runModuleName mn) <> ": "

460 , indent . paras $ map (line . runIdent) idents

462 , indent . paras $ map (line . runIdent) idents

461 ]

463 ]

462 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =

464 renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =

463− paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: "

465+ paras [ line $ "The following definitions in the foreign module for module " <> markCode (runModuleName mn) <> " are unused: "

464 , indent . paras $ map (line . runIdent) idents

466 , indent . paras $ map (line . runIdent) idents

465 ]

467 ]

466 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =

468 renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =

467− paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":"

469+ paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":"

468 , indent . paras $

470 , indent . paras $

469− [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."

471+ [ line $ "The identifier " <> markCode ident <> " is not valid in PureScript."

470 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."

472 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."

471 ]

473 ]

472 ]

474 ]

473 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

475 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

474− paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": "

476+ paras [ line $ "Multiple foreign module implementations have been provided for module " <> markCode (runModuleName mn) <> ": "

475− , indent . paras $ map line paths

477+ , indent . paras $ map lineS paths

476 ]

478 ]

477 renderSimpleErrorMessage InvalidDoBind =

479 renderSimpleErrorMessage InvalidDoBind =

478 line "The last statement in a 'do' block must be an expression, but this block ends with a binder."

480 line "The last statement in a 'do' block must be an expression, but this block ends with a binder."

@@ -489,63 +491,63 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

489 , indent $ line $ markCode $ prettyPrintKind ki

491 , indent $ line $ markCode $ prettyPrintKind ki

490 ]

492 ]

491 renderSimpleErrorMessage (MultipleValueOpFixities op) =

493 renderSimpleErrorMessage (MultipleValueOpFixities op) =

492− line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op)

494+ line $ "There are multiple fixity/precedence declarations for operator " <> markCode (showOp op)

493 renderSimpleErrorMessage (MultipleTypeOpFixities op) =

495 renderSimpleErrorMessage (MultipleTypeOpFixities op) =

494− line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)

496+ line $ "There are multiple fixity/precedence declarations for type operator " <> markCode (showOp op)

495 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

497 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

496− line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."

498+ line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition."

497 renderSimpleErrorMessage (RedefinedIdent name) =

499 renderSimpleErrorMessage (RedefinedIdent name) =

498− line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"

500+ line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times"

499 renderSimpleErrorMessage (UnknownName name) =

501 renderSimpleErrorMessage (UnknownName name) =

500− line $ "Unknown " ++ printName name

502+ line $ "Unknown " <> printName name

501 renderSimpleErrorMessage (UnknownImport mn name) =

503 renderSimpleErrorMessage (UnknownImport mn name) =

502− paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn)

504+ paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn)

503 , line "It either does not exist or the module does not export it."

505 , line "It either does not exist or the module does not export it."

504 ]

506 ]

505 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

507 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

506− line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon)

508+ line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon)

507 renderSimpleErrorMessage (UnknownExport name) =

509 renderSimpleErrorMessage (UnknownExport name) =

508− line $ "Cannot export unknown " ++ printName (Qualified Nothing name)

510+ line $ "Cannot export unknown " <> printName (Qualified Nothing name)

509 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

511 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

510− line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared."

512+ line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared."

511 renderSimpleErrorMessage (ScopeConflict nm ms) =

513 renderSimpleErrorMessage (ScopeConflict nm ms) =

512− paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"

514+ paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following modules:"

513 , indent $ paras $ map (line . markCode . runModuleName) ms

515 , indent $ paras $ map (line . markCode . runModuleName) ms

514 ]

516 ]

515 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =

517 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =

516− paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"

518+ paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:"

517− , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms

519+ , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms

518− , line $ "These will be ignored and the " ++ case exmn of

520+ , line $ "These will be ignored and the " <> case exmn of

519− Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."

521+ Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used."

520 Nothing -> "local declaration will be used."

522 Nothing -> "local declaration will be used."

521 ]

523 ]

522 renderSimpleErrorMessage (DeclConflict new existing) =

524 renderSimpleErrorMessage (DeclConflict new existing) =

523− line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."

525+ line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name."

524 renderSimpleErrorMessage (ExportConflict new existing) =

526 renderSimpleErrorMessage (ExportConflict new existing) =

525− line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing

527+ line $ "Export for " <> printName new <> " conflicts with " <> runName existing

526 renderSimpleErrorMessage (DuplicateModule mn ss) =

528 renderSimpleErrorMessage (DuplicateModule mn ss) =

527− paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:")

529+ paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:")

528 , indent . paras $ map (line . displaySourceSpan) ss

530 , indent . paras $ map (line . displaySourceSpan) ss

529 ]

531 ]

530 renderSimpleErrorMessage (CycleInDeclaration nm) =

532 renderSimpleErrorMessage (CycleInDeclaration nm) =

531− line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."

533+ line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."

532 renderSimpleErrorMessage (CycleInModules mns) =

534 renderSimpleErrorMessage (CycleInModules mns) =

533 paras [ line "There is a cycle in module dependencies in these modules: "

535 paras [ line "There is a cycle in module dependencies in these modules: "

534 , indent $ paras (map (line . markCode . runModuleName) mns)

536 , indent $ paras (map (line . markCode . runModuleName) mns)

535 ]

537 ]

536 renderSimpleErrorMessage (CycleInTypeSynonym name) =

538 renderSimpleErrorMessage (CycleInTypeSynonym name) =

537 paras [ line $ case name of

539 paras [ line $ case name of

538− Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn)

540+ Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn)

539 Nothing -> "A cycle appears in a set of type synonym definitions."

541 Nothing -> "A cycle appears in a set of type synonym definitions."

540 , line "Cycles are disallowed because they can lead to loops in the type checker."

542 , line "Cycles are disallowed because they can lead to loops in the type checker."

541 , line "Consider using a 'newtype' instead."

543 , line "Consider using a 'newtype' instead."

542 ]

544 ]

543 renderSimpleErrorMessage (NameIsUndefined ident) =

545 renderSimpleErrorMessage (NameIsUndefined ident) =

544− line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."

546+ line $ "Value " <> markCode (showIdent ident) <> " is undefined."

545 renderSimpleErrorMessage (UndefinedTypeVariable name) =

547 renderSimpleErrorMessage (UndefinedTypeVariable name) =

546− line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."

548+ line $ "Type variable " <> markCode (runProperName name) <> " is undefined."

547 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

549 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

548− paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied."

550+ paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied."

549 , line "Type synonyms must be applied to all of their type arguments."

551 , line "Type synonyms must be applied to all of their type arguments."

550 ]

552 ]

551 renderSimpleErrorMessage (EscapedSkolem binding) =

553 renderSimpleErrorMessage (EscapedSkolem binding) =

@@ -561,12 +563,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

561 sortRows t1 t2 = (t1, t2)

563 sortRows t1 t2 = (t1, t2)

562

564

563 -- Put the common labels last

565 -- Put the common labels last

564− sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)

566+ sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type)

565 sortRows' (s1, r1) (s2, r2) =

567 sortRows' (s1, r1) (s2, r2) =

566− let common :: [(String, (Type, Type))]

568+ let common :: [(Text, (Type, Type))]

567 common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

569 common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

568

570

569− sd1, sd2 :: [(String, Type)]

571+ sd1, sd2 :: [(Text, Type)]

570 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

572 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

571 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

573 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

572 in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)

574 in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)

@@ -597,7 +599,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

597 , Box.vcat Box.left (map typeAtomAsBox ts)

599 , Box.vcat Box.left (map typeAtomAsBox ts)

598 ]

600 ]

599 , line "The following instances were found:"

601 , line "The following instances were found:"

600− , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

602+ , indent $ paras (line (showQualified showIdent d <> " (chosen)") : map (line . showQualified showIdent) ds)

601 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."

603 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."

602 , line "They may be disallowed completely in a future version of the compiler."

604 , line "They may be disallowed completely in a future version of the compiler."

603 ]

605 ]

@@ -667,26 +669,26 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

667 , line "Make sure this is a newtype."

669 , line "Make sure this is a newtype."

668 ]

670 ]

669 renderSimpleErrorMessage (CannotFindDerivingType nm) =

671 renderSimpleErrorMessage (CannotFindDerivingType nm) =

670− line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."

672+ line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found."

671 renderSimpleErrorMessage (DuplicateLabel l expr) =

673 renderSimpleErrorMessage (DuplicateLabel l expr) =

672− paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ]

674+ paras $ [ line $ "Label " <> markCode l <> " appears more than once in a row type." ]

673 <> foldMap (\expr' -> [ line "Relevant expression: "

675 <> foldMap (\expr' -> [ line "Relevant expression: "

674 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

676 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

675 ]) expr

677 ]) expr

676 renderSimpleErrorMessage (DuplicateTypeArgument name) =

678 renderSimpleErrorMessage (DuplicateTypeArgument name) =

677− line $ "Type argument " ++ markCode name ++ " appears more than once."

679+ line $ "Type argument " <> markCode name <> " appears more than once."

678 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

680 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

679− line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."

681+ line $ "Multiple value declarations exist for " <> markCode (showIdent nm) <> "."

680 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

682 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

681− line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident)

683+ line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident)

682 renderSimpleErrorMessage (OverlappingArgNames ident) =

684 renderSimpleErrorMessage (OverlappingArgNames ident) =

683− line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident

685+ line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident

684 renderSimpleErrorMessage (MissingClassMember ident) =

686 renderSimpleErrorMessage (MissingClassMember ident) =

685− line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented."

687+ line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented."

686 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

688 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

687− line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className)

689+ line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)

688 renderSimpleErrorMessage (ExpectedType ty kind) =

690 renderSimpleErrorMessage (ExpectedType ty kind) =

689− paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "."

691+ paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."

690 , line "The error arises from the type"

692 , line "The error arises from the type"

691 , markCodeBox $ indent $ typeAsBox ty

693 , markCodeBox $ indent $ typeAsBox ty

692 , line "having the kind"

694 , line "having the kind"

@@ -694,7 +696,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

694 , line "instead."

696 , line "instead."

695 ]

697 ]

696 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

698 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

697− line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression."

699+ line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given the wrong number of arguments in a case expression."

698 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

700 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

699 paras [ line "Expression"

701 paras [ line "Expression"

700 , markCodeBox $ indent $ prettyPrintValue valueDepth expr

702 , markCodeBox $ indent $ prettyPrintValue valueDepth expr

@@ -702,13 +704,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

702 , markCodeBox $ indent $ typeAsBox ty

704 , markCodeBox $ indent $ typeAsBox ty

703 ]

705 ]

704 renderSimpleErrorMessage (PropertyIsMissing prop) =

706 renderSimpleErrorMessage (PropertyIsMissing prop) =

705− line $ "Type of expression lacks required label " ++ markCode prop ++ "."

707+ line $ "Type of expression lacks required label " <> markCode prop <> "."

706 renderSimpleErrorMessage (AdditionalProperty prop) =

708 renderSimpleErrorMessage (AdditionalProperty prop) =

707− line $ "Type of expression contains additional label " ++ markCode prop ++ "."

709+ line $ "Type of expression contains additional label " <> markCode prop <> "."

708 renderSimpleErrorMessage TypeSynonymInstance =

710 renderSimpleErrorMessage TypeSynonymInstance =

709 line "Type class instances for type synonyms are disallowed."

711 line "Type class instances for type synonyms are disallowed."

710 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

712 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

711− paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for "

713+ paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for "

712 , markCodeBox $ indent $ Box.hsep 1 Box.left

714 , markCodeBox $ indent $ Box.hsep 1 Box.left

713 [ line (showQualified runProperName cnm)

715 [ line (showQualified runProperName cnm)

714 , Box.vcat Box.left (map typeAtomAsBox ts)

716 , Box.vcat Box.left (map typeAtomAsBox ts)

@@ -718,38 +720,38 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

718 , line "Consider moving the instance, if possible, or using a newtype wrapper."

720 , line "Consider moving the instance, if possible, or using a newtype wrapper."

719 ]

721 ]

720 renderSimpleErrorMessage (InvalidNewtype name) =

722 renderSimpleErrorMessage (InvalidNewtype name) =

721− paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."

723+ paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid."

722 , line "Newtypes must define a single constructor with a single argument."

724 , line "Newtypes must define a single constructor with a single argument."

723 ]

725 ]

724 renderSimpleErrorMessage (InvalidInstanceHead ty) =

726 renderSimpleErrorMessage (InvalidInstanceHead ty) =

725 paras [ line "Type class instance head is invalid due to use of type"

727 paras [ line "Type class instance head is invalid due to use of type"

726 , markCodeBox $ indent $ typeAsBox ty

728 , markCodeBox $ indent $ typeAsBox ty

727− , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

729+ , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies."

728 ]

730 ]

729 renderSimpleErrorMessage (TransitiveExportError x ys) =

731 renderSimpleErrorMessage (TransitiveExportError x ys) =

730− paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: "

732+ paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: "

731 , indent $ paras $ map (line . markCode . prettyPrintExport) ys

733 , indent $ paras $ map (line . markCode . prettyPrintExport) ys

732 ]

734 ]

733 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =

735 renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =

734− paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: "

736+ paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor to also be exported: "

735 , indent $ line $ markCode $ runProperName ctor

737 , indent $ line $ markCode $ runProperName ctor

736 ]

738 ]

737 renderSimpleErrorMessage (ShadowedName nm) =

739 renderSimpleErrorMessage (ShadowedName nm) =

738− line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."

740+ line $ "Name " <> markCode (showIdent nm) <> " was shadowed."

739 renderSimpleErrorMessage (ShadowedTypeVar tv) =

741 renderSimpleErrorMessage (ShadowedTypeVar tv) =

740− line $ "Type variable " ++ markCode tv ++ " was shadowed."

742+ line $ "Type variable " <> markCode tv <> " was shadowed."

741 renderSimpleErrorMessage (UnusedTypeVar tv) =

743 renderSimpleErrorMessage (UnusedTypeVar tv) =

742− line $ "Type variable " ++ markCode tv ++ " was declared but not used."

744+ line $ "Type variable " <> markCode tv <> " was declared but not used."

743 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

745 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

744− line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors."

746+ line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors."

745 renderSimpleErrorMessage (ImportHidingModule name) =

747 renderSimpleErrorMessage (ImportHidingModule name) =

746 paras [ line "hiding imports cannot be used to hide modules."

748 paras [ line "hiding imports cannot be used to hide modules."

747− , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)

749+ , line $ "An attempt was made to hide the import of " <> markCode (runModuleName name)

748 ]

750 ]

749 renderSimpleErrorMessage (WildcardInferredType ty ctx) =

751 renderSimpleErrorMessage (WildcardInferredType ty ctx) =

750 paras $ [ line "Wildcard type definition has the inferred type "

752 paras $ [ line "Wildcard type definition has the inferred type "

751 , markCodeBox $ indent $ typeAsBox ty

753 , markCodeBox $ indent $ typeAsBox ty

752− ] ++ renderContext ctx

754+ ] <> renderContext ctx

753 renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =

755 renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =

754 let

756 let

755 maxTSResults = 15

757 maxTSResults = 15

@@ -758,7 +760,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

758 let

760 let

759 formatTS (names, types) =

761 formatTS (names, types) =

760 let

762 let

761− idBoxes = Box.text . showQualified runIdent <$> names

763+ idBoxes = Box.text . T.unpack . showQualified runIdent <$> names

762 tyBoxes = (\t -> BoxHelpers.indented

764 tyBoxes = (\t -> BoxHelpers.indented

763 (Box.text ":: " Box.<> typeAsBox t)) <$> types

765 (Box.text ":: " Box.<> typeAsBox t)) <$> types

764 longestId = maximum (map Box.cols idBoxes)

766 longestId = maximum (map Box.cols idBoxes)

@@ -772,13 +774,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

772 ]

774 ]

773 _ -> []

775 _ -> []

774 in

776 in

775− paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

777+ paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type "

776 , markCodeBox (indent (typeAsBox ty))

778 , markCodeBox (indent (typeAsBox ty))

777 ] ++ tsResult ++ renderContext ctx

779 ] ++ tsResult ++ renderContext ctx

778 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

780 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

779− paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."

781+ paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "."

780 , line "It is good practice to provide type declarations as a form of documentation."

782 , line "It is good practice to provide type declarations as a form of documentation."

781− , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"

783+ , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

782 , markCodeBox $ indent $ typeAsBox ty

784 , markCodeBox $ indent $ typeAsBox ty

783 ]

785 ]

784 renderSimpleErrorMessage (OverlappingPattern bs b) =

786 renderSimpleErrorMessage (OverlappingPattern bs b) =

@@ -791,70 +793,70 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

791 , line "You may want to decompose your data types into smaller types."

793 , line "You may want to decompose your data types into smaller types."

792 ]

794 ]

793 renderSimpleErrorMessage (UnusedImport name) =

795 renderSimpleErrorMessage (UnusedImport name) =

794− line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant"

796+ line $ "The import of module " <> markCode (runModuleName name) <> " is redundant"

795

797

796 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

798 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

797− paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"

799+ paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:"

798 , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names

800 , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names

799 , line "It could be replaced with:"

801 , line "It could be replaced with:"

800 , indent $ line $ markCode $ showSuggestion msg ]

802 , indent $ line $ markCode $ showSuggestion msg ]

801

803

802 renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =

804 renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =

803− paras [line $ "The import of type " ++ markCode (runProperName name)

805+ paras [line $ "The import of type " <> markCode (runProperName name)

804− ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used"

806+ <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used"

805 , line "It could be replaced with:"

807 , line "It could be replaced with:"

806 , indent $ line $ markCode $ showSuggestion msg ]

808 , indent $ line $ markCode $ showSuggestion msg ]

807

809

808 renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =

810 renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =

809− paras [ line $ "The import of type " ++ markCode (runProperName name)

811+ paras [ line $ "The import of type " <> markCode (runProperName name)

810− ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:"

812+ <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:"

811 , indent $ paras $ map (line . markCode . runProperName) names

813 , indent $ paras $ map (line . markCode . runProperName) names

812 , line "It could be replaced with:"

814 , line "It could be replaced with:"

813 , indent $ line $ markCode $ showSuggestion msg ]

815 , indent $ line $ markCode $ showSuggestion msg ]

814

816

815 renderSimpleErrorMessage (DuplicateSelectiveImport name) =

817 renderSimpleErrorMessage (DuplicateSelectiveImport name) =

816− line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"

818+ line $ "There is an existing import of " <> markCode (runModuleName name) <> ", consider merging the import lists"

817

819

818 renderSimpleErrorMessage (DuplicateImport name imp qual) =

820 renderSimpleErrorMessage (DuplicateImport name imp qual) =

819− line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual)

821+ line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual)

820

822

821 renderSimpleErrorMessage (DuplicateImportRef name) =

823 renderSimpleErrorMessage (DuplicateImportRef name) =

822− line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)

824+ line $ "Import list contains multiple references to " <> printName (Qualified Nothing name)

823

825

824 renderSimpleErrorMessage (DuplicateExportRef name) =

826 renderSimpleErrorMessage (DuplicateExportRef name) =

825− line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)

827+ line $ "Export list contains multiple references to " <> printName (Qualified Nothing name)

826

828

827 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

829 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

828− paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend."

830+ paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend."

829− , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ]

831+ , line $ "Acceptable values fall within the range " <> markCode (T.pack (show lo)) <> " to " <> markCode (T.pack (show hi)) <> " (inclusive)." ]

830

832

831 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

833 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

832− paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports."

834+ paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports."

833− , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:"

835+ , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:"

834 , indent $ line $ markCode $ showSuggestion msg

836 , indent $ line $ markCode $ showSuggestion msg

835 ]

837 ]

836

838

837 renderSimpleErrorMessage msg@(ImplicitImport mn _) =

839 renderSimpleErrorMessage msg@(ImplicitImport mn _) =

838− paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: "

840+ paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: "

839 , indent $ line $ markCode $ showSuggestion msg

841 , indent $ line $ markCode $ showSuggestion msg

840 ]

842 ]

841

843

842 renderSimpleErrorMessage msg@(HidingImport mn _) =

844 renderSimpleErrorMessage msg@(HidingImport mn _) =

843− paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: "

845+ paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the inclusive form: "

844 , indent $ line $ markCode $ showSuggestion msg

846 , indent $ line $ markCode $ showSuggestion msg

845 ]

847 ]

846

848

847 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

849 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

848 paras [ line "Binder list length differs in case alternative:"

850 paras [ line "Binder list length differs in case alternative:"

849− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

851+ , indent $ line $ T.intercalate ", " $ fmap prettyPrintBinderAtom bs

850− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."

852+ , line $ "Expecting " <> T.pack (show l) <> " binder" <> (if l == 1 then "" else "s") <> "."

851 ]

853 ]

852

854

853 renderSimpleErrorMessage IncorrectAnonymousArgument =

855 renderSimpleErrorMessage IncorrectAnonymousArgument =

854 line "An anonymous function argument appears in an invalid context."

856 line "An anonymous function argument appears in an invalid context."

855

857

856 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

858 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

857− paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."

859+ paras [ line $ "Operator " <> markCode (showQualified showOp op) <> " cannot be used in a pattern as it is an alias for function " <> showQualified showIdent fn <> "."

858 , line "Only aliases for data constructors may be used in patterns."

860 , line "Only aliases for data constructors may be used in patterns."

859 ]

861 ]

860

862

@@ -862,18 +864,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

862 line "The require-path option is deprecated and will be removed in PureScript 0.9."

864 line "The require-path option is deprecated and will be removed in PureScript 0.9."

863

865

864 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

866 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

865− paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."

867+ paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

866− , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"

868+ , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

867 , markCodeBox $ indent $ typeAsBox ty

869 , markCodeBox $ indent $ typeAsBox ty

868 , line "Try adding a type signature."

870 , line "Try adding a type signature."

869 ]

871 ]

870

872

871 renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =

873 renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =

872− paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."

874+ paras [ line $ "Cannot derive an instance of the " <> markCode "Newtype" <> " class for non-newtype " <> markCode (runProperName tyName) <> "."

873 ]

875 ]

874

876

875 renderSimpleErrorMessage (ExpectedWildcard tyName) =

877 renderSimpleErrorMessage (ExpectedWildcard tyName) =

876− paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "."

878+ paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."

877 ]

879 ]

878

880

879 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

881 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

@@ -893,7 +895,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

893 ]

895 ]

894 ]

896 ]

895 renderHint (ErrorInModule mn) detail =

897 renderHint (ErrorInModule mn) detail =

896− paras [ line $ "in module " ++ markCode (runModuleName mn)

898+ paras [ line $ "in module " <> markCode (runModuleName mn)

897 , detail

899 , detail

898 ]

900 ]

899 renderHint (ErrorInSubsumption t1 t2) detail =

901 renderHint (ErrorInSubsumption t1 t2) detail =

@@ -958,35 +960,39 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

958 ]

960 ]

959 renderHint (ErrorInDataConstructor nm) detail =

961 renderHint (ErrorInDataConstructor nm) detail =

960 paras [ detail

962 paras [ detail

961− , line $ "in data constructor " ++ markCode (runProperName nm)

963+ , line $ "in data constructor " <> markCode (runProperName nm)

962 ]

964 ]

963 renderHint (ErrorInTypeConstructor nm) detail =

965 renderHint (ErrorInTypeConstructor nm) detail =

964 paras [ detail

966 paras [ detail

965− , line $ "in type constructor " ++ markCode (runProperName nm)

967+ , line $ "in type constructor " <> markCode (runProperName nm)

966 ]

968 ]

967 renderHint (ErrorInBindingGroup nms) detail =

969 renderHint (ErrorInBindingGroup nms) detail =

968 paras [ detail

970 paras [ detail

969− , line $ "in binding group " ++ intercalate ", " (map showIdent nms)

971+ , line $ "in binding group " <> T.intercalate ", " (map showIdent nms)

970 ]

972 ]

971− renderHint ErrorInDataBindingGroup detail =

973+ renderHint (ErrorInDataBindingGroup nms) detail =

972 paras [ detail

974 paras [ detail

973− , line "in data binding group"

975+ , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms)

974 ]

976 ]

975 renderHint (ErrorInTypeSynonym name) detail =

977 renderHint (ErrorInTypeSynonym name) detail =

976 paras [ detail

978 paras [ detail

977− , line $ "in type synonym " ++ markCode (runProperName name)

979+ , line $ "in type synonym " <> markCode (runProperName name)

978 ]

980 ]

979 renderHint (ErrorInValueDeclaration n) detail =

981 renderHint (ErrorInValueDeclaration n) detail =

980 paras [ detail

982 paras [ detail

981− , line $ "in value declaration " ++ markCode (showIdent n)

983+ , line $ "in value declaration " <> markCode (showIdent n)

982 ]

984 ]

983 renderHint (ErrorInTypeDeclaration n) detail =

985 renderHint (ErrorInTypeDeclaration n) detail =

984 paras [ detail

986 paras [ detail

985− , line $ "in type declaration for " ++ markCode (showIdent n)

987+ , line $ "in type declaration for " <> markCode (showIdent n)

988+ ]

989+ renderHint (ErrorInTypeClassDeclaration name) detail =

990+ paras [ detail

991+ , line $ "in type class declaration for " <> markCode (runProperName name)

986 ]

992 ]

987 renderHint (ErrorInForeignImport nm) detail =

993 renderHint (ErrorInForeignImport nm) detail =

988 paras [ detail

994 paras [ detail

989− , line $ "in foreign import " ++ markCode (showIdent nm)

995+ , line $ "in foreign import " <> markCode (showIdent nm)

990 ]

996 ]

991 renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =

997 renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =

992 paras [ detail

998 paras [ detail

@@ -997,7 +1003,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

997 ]

1003 ]

998 ]

1004 ]

999 renderHint (PositionedError srcSpan) detail =

1005 renderHint (PositionedError srcSpan) detail =

1000− paras [ line $ "at " ++ displaySourceSpan srcSpan

1006+ paras [ line $ "at " <> displaySourceSpan srcSpan

1001 , detail

1007 , detail

1002 ]

1008 ]

1003

1009

@@ -1006,17 +1012,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1006 renderContext ctx =

1012 renderContext ctx =

1007 [ line "in the following context:"

1013 [ line "in the following context:"

1008 , indent $ paras

1014 , indent $ paras

1009− [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

1015+ [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ")

1010 , markCodeBox $ typeAsBox ty'

1016 , markCodeBox $ typeAsBox ty'

1011 ]

1017 ]

1012 | (ident, ty') <- take 5 ctx

1018 | (ident, ty') <- take 5 ctx

1013 ]

1019 ]

1014 ]

1020 ]

1015

1021

1016− printName :: Qualified Name -> String

1022+ printName :: Qualified Name -> Text

1017− printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

1023+ printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn)

1018

1024

1019− nameType :: Name -> String

1025+ nameType :: Name -> Text

1020 nameType (IdentName _) = "value"

1026 nameType (IdentName _) = "value"

1021 nameType (ValOpName _) = "operator"

1027 nameType (ValOpName _) = "operator"

1022 nameType (TyName _) = "type"

1028 nameType (TyName _) = "type"

@@ -1025,7 +1031,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1025 nameType (TyClassName _) = "type class"

1031 nameType (TyClassName _) = "type class"

1026 nameType (ModName _) = "module"

1032 nameType (ModName _) = "module"

1027

1033

1028− runName :: Qualified Name -> String

1034+ runName :: Qualified Name -> Text

1029 runName (Qualified mn (IdentName name)) =

1035 runName (Qualified mn (IdentName name)) =

1030 showQualified showIdent (Qualified mn name)

1036 showQualified showIdent (Qualified mn name)

1031 runName (Qualified mn (ValOpName op)) =

1037 runName (Qualified mn (ValOpName op)) =

@@ -1047,7 +1053,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1047 valueDepth | full = 1000

1053 valueDepth | full = 1000

1048 | otherwise = 3

1054 | otherwise = 3

1049

1055

1050− levelText :: String

1056+ levelText :: Text

1051 levelText = case level of

1057 levelText = case level of

1052 Error -> "error"

1058 Error -> "error"

1053 Warning -> "warning"

1059 Warning -> "warning"

@@ -1108,40 +1114,40 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

1108 hintCategory _ = OtherHint

1114 hintCategory _ = OtherHint

1109

1115

1110-- Pretty print and export declaration

1116-- Pretty print and export declaration

1111−prettyPrintExport :: DeclarationRef -> String

1117+prettyPrintExport :: DeclarationRef -> Text

1112prettyPrintExport (TypeRef pn _) = runProperName pn

1118prettyPrintExport (TypeRef pn _) = runProperName pn

1113prettyPrintExport ref =

1119prettyPrintExport ref =

1114 fromMaybe

1120 fromMaybe

1115 (internalError "prettyPrintRef returned Nothing in prettyPrintExport")

1121 (internalError "prettyPrintRef returned Nothing in prettyPrintExport")

1116 (prettyPrintRef ref)

1122 (prettyPrintRef ref)

1117

1123

1118−prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1124+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text

1119prettyPrintImport mn idt qual =

1125prettyPrintImport mn idt qual =

1120 let i = case idt of

1126 let i = case idt of

1121 Implicit -> runModuleName mn

1127 Implicit -> runModuleName mn

1122− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"

1128+ Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")"

1123− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"

1129+ Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate "," (mapMaybe prettyPrintRef refs) <> ")"

1124− in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1130+ in i <> maybe "" (\q -> " as " <> runModuleName q) qual

1125

1131

1126−prettyPrintRef :: DeclarationRef -> Maybe String

1132+prettyPrintRef :: DeclarationRef -> Maybe Text

1127prettyPrintRef (TypeRef pn Nothing) =

1133prettyPrintRef (TypeRef pn Nothing) =

1128− Just $ runProperName pn ++ "(..)"

1134+ Just $ runProperName pn <> "(..)"

1129prettyPrintRef (TypeRef pn (Just [])) =

1135prettyPrintRef (TypeRef pn (Just [])) =

1130 Just $ runProperName pn

1136 Just $ runProperName pn

1131prettyPrintRef (TypeRef pn (Just dctors)) =

1137prettyPrintRef (TypeRef pn (Just dctors)) =

1132− Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1138+ Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")"

1133prettyPrintRef (TypeOpRef op) =

1139prettyPrintRef (TypeOpRef op) =

1134− Just $ "type " ++ showOp op

1140+ Just $ "type " <> showOp op

1135prettyPrintRef (ValueRef ident) =

1141prettyPrintRef (ValueRef ident) =

1136 Just $ showIdent ident

1142 Just $ showIdent ident

1137prettyPrintRef (ValueOpRef op) =

1143prettyPrintRef (ValueOpRef op) =

1138 Just $ showOp op

1144 Just $ showOp op

1139prettyPrintRef (TypeClassRef pn) =

1145prettyPrintRef (TypeClassRef pn) =

1140− Just $ "class " ++ runProperName pn

1146+ Just $ "class " <> runProperName pn

1141prettyPrintRef (TypeInstanceRef ident) =

1147prettyPrintRef (TypeInstanceRef ident) =

1142 Just $ showIdent ident

1148 Just $ showIdent ident

1143prettyPrintRef (ModuleRef name) =

1149prettyPrintRef (ModuleRef name) =

1144− Just $ "module " ++ runModuleName name

1150+ Just $ "module " <> runModuleName name

1145prettyPrintRef (ReExportRef _ _) =

1151prettyPrintRef (ReExportRef _ _) =

1146 Nothing

1152 Nothing

1147prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1153prettyPrintRef (PositionedDeclarationRef _ _ ref) =

@@ -1234,8 +1240,11 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

1234indent :: Box.Box -> Box.Box

1240indent :: Box.Box -> Box.Box

1235indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

1241indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

1236

1242

1243+line :: Text -> Box.Box

1244+line = Box.text . T.unpack

1245+

1237−line :: String -> Box.Box

1246+lineS :: String -> Box.Box

1238−line = Box.text

1247+lineS = Box.text

1239

1248

1240renderBox :: Box.Box -> String

1249renderBox :: Box.Box -> String

1241renderBox = unlines

1250renderBox = unlines

@@ -1249,7 +1258,7 @@ renderBox = unlines

1249 whiteSpace = all isSpace

1258 whiteSpace = all isSpace

1250

1259

1251toTypelevelString :: Type -> Maybe Box.Box

1260toTypelevelString :: Type -> Maybe Box.Box

1252−toTypelevelString (TypeLevelString s) = Just $ Box.text s

1261+toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s)

1253toTypelevelString (TypeApp (TypeConstructor f) x)

1262toTypelevelString (TypeApp (TypeConstructor f) x)

1254 | f == primName "TypeString" = Just $ typeAsBox x

1263 | f == primName "TypeString" = Just $ typeAsBox x

1255toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

1264toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

src/Language/PureScript/Errors/JSON.hs+8−5

@@ -5,6 +5,9 @@ module Language.PureScript.Errors.JSON where

5import Prelude.Compat

6

7import qualified Data.Aeson.TH as A

8+import Data.Monoid ((<>))

9+import qualified Data.Text as T

10+import Data.Text (Text)

8

11

9import qualified Language.PureScript as P

12import qualified Language.PureScript as P

10

13

@@ -16,17 +19,17 @@ data ErrorPosition = ErrorPosition

16 } deriving (Show, Eq, Ord)

19 } deriving (Show, Eq, Ord)

17

20

18data ErrorSuggestion = ErrorSuggestion

21data ErrorSuggestion = ErrorSuggestion

19− { replacement :: String

22+ { replacement :: Text

20 , replaceRange :: Maybe ErrorPosition

23 , replaceRange :: Maybe ErrorPosition

21 } deriving (Show, Eq)

24 } deriving (Show, Eq)

22

25

23data JSONError = JSONError

26data JSONError = JSONError

24 { position :: Maybe ErrorPosition

27 { position :: Maybe ErrorPosition

25 , message :: String

28 , message :: String

26− , errorCode :: String

29+ , errorCode :: Text

27− , errorLink :: String

30+ , errorLink :: Text

28 , filename :: Maybe String

31 , filename :: Maybe String

29− , moduleName :: Maybe String

32+ , moduleName :: Maybe Text

30 , suggestion :: Maybe ErrorSuggestion

33 , suggestion :: Maybe ErrorSuggestion

31 } deriving (Show, Eq)

34 } deriving (Show, Eq)

32

35

@@ -70,4 +73,4 @@ toJSONError verbose level e =

70 Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)

73 Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)

71

74

72 -- TODO: Adding a newline because source spans chomp everything up to the next character

75 -- TODO: Adding a newline because source spans chomp everything up to the next character

73− suggestionText (P.ErrorSuggestion s) = if null s then s else s ++ "\n"

76+ suggestionText (P.ErrorSuggestion s) = if T.null s then s else s <> "\n"

src/Language/PureScript/Externs.hs+11−9

@@ -17,9 +17,11 @@ module Language.PureScript.Externs

17import Prelude.Compat

18

19import Data.Aeson.TH

20+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)

21+import Data.List (foldl', find)

20import Data.Foldable (fold)

22import Data.Foldable (fold)

21−import Data.List (find, foldl')

23+import Data.Text (Text)

22−import Data.Maybe (mapMaybe, maybeToList, fromMaybe)

24+import qualified Data.Text as T

23import Data.Version (showVersion)

25import Data.Version (showVersion)

24import qualified Data.Map as M

26import qualified Data.Map as M

25

27

@@ -37,7 +39,7 @@ import Paths_purescript as Paths

37data ExternsFile = ExternsFile

39data ExternsFile = ExternsFile

38 {

40 {

39 -- | The externs version

41 -- | The externs version

40− efVersion :: String

42+ efVersion :: Text

41 -- | Module name

43 -- | Module name

42 , efModuleName :: ModuleName

44 , efModuleName :: ModuleName

43 -- | List of module exports

45 -- | List of module exports

@@ -100,7 +102,7 @@ data ExternsDeclaration =

100 -- | A type synonym

102 -- | A type synonym

101 | EDTypeSynonym

103 | EDTypeSynonym

102 { edTypeSynonymName :: ProperName 'TypeName

104 { edTypeSynonymName :: ProperName 'TypeName

103− , edTypeSynonymArguments :: [(String, Maybe Kind)]

105+ , edTypeSynonymArguments :: [(Text, Maybe Kind)]

104 , edTypeSynonymType :: Type

106 , edTypeSynonymType :: Type

105 }

107 }

106 -- | A data construtor

108 -- | A data construtor

@@ -119,7 +121,7 @@ data ExternsDeclaration =

119 -- | A type class declaration

121 -- | A type class declaration

120 | EDClass

122 | EDClass

121 { edClassName :: ProperName 'ClassName

123 { edClassName :: ProperName 'ClassName

122− , edClassTypeArguments :: [(String, Maybe Kind)]

124+ , edClassTypeArguments :: [(Text, Maybe Kind)]

123 , edClassMembers :: [(Ident, Type)]

125 , edClassMembers :: [(Ident, Type)]

124 , edClassConstraints :: [Constraint]

126 , edClassConstraints :: [Constraint]

125 , edFunctionalDependencies :: [FunctionalDependency]

127 , edFunctionalDependencies :: [FunctionalDependency]

@@ -142,10 +144,10 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

142 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

144 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

143 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

145 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

144 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }

146 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }

145− applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) }

147+ applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }

146 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

148 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

147 where

149 where

148− dict :: TypeClassDictionaryInScope

150+ dict :: NamedDict

149 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs

151 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs

150

152

151 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a

153 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a

@@ -159,7 +161,7 @@ moduleToExternsFile :: Module -> Environment -> ExternsFile

159moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"

161moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"

160moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

162moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

161 where

163 where

162− efVersion = showVersion Paths.version

164+ efVersion = T.pack (showVersion Paths.version)

163 efModuleName = mn

165 efModuleName = mn

164 efExports = exps

166 efExports = exps

165 efImports = mapMaybe importDecl ds

167 efImports = mapMaybe importDecl ds

@@ -180,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

180 typeFixityDecl _ = Nothing

182 typeFixityDecl _ = Nothing

181

183

182 findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool

184 findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool

183− findOp get op = maybe False (== op) . get

185+ findOp g op = maybe False (== op) . g

184

186

185 importDecl :: Declaration -> Maybe ExternsImport

187 importDecl :: Declaration -> Maybe ExternsImport

186 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)

188 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)

src/Language/PureScript/Ide.hs+8−11

@@ -12,7 +12,6 @@

12-- Interface for the psc-ide-server

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE PackageImports #-}

15{-# LANGUAGE PackageImports #-}

17{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TemplateHaskell #-}

18

17

@@ -110,7 +109,7 @@ findPursuitPackages (PursuitQuery q) =

110 PursuitResult <$> liftIO (findPackagesForModuleIdent q)

109 PursuitResult <$> liftIO (findPackagesForModuleIdent q)

111

110

112printModules :: Ide m => m Success

111printModules :: Ide m => m Success

113−printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames

112+printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames

114

113

115outputDirectory :: Ide m => m FilePath

114outputDirectory :: Ide m => m FilePath

116outputDirectory = do

115outputDirectory = do

@@ -142,7 +141,7 @@ findAvailableExterns = do

142 liftIO $ do

141 liftIO $ do

143 directories <- getDirectoryContents oDir

142 directories <- getDirectoryContents oDir

144 moduleNames <- filterM (containsExterns oDir) directories

143 moduleNames <- filterM (containsExterns oDir) directories

145− pure (P.moduleNameFromString <$> moduleNames)

144+ pure (P.moduleNameFromString . toS <$> moduleNames)

146 where

145 where

147 -- Takes the output directory and a filepath like "Monad.Control.Eff" and

146 -- Takes the output directory and a filepath like "Monad.Control.Eff" and

148 -- looks up, whether that folder contains an externs.json

147 -- looks up, whether that folder contains an externs.json

@@ -171,26 +170,24 @@ loadModules moduleNames = do

171 -- We resolve all the modulenames to externs files and load these into memory.

170 -- We resolve all the modulenames to externs files and load these into memory.

172 oDir <- outputDirectory

171 oDir <- outputDirectory

173 let efPaths =

172 let efPaths =

174− map (\mn -> oDir </> P.runModuleName mn </> "externs.json") moduleNames

173+ map (\mn -> oDir </> toS (P.runModuleName mn) </> "externs.json") moduleNames

175 efiles <- traverse readExternFile efPaths

174 efiles <- traverse readExternFile efPaths

176 traverse_ insertExterns efiles

175 traverse_ insertExterns efiles

177

176

178− -- We parse all source files, log eventual parse failures if the debug flag

177+ -- We parse all source files, log eventual parse failures and insert the

179− -- was set and insert the succesful parses into the state.

178+ -- successful parses into the state.

180 (failures, allModules) <-

179 (failures, allModules) <-

181 partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)

180 partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)

182 unless (null failures) $

181 unless (null failures) $

183− $(logDebug) ("Failed to parse: " <> show failures)

182+ $(logWarn) ("Failed to parse: " <> show failures)

184 traverse_ insertModule allModules

183 traverse_ insertModule allModules

185

184

186 -- Finally we kick off the worker with @async@ and return the number of

185 -- Finally we kick off the worker with @async@ and return the number of

187 -- successfully parsed modules.

186 -- successfully parsed modules.

188 env <- ask

187 env <- ask

189− let runLogger =

190− runStdoutLoggingT

191− . filterLogger (\_ _ -> confDebug (ideConfiguration env))

188+ let ll = confLogLevel (ideConfiguration env)

192 -- populateStage2 and 3 return Unit for now, so it's fine to discard this

189 -- populateStage2 and 3 return Unit for now, so it's fine to discard this

193 -- result. We might want to block on this in a benchmarking situation.

190 -- result. We might want to block on this in a benchmarking situation.

194− _ <- liftIO (async (runLogger (runReaderT (populateStage2 *> populateStage3) env)))

191+ _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))

195 pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "

192 pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "

196 <> show (length allModules) <> " source files."))

193 <> show (length allModules) <> " source files."))

src/Language/PureScript/Ide/CaseSplit.hs+4−6

@@ -12,8 +12,6 @@

12-- Casesplitting and adding function clauses

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17module Language.PureScript.Ide.CaseSplit

15module Language.PureScript.Ide.CaseSplit

18 ( WildcardAnnotations()

16 ( WildcardAnnotations()

19 , explicitAnnotations

17 , explicitAnnotations

@@ -84,9 +82,9 @@ splitTypeConstructor = go []

84 go _ _ = throwError (GeneralError "Failed to read TypeConstructor")

82 go _ _ = throwError (GeneralError "Failed to read TypeConstructor")

85

83

86prettyCtor :: WildcardAnnotations -> Constructor -> Text

84prettyCtor :: WildcardAnnotations -> Constructor -> Text

87−prettyCtor _ (ctorName, []) = runProperNameT ctorName

85+prettyCtor _ (ctorName, []) = P.runProperName ctorName

88prettyCtor wsa (ctorName, ctorArgs) =

86prettyCtor wsa (ctorName, ctorArgs) =

89− "("<> runProperNameT ctorName <> " "

87+ "("<> P.runProperName ctorName <> " "

90 <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"

88 <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"

91

89

92prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text

90prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text

@@ -111,9 +109,9 @@ addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Tex

111addClause s wca = do

109addClause s wca = do

112 (fName, fType) <- parseTypeDeclaration' s

110 (fName, fType) <- parseTypeDeclaration' s

113 let args = splitFunctionType fType

111 let args = splitFunctionType fType

114− template = runIdentT fName <> " " <>

112+ template = P.runIdent fName <> " " <>

115 T.unwords (map (prettyPrintWildcard wca) args) <>

113 T.unwords (map (prettyPrintWildcard wca) args) <>

116− " = ?" <> (T.strip . runIdentT $ fName)

114+ " = ?" <> (T.strip . P.runIdent $ fName)

117 pure [s, template]

115 pure [s, template]

118

116

119parseType' :: (MonadError PscIdeError m) =>

117parseType' :: (MonadError PscIdeError m) =>

src/Language/PureScript/Ide/Command.hs+15−3

@@ -12,9 +12,6 @@

12-- Datatypes for the commands psc-ide accepts

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17−

18module Language.PureScript.Ide.Command where

15module Language.PureScript.Ide.Command where

19

16

20import Protolude

17import Protolude

@@ -61,6 +58,21 @@ data Command

61 | Reset

58 | Reset

62 | Quit

59 | Quit

63

60

61+commandName :: Command -> Text

62+commandName c = case c of

63+ Load{} -> "Load"

64+ Type{} -> "Type"

65+ Complete{} -> "Complete"

66+ Pursuit{} -> "Pursuit"

67+ CaseSplit{} -> "CaseSplit"

68+ AddClause{} -> "AddClause"

69+ Import{} -> "Import"

70+ List{} -> "List"

71+ Rebuild{} -> "Rebuild"

72+ Cwd{} -> "Cwd"

73+ Reset{} -> "Reset"

74+ Quit{} -> "Quit"

75+

64data ImportCommand

76data ImportCommand

65 = AddImplicitImport P.ModuleName

77 = AddImplicitImport P.ModuleName

66 | AddImportForIdentifier Text

78 | AddImportForIdentifier Text

src/Language/PureScript/Ide/Completion.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2module Language.PureScript.Ide.Completion

1module Language.PureScript.Ide.Completion

3 ( getCompletions

2 ( getCompletions

4 , getExactMatches

3 , getExactMatches

src/Language/PureScript/Ide/Conversions.hs+4−16

@@ -15,27 +15,15 @@

15module Language.PureScript.Ide.Conversions where

16

17import Control.Lens.Iso

18−import Data.Text (lines, strip, unwords)

18+import Data.Text (lines, strip, unwords, pack)

19import qualified Language.PureScript as P

20import Protolude

21

22−runProperNameT :: P.ProperName a -> Text

23−runProperNameT = toS . P.runProperName

24−

25properNameT :: Iso' (P.ProperName a) Text

22properNameT :: Iso' (P.ProperName a) Text

26−properNameT = iso (toS . P.runProperName) (P.ProperName . toS)

23+properNameT = iso P.runProperName P.ProperName

27−

28−runIdentT :: P.Ident -> Text

29−runIdentT = toS . P.runIdent

30

24

31identT :: Iso' P.Ident Text

25identT :: Iso' P.Ident Text

32−identT = iso (toS . P.runIdent) (P.Ident . toS)

26+identT = iso P.runIdent P.Ident

33−

34−runOpNameT :: P.OpName a -> Text

35−runOpNameT = toS . P.runOpName

36−

37−runModuleNameT :: P.ModuleName -> Text

38−runModuleNameT = toS . P.runModuleName

39

27

40prettyTypeT :: P.Type -> Text

28prettyTypeT :: P.Type -> Text

41−prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType

29+prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType

src/Language/PureScript/Ide/Error.hs−1

@@ -12,7 +12,6 @@

12-- Error types for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16module Language.PureScript.Ide.Error

15module Language.PureScript.Ide.Error

17 ( PscIdeError(..)

16 ( PscIdeError(..)

18 ) where

17 ) where

src/Language/PureScript/Ide/Externs.hs+25−13

@@ -12,8 +12,7 @@

12-- Handles externs files for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE PackageImports #-}

16−{-# LANGUAGE RecordWildCards #-}

17

16

18module Language.PureScript.Ide.Externs

17module Language.PureScript.Ide.Externs

19 ( readExternFile

18 ( readExternFile

@@ -23,25 +22,38 @@ module Language.PureScript.Ide.Externs

23

22

24import Protolude

23import Protolude

25

24

26−import Control.Lens ((^.))

25+import Control.Lens ((^.))

26+import "monad-logger" Control.Monad.Logger

27−import Data.Aeson (decodeStrict)

27+import Data.Aeson (decodeStrict)

28−import qualified Data.ByteString as BS

28+import qualified Data.ByteString as BS

29−import Data.List (nub)

30−import qualified Data.Map as Map

29+import qualified Data.Map as Map

30+import Data.Version (showVersion)

31import Language.PureScript.Ide.Error (PscIdeError (..))

32import Language.PureScript.Ide.Types

33import Language.PureScript.Ide.Util

34

35−import qualified Language.PureScript as P

35+import qualified Language.PureScript as P

36

37−readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

37+readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>

38 FilePath -> m P.ExternsFile

39readExternFile fp = do

40 parseResult <- liftIO (decodeStrict <$> BS.readFile fp)

41 case parseResult of

42+ Nothing ->

43+ throwError (GeneralError

42− Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"

44+ ("Parsing the extern at: " <> toS fp <> " failed"))

45+ Just externs

46+ | P.efVersion externs /= version -> do

47+ let errMsg = "Version mismatch for the externs at: " <> toS fp

48+ <> " Expected: " <> version

49+ <> " Found: " <> P.efVersion externs

50+ logErrorN errMsg

51+ throwError (GeneralError errMsg)

43 Just externs -> pure externs

52 Just externs -> pure externs

44

53

54+ where

55+ version = toS (showVersion P.version)

56+

45convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])

57convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])

46convertExterns ef =

58convertExterns ef =

47 ((P.efModuleName ef, decls), exportDecls)

59 ((P.efModuleName ef, decls), exportDecls)

@@ -55,7 +67,7 @@ convertExterns ef =

55 declarations = mapMaybe convertDecl (P.efDeclarations ef)

67 declarations = mapMaybe convertDecl (P.efDeclarations ef)

56

68

57 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

69 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

58− cleanDeclarations = nub $ appEndo typeClassFilter declarations

70+ cleanDeclarations = ordNub (appEndo typeClassFilter declarations)

59

71

60removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

72removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

61removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

73removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

@@ -120,13 +132,13 @@ annotateModule (defs, types) (moduleName, decls) =

120 IdeDeclDataConstructor dtor ->

132 IdeDeclDataConstructor dtor ->

121 annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)

133 annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)

122 IdeDeclTypeClass i ->

134 IdeDeclTypeClass i ->

123− annotateType (runProperNameT i) (IdeDeclTypeClass i)

135+ annotateType (i ^. properNameT) (IdeDeclTypeClass i)

124 IdeDeclValueOperator op ->

136 IdeDeclValueOperator op ->

125 annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

137 annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

126 IdeDeclTypeOperator op ->

138 IdeDeclTypeOperator op ->

127 annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

139 annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

128 where

140 where

129− annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs

141+ annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs

130 , annTypeAnnotation = Map.lookup x types

142 , annTypeAnnotation = Map.lookup x types

131 })

143 })

132 annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})

144 annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})

src/Language/PureScript/Ide/Filter.hs−1

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

13-----------------------------------------------------------------------------

14

15{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16−{-# LANGUAGE OverloadedStrings #-}

17

16

18module Language.PureScript.Ide.Filter

17module Language.PureScript.Ide.Filter

19 ( Filter

18 ( Filter

src/Language/PureScript/Ide/Imports.hs+5−7

@@ -12,8 +12,6 @@

12-- Provides functionality to manage imports

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17module Language.PureScript.Ide.Imports

15module Language.PureScript.Ide.Imports

18 ( addImplicitImport

16 ( addImplicitImport

19 , addImportForIdentifier

17 , addImportForIdentifier

@@ -145,7 +143,7 @@ step (Res start end) _ = Res start end

145

143

146moduleParse :: [Text] -> Either Text P.Module

144moduleParse :: [Text] -> Either Text P.Module

147moduleParse t = first show $ do

145moduleParse t = first show $ do

148− tokens <- (P.lex "" . T.unpack . T.unlines) t

146+ tokens <- P.lex "" (T.unlines t)

149 P.runTokenParser "<psc-ide>" P.parseModule tokens

147 P.runTokenParser "<psc-ide>" P.parseModule tokens

150

148

151-- | Adds an implicit import like @import Prelude@ to a Sourcefile.

149-- | Adds an implicit import like @import Prelude@ to a Sourcefile.

@@ -210,7 +208,7 @@ addExplicitImport' decl moduleName imports =

210 refFromDeclaration (IdeDeclTypeOperator op) =

208 refFromDeclaration (IdeDeclTypeOperator op) =

211 P.TypeOpRef (op ^. ideTypeOpName)

209 P.TypeOpRef (op ^. ideTypeOpName)

212 refFromDeclaration d =

210 refFromDeclaration d =

213− P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

211+ P.ValueRef (P.Ident (identifierFromIdeDeclaration d))

214

212

215 -- | Adds a declaration to an import:

213 -- | Adds a declaration to an import:

216 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

214 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

@@ -304,9 +302,9 @@ addImportForIdentifier fp ident filters = do

304prettyPrintImport' :: Import -> Text

302prettyPrintImport' :: Import -> Text

305-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs

303-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs

306prettyPrintImport' (Import mn (P.Explicit refs) qual) =

304prettyPrintImport' (Import mn (P.Explicit refs) qual) =

307− T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual

305+ "import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual

308prettyPrintImport' (Import mn idt qual) =

306prettyPrintImport' (Import mn idt qual) =

309− T.pack $ "import " ++ P.prettyPrintImport mn idt qual

307+ "import " <> P.prettyPrintImport mn idt qual

310

308

311prettyPrintImportSection :: [Import] -> [Text]

309prettyPrintImportSection :: [Import] -> [Text]

312prettyPrintImportSection imports = map prettyPrintImport' (sort imports)

310prettyPrintImportSection imports = map prettyPrintImport' (sort imports)

@@ -325,7 +323,7 @@ answerRequest outfp rs =

325-- | Test and ghci helper

323-- | Test and ghci helper

326parseImport :: Text -> Maybe Import

324parseImport :: Text -> Maybe Import

327parseImport t =

325parseImport t =

328− case P.lex "<psc-ide>" (T.unpack t)

326+ case P.lex "<psc-ide>" t

329 >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of

327 >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of

330 Right (mn, P.Explicit refs, mmn) ->

328 Right (mn, P.Explicit refs, mmn) ->

331 Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)

329 Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)

src/Language/PureScript/Ide/Logging.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE PackageImports #-}

2+

3+module Language.PureScript.Ide.Logging

4+ ( runLogger

5+ , logPerf

6+ , displayTimeSpec

7+ ) where

8+

9+import Protolude

10+

11+import "monad-logger" Control.Monad.Logger

12+import qualified Data.Text as T

13+import Language.PureScript.Ide.Types

14+import System.Clock

15+import Text.Printf

16+

17+runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a

18+runLogger logLevel' =

19+ runStdoutLoggingT . filterLogger (\_ logLevel ->

20+ case logLevel' of

21+ LogAll -> True

22+ LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)

23+ LogNone -> False

24+ LogDebug -> not (logLevel == LevelOther "perf")

25+ LogPerf -> logLevel == LevelOther "perf")

26+

27+logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t

28+logPerf format f = do

29+ start <- liftIO (getTime Monotonic)

30+ result <- f

31+ end <- liftIO (getTime Monotonic)

32+ logOtherN (LevelOther "perf") (format (diffTimeSpec start end))

33+ pure result

34+

35+displayTimeSpec :: TimeSpec -> Text

36+displayTimeSpec ts =

37+ T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"

src/Language/PureScript/Ide/Matcher.hs−1

@@ -14,7 +14,6 @@

14

15{-# LANGUAGE FlexibleInstances #-}

16{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17−{-# LANGUAGE OverloadedStrings #-}

18

17

19module Language.PureScript.Ide.Matcher

18module Language.PureScript.Ide.Matcher

20 ( Matcher

19 ( Matcher

src/Language/PureScript/Ide/Pursuit.hs+1−3

@@ -12,8 +12,6 @@

12-- Pursuit client for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17module Language.PureScript.Ide.Pursuit

15module Language.PureScript.Ide.Pursuit

18 ( searchPursuitForDeclarations

16 ( searchPursuitForDeclarations

19 , findPackagesForModuleIdent

17 , findPackagesForModuleIdent

@@ -36,7 +34,7 @@ import qualified Pipes.Prelude as P

36queryPursuit :: Text -> IO ByteString

34queryPursuit :: Text -> IO ByteString

37queryPursuit q = do

35queryPursuit q = do

38 let qClean = T.dropWhileEnd (== '.') q

36 let qClean = T.dropWhileEnd (== '.') q

39− req' <- parseRequest "http://pursuit.purescript.org/search"

37+ req' <- parseRequest "https://pursuit.purescript.org/search"

40 let req = req'

38 let req = req'

41 { queryString= "q=" <> (fromString . T.unpack) qClean

39 { queryString= "q=" <> (fromString . T.unpack) qClean

42 , requestHeaders=[(hAccept, "application/json")]

40 , requestHeaders=[(hAccept, "application/json")]

src/Language/PureScript/Ide/Rebuild.hs+1−5

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

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE PackageImports #-}

1{-# LANGUAGE PackageImports #-}

3−{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

5−{-# LANGUAGE TupleSections #-}

6

3

7module Language.PureScript.Ide.Rebuild

4module Language.PureScript.Ide.Rebuild

8 ( rebuildFile

5 ( rebuildFile

@@ -20,7 +17,6 @@ import Language.PureScript.Errors.JSON

20import Language.PureScript.Ide.Error

17import Language.PureScript.Ide.Error

21import Language.PureScript.Ide.State

18import Language.PureScript.Ide.State

22import Language.PureScript.Ide.Types

19import Language.PureScript.Ide.Types

23−import Language.PureScript.Ide.Util

24import System.IO.UTF8 (readUTF8FileT)

20import System.IO.UTF8 (readUTF8FileT)

25

21

26-- | Given a filepath performs the following steps:

22-- | Given a filepath performs the following steps:

@@ -96,7 +92,7 @@ rebuildModuleOpen makeEnv externs m = do

96 throwError (GeneralError "Failed when rebuilding with open exports")

92 throwError (GeneralError "Failed when rebuilding with open exports")

97 Right result -> do

93 Right result -> do

98 $(logDebug)

94 $(logDebug)

99− ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result))

95+ ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result))

100 cacheRebuild result

96 cacheRebuild result

101

97

102-- | Parameters we can access while building our @MakeActions@

98-- | Parameters we can access while building our @MakeActions@

src/Language/PureScript/Ide/Reexports.hs+1−4

@@ -13,9 +13,6 @@

13-- Resolves reexports for psc-ide

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

15

16−{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE RecordWildCards #-}

18−

19module Language.PureScript.Ide.Reexports

16module Language.PureScript.Ide.Reexports

20 ( resolveReexports

17 ( resolveReexports

21 , prettyPrintReexportResult

18 , prettyPrintReexportResult

@@ -53,7 +50,7 @@ prettyPrintReexportResult f ReexportResult{..}

53 | otherwise =

50 | otherwise =

54 "Failed to resolve reexports for "

51 "Failed to resolve reexports for "

55 <> f reResolved

52 <> f reResolved

56− <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed

53+ <> foldMap (\(mn, ref) -> P.runModuleName mn <> show ref) reFailed

57

54

58-- | Whether any Refs couldn't be resolved

55-- | Whether any Refs couldn't be resolved

59reexportHasFailures :: ReexportResult a -> Bool

56reexportHasFailures :: ReexportResult a -> Bool

src/Language/PureScript/Ide/SourceFile.hs+11−13

@@ -12,8 +12,6 @@

12-- Getting declarations from PureScript sourcefiles

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17module Language.PureScript.Ide.SourceFile

15module Language.PureScript.Ide.SourceFile

18 ( parseModule

16 ( parseModule

19 , getImportsForFile

17 , getImportsForFile

@@ -60,9 +58,9 @@ getImportsForFile fp = do

60 where

58 where

61 mkModuleImport (mn, importType', qualifier) =

59 mkModuleImport (mn, importType', qualifier) =

62 ModuleImport

60 ModuleImport

63− (runModuleNameT mn)

61+ (P.runModuleName mn)

64 importType'

62 importType'

65− (runModuleNameT <$> qualifier)

63+ (P.runModuleName <$> qualifier)

66 unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)

64 unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)

67 unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)

65 unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)

68 unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)

66 unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)

@@ -101,27 +99,27 @@ extractSpans ss d = case d of

101 P.PositionedDeclaration ss' _ d' ->

99 P.PositionedDeclaration ss' _ d' ->

102 extractSpans ss' d'

100 extractSpans ss' d'

103 P.ValueDeclaration i _ _ _ ->

101 P.ValueDeclaration i _ _ _ ->

104− [(Left (runIdentT i), ss)]

102+ [(Left (P.runIdent i), ss)]

105 P.TypeSynonymDeclaration name _ _ ->

103 P.TypeSynonymDeclaration name _ _ ->

106− [(Right (runProperNameT name), ss)]

104+ [(Right (P.runProperName name), ss)]

107 P.TypeClassDeclaration name _ _ _ members ->

105 P.TypeClassDeclaration name _ _ _ members ->

108− (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members

106+ (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members

109 P.DataDeclaration _ name _ ctors ->

107 P.DataDeclaration _ name _ ctors ->

110− (Right (runProperNameT name), ss)

108+ (Right (P.runProperName name), ss)

111− : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors

109+ : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors

112 P.ExternDeclaration ident _ ->

110 P.ExternDeclaration ident _ ->

113− [(Left (runIdentT ident), ss)]

111+ [(Left (P.runIdent ident), ss)]

114 P.ExternDataDeclaration name _ ->

112 P.ExternDataDeclaration name _ ->

115− [(Right (runProperNameT name), ss)]

113+ [(Right (P.runProperName name), ss)]

116 _ -> []

114 _ -> []

117 where

115 where

118 -- We need this special case to be able to also get the position info for

116 -- We need this special case to be able to also get the position info for

119− -- typeclass member functions. Typedeclaratations would clash with value

117+ -- typeclass member functions. Typedeclarations would clash with value

120 -- declarations for non-typeclass members, which is why we can't handle them

118 -- declarations for non-typeclass members, which is why we can't handle them

121 -- in extractSpans.

119 -- in extractSpans.

122 extractSpans' ssP dP = case dP of

120 extractSpans' ssP dP = case dP of

123 P.PositionedDeclaration ssP' _ dP' ->

121 P.PositionedDeclaration ssP' _ dP' ->

124 extractSpans' ssP' dP'

122 extractSpans' ssP' dP'

125 P.TypeDeclaration ident _ ->

123 P.TypeDeclaration ident _ ->

126− [(Left (runIdentT ident), ssP)]

124+ [(Left (P.runIdent ident), ssP)]

127 _ -> []

125 _ -> []

src/Language/PureScript/Ide/State.hs+5−16

@@ -12,7 +12,6 @@

12-- Functions to access psc-ide's state

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE PackageImports #-}

15{-# LANGUAGE PackageImports #-}

17{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TemplateHaskell #-}

18

17

@@ -32,7 +31,6 @@ module Language.PureScript.Ide.State

32 , resolveOperatorsForModule

31 , resolveOperatorsForModule

33 ) where

32 ) where

34

33

35−import qualified Prelude

36import Protolude

34import Protolude

37

35

38import Control.Concurrent.STM

36import Control.Concurrent.STM

@@ -46,7 +44,6 @@ import Language.PureScript.Ide.Reexports

46import Language.PureScript.Ide.SourceFile

44import Language.PureScript.Ide.SourceFile

47import Language.PureScript.Ide.Types

45import Language.PureScript.Ide.Types

48import Language.PureScript.Ide.Util

46import Language.PureScript.Ide.Util

49−import System.Clock

50

47

51-- | Resets all State inside psc-ide

48-- | Resets all State inside psc-ide

52resetIdeState :: Ide m => m ()

49resetIdeState :: Ide m => m ()

@@ -179,12 +176,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3

179populateStage2 :: (Ide m, MonadLogger m) => m ()

176populateStage2 :: (Ide m, MonadLogger m) => m ()

180populateStage2 = do

177populateStage2 = do

181 st <- ideStateVar <$> ask

178 st <- ideStateVar <$> ask

182− duration <- liftIO $ do

183− start <- getTime Monotonic

184− atomically (populateStage2STM st)

185− end <- getTime Monotonic

186− pure (Prelude.show (diffTimeSpec start end))

187− $(logDebug) $ "Finished populating Stage2 in " <> toS duration

179+ let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration

180+ logPerf message (liftIO (atomically (populateStage2STM st)))

188

181

189-- | STM version of populateStage2

182-- | STM version of populateStage2

190populateStage2STM :: TVar IdeState -> STM ()

183populateStage2STM :: TVar IdeState -> STM ()

@@ -197,15 +190,11 @@ populateStage2STM ref = do

197populateStage3 :: (Ide m, MonadLogger m) => m ()

190populateStage3 :: (Ide m, MonadLogger m) => m ()

198populateStage3 = do

191populateStage3 = do

199 st <- ideStateVar <$> ask

192 st <- ideStateVar <$> ask

200− (duration, results) <- liftIO $ do

193+ let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration

201− start <- getTime Monotonic

202− results <- atomically (populateStage3STM st)

194+ results <- logPerf message (liftIO (atomically (populateStage3STM st)))

203− end <- getTime Monotonic

204− pure (Prelude.show (diffTimeSpec start end), results)

205 traverse_

195 traverse_

206− (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

196+ (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))

207 (filter reexportHasFailures results)

197 (filter reexportHasFailures results)

208− $(logDebug) $ "Finished populating Stage3 in " <> toS duration

209

198

210-- | STM version of populateStage3

199-- | STM version of populateStage3

211populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

200populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

src/Language/PureScript/Ide/Types.hs+9−8

@@ -12,9 +12,8 @@

12-- Type definitions for psc-ide

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE DeriveFoldable #-}

15+{-# LANGUAGE DeriveFoldable #-}

16−{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE TemplateHaskell #-}

16+{-# LANGUAGE TemplateHaskell #-}

18

17

19module Language.PureScript.Ide.Types where

18module Language.PureScript.Ide.Types where

20

19

@@ -26,7 +25,6 @@ import Data.Aeson

26import qualified Data.Map.Lazy as M

25import qualified Data.Map.Lazy as M

27import qualified Language.PureScript as P

26import qualified Language.PureScript as P

28import qualified Language.PureScript.Errors.JSON as P

27import qualified Language.PureScript.Errors.JSON as P

29−import Language.PureScript.Ide.Conversions

30

28

31type ModuleIdent = Text

29type ModuleIdent = Text

32

30

@@ -111,10 +109,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation

111 -- annotations found in a module

109 -- annotations found in a module

112 deriving (Show, Eq, Ord, Functor, Foldable)

110 deriving (Show, Eq, Ord, Functor, Foldable)

113

111

112+data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone

113+ deriving (Show, Eq)

114+

114data Configuration =

115data Configuration =

115 Configuration

116 Configuration

116 { confOutputPath :: FilePath

117 { confOutputPath :: FilePath

117− , confDebug :: Bool

118+ , confLogLevel :: IdeLogLevel

118 , confGlobs :: [FilePath]

119 , confGlobs :: [FilePath]

119 }

120 }

120

121

@@ -210,9 +211,9 @@ instance ToJSON ModuleImport where

210 ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)

211 ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)

211

212

212identifierFromDeclarationRef :: P.DeclarationRef -> Text

213identifierFromDeclarationRef :: P.DeclarationRef -> Text

213−identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name

214+identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name

214−identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident

215+identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident

215−identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name

216+identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name

216identifierFromDeclarationRef _ = ""

217identifierFromDeclarationRef _ = ""

217

218

218data Success =

219data Success =

src/Language/PureScript/Ide/Util.hs+15−14

@@ -12,8 +12,6 @@

12-- Generally useful functions

13-----------------------------------------------------------------------------

14

15−{-# LANGUAGE OverloadedStrings #-}

16−

17module Language.PureScript.Ide.Util

15module Language.PureScript.Ide.Util

18 ( identifierFromIdeDeclaration

16 ( identifierFromIdeDeclaration

19 , unwrapMatch

17 , unwrapMatch

@@ -27,17 +25,20 @@ module Language.PureScript.Ide.Util

27 , valueOperatorAliasT

25 , valueOperatorAliasT

28 , typeOperatorAliasT

26 , typeOperatorAliasT

29 , module Language.PureScript.Ide.Conversions

27 , module Language.PureScript.Ide.Conversions

28+ , module Language.PureScript.Ide.Logging

30 ) where

29 ) where

31

30

31+import Protolude hiding (decodeUtf8,

32+ encodeUtf8)

33+

32import Control.Lens ((^.))

34import Control.Lens ((^.))

33import Data.Aeson

35import Data.Aeson

34import qualified Data.Text as T

36import qualified Data.Text as T

35import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

37import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

36import qualified Language.PureScript as P

38import qualified Language.PureScript as P

37import Language.PureScript.Ide.Conversions

39import Language.PureScript.Ide.Conversions

40+import Language.PureScript.Ide.Logging

38import Language.PureScript.Ide.Types

41import Language.PureScript.Ide.Types

39−import Protolude hiding (decodeUtf8,

40− encodeUtf8)

41

42

42identifierFromIdeDeclaration :: IdeDeclaration -> Text

43identifierFromIdeDeclaration :: IdeDeclaration -> Text

43identifierFromIdeDeclaration d = case d of

44identifierFromIdeDeclaration d = case d of

@@ -45,9 +46,9 @@ identifierFromIdeDeclaration d = case d of

45 IdeDeclType t -> t ^. ideTypeName . properNameT

46 IdeDeclType t -> t ^. ideTypeName . properNameT

46 IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT

47 IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT

47 IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT

48 IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT

48− IdeDeclTypeClass name -> runProperNameT name

49+ IdeDeclTypeClass name -> P.runProperName name

49− IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT

50+ IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName

50− IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT

51+ IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName

51

52

52discardAnn :: IdeDeclarationAnn -> IdeDeclaration

53discardAnn :: IdeDeclarationAnn -> IdeDeclaration

53discardAnn (IdeDeclarationAnn _ d) = d

54discardAnn (IdeDeclarationAnn _ d) = d

@@ -67,13 +68,13 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

67 IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )

68 IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )

68 IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)

69 IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)

69 IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)

70 IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)

70− IdeDeclTypeClass name -> (runProperNameT name, "class")

71+ IdeDeclTypeClass name -> (P.runProperName name, "class")

71 IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->

72 IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->

72− (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

73+ (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

73 IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->

74 IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->

74− (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

75+ (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

75

76

76− complModule = runModuleNameT m

77+ complModule = P.runModuleName m

77

78

78 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

79 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

79

80

@@ -86,17 +87,17 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

86 P.Infix -> "infix"

87 P.Infix -> "infix"

87 P.Infixl -> "infixl"

88 P.Infixl -> "infixl"

88 P.Infixr -> "infixr"

89 P.Infixr -> "infixr"

89− in T.unwords [asso, show p, r, "as", runOpNameT o]

90+ in T.unwords [asso, show p, r, "as", P.runOpName o]

90

91

91valueOperatorAliasT

92valueOperatorAliasT

92 :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text

93 :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text

93valueOperatorAliasT i =

94valueOperatorAliasT i =

94− toS (P.showQualified (either P.runIdent P.runProperName) i)

95+ P.showQualified (either P.runIdent P.runProperName) i

95

96

96typeOperatorAliasT

97typeOperatorAliasT

97 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

98 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

98typeOperatorAliasT i =

99typeOperatorAliasT i =

99− toS (P.showQualified P.runProperName i)

100+ P.showQualified P.runProperName i

100

101

101encodeT :: (ToJSON a) => a -> Text

102encodeT :: (ToJSON a) => a -> Text

102encodeT = toS . decodeUtf8 . encode

103encodeT = toS . decodeUtf8 . encode

src/Language/PureScript/Ide/Watcher.hs+12−8

@@ -22,6 +22,7 @@ import Control.Concurrent.STM

22import Language.PureScript.Ide.Externs

23import Language.PureScript.Ide.State

24import Language.PureScript.Ide.Types

25+import Language.PureScript.Ide.Util

25import System.FilePath

26import System.FilePath

26import System.FSNotify

27import System.FSNotify

27

28

@@ -31,7 +32,7 @@ reloadFile :: TVar IdeState -> Event -> IO ()

31reloadFile _ Removed{} = pure ()

32reloadFile _ Removed{} = pure ()

32reloadFile ref ev = do

33reloadFile ref ev = do

33 let fp = eventPath ev

34 let fp = eventPath ev

34− ef' <- runExceptT (readExternFile fp)

35+ ef' <- runLogger LogDefault (runExceptT (readExternFile fp))

35 case ef' of

36 case ef' of

36 Left _ -> pure ()

37 Left _ -> pure ()

37 Right ef -> do

38 Right ef -> do

@@ -40,10 +41,13 @@ reloadFile ref ev = do

40

41

41-- | Installs filewatchers for the given directory and reloads ExternsFiles when

42-- | Installs filewatchers for the given directory and reloads ExternsFiles when

42-- they change on disc

43-- they change on disc

43−watcher :: TVar IdeState -> FilePath -> IO ()

44+watcher :: Bool -> TVar IdeState -> FilePath -> IO ()

44−watcher stateVar fp =

45+watcher polling stateVar fp =

46+ withManagerConf

45− withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do

47+ (defaultConfig { confDebounce = NoDebounce

48+ , confUsePolling = polling

49+ }) $ \mgr -> do

46− _ <- watchTree mgr fp

50+ _ <- watchTree mgr fp

47− (\ev -> takeFileName (eventPath ev) == "externs.json")

51+ (\ev -> takeFileName (eventPath ev) == "externs.json")

48− (reloadFile stateVar)

52+ (reloadFile stateVar)

49− forever (threadDelay 100000)

53+ forever (threadDelay 100000)

src/Language/PureScript/Interactive.hs+19−20

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

1{-# LANGUAGE DoAndIfThenElse #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TupleSections #-}

5−{-# LANGUAGE DataKinds #-}

6

2

7module Language.PureScript.Interactive

3module Language.PureScript.Interactive

8 ( handleCommand

4 ( handleCommand

@@ -16,9 +12,12 @@ module Language.PureScript.Interactive

16import Prelude ()

12import Prelude ()

17import Prelude.Compat

13import Prelude.Compat

18

14

19−import Data.List (intercalate, nub, sort, find, foldl')

15+import Data.List (nub, sort, find, foldl')

20import Data.Maybe (mapMaybe)

16import Data.Maybe (mapMaybe)

21import qualified Data.Map as M

17import qualified Data.Map as M

18+import Data.Monoid ((<>))

19+import Data.Text (Text)

20+import qualified Data.Text as T

22

21

23import Control.Monad.IO.Class (MonadIO, liftIO)

22import Control.Monad.IO.Class (MonadIO, liftIO)

24import Control.Monad.State.Class

23import Control.Monad.State.Class

@@ -165,7 +164,7 @@ handleShowLoadedModules = do

165 loadedModules <- gets psciLoadedExterns

164 loadedModules <- gets psciLoadedExterns

166 liftIO $ putStrLn (readModules loadedModules)

165 liftIO $ putStrLn (readModules loadedModules)

167 where

166 where

168− readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)

167+ readModules = unlines . sort . nub . map (T.unpack . P.runModuleName . P.getModuleName . fst)

169

168

170-- | Show the imported modules in psci.

169-- | Show the imported modules in psci.

171handleShowImportedModules

170handleShowImportedModules

@@ -176,38 +175,38 @@ handleShowImportedModules = do

176 liftIO $ showModules importedModules >>= putStrLn

175 liftIO $ showModules importedModules >>= putStrLn

177 return ()

176 return ()

178 where

177 where

179− showModules = return . unlines . sort . map showModule

178+ showModules = return . unlines . sort . map (T.unpack . showModule)

180 showModule (mn, declType, asQ) =

179 showModule (mn, declType, asQ) =

181− "import " ++ N.runModuleName mn ++ showDeclType declType ++

180+ "import " <> N.runModuleName mn <> showDeclType declType <>

182− foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ

181+ foldMap (\mn' -> " as " <> N.runModuleName mn') asQ

183

182

184 showDeclType P.Implicit = ""

183 showDeclType P.Implicit = ""

185 showDeclType (P.Explicit refs) = refsList refs

184 showDeclType (P.Explicit refs) = refsList refs

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

185+ showDeclType (P.Hiding refs) = " hiding " <> refsList refs

187− refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"

186+ refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")"

188

187

189− showRef :: P.DeclarationRef -> Maybe String

188+ showRef :: P.DeclarationRef -> Maybe Text

190 showRef (P.TypeRef pn dctors) =

189 showRef (P.TypeRef pn dctors) =

191− Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

190+ Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")"

192 showRef (P.TypeOpRef op) =

191 showRef (P.TypeOpRef op) =

193− Just $ "type " ++ N.showOp op

192+ Just $ "type " <> N.showOp op

194 showRef (P.ValueRef ident) =

193 showRef (P.ValueRef ident) =

195 Just $ N.runIdent ident

194 Just $ N.runIdent ident

196 showRef (P.ValueOpRef op) =

195 showRef (P.ValueOpRef op) =

197 Just $ N.showOp op

196 Just $ N.showOp op

198 showRef (P.TypeClassRef pn) =

197 showRef (P.TypeClassRef pn) =

199− Just $ "class " ++ N.runProperName pn

198+ Just $ "class " <> N.runProperName pn

200 showRef (P.TypeInstanceRef ident) =

199 showRef (P.TypeInstanceRef ident) =

201 Just $ N.runIdent ident

200 Just $ N.runIdent ident

202 showRef (P.ModuleRef name) =

201 showRef (P.ModuleRef name) =

203− Just $ "module " ++ N.runModuleName name

202+ Just $ "module " <> N.runModuleName name

204 showRef (P.ReExportRef _ _) =

203 showRef (P.ReExportRef _ _) =

205 Nothing

204 Nothing

206 showRef (P.PositionedDeclarationRef _ _ ref) =

205 showRef (P.PositionedDeclarationRef _ _ ref) =

207 showRef ref

206 showRef ref

208

207

209− commaList :: [String] -> String

208+ commaList :: [Text] -> Text

210− commaList = intercalate ", "

209+ commaList = T.intercalate ", "

211

210

212-- | Imports a module, preserving the initial state on failure.

211-- | Imports a module, preserving the initial state on failure.

213handleImport

212handleImport

@@ -260,7 +259,7 @@ handleKindOf typ = do

260 check sew = fst . runWriter . runExceptT . runStateT sew

259 check sew = fst . runWriter . runExceptT . runStateT sew

261 case k of

260 case k of

262 Left err -> printErrors err

261 Left err -> printErrors err

263− Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind

262+ Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind

264 Nothing -> liftIO $ putStrLn "Could not find kind"

263 Nothing -> liftIO $ putStrLn "Could not find kind"

265

264

266-- | Browse a module and displays its signature

265-- | Browse a module and displays its signature

@@ -284,6 +283,6 @@ handleBrowse moduleName = do

284 isModInEnv modName =

283 isModInEnv modName =

285 any ((== modName) . P.getModuleName . fst) . psciLoadedExterns

284 any ((== modName) . P.getModuleName . fst) . psciLoadedExterns

286 failNotInEnv modName =

285 failNotInEnv modName =

287− liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."

286+ liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."

288 lookupUnQualifiedModName quaModName st =

287 lookupUnQualifiedModName quaModName st =

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

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

src/Language/PureScript/Interactive/Completion.hs+6−6

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

1−{-# LANGUAGE DataKinds #-}

2−

3module Language.PureScript.Interactive.Completion

1module Language.PureScript.Interactive.Completion

4 ( CompletionM

2 ( CompletionM

5 , liftCompletionM

3 , liftCompletionM

@@ -16,6 +14,8 @@ import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)

16import Data.Function (on)

14import Data.Function (on)

17import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix)

15import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix)

18import Data.Maybe (mapMaybe)

16import Data.Maybe (mapMaybe)

17+import Data.Text (Text)

18+import qualified Data.Text as T

19import qualified Language.PureScript as P

20import qualified Language.PureScript.Interactive.Directive as D

21import Language.PureScript.Interactive.Types

@@ -145,7 +145,7 @@ getLoadedModules = asks (map fst . psciLoadedExterns)

145getModuleNames :: CompletionM [String]

146getModuleNames = moduleNames <$> getLoadedModules

147

148−mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]

148+mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]

149mapLoadedModulesAndQualify sho f = do

150 ms <- getLoadedModules

151 let argPairs = do m <- ms

@@ -165,14 +165,14 @@ getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls

165-- | Given a module and a declaration in that module, return all possible ways

166-- it could have been referenced given the current PSCiState - including fully

167-- qualified, qualified using an alias, and unqualified.

168−getAllQualifications :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String]

168+getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> CompletionM [String]

169getAllQualifications sho m (declName, decl) = do

170 imports <- getAllImportsOf m

171 let fullyQualified = qualifyWith (Just (P.getModuleName m))

172 let otherQuals = nub (concatMap qualificationsUsing imports)

173 return $ fullyQualified : otherQuals

174 where

175− qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName)

175+ qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName))

176 referencedBy refs = P.isExported (Just refs) decl

177

178 qualificationsUsing (_, importType, asQ') =

@@ -220,4 +220,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

220 go _ = []

221

222moduleNames :: [P.Module] -> [String]

223−moduleNames = nub . map (P.runModuleName . P.getModuleName)

223+moduleNames = nub . map (T.unpack . P.runModuleName . P.getModuleName)

src/Language/PureScript/Interactive/Parser.hs+2−1

@@ -9,6 +9,7 @@ import Prelude.Compat hiding (lex)

9

10import Data.Char (isSpace)

11import Data.List (intercalate)

12+import qualified Data.Text as T

12import Text.Parsec hiding ((<|>))

13import Text.Parsec hiding ((<|>))

13import qualified Language.PureScript as P

14import qualified Language.PureScript as P

14import qualified Language.PureScript.Interactive.Directive as D

15import qualified Language.PureScript.Interactive.Directive as D

@@ -26,7 +27,7 @@ parseCommand cmdString =

26

27

27parseRest :: P.TokenParser a -> String -> Either String a

28parseRest :: P.TokenParser a -> String -> Either String a

28parseRest p s = either (Left . show) Right $ do

29parseRest p s = either (Left . show) Right $ do

29− ts <- P.lex "" s

30+ ts <- P.lex "" (T.pack s)

30 P.runTokenParser "" (p <* eof) ts

31 P.runTokenParser "" (p <* eof) ts

31

32

32psciCommand :: P.TokenParser Command

33psciCommand :: P.TokenParser Command

src/Language/PureScript/Interactive/Printer.hs+16−12

@@ -1,6 +1,3 @@

1−{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE DataKinds #-}

3−

4module Language.PureScript.Interactive.Printer where

1module Language.PureScript.Interactive.Printer where

5

2

6import Prelude.Compat

3import Prelude.Compat

@@ -8,9 +5,16 @@ import Prelude.Compat

8import Data.List (intersperse)

5import Data.List (intersperse)

9import qualified Data.Map as M

6import qualified Data.Map as M

10import Data.Maybe (mapMaybe)

7import Data.Maybe (mapMaybe)

8+import Data.Monoid ((<>))

9+import qualified Data.Text as T

10+import Data.Text (Text)

11import qualified Language.PureScript as P

12import qualified Text.PrettyPrint.Boxes as Box

13

14+-- TODO (Christoph): Text version of boxes

15+textT :: Text -> Box.Box

16+textT = Box.text . T.unpack

17+

14-- Printers

18-- Printers

15

19

16-- |

20-- |

@@ -40,7 +44,7 @@ printModuleSignatures moduleName P.Environment{..} =

40 findNameType envNames m = (P.disqualify m, M.lookup m envNames)

44 findNameType envNames m = (P.disqualify m, M.lookup m envNames)

41

45

42 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

46 showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

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

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

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

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

45

49

46 findTypeClass

50 findTypeClass

@@ -58,13 +62,13 @@ printModuleSignatures moduleName P.Environment{..} =

58 if null typeClassSuperclasses

62 if null typeClassSuperclasses

59 then Box.text ""

63 then Box.text ""

60 else Box.text "("

64 else Box.text "("

61− Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses)

65+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses)

62 Box.<> Box.text ") <= "

66 Box.<> Box.text ") <= "

63 className =

67 className =

64− Box.text (P.runProperName name)

68+ textT (P.runProperName name)

65− Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments)

69+ Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments)

66 classBody =

70 classBody =

67− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers)

71+ Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox t) typeClassMembers)

68

72

69 in

73 in

70 Just $

74 Just $

@@ -84,7 +88,7 @@ printModuleSignatures moduleName P.Environment{..} =

84 showType

88 showType

85 :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData

89 :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData

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

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

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

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

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

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

89 -> Maybe Box.Box

93 -> Maybe Box.Box

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

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

@@ -95,7 +99,7 @@ printModuleSignatures moduleName P.Environment{..} =

95 Nothing

99 Nothing

96 else

100 else

97 Just $

101 Just $

98− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

102+ textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars)

99 Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

103 Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

100

104

101 (Just (_, P.DataType typevars pt), _) ->

105 (Just (_, P.DataType typevars pt), _) ->

@@ -108,7 +112,7 @@ printModuleSignatures moduleName P.Environment{..} =

108 _ -> "data"

112 _ -> "data"

109

113

110 in

114 in

111− Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

115+ Just $ textT (prefix <> " " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// printCons pt

112

116

113 _ ->

117 _ ->

114 Nothing

118 Nothing

@@ -117,7 +121,7 @@ printModuleSignatures moduleName P.Environment{..} =

117 Box.moveRight 2 $

121 Box.moveRight 2 $

118 Box.vcat Box.left $

122 Box.vcat Box.left $

119 mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

123 mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

120− map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

124+ map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

121

125

122 prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

126 prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

123

127

src/Language/PureScript/Linter.hs+16−10

@@ -11,6 +11,7 @@ import Data.List (nub, (\\))

11import Data.Maybe (mapMaybe)

12import Data.Monoid

13import qualified Data.Set as S

14+import Data.Text (Text)

14

15

15import Language.PureScript.AST

16import Language.PureScript.AST

16import Language.PureScript.Crash

17import Language.PureScript.Crash

@@ -44,9 +45,14 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

44

45

45 f :: Declaration -> MultipleErrors

46 f :: Declaration -> MultipleErrors

46 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

47 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

48+ f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs)

49+ f dec = f' S.empty dec

50+

51+ f' :: S.Set Text -> Declaration -> MultipleErrors

52+ f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec)

47− f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)

53+ f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)

48− f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

54+ f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)

49− f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec

55+ f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec

50

56

51 stepE :: S.Set Ident -> Expr -> MultipleErrors

57 stepE :: S.Set Ident -> Expr -> MultipleErrors

52 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

58 stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)

@@ -70,16 +76,16 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

70 | otherwise = mempty

76 | otherwise = mempty

71 stepDo _ _ = mempty

77 stepDo _ _ = mempty

72

78

73− checkTypeVarsInDecl :: Declaration -> MultipleErrors

79+ checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors

74− checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

80+ checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d

75

81

76− checkTypeVars :: Type -> MultipleErrors

82+ checkTypeVars :: S.Set Text -> Type -> MultipleErrors

77− checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty

83+ checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty

78 where

84 where

79− step :: S.Set String -> Type -> (S.Set String, MultipleErrors)

85+ step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors)

80 step s (ForAll tv _ _) = bindVar s tv

86 step s (ForAll tv _ _) = bindVar s tv

81 step s _ = (s, mempty)

87 step s _ = (s, mempty)

82− bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)

88+ bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors)

83 bindVar = bind ShadowedTypeVar

89 bindVar = bind ShadowedTypeVar

84 findUnused :: Type -> MultipleErrors

90 findUnused :: Type -> MultipleErrors

85 findUnused ty' =

91 findUnused ty' =

@@ -88,7 +94,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

88 unused = nub declared \\ nub used

94 unused = nub declared \\ nub used

89 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused

95 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused

90 where

96 where

91− go :: Type -> [String]

97+ go :: Type -> [Text]

92 go (ForAll tv _ _) = [tv]

98 go (ForAll tv _ _) = [tv]

93 go _ = []

99 go _ = []

94

100

src/Language/PureScript/Linter/Exhaustive.hs+7−4

@@ -19,7 +19,10 @@ import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)

19import Data.Function (on)

20import Data.List (foldl', sortBy, nub)

21import Data.Maybe (fromMaybe)

22+import Data.Monoid ((<>))

22import qualified Data.Map as M

23import qualified Data.Map as M

24+import Data.Text (Text)

25+import qualified Data.Text as T

23

26

24import Language.PureScript.AST.Binders

27import Language.PureScript.AST.Binders

25import Language.PureScript.AST.Declarations

28import Language.PureScript.AST.Declarations

@@ -77,7 +80,7 @@ getConstructors env defmn n = extractConstructors lnte

77 getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

80 getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

78 getConsDataName con =

81 getConsDataName con =

79 case getConsInfo con of

82 case getConsInfo con of

80− Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

83+ Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName."

81 Just (_, pm, _, _) -> qualifyName pm defmn con

84 Just (_, pm, _, _) -> qualifyName pm defmn con

82

85

83 getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])

86 getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])

@@ -276,14 +279,14 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (

276 -- and then included in the error message.

279 -- and then included in the error message.

277 addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr

280 addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr

278 addPartialConstraint (bss, complete) e = do

281 addPartialConstraint (bss, complete) e = do

279− tyVar <- ("p" ++) . show <$> fresh

282+ tyVar <- ("p" <>) . T.pack . show <$> fresh

280 var <- freshName

283 var <- freshName

281 return $

284 return $

282 Let

285 Let

283 [ partial var tyVar ]

286 [ partial var tyVar ]

284 $ App (Var (Qualified Nothing (Ident C.__unused))) e

287 $ App (Var (Qualified Nothing (Ident C.__unused))) e

285 where

288 where

286− partial :: String -> String -> Declaration

289+ partial :: Text -> Text -> Declaration

287 partial var tyVar =

290 partial var tyVar =

288 ValueDeclaration (Ident C.__unused) Private [] $ Right $

291 ValueDeclaration (Ident C.__unused) Private [] $ Right $

289 TypedValue

292 TypedValue

@@ -291,7 +294,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (

291 (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))

294 (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))

292 (ty tyVar)

295 (ty tyVar)

293

296

294− ty :: String -> Type

297+ ty :: Text -> Type

295 ty tyVar =

298 ty tyVar =

296 ForAll tyVar

299 ForAll tyVar

297 ( ConstrainedType

300 ( ConstrainedType

src/Language/PureScript/Linter/Imports.hs+3−2

@@ -15,6 +15,7 @@ import Data.List (find, intersect, nub, groupBy, sortBy, (\\))

15import Data.Maybe (mapMaybe, fromMaybe)

16import Data.Monoid (Sum(..))

17import Data.Traversable (forM)

18+import qualified Data.Text as T

18import qualified Data.Map as M

19import qualified Data.Map as M

19

20

20import Language.PureScript.AST.Declarations

21import Language.PureScript.AST.Declarations

@@ -329,8 +330,8 @@ findUsedRefs env mni qn names =

329 Just (_, _, exps) ->

330 Just (_, _, exps) ->

330 case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of

331 case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of

331 Just (ty, _) -> ty

332 Just (ty, _) -> ty

332− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

333+ Nothing -> internalError $ "missing type for data constructor " ++ T.unpack (runProperName dctor) ++ " in findTypeForDctor"

333− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

334+ Nothing -> internalError $ "missing module " ++ T.unpack (runModuleName mn) ++ " in findTypeForDctor"

334

335

335matchName

336matchName

336 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

337 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

src/Language/PureScript/Make.hs+26−27

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE OverloadedStrings #-}

4

3

5module Language.PureScript.Make

4module Language.PureScript.Make

6 (

5 (

@@ -38,13 +37,12 @@ import Control.Monad.Writer.Class (MonadWriter(..))

38

37

39import Data.Aeson (encode, decode)

38import Data.Aeson (encode, decode)

40import qualified Data.Aeson as Aeson

39import qualified Data.Aeson as Aeson

41−import Data.ByteString.Builder (toLazyByteString, stringUtf8)

42import Data.Either (partitionEithers)

40import Data.Either (partitionEithers)

43import Data.Function (on)

41import Data.Function (on)

44import Data.Foldable (for_)

42import Data.Foldable (for_)

45import Data.List (foldl', sortBy, groupBy)

43import Data.List (foldl', sortBy, groupBy)

46import Data.Maybe (fromMaybe, catMaybes)

44import Data.Maybe (fromMaybe, catMaybes)

47−import Data.String (fromString)

45+import Data.Monoid ((<>))

48import Data.Time.Clock

46import Data.Time.Clock

49import Data.Traversable (for)

47import Data.Traversable (for)

50import Data.Version (showVersion)

48import Data.Version (showVersion)

@@ -52,6 +50,8 @@ import qualified Data.ByteString.Lazy as B

52import qualified Data.ByteString.UTF8 as BU8

50import qualified Data.ByteString.UTF8 as BU8

53import qualified Data.Map as M

51import qualified Data.Map as M

54import qualified Data.Set as S

52import qualified Data.Set as S

53+import qualified Data.Text as T

54+import qualified Data.Text.Encoding as TE

55

56import Language.PureScript.AST

57import Language.PureScript.Crash

@@ -83,7 +83,6 @@ import SourceMap.Types

83import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

84import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

85import System.IO.Error (tryIOError)

86−import System.IO.UTF8 (readUTF8File, writeUTF8File)

87

86

88import qualified Text.Parsec as Parsec

87import qualified Text.Parsec as Parsec

89

88

@@ -94,7 +93,7 @@ data ProgressMessage

94

93

95-- | Render a progress message

94-- | Render a progress message

96renderProgressMessage :: ProgressMessage -> String

95renderProgressMessage :: ProgressMessage -> String

97−renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn

96+renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn)

98

97

99-- | Actions that require implementations when running in "make" mode.

98-- | Actions that require implementations when running in "make" mode.

100--

99--

@@ -125,7 +124,7 @@ data MakeActions m = MakeActions

125-- |

124-- |

126-- Generated code for an externs file.

125-- Generated code for an externs file.

127--

126--

128−type Externs = String

127+type Externs = B.ByteString

129

128

130-- |

129-- |

131-- Determines when to rebuild a module

130-- Determines when to rebuild a module

@@ -155,7 +154,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

155 corefn = CF.moduleToCoreFn env' mod'

154 corefn = CF.moduleToCoreFn env' mod'

156 [renamed] = renameInModules [corefn]

155 [renamed] = renameInModules [corefn]

157 exts = moduleToExternsFile mod' env'

156 exts = moduleToExternsFile mod' env'

158− evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts

157+ evalSupplyT nextVar . codegen renamed env' . encode $ exts

159 return exts

158 return exts

160

159

161-- |

160-- |

@@ -256,8 +255,8 @@ make ma@MakeActions{..} ms = do

256

255

257 decodeExterns :: Externs -> Maybe ExternsFile

256 decodeExterns :: Externs -> Maybe ExternsFile

258 decodeExterns bs = do

257 decodeExterns bs = do

259− externs <- decode (toLazyByteString (stringUtf8 bs))

258+ externs <- decode bs

260− guard $ efVersion externs == showVersion Paths.version

259+ guard $ T.unpack (efVersion externs) == showVersion Paths.version

261 return externs

260 return externs

262

261

263importPrim :: Module -> Module

262importPrim :: Module -> Module

@@ -290,8 +289,8 @@ makeIO f io = do

290

289

291-- | Read a text file in the 'Make' monad, capturing any errors using the

290-- | Read a text file in the 'Make' monad, capturing any errors using the

292-- 'MonadError' instance.

291-- 'MonadError' instance.

293−readTextFile :: FilePath -> Make String

292+readTextFile :: FilePath -> Make B.ByteString

294−readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

293+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path

295

294

296-- | Infer the module name for a module by looking for the same filename with

295-- | Infer the module name for a module by looking for the same filename with

297-- a .js extension.

296-- a .js extension.

@@ -332,14 +331,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

332

331

333 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)

332 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)

334 getOutputTimestamp mn = do

333 getOutputTimestamp mn = do

335− let filePath = runModuleName mn

334+ let filePath = T.unpack (runModuleName mn)

336 jsFile = outputDir </> filePath </> "index.js"

335 jsFile = outputDir </> filePath </> "index.js"

337 externsFile = outputDir </> filePath </> "externs.json"

336 externsFile = outputDir </> filePath </> "externs.json"

338 min <$> getTimestamp jsFile <*> getTimestamp externsFile

337 min <$> getTimestamp jsFile <*> getTimestamp externsFile

339

338

340 readExterns :: ModuleName -> Make (FilePath, Externs)

339 readExterns :: ModuleName -> Make (FilePath, Externs)

341 readExterns mn = do

340 readExterns mn = do

342− let path = outputDir </> runModuleName mn </> "externs.json"

341+ let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"

343 (path, ) <$> readTextFile path

342 (path, ) <$> readTextFile path

344

343

345 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()

344 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()

@@ -359,16 +358,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

359 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory

358 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory

360 sourceMaps <- lift $ asks optionsSourceMaps

359 sourceMaps <- lift $ asks optionsSourceMaps

361 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])

360 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])

362− let filePath = runModuleName mn

361+ let filePath = T.unpack (runModuleName mn)

363 jsFile = outputDir </> filePath </> "index.js"

362 jsFile = outputDir </> filePath </> "index.js"

364 mapFile = outputDir </> filePath </> "index.js.map"

363 mapFile = outputDir </> filePath </> "index.js.map"

365 externsFile = outputDir </> filePath </> "externs.json"

364 externsFile = outputDir </> filePath </> "externs.json"

366 foreignFile = outputDir </> filePath </> "foreign.js"

365 foreignFile = outputDir </> filePath </> "foreign.js"

367− prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

366+ prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix]

368− js = unlines $ map ("// " ++) prefix ++ [pjs]

367+ js = T.unlines $ map ("// " <>) prefix ++ [pjs]

369 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

368 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

370 lift $ do

369 lift $ do

371− writeTextFile jsFile (fromString $ js ++ mapRef)

370+ writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)

372 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

371 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

373 writeTextFile externsFile exts

372 writeTextFile externsFile exts

374 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings

373 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings

@@ -376,14 +375,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

376 when dumpCoreFn $ do

375 when dumpCoreFn $ do

377 let coreFnFile = outputDir </> filePath </> "corefn.json"

376 let coreFnFile = outputDir </> filePath </> "corefn.json"

378 let jsonPayload = CFJ.moduleToJSON Paths.version m

377 let jsonPayload = CFJ.moduleToJSON Paths.version m

379− let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]

378+ let json = Aeson.object [ (runModuleName mn, jsonPayload) ]

380− lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)

379+ lift $ writeTextFile coreFnFile (encode json)

381

380

382 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()

381 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()

383 genSourceMap dir mapFile extraLines mappings = do

382 genSourceMap dir mapFile extraLines mappings = do

384 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)

383 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)

385 sourceFile = case mappings of

384 sourceFile = case mappings of

386− (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file

385+ (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir (T.unpack file)

387 _ -> Nothing

386 _ -> Nothing

388 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

387 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

389 map (\(SMap _ orig gen) -> Mapping {

388 map (\(SMap _ orig gen) -> Mapping {

@@ -394,7 +393,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

394 }) mappings

393 }) mappings

395 }

394 }

396 let mapping = generate rawMapping

395 let mapping = generate rawMapping

397− writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping

396+ writeTextFile mapFile (encode mapping)

398 where

397 where

399 add :: Int -> Int -> SourcePos -> SourcePos

398 add :: Int -> Int -> SourcePos -> SourcePos

400 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')

399 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')

@@ -411,10 +410,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

411 exists <- doesFileExist path

410 exists <- doesFileExist path

412 traverse (const $ getModificationTime path) $ guard exists

411 traverse (const $ getModificationTime path) $ guard exists

413

412

414− writeTextFile :: FilePath -> String -> Make ()

413+ writeTextFile :: FilePath -> B.ByteString -> Make ()

415 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

414 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

416 mkdirp path

415 mkdirp path

417− writeUTF8File path text

416+ B.writeFile path text

418 where

417 where

419 mkdirp :: FilePath -> IO ()

418 mkdirp :: FilePath -> IO ()

420 mkdirp = createDirectoryIfMissing True . takeDirectory

419 mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -429,7 +428,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

429checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

428checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

430checkForeignDecls m path = do

429checkForeignDecls m path = do

431 jsStr <- lift $ readTextFile path

430 jsStr <- lift $ readTextFile path

432− js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path

431+ js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path

433

432

434 foreignIdentsStrs <- either errorParsingModule pure $ getExps js

433 foreignIdentsStrs <- either errorParsingModule pure $ getExps js

435 foreignIdents <- either

434 foreignIdents <- either

@@ -455,11 +454,11 @@ checkForeignDecls m path = do

455 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just

454 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just

456

455

457 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

456 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

458− getExps = Bundle.getExportedIdentifiers (runModuleName mname)

457+ getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))

459

458

460 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a

459 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a

461 errorInvalidForeignIdentifiers =

460 errorInvalidForeignIdentifiers =

462− throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)

461+ throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)

463

462

464 parseIdents :: [String] -> Either [String] [Ident]

463 parseIdents :: [String] -> Either [String] [Ident]

465 parseIdents strs =

464 parseIdents strs =

@@ -472,7 +471,7 @@ checkForeignDecls m path = do

472 -- We ignore the error message here, just being told it's an invalid

471 -- We ignore the error message here, just being told it's an invalid

473 -- identifier should be enough.

472 -- identifier should be enough.

474 parseIdent :: String -> Either String Ident

473 parseIdent :: String -> Either String Ident

475− parseIdent str = try str

474+ parseIdent str = try (T.pack str)

476 where

475 where

477 try s = either (const (Left str)) Right $ do

476 try s = either (const (Left str)) Right $ do

478 ts <- PSParser.lex "" s

477 ts <- PSParser.lex "" s

src/Language/PureScript/Names.hs+21−19

@@ -11,7 +11,9 @@ import Control.Monad.Supply.Class

11

12import Data.Aeson

13import Data.Aeson.TH

14−import Data.List

14+import Data.Monoid ((<>))

15+import Data.Text (Text)

16+import qualified Data.Text as T

15

17

16-- | A sum of the possible name types, useful for error and lint messages.

18-- | A sum of the possible name types, useful for error and lint messages.

17data Name

19data Name

@@ -59,22 +61,22 @@ data Ident

59 -- |

61 -- |

60 -- An alphanumeric identifier

62 -- An alphanumeric identifier

61 --

63 --

62− = Ident String

64+ = Ident Text

63 -- |

65 -- |

64 -- A generated name for an identifier

66 -- A generated name for an identifier

65 --

67 --

66− | GenIdent (Maybe String) Integer

68+ | GenIdent (Maybe Text) Integer

67 deriving (Show, Eq, Ord)

69 deriving (Show, Eq, Ord)

68

70

69−runIdent :: Ident -> String

71+runIdent :: Ident -> Text

70runIdent (Ident i) = i

72runIdent (Ident i) = i

71−runIdent (GenIdent Nothing n) = "$" ++ show n

73+runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)

72−runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

74+runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)

73

75

74−showIdent :: Ident -> String

76+showIdent :: Ident -> Text

75showIdent = runIdent

77showIdent = runIdent

76

78

77−freshIdent :: MonadSupply m => String -> m Ident

79+freshIdent :: MonadSupply m => Text -> m Ident

78freshIdent name = GenIdent (Just name) <$> fresh

80freshIdent name = GenIdent (Just name) <$> fresh

79

81

80freshIdent' :: MonadSupply m => m Ident

82freshIdent' :: MonadSupply m => m Ident

@@ -83,7 +85,7 @@ freshIdent' = GenIdent Nothing <$> fresh

83-- |

85-- |

84-- Operator alias names.

86-- Operator alias names.

85--

87--

86−newtype OpName (a :: OpNameType) = OpName { runOpName :: String }

88+newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }

87 deriving (Show, Eq, Ord)

89 deriving (Show, Eq, Ord)

88

90

89instance ToJSON (OpName a) where

91instance ToJSON (OpName a) where

@@ -92,8 +94,8 @@ instance ToJSON (OpName a) where

92instance FromJSON (OpName a) where

94instance FromJSON (OpName a) where

93 parseJSON = fmap OpName . parseJSON

95 parseJSON = fmap OpName . parseJSON

94

96

95−showOp :: OpName a -> String

97+showOp :: OpName a -> Text

96−showOp op = '(' : runOpName op ++ ")"

98+showOp op = "(" <> runOpName op <> ")"

97

99

98-- |

100-- |

99-- The closed set of operator alias types.

101-- The closed set of operator alias types.

@@ -103,7 +105,7 @@ data OpNameType = ValueOpName | TypeOpName

103-- |

105-- |

104-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

106-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

105--

107--

106−newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }

108+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }

107 deriving (Show, Eq, Ord)

109 deriving (Show, Eq, Ord)

108

110

109instance ToJSON (ProperName a) where

111instance ToJSON (ProperName a) where

@@ -131,16 +133,16 @@ coerceProperName = ProperName . runProperName

131newtype ModuleName = ModuleName [ProperName 'Namespace]

133newtype ModuleName = ModuleName [ProperName 'Namespace]

132 deriving (Show, Eq, Ord)

134 deriving (Show, Eq, Ord)

133

135

134−runModuleName :: ModuleName -> String

136+runModuleName :: ModuleName -> Text

135−runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

137+runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)

136

138

137−moduleNameFromString :: String -> ModuleName

139+moduleNameFromString :: Text -> ModuleName

138moduleNameFromString = ModuleName . splitProperNames

140moduleNameFromString = ModuleName . splitProperNames

139 where

141 where

140− splitProperNames s = case dropWhile (== '.') s of

142+ splitProperNames s = case T.dropWhile (== '.') s of

141 "" -> []

143 "" -> []

142 s' -> ProperName w : splitProperNames s''

144 s' -> ProperName w : splitProperNames s''

143− where (w, s'') = break (== '.') s'

145+ where (w, s'') = T.break (== '.') s'

144

146

145-- |

147-- |

146-- A qualified name, i.e. a name with an optional module name

148-- A qualified name, i.e. a name with an optional module name

@@ -148,9 +150,9 @@ moduleNameFromString = ModuleName . splitProperNames

148data Qualified a = Qualified (Maybe ModuleName) a

150data Qualified a = Qualified (Maybe ModuleName) a

149 deriving (Show, Eq, Ord, Functor)

151 deriving (Show, Eq, Ord, Functor)

150

152

151−showQualified :: (a -> String) -> Qualified a -> String

153+showQualified :: (a -> Text) -> Qualified a -> Text

152showQualified f (Qualified Nothing a) = f a

154showQualified f (Qualified Nothing a) = f a

153−showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

155+showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a

154

156

155getQual :: Qualified a -> Maybe ModuleName

157getQual :: Qualified a -> Maybe ModuleName

156getQual (Qualified mn _) = mn

158getQual (Qualified mn _) = mn

src/Language/PureScript/Parser/Common.hs+12−9

@@ -5,8 +5,11 @@ module Language.PureScript.Parser.Common where

5

6import Prelude.Compat

7

8−import Control.Applicative

8+import Control.Applicative ((<|>))

9import Control.Monad (guard)

10+import Data.Monoid ((<>))

11+import Data.Text (Text)

12+import qualified Data.Text as T

10

13

11import Language.PureScript.AST.SourcePos

14import Language.PureScript.AST.SourcePos

12import Language.PureScript.Comments

15import Language.PureScript.Comments

@@ -79,8 +82,8 @@ augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

79-- Run the first parser, then match the second zero or more times, applying the specified function for each match

82-- Run the first parser, then match the second zero or more times, applying the specified function for each match

80--

83--

81fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

84fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

82−fold first more combine = do

85+fold first' more combine = do

83− a <- first

86+ a <- first'

84 bs <- P.many more

87 bs <- P.many more

85 return $ foldl combine a bs

88 return $ foldl combine a bs

86

89

@@ -88,8 +91,8 @@ fold first more combine = do

88-- Build a parser from a smaller parser and a list of parsers for postfix operators

91-- Build a parser from a smaller parser and a list of parsers for postfix operators

89--

92--

90buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

93buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

91−buildPostfixParser fs first = do

94+buildPostfixParser fs first' = do

92− a <- first

95+ a <- first'

93 go a

96 go a

94 where

97 where

95 go a = do

98 go a = do

@@ -114,25 +117,25 @@ mark p = do

114-- Check that the current identation level matches a predicate

117-- Check that the current identation level matches a predicate

115--

118--

116checkIndentation

119checkIndentation

117− :: (P.Column -> String)

120+ :: (P.Column -> Text)

118 -> (P.Column -> P.Column -> Bool)

121 -> (P.Column -> P.Column -> Bool)

119 -> P.Parsec s ParseState ()

122 -> P.Parsec s ParseState ()

120checkIndentation mkMsg rel = do

123checkIndentation mkMsg rel = do

121 col <- P.sourceColumn <$> P.getPosition

124 col <- P.sourceColumn <$> P.getPosition

122 current <- indentationLevel <$> P.getState

125 current <- indentationLevel <$> P.getState

123− guard (col `rel` current) P.<?> mkMsg current

126+ guard (col `rel` current) P.<?> T.unpack (mkMsg current)

124

127

125-- |

128-- |

126-- Check that the current indentation level is past the current mark

129-- Check that the current indentation level is past the current mark

127--

130--

128indented :: P.Parsec s ParseState ()

131indented :: P.Parsec s ParseState ()

129−indented = checkIndentation (("indentation past column " ++) . show) (>)

132+indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)

130

133

131-- |

134-- |

132-- Check that the current indentation level is at the same indentation as the current mark

135-- Check that the current indentation level is at the same indentation as the current mark

133--

136--

134same :: P.Parsec s ParseState ()

137same :: P.Parsec s ParseState ()

135−same = checkIndentation (("indentation at column " ++) . show) (==)

138+same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)

136

139

137-- |

140-- |

138-- Read the comments from the the next token, without consuming it

141-- Read the comments from the the next token, without consuming it

src/Language/PureScript/Parser/Declarations.hs+6−6

@@ -61,7 +61,7 @@ withSourceSpan f p = do

61 let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end')

62 return $ f sp comments x

63

64−kindedIdent :: TokenParser (String, Maybe Kind)

64+kindedIdent :: TokenParser (Text, Maybe Kind)

65kindedIdent = (, Nothing) <$> identifier

66 <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

67

@@ -303,7 +303,7 @@ parseModuleFromFile

303 -> Either P.ParseError (k, Module)

304parseModuleFromFile toFilePath (k, content) = do

305 let filename = toFilePath k

306− ts <- lex' filename content

306+ ts <- lex filename content

307 m <- runTokenParser filename parseModule ts

308 pure (k, m)

309

@@ -333,10 +333,10 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

333parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

334parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

335

336−parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)

336+parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a)

337parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

338

339−parseIdentifierAndValue :: TokenParser (String, Expr)

339+parseIdentifierAndValue :: TokenParser (Text, Expr)

340parseIdentifierAndValue =

341 do

342 name <- C.indented *> lname

@@ -423,7 +423,7 @@ parseInfixExpr

423parseHole :: TokenParser Expr

424parseHole = Hole <$> holeLit

425

426−parsePropertyUpdate :: TokenParser (String, Expr)

426+parsePropertyUpdate :: TokenParser (Text, Expr)

427parsePropertyUpdate = do

428 name <- lname <|> stringLiteral

429 _ <- C.indented *> equals

@@ -515,7 +515,7 @@ parseVarOrNamedBinder = do

515parseNullBinder :: TokenParser Binder

516parseNullBinder = underscore *> return NullBinder

517

518−parseIdentifierAndBinder :: TokenParser (String, Binder)

518+parseIdentifierAndBinder :: TokenParser (Text, Binder)

519parseIdentifierAndBinder =

520 do name <- lname

521 b <- P.option (VarBinder (Ident name)) rest

src/Language/PureScript/Parser/Lexer.hs+94−77

@@ -6,7 +6,6 @@ module Language.PureScript.Parser.Lexer

6 , Token()

7 , TokenParser()

8 , lex

9− , lex'

10 , anyToken

9 , anyToken

11 , token

10 , token

12 , match

11 , match

@@ -63,13 +62,13 @@ module Language.PureScript.Parser.Lexer

63 )

62 )

64 where

63 where

65

64

66−import Prelude hiding (lex)

65+import Prelude.Compat hiding (lex)

67

66

68−import Control.Applicative

67+import Control.Applicative ((<|>))

69import Control.Monad (void, guard)

68import Control.Monad (void, guard)

70−

69+import Control.Monad.Identity (Identity)

71import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

70import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

72−import Data.Functor.Identity

71+import Data.Monoid ((<>))

73import Data.Text (Text)

72import Data.Text (Text)

74import qualified Data.Text as T

73import qualified Data.Text as T

75

74

@@ -101,17 +100,17 @@ data Token

101 | Semi

100 | Semi

102 | At

101 | At

103 | Underscore

102 | Underscore

104− | LName String

103+ | LName Text

105− | UName String

104+ | UName Text

106− | Qualifier String

105+ | Qualifier Text

107− | Symbol String

106+ | Symbol Text

108 | CharLiteral Char

107 | CharLiteral Char

109− | StringLiteral String

108+ | StringLiteral Text

110 | Number (Either Integer Double)

109 | Number (Either Integer Double)

111− | HoleLit String

110+ | HoleLit Text

112 deriving (Show, Eq, Ord)

111 deriving (Show, Eq, Ord)

113

112

114−prettyPrintToken :: Token -> String

113+prettyPrintToken :: Token -> Text

115prettyPrintToken LParen = "("

114prettyPrintToken LParen = "("

116prettyPrintToken RParen = ")"

115prettyPrintToken RParen = ")"

117prettyPrintToken LBrace = "{"

116prettyPrintToken LBrace = "{"

@@ -132,15 +131,15 @@ prettyPrintToken Comma = ","

132prettyPrintToken Semi = ";"

131prettyPrintToken Semi = ";"

133prettyPrintToken At = "@"

132prettyPrintToken At = "@"

134prettyPrintToken Underscore = "_"

133prettyPrintToken Underscore = "_"

135−prettyPrintToken (Indent n) = "indentation at level " ++ show n

134+prettyPrintToken (Indent n) = "indentation at level " <> T.pack (show n)

136−prettyPrintToken (LName s) = show s

135+prettyPrintToken (LName s) = T.pack (show s)

137−prettyPrintToken (UName s) = show s

136+prettyPrintToken (UName s) = T.pack (show s)

138prettyPrintToken (Qualifier _) = "qualifier"

137prettyPrintToken (Qualifier _) = "qualifier"

139prettyPrintToken (Symbol s) = s

138prettyPrintToken (Symbol s) = s

140−prettyPrintToken (CharLiteral c) = show c

139+prettyPrintToken (CharLiteral c) = T.pack (show c)

141−prettyPrintToken (StringLiteral s) = show s

140+prettyPrintToken (StringLiteral s) = T.pack (show s)

142−prettyPrintToken (Number n) = either show show n

141+prettyPrintToken (Number n) = T.pack (either show show n)

143−prettyPrintToken (HoleLit name) = "?" ++ name

142+prettyPrintToken (HoleLit name) = "?" <> name

144

143

145data PositionedToken = PositionedToken

144data PositionedToken = PositionedToken

146 { -- | Start position of this token

145 { -- | Start position of this token

@@ -155,15 +154,12 @@ data PositionedToken = PositionedToken

155

154

156-- Parsec requires this instance for various token-level combinators

155-- Parsec requires this instance for various token-level combinators

157instance Show PositionedToken where

156instance Show PositionedToken where

158− show = prettyPrintToken . ptToken

157+ show = T.unpack . prettyPrintToken . ptToken

159

158

160type Lexer u a = P.Parsec Text u a

159type Lexer u a = P.Parsec Text u a

161

160

162−lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

163−lex fp = lex' fp . T.pack

164−

165−lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]

161+lex :: FilePath -> Text -> Either P.ParseError [PositionedToken]

166−lex' f s = updatePositions <$> P.parse parseTokens f s

162+lex f s = updatePositions <$> P.parse parseTokens f s

167

163

168updatePositions :: [PositionedToken] -> [PositionedToken]

164updatePositions :: [PositionedToken] -> [PositionedToken]

169updatePositions [] = []

165updatePositions [] = []

@@ -180,11 +176,11 @@ whitespace = P.skipMany (P.satisfy isSpace)

180parseComment :: Lexer u Comment

176parseComment :: Lexer u Comment

181parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

177parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

182 where

178 where

183− blockComment :: Lexer u String

179+ blockComment :: Lexer u Text

184− blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))

180+ blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}")))

185

181

186− lineComment :: Lexer u String

182+ lineComment :: Lexer u Text

187− lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))

183+ lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)))

188

184

189parsePositionedToken :: Lexer u PositionedToken

185parsePositionedToken :: Lexer u PositionedToken

190parsePositionedToken = P.try $ do

186parsePositionedToken = P.try $ do

@@ -222,11 +218,11 @@ parseToken = P.choice

222 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

218 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

223 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

219 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

224 , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

220 , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

225− , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter)

221+ , HoleLit <$> P.try (P.char '?' *> (T.pack <$> P.many1 identLetter))

226 , LName <$> parseLName

222 , LName <$> parseLName

227 , parseUName >>= \uName ->

223 , parseUName >>= \uName ->

228− (guard (validModuleName uName) >> Qualifier uName <$ P.char '.')

224+ guard (validModuleName uName) *> (Qualifier uName <$ P.char '.')

229− <|> pure (UName uName)

225+ <|> pure (UName uName)

230 , Symbol <$> parseSymbol

226 , Symbol <$> parseSymbol

231 , CharLiteral <$> parseCharLiteral

227 , CharLiteral <$> parseCharLiteral

232 , StringLiteral <$> parseStringLiteral

228 , StringLiteral <$> parseStringLiteral

@@ -234,14 +230,14 @@ parseToken = P.choice

234 ]

230 ]

235

231

236 where

232 where

237− parseLName :: Lexer u String

233+ parseLName :: Lexer u Text

238− parseLName = (:) <$> identStart <*> P.many identLetter

234+ parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter)

239

235

240− parseUName :: Lexer u String

236+ parseUName :: Lexer u Text

241− parseUName = (:) <$> P.upper <*> P.many identLetter

237+ parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter)

242

238

243− parseSymbol :: Lexer u String

239+ parseSymbol :: Lexer u Text

244− parseSymbol = P.many1 symbolChar

240+ parseSymbol = T.pack <$> P.many1 symbolChar

245

241

246 identStart :: Lexer u Char

242 identStart :: Lexer u Char

247 identStart = P.lower <|> P.oneOf "_"

243 identStart = P.lower <|> P.oneOf "_"

@@ -252,24 +248,41 @@ parseToken = P.choice

252 symbolChar :: Lexer u Char

248 symbolChar :: Lexer u Char

253 symbolChar = P.satisfy isSymbolChar

249 symbolChar = P.satisfy isSymbolChar

254

250

251+ surrogates :: Char -> (Char, Char)

252+ surrogates c = (high, low)

253+ where

254+ (h, l) = divMod (fromEnum c - 0x10000) 0x400

255+ high = toEnum (h + 0xD800)

256+ low = toEnum (l + 0xDC00)

257+

258+ expandAstralCodePointToUTF16Surrogates :: Char -> [Char]

259+ expandAstralCodePointToUTF16Surrogates c | fromEnum c > 0xFFFF = [high, low]

260+ where (high, low) = surrogates c

261+ expandAstralCodePointToUTF16Surrogates c = [c]

262+

255 parseCharLiteral :: Lexer u Char

263 parseCharLiteral :: Lexer u Char

264+ parseCharLiteral = P.try $ do {

256− parseCharLiteral = PT.charLiteral tokenParser

265+ c <- PT.charLiteral tokenParser;

266+ if fromEnum c > 0xFFFF

267+ then P.unexpected "astral code point in character literal; characters must be valid UTF-16 code units"

268+ else return c

269+ }

257

270

258− parseStringLiteral :: Lexer u String

271+ parseStringLiteral :: Lexer u Text

259− parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

272+ parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser

260 where

273 where

261 delimiter = P.try (P.string "\"\"\"")

274 delimiter = P.try (P.string "\"\"\"")

262− blockString = delimiter >> P.manyTill P.anyChar delimiter

275+ blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter)

263

276

264 parseNumber :: Lexer u (Either Integer Double)

277 parseNumber :: Lexer u (Either Integer Double)

265− parseNumber = (consumeLeadingZero >> P.parserZero) <|>

278+ parseNumber = (consumeLeadingZero *> P.parserZero) <|>

266 (Right <$> P.try (PT.float tokenParser) <|>

279 (Right <$> P.try (PT.float tokenParser) <|>

267 Left <$> P.try (PT.natural tokenParser))

280 Left <$> P.try (PT.natural tokenParser))

268 P.<?> "number"

281 P.<?> "number"

269 where

282 where

270 -- lookAhead doesn't consume any input if its parser succeeds

283 -- lookAhead doesn't consume any input if its parser succeeds

271 -- if notFollowedBy fails though, the consumed '0' will break the choice chain

284 -- if notFollowedBy fails though, the consumed '0' will break the choice chain

272− consumeLeadingZero = P.lookAhead (P.char '0' >>

285+ consumeLeadingZero = P.lookAhead (P.char '0' *>

273 (P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))

286 (P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))

274

287

275-- |

288-- |

@@ -283,10 +296,10 @@ langDef = PT.LanguageDef

283 , PT.commentEnd = ""

296 , PT.commentEnd = ""

284 , PT.commentLine = ""

297 , PT.commentLine = ""

285 , PT.nestedComments = True

298 , PT.nestedComments = True

286− , PT.identStart = fail "Identifiers not supported"

299+ , PT.identStart = P.parserFail "Identifiers not supported"

287− , PT.identLetter = fail "Identifiers not supported"

300+ , PT.identLetter = P.parserFail "Identifiers not supported"

288− , PT.opStart = fail "Operators not supported"

301+ , PT.opStart = P.parserFail "Operators not supported"

289− , PT.opLetter = fail "Operators not supported"

302+ , PT.opLetter = P.parserFail "Operators not supported"

290 , PT.caseSensitive = True

303 , PT.caseSensitive = True

291 }

304 }

292

305

@@ -299,13 +312,13 @@ tokenParser = PT.makeTokenParser langDef

299type TokenParser a = P.Parsec [PositionedToken] ParseState a

312type TokenParser a = P.Parsec [PositionedToken] ParseState a

300

313

301anyToken :: TokenParser PositionedToken

314anyToken :: TokenParser PositionedToken

302−anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just

315+anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just

303

316

304token :: (Token -> Maybe a) -> TokenParser a

317token :: (Token -> Maybe a) -> TokenParser a

305−token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

318+token f = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

306

319

307match :: Token -> TokenParser ()

320match :: Token -> TokenParser ()

308−match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok

321+match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> T.unpack (prettyPrintToken tok)

309

322

310lparen :: TokenParser ()

323lparen :: TokenParser ()

311lparen = match LParen

324lparen = match LParen

@@ -388,7 +401,7 @@ at = match At

388underscore :: TokenParser ()

401underscore :: TokenParser ()

389underscore = match Underscore

402underscore = match Underscore

390

403

391−holeLit :: TokenParser String

404+holeLit :: TokenParser Text

392holeLit = token go P.<?> "hole literal"

405holeLit = token go P.<?> "hole literal"

393 where

406 where

394 go (HoleLit n) = Just n

407 go (HoleLit n) = Just n

@@ -418,62 +431,62 @@ commaSep = flip P.sepBy comma

418commaSep1 :: TokenParser a -> TokenParser [a]

431commaSep1 :: TokenParser a -> TokenParser [a]

419commaSep1 = flip P.sepBy1 comma

432commaSep1 = flip P.sepBy1 comma

420

433

421−lname :: TokenParser String

434+lname :: TokenParser Text

422lname = token go P.<?> "identifier"

435lname = token go P.<?> "identifier"

423 where

436 where

424 go (LName s) = Just s

437 go (LName s) = Just s

425 go _ = Nothing

438 go _ = Nothing

426

439

427−lname' :: String -> TokenParser ()

440+lname' :: Text -> TokenParser ()

428lname' s = token go P.<?> show s

441lname' s = token go P.<?> show s

429 where

442 where

430 go (LName s') | s == s' = Just ()

443 go (LName s') | s == s' = Just ()

431 go _ = Nothing

444 go _ = Nothing

432

445

433−qualifier :: TokenParser String

446+qualifier :: TokenParser Text

434qualifier = token go P.<?> "qualifier"

447qualifier = token go P.<?> "qualifier"

435 where

448 where

436 go (Qualifier s) = Just s

449 go (Qualifier s) = Just s

437 go _ = Nothing

450 go _ = Nothing

438

451

439−reserved :: String -> TokenParser ()

452+reserved :: Text -> TokenParser ()

440reserved s = token go P.<?> show s

453reserved s = token go P.<?> show s

441 where

454 where

442 go (LName s') | s == s' = Just ()

455 go (LName s') | s == s' = Just ()

443 go (Symbol s') | s == s' = Just ()

456 go (Symbol s') | s == s' = Just ()

444 go _ = Nothing

457 go _ = Nothing

445

458

446−uname :: TokenParser String

459+uname :: TokenParser Text

447uname = token go P.<?> "proper name"

460uname = token go P.<?> "proper name"

448 where

461 where

449 go (UName s) | validUName s = Just s

462 go (UName s) | validUName s = Just s

450 go _ = Nothing

463 go _ = Nothing

451

464

452−uname' :: String -> TokenParser ()

465+uname' :: Text -> TokenParser ()

453uname' s = token go P.<?> "proper name"

466uname' s = token go P.<?> "proper name"

454 where

467 where

455 go (UName s') | s == s' = Just ()

468 go (UName s') | s == s' = Just ()

456 go _ = Nothing

469 go _ = Nothing

457

470

458−tyname :: TokenParser String

471+tyname :: TokenParser Text

459tyname = token go P.<?> "type name"

472tyname = token go P.<?> "type name"

460 where

473 where

461 go (UName s) = Just s

474 go (UName s) = Just s

462 go _ = Nothing

475 go _ = Nothing

463

476

464−dconsname :: TokenParser String

477+dconsname :: TokenParser Text

465dconsname = token go P.<?> "data constructor name"

478dconsname = token go P.<?> "data constructor name"

466 where

479 where

467 go (UName s) = Just s

480 go (UName s) = Just s

468 go _ = Nothing

481 go _ = Nothing

469

482

470−mname :: TokenParser String

483+mname :: TokenParser Text

471mname = token go P.<?> "module name"

484mname = token go P.<?> "module name"

472 where

485 where

473 go (UName s) | validModuleName s = Just s

486 go (UName s) | validModuleName s = Just s

474 go _ = Nothing

487 go _ = Nothing

475

488

476−symbol :: TokenParser String

489+symbol :: TokenParser Text

477symbol = token go P.<?> "symbol"

490symbol = token go P.<?> "symbol"

478 where

491 where

479 go (Symbol s) = Just s

492 go (Symbol s) = Just s

@@ -482,7 +495,7 @@ symbol = token go P.<?> "symbol"

482 go At = Just "@"

495 go At = Just "@"

483 go _ = Nothing

496 go _ = Nothing

484

497

485−symbol' :: String -> TokenParser ()

498+symbol' :: Text -> TokenParser ()

486symbol' s = token go P.<?> show s

499symbol' s = token go P.<?> show s

487 where

500 where

488 go (Symbol s') | s == s' = Just ()

501 go (Symbol s') | s == s' = Just ()

@@ -496,7 +509,7 @@ charLiteral = token go P.<?> "char literal"

496 go (CharLiteral c) = Just c

509 go (CharLiteral c) = Just c

497 go _ = Nothing

510 go _ = Nothing

498

511

499−stringLiteral :: TokenParser String

512+stringLiteral :: TokenParser Text

500stringLiteral = token go P.<?> "string literal"

513stringLiteral = token go P.<?> "string literal"

501 where

514 where

502 go (StringLiteral s) = Just s

515 go (StringLiteral s) = Just s

@@ -514,22 +527,25 @@ natural = token go P.<?> "natural"

514 go (Number (Left n)) = Just n

527 go (Number (Left n)) = Just n

515 go _ = Nothing

528 go _ = Nothing

516

529

517−identifier :: TokenParser String

530+identifier :: TokenParser Text

518identifier = token go P.<?> "identifier"

531identifier = token go P.<?> "identifier"

519 where

532 where

520 go (LName s) | s `notElem` reservedPsNames = Just s

533 go (LName s) | s `notElem` reservedPsNames = Just s

521 go _ = Nothing

534 go _ = Nothing

522

535

523−validModuleName :: String -> Bool

536+validModuleName :: Text -> Bool

524−validModuleName s = '_' `notElem` s

537+validModuleName s = '_' `notElemT` s

538+

539+validUName :: Text -> Bool

540+validUName s = '\'' `notElemT` s

525

541

526−validUName :: String -> Bool

542+notElemT :: Char -> Text -> Bool

527−validUName s = '\'' `notElem` s

543+notElemT c = not . T.any (== c)

528

544

529-- |

545-- |

530-- A list of purescript reserved identifiers

546-- A list of purescript reserved identifiers

531--

547--

532−reservedPsNames :: [String]

548+reservedPsNames :: [Text]

533reservedPsNames = [ "data"

549reservedPsNames = [ "data"

534 , "newtype"

550 , "newtype"

535 , "type"

551 , "type"

@@ -555,14 +571,14 @@ reservedPsNames = [ "data"

555 , "where"

571 , "where"

556 ]

572 ]

557

573

558−reservedTypeNames :: [String]

574+reservedTypeNames :: [Text]

559reservedTypeNames = [ "forall", "where" ]

575reservedTypeNames = [ "forall", "where" ]

560

576

561-- |

577-- |

562-- The characters allowed for use in operators

578-- The characters allowed for use in operators

563--

579--

564isSymbolChar :: Char -> Bool

580isSymbolChar :: Char -> Bool

565−isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)

581+isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c)

566

582

567

583

568-- |

584-- |

@@ -575,12 +591,13 @@ isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c

575-- The characters allowed in the tail of an unquoted record key

591-- The characters allowed in the tail of an unquoted record key

576--

592--

577isUnquotedKeyTailChar :: Char -> Bool

593isUnquotedKeyTailChar :: Char -> Bool

578−isUnquotedKeyTailChar c = (c `elem` "_'") || isAlphaNum c

594+isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c

579

595

580-- |

596-- |

581-- Strings allowed to be left unquoted in a record key

597-- Strings allowed to be left unquoted in a record key

582--

598--

583−isUnquotedKey :: String -> Bool

599+isUnquotedKey :: Text -> Bool

584−isUnquotedKey [] = False

600+isUnquotedKey t = case T.uncons t of

601+ Nothing -> False

585−isUnquotedKey (hd : tl) = isUnquotedKeyHeadChar hd &&

602+ Just (hd, tl) -> isUnquotedKeyHeadChar hd &&

586− all isUnquotedKeyTailChar tl

603+ T.all isUnquotedKeyTailChar tl

src/Language/PureScript/Parser/Types.hs+7−5

@@ -7,8 +7,10 @@ module Language.PureScript.Parser.Types

7

8import Prelude.Compat

9

10−import Control.Applicative

11import Control.Monad (when, unless)

10import Control.Monad (when, unless)

11+import Control.Applicative ((<|>))

12+import Data.Text (Text)

13+import qualified Data.Text as T

12

14

13import Language.PureScript.AST.SourcePos

15import Language.PureScript.AST.SourcePos

14import Language.PureScript.Environment

16import Language.PureScript.Environment

@@ -21,7 +23,7 @@ import qualified Text.Parsec as P

21import qualified Text.Parsec.Expr as P

23import qualified Text.Parsec.Expr as P

22

24

23parseFunction :: TokenParser Type

25parseFunction :: TokenParser Type

24−parseFunction = parens rarrow >> return tyFunction

26+parseFunction = parens rarrow *> return tyFunction

25

27

26parseObject :: TokenParser Type

28parseObject :: TokenParser Type

27parseObject = braces $ TypeApp tyRecord <$> parseRow

29parseObject = braces $ TypeApp tyRecord <$> parseRow

@@ -39,7 +41,7 @@ parseTypeWildcard = do

39parseTypeVariable :: TokenParser Type

41parseTypeVariable :: TokenParser Type

40parseTypeVariable = do

42parseTypeVariable = do

41 ident <- identifier

43 ident <- identifier

42− when (ident `elem` reservedTypeNames) $ P.unexpected ident

44+ when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident)

43 return $ TypeVar ident

45 return $ TypeVar ident

44

46

45parseTypeConstructor :: TokenParser Type

47parseTypeConstructor :: TokenParser Type

@@ -87,7 +89,7 @@ parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTabl

87 , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->

89 , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->

88 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

90 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

89 ]

91 ]

90− , [ P.Infix (rarrow >> return function) P.AssocRight ]

92+ , [ P.Infix (rarrow *> return function) P.AssocRight ]

91 ]

93 ]

92 postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

94 postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

93 ]

95 ]

@@ -116,7 +118,7 @@ noWildcards p = do

116 when (containsWildcards ty) $ P.unexpected "type wildcard"

118 when (containsWildcards ty) $ P.unexpected "type wildcard"

117 return ty

119 return ty

118

120

119−parseNameAndType :: TokenParser t -> TokenParser (String, t)

121+parseNameAndType :: TokenParser t -> TokenParser (Text, t)

120parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p

122parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p

121

123

122parseRowEnding :: TokenParser Type

124parseRowEnding :: TokenParser Type

src/Language/PureScript/Pretty/Common.hs+28−20

@@ -10,20 +10,27 @@ import Prelude.Compat

10import Control.Monad.State (StateT, modify, get)

11

12import Data.List (elemIndices, intersperse)

13+import Data.Monoid ((<>))

14+import Data.Text (Text)

15+import qualified Data.Text as T

13

16

14import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

17import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

15import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey)

18import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey)

16

19

17−import Text.PrettyPrint.Boxes

20+import Text.PrettyPrint.Boxes hiding ((<>))

21+import qualified Text.PrettyPrint.Boxes as Box

18

22

19-- |

23-- |

20-- Wrap a string in parentheses

24-- Wrap a string in parentheses

21--

25--

22parens :: String -> String

26parens :: String -> String

23−parens s = '(':s ++ ")"

27+parens s = "(" <> s <> ")"

28+

29+parensT :: Text -> Text

30+parensT s = "(" <> s <> ")"

24

31

25parensPos :: (Emit gen) => gen -> gen

32parensPos :: (Emit gen) => gen -> gen

26−parensPos s = emit "(" `mappend` s `mappend` emit ")"

33+parensPos s = emit "(" <> s <> emit ")"

27

34

28-- |

35-- |

29-- Generalize intercalate slightly for monoids

36-- Generalize intercalate slightly for monoids

@@ -32,15 +39,15 @@ intercalate :: Monoid m => m -> [m] -> m

32intercalate x xs = mconcat (intersperse x xs)

39intercalate x xs = mconcat (intersperse x xs)

33

40

34class (Monoid gen) => Emit gen where

41class (Monoid gen) => Emit gen where

35− emit :: String -> gen

42+ emit :: Text -> gen

36 addMapping :: SourceSpan -> gen

43 addMapping :: SourceSpan -> gen

37

44

38−data SMap = SMap String SourcePos SourcePos

45+data SMap = SMap Text SourcePos SourcePos

39

46

40-- |

47-- |

41-- String with length and source-map entries

48-- String with length and source-map entries

42--

49--

43−newtype StrPos = StrPos (SourcePos, String, [SMap])

50+newtype StrPos = StrPos (SourcePos, Text, [SMap])

44

51

45-- |

52-- |

46-- Make a monoid where append consists of concatenating the string part, adding the lengths

53-- Make a monoid where append consists of concatenating the string part, adding the lengths

@@ -50,10 +57,10 @@ newtype StrPos = StrPos (SourcePos, String, [SMap])

50instance Monoid StrPos where

57instance Monoid StrPos where

51 mempty = StrPos (SourcePos 0 0, "", [])

58 mempty = StrPos (SourcePos 0 0, "", [])

52

59

53− StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))

60+ StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c'))

54

61

55 mconcat ms =

62 mconcat ms =

56− let s' = concatMap (\(StrPos(_, s, _)) -> s) ms

63+ let s' = foldMap (\(StrPos(_, s, _)) -> s) ms

57 (p, maps) = foldl plus (SourcePos 0 0, []) ms

64 (p, maps) = foldl plus (SourcePos 0 0, []) ms

58 in

65 in

59 StrPos (p, s', concat $ reverse maps)

66 StrPos (p, s', concat $ reverse maps)

@@ -66,22 +73,23 @@ instance Emit StrPos where

66 -- Augment a string with its length (rows/column)

73 -- Augment a string with its length (rows/column)

67 --

74 --

68 emit str =

75 emit str =

76+ -- TODO(Christoph): get rid of T.unpack

69− let newlines = elemIndices '\n' str

77+ let newlines = elemIndices '\n' (T.unpack str)

70 index = if null newlines then 0 else last newlines + 1

78 index = if null newlines then 0 else last newlines + 1

71 in

79 in

72− StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])

80+ StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = T.length str - index }, str, [])

73

81

74 -- |

82 -- |

75 -- Add a new mapping entry for given source position with initially zero generated position

83 -- Add a new mapping entry for given source position with initially zero generated position

76 --

84 --

77 addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])

85 addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])

78 where

86 where

79− mapping = SMap file startPos zeroPos

87+ mapping = SMap (T.pack file) startPos zeroPos

80 zeroPos = SourcePos 0 0

88 zeroPos = SourcePos 0 0

81

89

82−newtype PlainString = PlainString String deriving Monoid

90+newtype PlainString = PlainString Text deriving Monoid

83

91

84−runPlainString :: PlainString -> String

92+runPlainString :: PlainString -> Text

85runPlainString (PlainString s) = s

93runPlainString (PlainString s) = s

86

94

87instance Emit PlainString where

95instance Emit PlainString where

@@ -127,7 +135,7 @@ withIndent action = do

127currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

135currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

128currentIndent = do

136currentIndent = do

129 current <- get

137 current <- get

130− return $ emit $ replicate (indent current) ' '

138+ return $ emit $ T.replicate (indent current) " "

131

139

132-- |

140-- |

133-- Print many lines

141-- Print many lines

@@ -141,19 +149,19 @@ prettyPrintMany f xs = do

141-- |

149-- |

142-- Prints an object key, escaping reserved names.

150-- Prints an object key, escaping reserved names.

143--

151--

144−prettyPrintObjectKey :: String -> String

152+prettyPrintObjectKey :: Text -> Text

145−prettyPrintObjectKey s | s `elem` reservedPsNames = show s

153+prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s)

146 | isUnquotedKey s = s

154 | isUnquotedKey s = s

147− | otherwise = show s

155+ | otherwise = T.pack (show s)

148

156

149-- | Place a box before another, vertically when the first box takes up multiple lines.

157-- | Place a box before another, vertically when the first box takes up multiple lines.

150before :: Box -> Box -> Box

158before :: Box -> Box -> Box

151before b1 b2 | rows b1 > 1 = b1 // b2

159before b1 b2 | rows b1 > 1 = b1 // b2

152− | otherwise = b1 <> b2

160+ | otherwise = b1 Box.<> b2

153

161

154beforeWithSpace :: Box -> Box -> Box

162beforeWithSpace :: Box -> Box -> Box

155−beforeWithSpace b1 = before (b1 <> text " ")

163+beforeWithSpace b1 = before (b1 Box.<> text " ")

156

164

157-- | Place a Box on the bottom right of another

165-- | Place a Box on the bottom right of another

158endWith :: Box -> Box -> Box

166endWith :: Box -> Box -> Box

159−endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r]

167+endWith l r = l Box.<> vcat top [emptyBox (rows l - 1) (cols r), r]

src/Language/PureScript/Pretty/JS.hs+50−43

@@ -9,12 +9,15 @@ module Language.PureScript.Pretty.JS

9import Prelude.Compat

10

11import Control.Arrow ((<+>))

12−import Control.Monad.State hiding (sequence)

12+import Control.Monad (forM, mzero)

13+import Control.Monad.State (StateT, evalStateT)

13import Control.PatternArrows

14import Control.PatternArrows

14import qualified Control.Arrow as A

15import qualified Control.Arrow as A

15

16

16import Data.Maybe (fromMaybe)

17import Data.Maybe (fromMaybe)

17−import Data.Monoid

18+import Data.Monoid ((<>))

19+import Data.Text (Text)

20+import qualified Data.Text as T

18

21

19import Language.PureScript.AST (SourceSpan(..))

22import Language.PureScript.AST (SourceSpan(..))

20import Language.PureScript.CodeGen.JS.AST

23import Language.PureScript.CodeGen.JS.AST

@@ -25,6 +28,8 @@ import Language.PureScript.Pretty.Common

25

28

26import Numeric

29import Numeric

27

30

31+-- TODO (Christoph): Get rid of T.unpack / pack

32+

28literals :: (Emit gen) => Pattern PrinterState JS gen

33literals :: (Emit gen) => Pattern PrinterState JS gen

29literals = mkPattern' match'

34literals = mkPattern' match'

30 where

35 where

@@ -32,7 +37,7 @@ literals = mkPattern' match'

32 match' js = (addMapping' (getSourceSpan js) <>) <$> match js

37 match' js = (addMapping' (getSourceSpan js) <>) <$> match js

33

38

34 match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

39 match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

35− match (JSNumericLiteral _ n) = return $ emit $ either show show n

40+ match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n

36 match (JSStringLiteral _ s) = return $ string s

41 match (JSStringLiteral _ s) = return $ string s

37 match (JSBooleanLiteral _ True) = return $ emit "true"

42 match (JSBooleanLiteral _ True) = return $ emit "true"

38 match (JSBooleanLiteral _ False) = return $ emit "false"

43 match (JSBooleanLiteral _ False) = return $ emit "false"

@@ -53,8 +58,8 @@ literals = mkPattern' match'

53 , return $ emit "}"

58 , return $ emit "}"

54 ]

59 ]

55 where

60 where

56− objectPropertyToString :: (Emit gen) => String -> gen

61+ objectPropertyToString :: (Emit gen) => Text -> gen

57− objectPropertyToString s | identNeedsEscaping s = emit $ show s

62+ objectPropertyToString s | identNeedsEscaping s = string s

58 | otherwise = emit s

63 | otherwise = emit s

59 match (JSBlock _ sts) = mconcat <$> sequence

64 match (JSBlock _ sts) = mconcat <$> sequence

60 [ return $ emit "{\n"

65 [ return $ emit "{\n"

@@ -65,7 +70,7 @@ literals = mkPattern' match'

65 ]

70 ]

66 match (JSVar _ ident) = return $ emit ident

71 match (JSVar _ ident) = return $ emit ident

67 match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

72 match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

68− [ return $ emit $ "var " ++ ident

73+ [ return $ emit $ "var " <> ident

69 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

74 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

70 ]

75 ]

71 match (JSAssignment _ target value) = mconcat <$> sequence

76 match (JSAssignment _ target value) = mconcat <$> sequence

@@ -80,15 +85,15 @@ literals = mkPattern' match'

80 , prettyPrintJS' sts

85 , prettyPrintJS' sts

81 ]

86 ]

82 match (JSFor _ ident start end sts) = mconcat <$> sequence

87 match (JSFor _ ident start end sts) = mconcat <$> sequence

83− [ return $ emit $ "for (var " ++ ident ++ " = "

88+ [ return $ emit $ "for (var " <> ident <> " = "

84 , prettyPrintJS' start

89 , prettyPrintJS' start

85− , return $ emit $ "; " ++ ident ++ " < "

90+ , return $ emit $ "; " <> ident <> " < "

86 , prettyPrintJS' end

91 , prettyPrintJS' end

87− , return $ emit $ "; " ++ ident ++ "++) "

92+ , return $ emit $ "; " <> ident <> "++) "

88 , prettyPrintJS' sts

93 , prettyPrintJS' sts

89 ]

94 ]

90 match (JSForIn _ ident obj sts) = mconcat <$> sequence

95 match (JSForIn _ ident obj sts) = mconcat <$> sequence

91− [ return $ emit $ "for (var " ++ ident ++ " in "

96+ [ return $ emit $ "for (var " <> ident <> " in "

92 , prettyPrintJS' obj

97 , prettyPrintJS' obj

93 , return $ emit ") "

98 , return $ emit ") "

94 , prettyPrintJS' sts

99 , prettyPrintJS' sts

@@ -108,10 +113,10 @@ literals = mkPattern' match'

108 [ return $ emit "throw "

113 [ return $ emit "throw "

109 , prettyPrintJS' value

114 , prettyPrintJS' value

110 ]

115 ]

111− match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl

116+ match (JSBreak _ lbl) = return $ emit $ "break " <> lbl

112− match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl

117+ match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl

113 match (JSLabel _ lbl js) = mconcat <$> sequence

118 match (JSLabel _ lbl js) = mconcat <$> sequence

114− [ return $ emit $ lbl ++ ": "

119+ [ return $ emit $ lbl <> ": "

115 , prettyPrintJS' js

120 , prettyPrintJS' js

116 ]

121 ]

117 match (JSComment _ com js) = fmap mconcat $ sequence $

122 match (JSComment _ com js) = fmap mconcat $ sequence $

@@ -126,27 +131,29 @@ literals = mkPattern' match'

126 , prettyPrintJS' js

131 , prettyPrintJS' js

127 ]

132 ]

128 where

133 where

129− commentLines :: Comment -> [String]

134+ commentLines :: Comment -> [Text]

130 commentLines (LineComment s) = [s]

135 commentLines (LineComment s) = [s]

131− commentLines (BlockComment s) = lines s

136+ commentLines (BlockComment s) = T.lines s

132

137

133− asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen

138+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

134 asLine s = do

139 asLine s = do

135 i <- currentIndent

140 i <- currentIndent

136 return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

141 return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

137

142

138− removeComments :: String -> String

143+ removeComments :: Text -> Text

139− removeComments ('*' : '/' : s) = removeComments s

144+ removeComments t =

145+ case T.stripPrefix "*/" t of

146+ Just rest -> removeComments rest

147+ Nothing -> case T.uncons t of

140− removeComments (c : s) = c : removeComments s

148+ Just (x, xs) -> x `T.cons` removeComments xs

141−

149+ Nothing -> ""

142− removeComments [] = []

143 match (JSRaw _ js) = return $ emit js

150 match (JSRaw _ js) = return $ emit js

144 match _ = mzero

151 match _ = mzero

145

152

146−string :: (Emit gen) => String -> gen

153+string :: (Emit gen) => Text -> gen

147−string s = emit $ '"' : concatMap encodeChar s ++ "\""

154+string s = emit $ "\"" <> T.concatMap encodeChar s <> "\""

148 where

155 where

149− encodeChar :: Char -> String

156+ encodeChar :: Char -> Text

150 encodeChar '\b' = "\\b"

157 encodeChar '\b' = "\\b"

151 encodeChar '\t' = "\\t"

158 encodeChar '\t' = "\\t"

152 encodeChar '\n' = "\\n"

159 encodeChar '\n' = "\\n"

@@ -155,16 +162,16 @@ string s = emit $ '"' : concatMap encodeChar s ++ "\""

155 encodeChar '\r' = "\\r"

162 encodeChar '\r' = "\\r"

156 encodeChar '"' = "\\\""

163 encodeChar '"' = "\\\""

157 encodeChar '\\' = "\\\\"

164 encodeChar '\\' = "\\\\"

165+ -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit.

166+ -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD.

158− encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "")

167+ encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD"

159− where

160− (h, l) = divMod (fromEnum c - 0x10000) 0x400

161− highSurrogate = h + 0xD800

162− lowSurrogate = l + 0xDC00

163− encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""

168+ encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) ""

164− encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""

169+ encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) ""

165− encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) ""

170+ encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) ""

166− encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

171+ encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) ""

167− encodeChar c = [c]

172+ encodeChar c = T.singleton c

173+

174+ showHex' a b = T.pack (showHex a b)

168

175

169conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

176conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

170conditional = mkPattern match

177conditional = mkPattern match

@@ -185,7 +192,7 @@ indexer = mkPattern' match

185

192

186 match _ = mzero

193 match _ = mzero

187

194

188−lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)

195+lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)

189lam = mkPattern match

196lam = mkPattern match

190 where

197 where

191 match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

198 match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

@@ -211,7 +218,7 @@ instanceOf = mkPattern match

211 match (JSInstanceOf _ val ty) = Just (val, ty)

218 match (JSInstanceOf _ val ty) = Just (val, ty)

212 match _ = Nothing

219 match _ = Nothing

213

220

214−unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen

221+unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen

215unary' op mkStr = Wrap match (<>)

222unary' op mkStr = Wrap match (<>)

216 where

223 where

217 match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

224 match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

@@ -220,7 +227,7 @@ unary' op mkStr = Wrap match (<>)

220 match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

227 match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

221 match' _ = Nothing

228 match' _ = Nothing

222

229

223−unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen

230+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen

224unary op str = unary' op (const str)

231unary op str = unary' op (const str)

225

232

226negateOperator :: (Emit gen) => Operator PrinterState JS gen

233negateOperator :: (Emit gen) => Operator PrinterState JS gen

@@ -229,8 +236,8 @@ negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

229 isNegate (JSUnary _ Negate _) = True

236 isNegate (JSUnary _ Negate _) = True

230 isNegate _ = False

237 isNegate _ = False

231

238

232−binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen

239+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen

233−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)

240+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

234 where

241 where

235 match :: Pattern PrinterState JS (JS, JS)

242 match :: Pattern PrinterState JS (JS, JS)

236 match = mkPattern match'

243 match = mkPattern match'

@@ -253,12 +260,12 @@ prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalState

253-- |

260-- |

254-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

261-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

255--

262--

256−prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])

263+prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap])

257prettyPrintJSWithSourceMaps js =

264prettyPrintJSWithSourceMaps js =

258 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js

265 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js

259 in (s, mp)

266 in (s, mp)

260

267

261−prettyPrintJS :: [JS] -> String

268+prettyPrintJS :: [JS] -> Text

262prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

269prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

263-- |

270-- |

264-- Generate an indented, pretty-printed string representing a Javascript expression

271-- Generate an indented, pretty-printed string representing a Javascript expression

@@ -276,8 +283,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

276 , [ unary JSNew "new " ]

283 , [ unary JSNew "new " ]

277 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

284 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

278 emit ("function "

285 emit ("function "

279− ++ fromMaybe "" name

286+ <> fromMaybe "" name

280− ++ "(" ++ intercalate ", " args ++ ") ")

287+ <> "(" <> intercalate ", " args <> ") ")

281 <> ret ]

288 <> ret ]

282 , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

289 , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

283 , [ unary Not "!"

290 , [ unary Not "!"

src/Language/PureScript/Pretty/Kinds.hs+6−2

@@ -11,6 +11,8 @@ import Control.Arrow (ArrowPlus(..))

11import Control.PatternArrows as PA

12

13import Data.Maybe (fromMaybe)

14+import qualified Data.Text as T

15+import Data.Text (Text)

14

16

15import Language.PureScript.Crash

17import Language.PureScript.Crash

16import Language.PureScript.Kinds

18import Language.PureScript.Kinds

@@ -38,9 +40,11 @@ funKind = mkPattern match

38 match _ = Nothing

40 match _ = Nothing

39

41

40-- | Generate a pretty-printed string representing a Kind

42-- | Generate a pretty-printed string representing a Kind

41−prettyPrintKind :: Kind -> String

43+prettyPrintKind :: Kind -> Text

42prettyPrintKind

44prettyPrintKind

45+ -- TODO(Christoph): get rid of T.pack

46+ = T.pack

43− = fromMaybe (internalError "Incomplete pattern")

47+ . fromMaybe (internalError "Incomplete pattern")

44 . PA.pattern matchKind ()

48 . PA.pattern matchKind ()

45 where

49 where

46 matchKind :: Pattern () Kind String

50 matchKind :: Pattern () Kind String

src/Language/PureScript/Pretty/Types.hs+12−9

@@ -18,6 +18,7 @@ import Control.Arrow ((<+>))

18import Control.PatternArrows as PA

19

20import Data.Maybe (fromMaybe)

21+import qualified Data.Text as T

21

22

22import Language.PureScript.Crash

23import Language.PureScript.Crash

23import Language.PureScript.Environment

24import Language.PureScript.Environment

@@ -29,6 +30,8 @@ import Language.PureScript.Types

29

30

30import Text.PrettyPrint.Boxes hiding ((<+>))

31import Text.PrettyPrint.Boxes hiding ((<+>))

31

32

33+-- TODO(Christoph): get rid of T.unpack s

34+

32constraintsAsBox :: [Constraint] -> Box -> Box

35constraintsAsBox :: [Constraint] -> Box -> Box

33constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

36constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

34constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)

37constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)

@@ -43,7 +46,7 @@ prettyPrintRowWith :: Char -> Char -> Type -> Box

43prettyPrintRowWith open close = uncurry listToBox . toList []

46prettyPrintRowWith open close = uncurry listToBox . toList []

44 where

47 where

45 nameAndTypeToPs :: Char -> String -> Type -> Box

48 nameAndTypeToPs :: Char -> String -> Type -> Box

46− nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty

49+ nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty

47

50

48 tailToPs :: Type -> Box

51 tailToPs :: Type -> Box

49 tailToPs REmpty = nullBox

52 tailToPs REmpty = nullBox

@@ -57,7 +60,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList []

57 [ tailToPs rest, text [close] ]

60 [ tailToPs rest, text [close] ]

58

61

59 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

62 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

60− toList tys (RCons name ty row) = toList ((name, ty):tys) row

63+ toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row

61 toList tys r = (reverse tys, r)

64 toList tys r = (reverse tys, r)

62

65

63prettyPrintRow :: Type -> String

66prettyPrintRow :: Type -> String

@@ -112,21 +115,21 @@ matchTypeAtom suggesting =

112 typeLiterals :: Pattern () Type Box

115 typeLiterals :: Pattern () Type Box

113 typeLiterals = mkPattern match where

116 typeLiterals = mkPattern match where

114 match TypeWildcard{} = Just $ text "_"

117 match TypeWildcard{} = Just $ text "_"

115− match (TypeVar var) = Just $ text var

118+ match (TypeVar var) = Just $ text $ T.unpack var

116 match (TypeLevelString s) = Just . text $ show s

119 match (TypeLevelString s) = Just . text $ show s

117 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

120 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

118− match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor

121+ match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor

119 match (TUnknown u)

122 match (TUnknown u)

120 | suggesting = Just $ text "_"

123 | suggesting = Just $ text "_"

121 | otherwise = Just $ text $ 't' : show u

124 | otherwise = Just $ text $ 't' : show u

122 match (Skolem name s _ _)

125 match (Skolem name s _ _)

123− | suggesting = Just $ text name

126+ | suggesting = Just $ text $ T.unpack name

124− | otherwise = Just $ text $ name ++ show s

127+ | otherwise = Just $ text $ T.unpack name ++ show s

125 match REmpty = Just $ text "()"

128 match REmpty = Just $ text "()"

126 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

129 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

127 match (BinaryNoParensType op l r) =

130 match (BinaryNoParensType op l r) =

128 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r

131 Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r

129− match (TypeOp op) = Just $ text $ showQualified runOpName op

132+ match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op

130 match _ = Nothing

133 match _ = Nothing

131

134

132matchType :: Bool -> Pattern () Type Box

135matchType :: Bool -> Pattern () Type Box

@@ -137,7 +140,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where

137 , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]

140 , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]

138 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

141 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

139 , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]

142 , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]

140− , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]

143+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ]

141 , [ Wrap explicitParens $ \_ ty -> ty ]

144 , [ Wrap explicitParens $ \_ ty -> ty ]

142 ]

145 ]

143

146

@@ -151,7 +154,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where

151forall_ :: Pattern () Type ([String], Type)

154forall_ :: Pattern () Type ([String], Type)

152forall_ = mkPattern match

155forall_ = mkPattern match

153 where

156 where

154− match (PrettyPrintForAll idents ty) = Just (idents, ty)

157+ match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)

155 match _ = Nothing

158 match _ = Nothing

156

159

157typeAtomAsBox :: Type -> Box

160typeAtomAsBox :: Type -> Box

src/Language/PureScript/Pretty/Values.hs+46−36

@@ -11,6 +11,11 @@ import Prelude.Compat

11

12import Control.Arrow (second)

13

14+import qualified Data.Monoid as Monoid ((<>))

15+

16+import qualified Data.Text as T

17+import Data.Text (Text)

18+

14import Language.PureScript.AST

19import Language.PureScript.AST

15import Language.PureScript.Crash

20import Language.PureScript.Crash

16import Language.PureScript.Names

21import Language.PureScript.Names

@@ -20,6 +25,11 @@ import Language.PureScript.Types (Constraint(..))

20

25

21import Text.PrettyPrint.Boxes

26import Text.PrettyPrint.Boxes

22

27

28+-- TODO(Christoph): remove T.unpack s

29+

30+textT :: Text -> Box

31+textT = text . T.unpack

32+

23-- | Render an aligned list of items separated with commas

33-- | Render an aligned list of items separated with commas

24list :: Char -> Char -> (a -> Box) -> [a] -> Box

34list :: Char -> Char -> (a -> Box) -> [a] -> Box

25list open close _ [] = text [open, close]

35list open close _ [] = text [open, close]

@@ -30,11 +40,11 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl

30ellipsis :: Box

40ellipsis :: Box

31ellipsis = text "..."

41ellipsis = text "..."

32

42

33−prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box

43+prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box

34prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

44prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

35 where

45 where

36− prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

46+ prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box

37− prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

47+ prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

38

48

39-- | Pretty-print an expression

49-- | Pretty-print an expression

40prettyPrintValue :: Int -> Expr -> Box

50prettyPrintValue :: Int -> Expr -> Box

@@ -44,13 +54,13 @@ prettyPrintValue d (IfThenElse cond th el) =

44 // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th

54 // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th

45 , text "else " <> prettyPrintValueAtom (d - 1) el

55 , text "else " <> prettyPrintValueAtom (d - 1) el

46 ])

56 ])

47−prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ prettyPrintObjectKey prop)

57+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop)

48−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

58+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps

49prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

59prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

50−prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

60+prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

51−prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

61+prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

52prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

62prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

53− text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

63+ text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps

54prettyPrintValue d (Case values binders) =

64prettyPrintValue d (Case values binders) =

55 (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //

65 (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //

56 moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))

66 moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))

@@ -60,14 +70,14 @@ prettyPrintValue d (Let ds val) =

60 (text "in " <> prettyPrintValue (d - 1) val)

70 (text "in " <> prettyPrintValue (d - 1) val)

61prettyPrintValue d (Do els) =

71prettyPrintValue d (Do els) =

62 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

72 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

63−prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

73+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys

64−prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

74+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name))

65prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

75prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

66− text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

76+ text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">"

67prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

77prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

68prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

78prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

69prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

79prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

70−prettyPrintValue _ (Hole name) = text "?" <> text name

80+prettyPrintValue _ (Hole name) = text "?" <> textT name

71prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

81prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

72prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

82prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

73prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

83prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

@@ -80,12 +90,12 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

80prettyPrintValueAtom :: Int -> Expr -> Box

90prettyPrintValueAtom :: Int -> Expr -> Box

81prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

91prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

82prettyPrintValueAtom _ AnonymousArgument = text "_"

92prettyPrintValueAtom _ AnonymousArgument = text "_"

83−prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

93+prettyPrintValueAtom _ (Constructor name) = text $ T.unpack $ runProperName (disqualify name)

84−prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

94+prettyPrintValueAtom _ (Var ident) = text $ T.unpack $ showIdent (disqualify ident)

85prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

95prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

86 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

96 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

87 where

97 where

88− printOp (Op (Qualified _ name)) = text (runOpName name)

98+ printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name

89 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

99 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

90prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

100prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

91prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

101prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

@@ -105,9 +115,9 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon

105prettyPrintDeclaration :: Int -> Declaration -> Box

115prettyPrintDeclaration :: Int -> Declaration -> Box

106prettyPrintDeclaration d _ | d < 0 = ellipsis

116prettyPrintDeclaration d _ | d < 0 = ellipsis

107prettyPrintDeclaration _ (TypeDeclaration ident ty) =

117prettyPrintDeclaration _ (TypeDeclaration ident ty) =

108− text (showIdent ident ++ " :: ") <> typeAsBox ty

118+ text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty

109prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =

119prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =

110− text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val

120+ text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val

111prettyPrintDeclaration d (BindingGroupDeclaration ds) =

121prettyPrintDeclaration d (BindingGroupDeclaration ds) =

112 vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)

122 vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)

113 where

123 where

@@ -118,7 +128,7 @@ prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDecla

118prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box

128prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box

119prettyPrintCaseAlternative d _ | d < 0 = ellipsis

129prettyPrintCaseAlternative d _ | d < 0 = ellipsis

120prettyPrintCaseAlternative d (CaseAlternative binders result) =

130prettyPrintCaseAlternative d (CaseAlternative binders result) =

121− text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

131+ text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result

122 where

132 where

123 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

133 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

124 prettyPrintResult (Left gs) =

134 prettyPrintResult (Left gs) =

@@ -138,50 +148,50 @@ prettyPrintDoNotationElement d _ | d < 0 = ellipsis

138prettyPrintDoNotationElement d (DoNotationValue val) =

148prettyPrintDoNotationElement d (DoNotationValue val) =

139 prettyPrintValue d val

149 prettyPrintValue d val

140prettyPrintDoNotationElement d (DoNotationBind binder val) =

150prettyPrintDoNotationElement d (DoNotationBind binder val) =

141− text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val

151+ textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val

142prettyPrintDoNotationElement d (DoNotationLet ds) =

152prettyPrintDoNotationElement d (DoNotationLet ds) =

143 text "let" //

153 text "let" //

144 moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))

154 moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))

145prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el

155prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el

146

156

147−prettyPrintBinderAtom :: Binder -> String

157+prettyPrintBinderAtom :: Binder -> Text

148prettyPrintBinderAtom NullBinder = "_"

158prettyPrintBinderAtom NullBinder = "_"

149prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

159prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

150prettyPrintBinderAtom (VarBinder ident) = showIdent ident

160prettyPrintBinderAtom (VarBinder ident) = showIdent ident

151prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

161prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

152−prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

162+prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b)

153−prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

163+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder

154prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

164prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

155prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

165prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

156prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op)

166prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op)

157prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

167prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

158− prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

168+ prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2

159−prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

169+prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b)

160

170

161−prettyPrintLiteralBinder :: Literal Binder -> String

171+prettyPrintLiteralBinder :: Literal Binder -> Text

162−prettyPrintLiteralBinder (StringLiteral str) = show str

172+prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str)

163−prettyPrintLiteralBinder (CharLiteral c) = show c

173+prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)

164−prettyPrintLiteralBinder (NumericLiteral num) = either show show num

174+prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num

165prettyPrintLiteralBinder (BooleanLiteral True) = "true"

175prettyPrintLiteralBinder (BooleanLiteral True) = "true"

166prettyPrintLiteralBinder (BooleanLiteral False) = "false"

176prettyPrintLiteralBinder (BooleanLiteral False) = "false"

167prettyPrintLiteralBinder (ObjectLiteral bs) =

177prettyPrintLiteralBinder (ObjectLiteral bs) =

168 "{ "

178 "{ "

169− ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

179+ Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)

170− ++ " }"

180+ Monoid.<> " }"

171 where

181 where

172− prettyPrintObjectPropertyBinder :: (String, Binder) -> String

182+ prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text

173− prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

183+ prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder

174prettyPrintLiteralBinder (ArrayLiteral bs) =

184prettyPrintLiteralBinder (ArrayLiteral bs) =

175 "[ "

185 "[ "

176− ++ intercalate ", " (map prettyPrintBinder bs)

186+ Monoid.<> T.intercalate ", " (map prettyPrintBinder bs)

177− ++ " ]"

187+ Monoid.<> " ]"

178

188

179-- |

189-- |

180-- Generate a pretty-printed string representing a Binder

190-- Generate a pretty-printed string representing a Binder

181--

191--

182−prettyPrintBinder :: Binder -> String

192+prettyPrintBinder :: Binder -> Text

183prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

193prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)

184−prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)

194+prettyPrintBinder (ConstructorBinder ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args)

185prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

195prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

186prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder

196prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder

187prettyPrintBinder b = prettyPrintBinderAtom b

197prettyPrintBinder b = prettyPrintBinderAtom b

src/Language/PureScript/Publish.hs−1

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE OverloadedStrings #-}

3

2

4module Language.PureScript.Publish

3module Language.PureScript.Publish

5 ( preparePackage

4 ( preparePackage

src/Language/PureScript/Publish/ErrorsWarnings.hs−2

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3module Language.PureScript.Publish.ErrorsWarnings

1module Language.PureScript.Publish.ErrorsWarnings

4 ( PackageError(..)

2 ( PackageError(..)

5 , PackageWarning(..)

3 , PackageWarning(..)

src/Language/PureScript/Renamer.hs+4−2

@@ -10,7 +10,9 @@ import Control.Monad.State

10import Data.List (find)

11import Data.Maybe (fromJust, fromMaybe)

12import qualified Data.Map as M

13+import Data.Monoid ((<>))

13import qualified Data.Set as S

14import qualified Data.Set as S

15+import qualified Data.Text as T

14

16

15import Language.PureScript.CoreFn

17import Language.PureScript.CoreFn

16import Language.PureScript.Names

18import Language.PureScript.Names

@@ -80,7 +82,7 @@ updateScope ident =

80 getNewName usedNames name =

82 getNewName usedNames name =

81 fromJust $ find

83 fromJust $ find

82 (`S.notMember` usedNames)

84 (`S.notMember` usedNames)

83− [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]

85+ [ Ident (runIdent name <> T.pack (show (i :: Int))) | i <- [1..] ]

84

86

85-- |

87-- |

86-- Finds the new name to use for an ident.

88-- Finds the new name to use for an ident.

@@ -91,7 +93,7 @@ lookupIdent name = do

91 name' <- gets $ M.lookup name . rsBoundNames

93 name' <- gets $ M.lookup name . rsBoundNames

92 case name' of

94 case name' of

93 Just name'' -> return name''

95 Just name'' -> return name''

94− Nothing -> error $ "Rename scope is missing ident '" ++ showIdent name ++ "'"

96+ Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"

95

97

96-- |

98-- |

97-- Finds idents introduced by declarations.

99-- Finds idents introduced by declarations.

src/Language/PureScript/Sugar/ObjectWildcards.hs+4−3

@@ -11,6 +11,7 @@ import Control.Monad.Supply.Class

11

12import Data.List (partition)

13import Data.Maybe (catMaybes)

14+import Data.Text (Text)

14

15

15import Language.PureScript.AST

16import Language.PureScript.AST

16import Language.PureScript.Errors

17import Language.PureScript.Errors

@@ -61,7 +62,7 @@ desugarDecl other = fn other

61 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

62 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

62 desugarExpr e = return e

63 desugarExpr e = return e

63

64

64− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

65+ wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr

65 wrapLambda mkVal ps =

66 wrapLambda mkVal ps =

66 let (args, props) = partition (isAnonymousArgument . snd) ps

67 let (args, props) = partition (isAnonymousArgument . snd) ps

67 in if null args

68 in if null args

@@ -74,7 +75,7 @@ desugarDecl other = fn other

74 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

75 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

75 stripPositionInfo e = e

76 stripPositionInfo e = e

76

77

77− peelAnonAccessorChain :: Expr -> Maybe [String]

78+ peelAnonAccessorChain :: Expr -> Maybe [Text]

78 peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e

79 peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e

79 peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e

80 peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e

80 peelAnonAccessorChain AnonymousArgument = Just []

81 peelAnonAccessorChain AnonymousArgument = Just []

@@ -85,7 +86,7 @@ desugarDecl other = fn other

85 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

86 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

86 isAnonymousArgument _ = False

87 isAnonymousArgument _ = False

87

88

88− mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

89+ mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr))

89 mkProp (name, e) = do

90 mkProp (name, e) = do

90 arg <- freshIfAnon e

91 arg <- freshIfAnon e

91 return (arg, (name, maybe e argToExpr arg))

92 return (arg, (name, maybe e argToExpr arg))

src/Language/PureScript/Sugar/TypeClasses.hs+10−12

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

27import Control.Monad.State

28import Data.List ((\\), find, sortBy)

29import Data.Maybe (catMaybes, mapMaybe, isJust)

30−

31import qualified Data.Map as M

30import qualified Data.Map as M

31+import Data.Monoid ((<>))

32+import Data.Text (Text)

33+import qualified Data.Text as T

32

34

33type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData

35type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData

34

36

@@ -55,11 +57,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu

55 -> ExternsDeclaration

57 -> ExternsDeclaration

56 -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)

58 -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)

57 fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where

59 fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where

58− typeClass = TypeClassData { typeClassArguments = args

60+ typeClass = makeTypeClassData args members implies deps

59− , typeClassMembers = members

60− , typeClassSuperclasses = implies

61− , typeClassDependencies = deps

62− }

63 fromExternsDecl _ _ = Nothing

61 fromExternsDecl _ _ = Nothing

64

62

65desugarModule

63desugarModule

@@ -180,7 +178,7 @@ desugarDecl

180desugarDecl mn exps = go

178desugarDecl mn exps = go

181 where

179 where

182 go d@(TypeClassDeclaration name args implies deps members) = do

180 go d@(TypeClassDeclaration name args implies deps members) = do

183− modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps))

181+ modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps))

184 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

182 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

185 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"

183 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"

186 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

184 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

@@ -231,7 +229,7 @@ memberToNameAndType _ = internalError "Invalid declaration in type class definit

231

229

232typeClassDictionaryDeclaration

230typeClassDictionaryDeclaration

233 :: ProperName 'ClassName

231 :: ProperName 'ClassName

234− -> [(String, Maybe Kind)]

232+ -> [(Text, Maybe Kind)]

235 -> [Constraint]

233 -> [Constraint]

236 -> [Declaration]

234 -> [Declaration]

237 -> Declaration

235 -> Declaration

@@ -247,7 +245,7 @@ typeClassDictionaryDeclaration name args implies members =

247typeClassMemberToDictionaryAccessor

245typeClassMemberToDictionaryAccessor

248 :: ModuleName

246 :: ModuleName

249 -> ProperName 'ClassName

247 -> ProperName 'ClassName

250− -> [(String, Maybe Kind)]

248+ -> [(Text, Maybe Kind)]

251 -> Declaration

249 -> Declaration

252 -> Declaration

250 -> Declaration

253typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

251typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

@@ -323,14 +321,14 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

323 return (PositionedValue pos com val)

321 return (PositionedValue pos com val)

324 memberToValue _ _ = internalError "Invalid declaration in type instance definition"

322 memberToValue _ _ = internalError "Invalid declaration in type instance definition"

325

323

326−typeClassMemberName :: Declaration -> String

324+typeClassMemberName :: Declaration -> Text

327typeClassMemberName (TypeDeclaration ident _) = runIdent ident

325typeClassMemberName (TypeDeclaration ident _) = runIdent ident

328typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

326typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

329typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

327typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

330typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"

328typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"

331

329

332−superClassDictionaryNames :: [Constraint] -> [String]

330+superClassDictionaryNames :: [Constraint] -> [Text]

333superClassDictionaryNames supers =

331superClassDictionaryNames supers =

334− [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)

332+ [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer))

335 | (index, Constraint pn _ _) <- zip [0..] supers

333 | (index, Constraint pn _ _) <- zip [0..] supers

336 ]

334 ]

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+8−10

@@ -1,6 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE PatternGuards #-}

3−

4-- |

1-- |

5-- This module implements the generic deriving elaboration that takes place during desugaring.

2-- This module implements the generic deriving elaboration that takes place during desugaring.

6--

3--

@@ -16,6 +13,7 @@ import Control.Monad.Supply.Class (MonadSupply)

16import Data.List (foldl', find, sortBy, unzip5)

13import Data.List (foldl', find, sortBy, unzip5)

17import Data.Maybe (fromMaybe)

14import Data.Maybe (fromMaybe)

18import Data.Ord (comparing)

15import Data.Ord (comparing)

16+import Data.Text (Text)

19

17

20import Language.PureScript.AST

18import Language.PureScript.AST

21import Language.PureScript.Crash

19import Language.PureScript.Crash

@@ -118,7 +116,7 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do

118 takeReverse :: Int -> [a] -> [a]

116 takeReverse :: Int -> [a] -> [a]

119 takeReverse n = take n . reverse

117 takeReverse n = take n . reverse

120

118

121− stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type

119+ stripRight :: [(Text, Maybe kind)] -> Type -> Maybe Type

122 stripRight [] ty = Just ty

120 stripRight [] ty = Just ty

123 stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))

121 stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))

124 | arg == arg' = stripRight args t

122 | arg == arg' = stripRight args t

@@ -285,14 +283,14 @@ deriveGeneric mn ds tyConNm dargs = do

285 (App e unitVal)

283 (App e unitVal)

286 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal)

284 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal)

287

285

288− mkRecCase :: [(String, Type)] -> CaseAlternative

286+ mkRecCase :: [(Text, Type)] -> CaseAlternative

289 mkRecCase rs =

287 mkRecCase rs =

290 CaseAlternative

288 CaseAlternative

291 [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

289 [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

292 . Right

290 . Right

293 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

291 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

294

292

295− mkRecFun :: [(String, Type)] -> Expr

293+ mkRecFun :: [(Text, Type)] -> Expr

296 mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs

294 mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs

297 where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

295 where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

298 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

296 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

@@ -576,13 +574,13 @@ deriveOrd mn ds tyConNm = do

576 where

574 where

577 catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ"))

575 catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ"))

578

576

579− orderingName :: String -> Qualified (ProperName a)

577+ orderingName :: Text -> Qualified (ProperName a)

580 orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName

578 orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName

581

579

582− orderingCtor :: String -> Expr

580+ orderingCtor :: Text -> Expr

583 orderingCtor = Constructor . orderingName

581 orderingCtor = Constructor . orderingName

584

582

585− orderingBinder :: String -> Binder

583+ orderingBinder :: Text -> Binder

586 orderingBinder name = ConstructorBinder (orderingName name) []

584 orderingBinder name = ConstructorBinder (orderingName name) []

587

585

588 ordCompare :: Expr -> Expr -> Expr

586 ordCompare :: Expr -> Expr -> Expr

@@ -700,7 +698,7 @@ objectType :: Type -> Maybe Type

700objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec

698objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec

701objectType _ = Nothing

699objectType _ = Nothing

702

700

703−decomposeRec :: Type -> [(String, Type)]

701+decomposeRec :: Type -> [(Text, Type)]

704decomposeRec = sortBy (comparing fst) . go

702decomposeRec = sortBy (comparing fst) . go

705 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

703 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

706 go _ = []

704 go _ = []

src/Language/PureScript/TypeChecker.hs+49−34

@@ -16,11 +16,16 @@ import Control.Monad.Error.Class (MonadError(..))

16import Control.Monad.State.Class (MonadState(..), modify)

17import Control.Monad.Supply.Class (MonadSupply)

18import Control.Monad.Writer.Class (MonadWriter(..))

19+import Control.Lens ((^..), _1, _2)

19

20

20import Data.Foldable (for_, traverse_)

21import Data.Foldable (for_, traverse_)

21import Data.List (nub, nubBy, (\\), sort, group)

22import Data.List (nub, nubBy, (\\), sort, group)

22import Data.Maybe

23import Data.Maybe

23import qualified Data.Map as M

24import qualified Data.Map as M

25+import qualified Data.Set as S

26+import Data.Monoid ((<>))

27+import qualified Data.Text as T

28+import Data.Text (Text)

24

29

25import Language.PureScript.AST

30import Language.PureScript.AST

26import Language.PureScript.Crash

31import Language.PureScript.Crash

@@ -42,7 +47,7 @@ addDataType

42 => ModuleName

47 => ModuleName

43 -> DataDeclType

48 -> DataDeclType

44 -> ProperName 'TypeName

49 -> ProperName 'TypeName

45− -> [(String, Maybe Kind)]

50+ -> [(Text, Maybe Kind)]

46 -> [(ProperName 'ConstructorName, [Type])]

51 -> [(ProperName 'ConstructorName, [Type])]

47 -> Kind

52 -> Kind

48 -> m ()

53 -> m ()

@@ -58,7 +63,7 @@ addDataConstructor

58 => ModuleName

63 => ModuleName

59 -> DataDeclType

64 -> DataDeclType

60 -> ProperName 'TypeName

65 -> ProperName 'TypeName

61− -> [String]

66+ -> [Text]

62 -> ProperName 'ConstructorName

67 -> ProperName 'ConstructorName

63 -> [Type]

68 -> [Type]

64 -> m ()

69 -> m ()

@@ -68,14 +73,14 @@ addDataConstructor moduleName dtype name args dctor tys = do

68 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

73 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

69 let dctorTy = foldr function retTy tys

74 let dctorTy = foldr function retTy tys

70 let polyType = mkForAll args dctorTy

75 let polyType = mkForAll args dctorTy

71− let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]

76+ let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]]

72 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

77 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

73

78

74addTypeSynonym

79addTypeSynonym

75 :: (MonadState CheckState m, MonadError MultipleErrors m)

80 :: (MonadState CheckState m, MonadError MultipleErrors m)

76 => ModuleName

81 => ModuleName

77 -> ProperName 'TypeName

82 -> ProperName 'TypeName

78− -> [(String, Maybe Kind)]

83+ -> [(Text, Maybe Kind)]

79 -> Type

84 -> Type

80 -> Kind

85 -> Kind

81 -> m ()

86 -> m ()

@@ -111,7 +116,7 @@ addTypeClass

111 :: (MonadState CheckState m)

116 :: (MonadState CheckState m)

112 => ModuleName

117 => ModuleName

113 -> ProperName 'ClassName

118 -> ProperName 'ClassName

114− -> [(String, Maybe Kind)]

119+ -> [(Text, Maybe Kind)]

115 -> [Constraint]

120 -> [Constraint]

116 -> [FunctionalDependency]

121 -> [FunctionalDependency]

117 -> [Declaration]

122 -> [Declaration]

@@ -120,12 +125,7 @@ addTypeClass moduleName pn args implies dependencies ds =

120 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }

125 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }

121 where

126 where

122 newClass :: TypeClassData

127 newClass :: TypeClassData

123− newClass =

128+ newClass = makeTypeClassData args (map toPair ds) implies dependencies

124− TypeClassData { typeClassArguments = args

125− , typeClassMembers = map toPair ds

126− , typeClassSuperclasses = implies

127− , typeClassDependencies = dependencies

128− }

129

130 toPair (TypeDeclaration ident ty) = (ident, ty)

131 toPair (PositionedDeclaration _ _ d) = toPair d

@@ -134,7 +134,7 @@ addTypeClass moduleName pn args implies dependencies ds =

134addTypeClassDictionaries

135 :: (MonadState CheckState m)

136 => Maybe ModuleName

137− -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

137+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)

138 -> m ()

139addTypeClassDictionaries mn entries =

140 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

@@ -142,27 +142,37 @@ addTypeClassDictionaries mn entries =

142

143checkDuplicateTypeArguments

144 :: (MonadState CheckState m, MonadError MultipleErrors m)

145− => [String]

145+ => [Text]

146 -> m ()

147checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

148 throwError . errorMessage $ DuplicateTypeArgument dup

149 where

150− firstDup :: Maybe String

150+ firstDup :: Maybe Text

151 firstDup = listToMaybe $ args \\ nub args

152

153checkTypeClassInstance

154− :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

154+ :: (MonadState CheckState m, MonadError MultipleErrors m)

155− => ModuleName

155+ => TypeClassData

156+ -> Int -- ^ index of type class argument

156 -> Type

157 -> Type

157 -> m ()

158 -> m ()

158−checkTypeClassInstance _ (TypeVar _) = return ()

159+checkTypeClassInstance cls i = check where

160+ -- If the argument is determined via fundeps then we are less restrictive in

161+ -- what type is allowed. This is because the type cannot be used to influence

162+ -- which instance is selected. Currently the only weakened restriction is that

163+ -- row types are allowed in determined type class arguments.

164+ isFunDepDetermined = S.member i (typeClassDeterminedArguments cls)

165+ check = \case

166+ TypeVar _ -> return ()

159−checkTypeClassInstance _ (TypeLevelString _) = return ()

167+ TypeLevelString _ -> return ()

160−checkTypeClassInstance _ (TypeConstructor ctor) = do

168+ TypeConstructor ctor -> do

161− env <- getEnv

169+ env <- getEnv

162− when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance

170+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance

163− return ()

171+ return ()

164−checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

172+ TypeApp t1 t2 -> check t1 >> check t2

173+ REmpty | isFunDepDetermined -> return ()

174+ RCons _ hd tl | isFunDepDetermined -> check hd >> check tl

165−checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

175+ ty -> throwError . errorMessage $ InvalidInstanceHead ty

166

176

167-- |

177-- |

168-- Check that type synonyms are fully-applied in a type

178-- Check that type synonyms are fully-applied in a type

@@ -205,9 +215,10 @@ typeCheckAll moduleName _ = traverse go

205 addDataType moduleName dtype name args' dctors ctorKind

215 addDataType moduleName dtype name args' dctors ctorKind

206 return $ DataDeclaration dtype name args dctors

216 return $ DataDeclaration dtype name args dctors

207 go (d@(DataBindingGroupDeclaration tys)) = do

217 go (d@(DataBindingGroupDeclaration tys)) = do

218+ let syns = mapMaybe toTypeSynonym tys

219+ dataDecls = mapMaybe toDataDecl tys

220+ bindingGroupNames = nub ((syns^..traverse._1) ++ (dataDecls^..traverse._2))

208− warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

221+ warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do

209− let syns = mapMaybe toTypeSynonym tys

210− let dataDecls = mapMaybe toDataDecl tys

211 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

222 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

212 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do

223 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do

213 when (dtype == Newtype) $ checkNewtype name dctors

224 when (dtype == Newtype) $ checkNewtype name dctors

@@ -278,12 +289,16 @@ typeCheckAll moduleName _ = traverse go

278 addTypeClass moduleName pn args implies deps tys

289 addTypeClass moduleName pn args implies deps tys

279 return d

290 return d

280 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

291 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

292+ env <- getEnv

293+ case M.lookup className (typeClasses env) of

294+ Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"

295+ Just typeClass -> do

281− traverse_ (checkTypeClassInstance moduleName) tys

296+ sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

282− checkOrphanInstance dictName className tys

297+ checkOrphanInstance dictName className tys

283− _ <- traverseTypeInstanceBody checkInstanceMembers body

298+ _ <- traverseTypeInstanceBody checkInstanceMembers body

284− let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

299+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

285− addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict

300+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict

286− return d

301+ return d

287 go (PositionedDeclaration pos com d) =

302 go (PositionedDeclaration pos com d) =

288 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

303 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

289

304

@@ -323,7 +338,7 @@ typeCheckAll moduleName _ = traverse go

323 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

338 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

324 -- extracted from the kind of the type constructor itself.

339 -- extracted from the kind of the type constructor itself.

325 --

340 --

326− withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]

341+ withKinds :: [(Text, Maybe Kind)] -> Kind -> [(Text, Maybe Kind)]

327 withKinds [] _ = []

342 withKinds [] _ = []

328 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

343 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

329 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

344 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

src/Language/PureScript/TypeChecker/Entailment.hs+46−27

@@ -19,12 +19,14 @@ import Control.Monad.State

19import Control.Monad.Supply.Class (MonadSupply(..))

20import Control.Monad.Writer

21

22−import Data.Foldable (for_)

22+import Data.Foldable (for_, fold, toList)

23import Data.Function (on)

24import Data.List (minimumBy, nub)

25import Data.Maybe (fromMaybe, maybeToList, mapMaybe)

26import qualified Data.Map as M

27import qualified Data.Set as S

28+import qualified Data.Text as T

29+import Data.Text (Text)

28

30

29import Language.PureScript.AST

31import Language.PureScript.AST

30import Language.PureScript.Crash

32import Language.PureScript.Crash

@@ -37,17 +39,32 @@ import Language.PureScript.TypeClassDictionaries

37import Language.PureScript.Types

39import Language.PureScript.Types

38import qualified Language.PureScript.Constants as C

40import qualified Language.PureScript.Constants as C

39

41

42+-- | Describes what sort of dictionary to generate for type class instances

43+data Evidence

44+ = NamedInstance (Qualified Ident)

45+ -- ^ An existing named instance

46+ | IsSymbolInstance Text

47+ -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

48+ deriving (Eq)

49+

50+-- | Extract the identifier of a named instance

51+namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident)

52+namedInstanceIdentifier (NamedInstance i) = Just i

53+namedInstanceIdentifier _ = Nothing

54+

55+-- | Description of a type class dictionary with instance evidence

56+type TypeClassDict = TypeClassDictionaryInScope Evidence

57+

40-- | The 'InstanceContext' tracks those constraints which can be satisfied.

58-- | The 'InstanceContext' tracks those constraints which can be satisfied.

41type InstanceContext = M.Map (Maybe ModuleName)

59type InstanceContext = M.Map (Maybe ModuleName)

42 (M.Map (Qualified (ProperName 'ClassName))

60 (M.Map (Qualified (ProperName 'ClassName))

43− (M.Map (Qualified Ident)

61+ (M.Map (Qualified Ident) NamedDict))

44− TypeClassDictionaryInScope))

45

62

46-- | A type substitution which makes an instance head match a list of types.

63-- | A type substitution which makes an instance head match a list of types.

47--

64--

48-- Note: we store many types per type variable name. For any name, all types

65-- Note: we store many types per type variable name. For any name, all types

49-- should unify if we are going to commit to an instance.

66-- should unify if we are going to commit to an instance.

50−type Matching a = M.Map String a

67+type Matching a = M.Map Text a

51

68

52combineContexts :: InstanceContext -> InstanceContext -> InstanceContext

69combineContexts :: InstanceContext -> InstanceContext -> InstanceContext

53combineContexts = M.unionWith (M.unionWith M.union)

70combineContexts = M.unionWith (M.unionWith M.union)

@@ -88,7 +105,7 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d

88

105

89-- | Three options for how we can handle a constraint, depending on the mode we're in.

106-- | Three options for how we can handle a constraint, depending on the mode we're in.

90data EntailsResult a

107data EntailsResult a

91− = Solved a TypeClassDictionaryInScope

108+ = Solved a TypeClassDict

92 -- ^ We solved this constraint

109 -- ^ We solved this constraint

93 | Unsolved Constraint

110 | Unsolved Constraint

94 -- ^ We couldn't solve this constraint right now, it will be generalized

111 -- ^ We couldn't solve this constraint right now, it will be generalized

@@ -120,7 +137,8 @@ entails

120entails SolverOptions{..} constraint context hints =

137entails SolverOptions{..} constraint context hints =

121 solve constraint

138 solve constraint

122 where

139 where

123− forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

140+ forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

141+ forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

124 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))

142 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))

125 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

143 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

126

144

@@ -130,8 +148,8 @@ entails SolverOptions{..} constraint context hints =

130 ctorModules (TypeApp ty _) = ctorModules ty

148 ctorModules (TypeApp ty _) = ctorModules ty

131 ctorModules _ = Nothing

149 ctorModules _ = Nothing

132

150

133− findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

151+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]

134− findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

152+ findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

135

153

136 valUndefined :: Expr

154 valUndefined :: Expr

137 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

155 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

@@ -181,12 +199,12 @@ entails SolverOptions{..} constraint context hints =

181 -- Solve any necessary subgoals

199 -- Solve any necessary subgoals

182 args <- solveSubgoals subst'' (tcdDependencies tcd)

200 args <- solveSubgoals subst'' (tcdDependencies tcd)

183 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

201 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

184− (mkDictionary (tcdName tcd) args)

202+ (mkDictionary (tcdValue tcd) args)

185 (tcdPath tcd)

203 (tcdPath tcd)

186 return match

204 return match

187 Unsolved unsolved -> do

205 Unsolved unsolved -> do

188 -- Generate a fresh name for the unsolved constraint's new dictionary

206 -- Generate a fresh name for the unsolved constraint's new dictionary

189− ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved)))

207+ ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved)))

190 let qident = Qualified Nothing ident

208 let qident = Qualified Nothing ident

191 -- Store the new dictionary in the InstanceContext so that we can solve this goal in

209 -- Store the new dictionary in the InstanceContext so that we can solve this goal in

192 -- future.

210 -- future.

@@ -213,7 +231,7 @@ entails SolverOptions{..} constraint context hints =

213 -- fresh type variables. This function extends a substitution with fresh type variables

231 -- fresh type variables. This function extends a substitution with fresh type variables

214 -- as necessary, based on the types in the instance head.

232 -- as necessary, based on the types in the instance head.

215 withFreshTypes

233 withFreshTypes

216− :: TypeClassDictionaryInScope

234+ :: TypeClassDict

217 -> Matching Type

235 -> Matching Type

218 -> m (Matching Type)

236 -> m (Matching Type)

219 withFreshTypes TypeClassDictionaryInScope{..} subst = do

237 withFreshTypes TypeClassDictionaryInScope{..} subst = do

@@ -232,7 +250,7 @@ entails SolverOptions{..} constraint context hints =

232 t <- freshType

250 t <- freshType

233 return (s, t)

251 return (s, t)

234

252

235− unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

253+ unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a)

236 unique tyArgs []

254 unique tyArgs []

237 | solverDeferErrors = return Deferred

255 | solverDeferErrors = return Deferred

238 -- We need a special case for nullary type classes, since we want

256 -- We need a special case for nullary type classes, since we want

@@ -242,7 +260,7 @@ entails SolverOptions{..} constraint context hints =

242 unique _ [(a, dict)] = return $ Solved a dict

260 unique _ [(a, dict)] = return $ Solved a dict

243 unique tyArgs tcds

261 unique tyArgs tcds

244 | pairwiseAny overlapping (map snd tcds) = do

262 | pairwiseAny overlapping (map snd tcds) = do

245− tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds)

263+ tell . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd))

246 return $ uncurry Solved (head tcds)

264 return $ uncurry Solved (head tcds)

247 | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)

265 | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)

248

266

@@ -255,12 +273,12 @@ entails SolverOptions{..} constraint context hints =

255 --

273 --

256 -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have

274 -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have

257 -- been caught when constructing superclass dictionaries.

275 -- been caught when constructing superclass dictionaries.

258− overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool

276+ overlapping :: TypeClassDict -> TypeClassDict -> Bool

259 overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False

277 overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False

260 overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False

278 overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False

261 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

279 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

262 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

280 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

263− overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2

281+ overlapping tcd1 tcd2 = tcdValue tcd1 /= tcdValue tcd2

264

282

265 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

283 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

266 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

284 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

@@ -271,22 +289,23 @@ entails SolverOptions{..} constraint context hints =

271 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

289 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

272

290

273 -- Make a dictionary from subgoal dictionaries by applying the correct function

291 -- Make a dictionary from subgoal dictionaries by applying the correct function

274− mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr

292+ mkDictionary :: Evidence -> Maybe [Expr] -> Expr

275− mkDictionary fnName Nothing = Var fnName

293+ mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

276− mkDictionary fnName (Just []) = Var fnName

294+ mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where

277− mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts

295+ fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))

296+ ]

278

297

279 -- Turn a DictionaryValue into a Expr

298 -- Turn a DictionaryValue into a Expr

280 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

299 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

281 subclassDictionaryValue dict superclassName index =

300 subclassDictionaryValue dict superclassName index =

282− App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)

301+ App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))

283 dict)

302 dict)

284 valUndefined

303 valUndefined

285

304

286-- Check if an instance matches our list of types, allowing for types

305-- Check if an instance matches our list of types, allowing for types

287-- to be solved via functional dependencies. If the types match, we return a

306-- to be solved via functional dependencies. If the types match, we return a

288-- substitution which makes them match. If not, we return 'Nothing'.

307-- substitution which makes them match. If not, we return 'Nothing'.

289−matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type])

308+matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Maybe (Matching [Type])

290matches deps TypeClassDictionaryInScope{..} tys = do

309matches deps TypeClassDictionaryInScope{..} tys = do

291 -- First, find those types which match exactly

310 -- First, find those types which match exactly

292 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

311 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

@@ -345,7 +364,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

345 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

364 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

346 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

365 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

347

366

348− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type])

367+ go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])

349 go [] REmpty [] REmpty = (True, M.empty)

368 go [] REmpty [] REmpty = (True, M.empty)

350 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)

369 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)

351 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)

370 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)

@@ -383,7 +402,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

383 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

402 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

384 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

403 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

385 where

404 where

386− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

405+ go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool

387 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

406 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

388 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

407 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

389 go [] REmpty [] REmpty = True

408 go [] REmpty [] REmpty = True

@@ -402,7 +421,7 @@ newDictionaries

402 => [(Qualified (ProperName 'ClassName), Integer)]

421 => [(Qualified (ProperName 'ClassName), Integer)]

403 -> Qualified Ident

422 -> Qualified Ident

404 -> Constraint

423 -> Constraint

405− -> m [TypeClassDictionaryInScope]

424+ -> m [NamedDict]

406newDictionaries path name (Constraint className instanceTy _) = do

425newDictionaries path name (Constraint className instanceTy _) = do

407 tcs <- gets (typeClasses . checkEnv)

426 tcs <- gets (typeClasses . checkEnv)

408 let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

427 let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

@@ -413,12 +432,12 @@ newDictionaries path name (Constraint className instanceTy _) = do

413 ) typeClassSuperclasses [0..]

432 ) typeClassSuperclasses [0..]

414 return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)

433 return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)

415 where

434 where

416− instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

435+ instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type]

417 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

436 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

418

437

419−mkContext :: [TypeClassDictionaryInScope] -> InstanceContext

438+mkContext :: [NamedDict] -> InstanceContext

420mkContext = foldr combineContexts M.empty . map fromDict where

439mkContext = foldr combineContexts M.empty . map fromDict where

421− fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d))

440+ fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d))

422

441

423-- | Check all pairs of values in a list match a predicate

442-- | Check all pairs of values in a list match a predicate

424pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool

443pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool

src/Language/PureScript/TypeChecker/Kinds.hs+8−7

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

18import Control.Monad.State

19

20import qualified Data.Map as M

21+import Data.Text (Text)

21

22

22import Language.PureScript.Crash

23import Language.PureScript.Crash

23import Language.PureScript.Environment

24import Language.PureScript.Environment

@@ -104,7 +105,7 @@ kindOf ty = fst <$> kindOfWithScopedVars ty

104kindOfWithScopedVars ::

105kindOfWithScopedVars ::

105 (MonadError MultipleErrors m, MonadState CheckState m) =>

106 (MonadError MultipleErrors m, MonadState CheckState m) =>

106 Type ->

107 Type ->

107− m (Kind, [(String, Kind)])

108+ m (Kind, [(Text, Kind)])

108kindOfWithScopedVars ty =

109kindOfWithScopedVars ty =

109 withErrorMessageHint (ErrorCheckingKind ty) $

110 withErrorMessageHint (ErrorCheckingKind ty) $

110 fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty

111 fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty

@@ -119,7 +120,7 @@ kindsOf

119 => Bool

120 => Bool

120 -> ModuleName

121 -> ModuleName

121 -> ProperName 'TypeName

122 -> ProperName 'TypeName

122− -> [(String, Maybe Kind)]

123+ -> [(Text, Maybe Kind)]

123 -> [Type]

124 -> [Type]

124 -> m Kind

125 -> m Kind

125kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

126kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

@@ -134,7 +135,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . c

134

135

135freshKindVar

136freshKindVar

136 :: (MonadError MultipleErrors m, MonadState CheckState m)

137 :: (MonadError MultipleErrors m, MonadState CheckState m)

137− => (String, Maybe Kind)

138+ => (Text, Maybe Kind)

138 -> Kind

139 -> Kind

139 -> m (ProperName 'TypeName, Kind)

140 -> m (ProperName 'TypeName, Kind)

140freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

141freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

@@ -146,8 +147,8 @@ freshKindVar (arg, Just kind') kind = do

146kindsOfAll

147kindsOfAll

147 :: (MonadError MultipleErrors m, MonadState CheckState m)

148 :: (MonadError MultipleErrors m, MonadState CheckState m)

148 => ModuleName

149 => ModuleName

149− -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

150+ -> [(ProperName 'TypeName, [(Text, Maybe Kind)], Type)]

150− -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

151+ -> [(ProperName 'TypeName, [(Text, Maybe Kind)], [Type])]

151 -> m ([Kind], [Kind])

152 -> m ([Kind], [Kind])

152kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

153kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

153 synVars <- replicateM (length syns) freshKind

154 synVars <- replicateM (length syns) freshKind

@@ -198,14 +199,14 @@ starIfUnknown k = k

198infer

199infer

199 :: (MonadError MultipleErrors m, MonadState CheckState m)

200 :: (MonadError MultipleErrors m, MonadState CheckState m)

200 => Type

201 => Type

201− -> m (Kind, [(String, Kind)])

202+ -> m (Kind, [(Text, Kind)])

202infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty

203infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty

203

204

204infer'

205infer'

205 :: forall m

206 :: forall m

206 . (MonadError MultipleErrors m, MonadState CheckState m)

207 . (MonadError MultipleErrors m, MonadState CheckState m)

207 => Type

208 => Type

208− -> m (Kind, [(String, Kind)])

209+ -> m (Kind, [(Text, Kind)])

209infer' (ForAll ident ty _) = do

210infer' (ForAll ident ty _) = do

210 k1 <- freshKind

211 k1 <- freshKind

211 Just moduleName <- checkCurrentModule <$> get

212 Just moduleName <- checkCurrentModule <$> get

src/Language/PureScript/TypeChecker/Monad.hs+6−5

@@ -15,6 +15,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor)

15

16import Data.Maybe

17import qualified Data.Map as M

18+import Data.Text (Text)

18

19

19import Language.PureScript.Environment

20import Language.PureScript.Environment

20import Language.PureScript.Errors

21import Language.PureScript.Errors

@@ -93,7 +94,7 @@ bindTypes newNames action = do

93withScopedTypeVars

94withScopedTypeVars

94 :: (MonadState CheckState m, MonadWriter MultipleErrors m)

95 :: (MonadState CheckState m, MonadWriter MultipleErrors m)

95 => ModuleName

96 => ModuleName

96− -> [(String, Kind)]

97+ -> [(Text, Kind)]

97 -> m a

98 -> m a

99 -> m a

99withScopedTypeVars mn ks ma = do

100withScopedTypeVars mn ks ma = do

@@ -133,12 +134,12 @@ warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition

133-- | Temporarily make a collection of type class dictionaries available

134-- | Temporarily make a collection of type class dictionaries available

134withTypeClassDictionaries

135withTypeClassDictionaries

135 :: MonadState CheckState m

136 :: MonadState CheckState m

136− => [TypeClassDictionaryInScope]

137+ => [NamedDict]

137 -> m a

138 -> m a

139 -> m a

139withTypeClassDictionaries entries action = do

140withTypeClassDictionaries entries action = do

140 orig <- get

141 orig <- get

141− let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

142+ let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdValue entry) entry)) | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } <- entries ]

142 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

143 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

143 a <- action

144 a <- action

144 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

145 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

@@ -147,14 +148,14 @@ withTypeClassDictionaries entries action = do

147-- | Get the currently available map of type class dictionaries

148-- | Get the currently available map of type class dictionaries

148getTypeClassDictionaries

149getTypeClassDictionaries

149 :: (MonadState CheckState m)

150 :: (MonadState CheckState m)

150− => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

151+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))

151getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

152getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

152

153

153-- | Lookup type class dictionaries in a module.

154-- | Lookup type class dictionaries in a module.

154lookupTypeClassDictionaries

155lookupTypeClassDictionaries

155 :: (MonadState CheckState m)

156 :: (MonadState CheckState m)

156 => Maybe ModuleName

157 => Maybe ModuleName

157− -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

158+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))

158lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

159lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

159

160

160-- | Temporarily bind a collection of names to local variables

161-- | Temporarily bind a collection of names to local variables

src/Language/PureScript/TypeChecker/Skolems.hs+6−5

@@ -18,6 +18,7 @@ import Control.Monad.State.Class (MonadState(..), gets, modify)

18import Data.Functor.Identity (Identity(), runIdentity)

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

20import Data.Monoid

21+import Data.Text (Text)

21

22

22import Language.PureScript.AST

23import Language.PureScript.AST

23import Language.PureScript.Crash

24import Language.PureScript.Crash

@@ -56,7 +57,7 @@ newSkolemScope = do

56-- |

57-- |

57-- Skolemize a type variable by replacing its instances with fresh skolem constants

58-- Skolemize a type variable by replacing its instances with fresh skolem constants

58--

59--

59−skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type

60+skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type

60skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

61skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

61

62

62-- |

63-- |

@@ -64,25 +65,25 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

64-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the

65-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the

65-- only example of scoped type variables.

66-- only example of scoped type variables.

66--

67--

67−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

68+skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

68skolemizeTypesInValue ident sko scope ss =

69skolemizeTypesInValue ident sko scope ss =

69 let

70 let

70 (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS

71 (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS

71 in runIdentity . f

72 in runIdentity . f

72 where

73 where

73− onExpr :: [String] -> Expr -> Identity ([String], Expr)

74+ onExpr :: [Text] -> Expr -> Identity ([Text], Expr)

74 onExpr sco (DeferredDictionary c ts)

75 onExpr sco (DeferredDictionary c ts)

75 | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))

76 | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))

76 onExpr sco (TypedValue check val ty)

77 onExpr sco (TypedValue check val ty)

77 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))

78 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))

78 onExpr sco other = return (sco, other)

79 onExpr sco other = return (sco, other)

79

80

80− onBinder :: [String] -> Binder -> Identity ([String], Binder)

81+ onBinder :: [Text] -> Binder -> Identity ([Text], Binder)

81 onBinder sco (TypedBinder ty b)

82 onBinder sco (TypedBinder ty b)

82 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)

83 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)

83 onBinder sco other = return (sco, other)

84 onBinder sco other = return (sco, other)

84

85

85− peelTypeVars :: Type -> [String]

86+ peelTypeVars :: Type -> [Text]

86 peelTypeVars (ForAll i ty _) = i : peelTypeVars ty

87 peelTypeVars (ForAll i ty _) = i : peelTypeVars ty

87 peelTypeVars _ = []

88 peelTypeVars _ = []

88

89

src/Language/PureScript/TypeChecker/Subsumption.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

1{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

4

3

src/Language/PureScript/TypeChecker/TypeSearch.hs−4

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

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−

5module Language.PureScript.TypeChecker.TypeSearch

1module Language.PureScript.TypeChecker.TypeSearch

6 ( typeSearch

2 ( typeSearch

7 ) where

3 ) where

src/Language/PureScript/TypeChecker/Types.hs+7−7

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE NamedFieldPuns #-}

1{-# LANGUAGE NamedFieldPuns #-}

4

2

5-- |

3-- |

@@ -40,8 +38,10 @@ import Data.Either (lefts, rights)

40import Data.Functor (($>))

38import Data.Functor (($>))

41import Data.List (transpose, nub, (\\), partition, delete)

39import Data.List (transpose, nub, (\\), partition, delete)

42import Data.Maybe (fromMaybe)

40import Data.Maybe (fromMaybe)

41+import Data.Monoid ((<>))

43import qualified Data.Map as M

42import qualified Data.Map as M

44import qualified Data.Set as S

43import qualified Data.Set as S

44+import Data.Text (Text)

45

46import Language.PureScript.AST

47import Language.PureScript.Crash

@@ -442,7 +442,7 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do

442 unifyTypes val (TypeApp tyRecord row)

443 return m1

444 where

445− inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type)

445+ inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)

446 inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty

447 inferRowProperties nrow row ((name, binder):binders) = do

448 propTy <- freshType

@@ -559,7 +559,7 @@ check' val (ForAll ident ty _) = do

559 return $ TypedValue True val' (ForAll ident ty (Just scope))

560check' val t@(ConstrainedType constraints ty) = do

561 dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) ->

562− freshIdent ("dict" ++ className)

562+ freshIdent ("dict" <> className)

563 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

564 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

565 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

@@ -681,10 +681,10 @@ check' val ty = do

681checkProperties ::

682 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

683 Expr ->

684− [(String, Expr)] ->

684+ [(Text, Expr)] ->

685 Type ->

686 Bool ->

687− m [(String, Expr)]

687+ m [(Text, Expr)]

688checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where

689 go [] [] REmpty = return []

690 go [] [] u@(TUnknown _)

@@ -771,7 +771,7 @@ checkFunctionApplication' fn u arg = do

771-- |

772-- Ensure a set of property names and value does not contain duplicate labels

773--

774−ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()

774+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m ()

775ensureNoDuplicateProperties ps =

776 let ls = map fst ps in

777 case ls \\ nub ls of

src/Language/PureScript/TypeChecker/Unify.hs+5−3

@@ -24,6 +24,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))

24

25import Data.List (nub, sort)

26import qualified Data.Map as M

27+import Data.Text (Text)

28+import qualified Data.Text as T

27

29

28import Language.PureScript.Crash

30import Language.PureScript.Crash

29import Language.PureScript.Errors

31import Language.PureScript.Errors

@@ -137,7 +139,7 @@ unifyRows r1 r2 =

137 forM_ int (uncurry unifyTypes)

139 forM_ int (uncurry unifyTypes)

138 unifyRows' sd1 r1' sd2 r2'

140 unifyRows' sd1 r1' sd2 r2'

139 where

141 where

140− unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m ()

142+ unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m ()

141 unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r))

143 unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r))

142 unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r))

144 unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r))

143 unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do

145 unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do

@@ -155,7 +157,7 @@ unifyRows r1 r2 =

155-- |

157-- |

156-- Replace a single type variable with a new unification variable

158-- Replace a single type variable with a new unification variable

157--

159--

158−replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type

160+replaceVarWithUnknown :: (MonadState CheckState m) => Text -> Type -> m Type

159replaceVarWithUnknown ident ty = do

161replaceVarWithUnknown ident ty = do

160 tu <- freshType

162 tu <- freshType

161 return $ replaceTypeVars ident tu ty

163 return $ replaceTypeVars ident tu ty

@@ -179,7 +181,7 @@ replaceTypeWildcards = everywhereOnTypesM replace

179varIfUnknown :: Type -> Type

181varIfUnknown :: Type -> Type

180varIfUnknown ty =

182varIfUnknown ty =

181 let unks = nub $ unknownsInType ty

183 let unks = nub $ unknownsInType ty

182− toName = (:) 't' . show

184+ toName = T.cons 't' . T.pack . show

183 ty' = everywhereOnTypes typeToVar ty

185 ty' = everywhereOnTypes typeToVar ty

184 typeToVar :: Type -> Type

186 typeToVar :: Type -> Type

185 typeToVar (TUnknown u) = TypeVar (toName u)

187 typeToVar (TUnknown u) = TypeVar (toName u)

src/Language/PureScript/TypeClassDictionaries.hs+9−4

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

1+{-# LANGUAGE DeriveFoldable #-}

2+{-# LANGUAGE DeriveTraversable #-}

1module Language.PureScript.TypeClassDictionaries where

3module Language.PureScript.TypeClassDictionaries where

2

4

3import Prelude.Compat

5import Prelude.Compat

@@ -8,10 +10,10 @@ import Language.PureScript.Types

8-- |

10-- |

9-- Data representing a type class dictionary which is in scope

11-- Data representing a type class dictionary which is in scope

10--

12--

11−data TypeClassDictionaryInScope

13+data TypeClassDictionaryInScope v

12 = TypeClassDictionaryInScope {

14 = TypeClassDictionaryInScope {

13− -- | The identifier with which the dictionary can be accessed at runtime

15+ -- | The value with which the dictionary can be accessed at runtime

14− tcdName :: Qualified Ident

16+ tcdValue :: v

15 -- | How to obtain this instance via superclass relationships

17 -- | How to obtain this instance via superclass relationships

16 , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

18 , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

17 -- | The name of the type class to which this type class instance applies

19 -- | The name of the type class to which this type class instance applies

@@ -21,4 +23,7 @@ data TypeClassDictionaryInScope

21 -- | Type class dependencies which must be satisfied to construct this dictionary

23 -- | Type class dependencies which must be satisfied to construct this dictionary

22 , tcdDependencies :: Maybe [Constraint]

24 , tcdDependencies :: Maybe [Constraint]

23 }

25 }

24− deriving (Show)

26+ deriving (Show, Functor, Foldable, Traversable)

27+

28+type NamedDict = TypeClassDictionaryInScope (Qualified Ident)

29+

src/Language/PureScript/Types.hs+43−41

@@ -9,11 +9,13 @@ module Language.PureScript.Types where

9import Prelude.Compat

10

11import Control.Monad ((<=<))

12−

13−import Data.List (nub)

14−import Data.Maybe (fromMaybe)

15import qualified Data.Aeson as A

12import qualified Data.Aeson as A

16import qualified Data.Aeson.TH as A

13import qualified Data.Aeson.TH as A

14+import Data.List (nub)

15+import Data.Maybe (fromMaybe)

16+import Data.Monoid ((<>))

17+import Data.Text (Text)

18+import qualified Data.Text as T

17

19

18import Language.PureScript.AST.SourcePos

20import Language.PureScript.AST.SourcePos

19import Language.PureScript.Kinds

21import Language.PureScript.Kinds

@@ -32,9 +34,9 @@ data Type

32 -- | A unification variable of type Type

34 -- | A unification variable of type Type

33 = TUnknown Int

35 = TUnknown Int

34 -- | A named type variable

36 -- | A named type variable

35− | TypeVar String

37+ | TypeVar Text

36 -- | A type-level string

38 -- | A type-level string

37− | TypeLevelString String

39+ | TypeLevelString Text

38 -- | A type wildcard, as would appear in a partial type synonym

40 -- | A type wildcard, as would appear in a partial type synonym

39 | TypeWildcard SourceSpan

41 | TypeWildcard SourceSpan

40 -- | A type constructor

42 -- | A type constructor

@@ -45,15 +47,15 @@ data Type

45 -- | A type application

47 -- | A type application

46 | TypeApp Type Type

48 | TypeApp Type Type

47 -- | Forall quantifier

49 -- | Forall quantifier

48− | ForAll String Type (Maybe SkolemScope)

50+ | ForAll Text Type (Maybe SkolemScope)

49 -- | A type with a set of type class constraints

51 -- | A type with a set of type class constraints

50 | ConstrainedType [Constraint] Type

52 | ConstrainedType [Constraint] Type

51 -- | A skolem constant

53 -- | A skolem constant

52− | Skolem String Int SkolemScope (Maybe SourceSpan)

54+ | Skolem Text Int SkolemScope (Maybe SourceSpan)

53 -- | An empty row

55 -- | An empty row

54 | REmpty

56 | REmpty

55 -- | A non-empty row

57 -- | A non-empty row

56− | RCons String Type Type

58+ | RCons Text Type Type

57 -- | A type with a kind annotation

59 -- | A type with a kind annotation

58 | KindedType Type Kind

60 | KindedType Type Kind

59 -- | A placeholder used in pretty printing

61 -- | A placeholder used in pretty printing

@@ -61,7 +63,7 @@ data Type

61 -- | A placeholder used in pretty printing

63 -- | A placeholder used in pretty printing

62 | PrettyPrintObject Type

64 | PrettyPrintObject Type

63 -- | A placeholder used in pretty printing

65 -- | A placeholder used in pretty printing

64− | PrettyPrintForAll [String] Type

66+ | PrettyPrintForAll [Text] Type

65 -- | Binary operator application. During the rebracketing phase of desugaring,

67 -- | Binary operator application. During the rebracketing phase of desugaring,

66 -- this data constructor will be removed.

68 -- this data constructor will be removed.

67 | BinaryNoParensType Type Type Type

69 | BinaryNoParensType Type Type Type

@@ -75,7 +77,7 @@ data Type

75

77

76-- | Additional data relevant to type class constraints

78-- | Additional data relevant to type class constraints

77data ConstraintData

79data ConstraintData

78− = PartialConstraintData [[String]] Bool

80+ = PartialConstraintData [[Text]] Bool

79 -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.

81 -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.

80 -- It contains (rendered) binder information for those binders which were

82 -- It contains (rendered) binder information for those binders which were

81 -- not matched, and a flag indicating whether the list was truncated or not.

83 -- not matched, and a flag indicating whether the list was truncated or not.

@@ -106,7 +108,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData)

106-- |

108-- |

107-- Convert a row to a list of pairs of labels and types

109-- Convert a row to a list of pairs of labels and types

108--

110--

109−rowToList :: Type -> ([(String, Type)], Type)

111+rowToList :: Type -> ([(Text, Type)], Type)

110rowToList (RCons name ty row) = let (tys, rest) = rowToList row

112rowToList (RCons name ty row) = let (tys, rest) = rowToList row

111 in ((name, ty):tys, rest)

113 in ((name, ty):tys, rest)

112rowToList r = ([], r)

114rowToList r = ([], r)

@@ -114,7 +116,7 @@ rowToList r = ([], r)

114-- |

116-- |

115-- Convert a list of labels and types to a row

117-- Convert a list of labels and types to a row

116--

118--

117−rowFromList :: ([(String, Type)], Type) -> Type

119+rowFromList :: ([(Text, Type)], Type) -> Type

118rowFromList ([], r) = r

120rowFromList ([], r) = r

119rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

121rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

120

122

@@ -128,23 +130,23 @@ isMonoType _ = True

128-- |

130-- |

129-- Universally quantify a type

131-- Universally quantify a type

130--

132--

131−mkForAll :: [String] -> Type -> Type

133+mkForAll :: [Text] -> Type -> Type

132mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

134mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

133

135

134-- |

136-- |

135-- Replace a type variable, taking into account variable shadowing

137-- Replace a type variable, taking into account variable shadowing

136--

138--

137−replaceTypeVars :: String -> Type -> Type -> Type

139+replaceTypeVars :: Text -> Type -> Type -> Type

138replaceTypeVars v r = replaceAllTypeVars [(v, r)]

140replaceTypeVars v r = replaceAllTypeVars [(v, r)]

139

141

140-- |

142-- |

141-- Replace named type variables with types

143-- Replace named type variables with types

142--

144--

143−replaceAllTypeVars :: [(String, Type)] -> Type -> Type

145+replaceAllTypeVars :: [(Text, Type)] -> Type -> Type

144replaceAllTypeVars = go []

146replaceAllTypeVars = go []

145 where

147 where

146

148

147− go :: [String] -> [(String, Type)] -> Type -> Type

149+ go :: [Text] -> [(Text, Type)] -> Type -> Type

148 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)

150 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)

149 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)

151 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)

150 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f

152 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f

@@ -163,16 +165,16 @@ replaceAllTypeVars = go []

163 go bs m (ParensInType t) = ParensInType (go bs m t)

165 go bs m (ParensInType t) = ParensInType (go bs m t)

164 go _ _ ty = ty

166 go _ _ ty = ty

165

167

166− genName orig inUse = try 0

168+ genName orig inUse = try' 0

167 where

169 where

168− try :: Integer -> String

170+ try' :: Integer -> Text

169− try n | (orig ++ show n) `elem` inUse = try (n + 1)

171+ try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1)

170− | otherwise = orig ++ show n

172+ | otherwise = orig <> T.pack (show n)

171

173

172-- |

174-- |

173-- Collect all type variables appearing in a type

175-- Collect all type variables appearing in a type

174--

176--

175−usedTypeVariables :: Type -> [String]

177+usedTypeVariables :: Type -> [Text]

176usedTypeVariables = nub . everythingOnTypes (++) go

178usedTypeVariables = nub . everythingOnTypes (++) go

177 where

179 where

178 go (TypeVar v) = [v]

180 go (TypeVar v) = [v]

@@ -181,10 +183,10 @@ usedTypeVariables = nub . everythingOnTypes (++) go

181-- |

183-- |

182-- Collect all free type variables appearing in a type

184-- Collect all free type variables appearing in a type

183--

185--

184−freeTypeVariables :: Type -> [String]

186+freeTypeVariables :: Type -> [Text]

185freeTypeVariables = nub . go []

187freeTypeVariables = nub . go []

186 where

188 where

187− go :: [String] -> Type -> [String]

189+ go :: [Text] -> Type -> [Text]

188 go bound (TypeVar v) | v `notElem` bound = [v]

190 go bound (TypeVar v) | v `notElem` bound = [v]

189 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

191 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

190 go bound (ForAll v t _) = go (v : bound) t

192 go bound (ForAll v t _) = go (v : bound) t

@@ -292,32 +294,32 @@ everywhereOnTypesTopDownM f = go <=< f

292 go other = f other

294 go other = f other

293

295

294everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

296everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

295−everythingOnTypes (<>) f = go

297+everythingOnTypes (<+>) f = go

296 where

298 where

297− go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

299+ go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2

298− go t@(ForAll _ ty _) = f t <> go ty

300+ go t@(ForAll _ ty _) = f t <+> go ty

299− go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty

301+ go t@(ConstrainedType cs ty) = foldl (<+>) (f t) (map go $ concatMap constraintArgs cs) <+> go ty

300− go t@(RCons _ ty rest) = f t <> go ty <> go rest

302+ go t@(RCons _ ty rest) = f t <+> go ty <+> go rest

301− go t@(KindedType ty _) = f t <> go ty

303+ go t@(KindedType ty _) = f t <+> go ty

302− go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

304+ go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2

303− go t@(PrettyPrintObject t1) = f t <> go t1

305+ go t@(PrettyPrintObject t1) = f t <+> go t1

304− go t@(PrettyPrintForAll _ t1) = f t <> go t1

306+ go t@(PrettyPrintForAll _ t1) = f t <+> go t1

305− go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3

307+ go t@(BinaryNoParensType t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3

306− go t@(ParensInType t1) = f t <> go t1

308+ go t@(ParensInType t1) = f t <+> go t1

307 go other = f other

309 go other = f other

308

310

309everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r

311everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r

310−everythingWithContextOnTypes s0 r0 (<>) f = go' s0

312+everythingWithContextOnTypes s0 r0 (<+>) f = go' s0

311 where

313 where

312− go' s t = let (s', r) = f s t in r <> go s' t

314+ go' s t = let (s', r) = f s t in r <+> go s' t

313− go s (TypeApp t1 t2) = go' s t1 <> go' s t2

315+ go s (TypeApp t1 t2) = go' s t1 <+> go' s t2

314 go s (ForAll _ ty _) = go' s ty

316 go s (ForAll _ ty _) = go' s ty

315− go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty

317+ go s (ConstrainedType cs ty) = foldl (<+>) r0 (map (go' s) $ concatMap constraintArgs cs) <+> go' s ty

316− go s (RCons _ ty rest) = go' s ty <> go' s rest

318+ go s (RCons _ ty rest) = go' s ty <+> go' s rest

317 go s (KindedType ty _) = go' s ty

319 go s (KindedType ty _) = go' s ty

318− go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

320+ go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2

319 go s (PrettyPrintObject t1) = go' s t1

321 go s (PrettyPrintObject t1) = go' s t1

320 go s (PrettyPrintForAll _ t1) = go' s t1

322 go s (PrettyPrintForAll _ t1) = go' s t1

321− go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3

323+ go s (BinaryNoParensType t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3

322 go s (ParensInType t1) = go' s t1

324 go s (ParensInType t1) = go' s t1

323 go _ _ = r0

325 go _ _ = r0

stack-ghc-8.0.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: nightly-2016-07-19

1+resolver: lts-7.9

2packages:

3- '.'

4extra-deps:

tests/Language/PureScript/Ide/ReexportsSpec.hs+1−2

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

2{-# LANGUAGE NoImplicitPrelude #-}

3module Language.PureScript.Ide.ReexportsSpec where

4

5−import qualified Prelude

6import Protolude

5import Protolude

7

6

8import qualified Data.Map as Map

7import qualified Data.Map as Map

@@ -11,7 +10,7 @@ import Language.PureScript.Ide.Types

11import qualified Language.PureScript as P

10import qualified Language.PureScript as P

12import Test.Hspec

11import Test.Hspec

13

12

14−m :: Prelude.String -> P.ModuleName

13+m :: Text -> P.ModuleName

15m = P.moduleNameFromString

14m = P.moduleNameFromString

16

15

17d :: IdeDeclaration -> IdeDeclarationAnn

16d :: IdeDeclaration -> IdeDeclarationAnn

tests/TestCompiler.hs+28−11

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

2{-# LANGUAGE DoAndIfThenElse #-}

3{-# LANGUAGE TupleSections #-}

4{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

5

6

6module TestCompiler where

7module TestCompiler where

7

8

@@ -30,8 +31,8 @@ import Data.Function (on)

30import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

31import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

31import Data.Maybe (mapMaybe)

32import Data.Maybe (mapMaybe)

32import Data.Time.Clock (UTCTime())

33import Data.Time.Clock (UTCTime())

33−import Data.Tuple (swap)

34import qualified Data.Text as T

35+import Data.Tuple (swap)

35

36

36import qualified Data.Map as M

37import qualified Data.Map as M

37

38

@@ -46,6 +47,7 @@ import System.Exit

46import System.Process hiding (cwd)

47import System.Process hiding (cwd)

47import System.FilePath

48import System.FilePath

48import System.Directory

49import System.Directory

50+import System.IO

49import System.IO.UTF8

51import System.IO.UTF8

50import System.IO.Silently

52import System.IO.Silently

51import qualified System.FilePath.Glob as Glob

53import qualified System.FilePath.Glob as Glob

@@ -72,7 +74,7 @@ spec = do

72 supportPurs <- supportFiles "purs"

74 supportPurs <- supportFiles "purs"

73 supportPursFiles <- readInput supportPurs

75 supportPursFiles <- readInput supportPurs

74 supportExterns <- runExceptT $ do

76 supportExterns <- runExceptT $ do

75− modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)

77+ modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

76 foreigns <- inferForeignModules modules

78 foreigns <- inferForeignModules modules

77 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

79 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

78 return (zip (map snd modules) externs)

80 return (zip (map snd modules) externs)

@@ -80,10 +82,15 @@ spec = do

80 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)

82 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)

81 Right externs -> return (externs, passingFiles, warningFiles, failingFiles)

83 Right externs -> return (externs, passingFiles, warningFiles, failingFiles)

82

84

85+ outputFile <- runIO $ do

86+ tmp <- getTemporaryDirectory

87+ createDirectoryIfMissing False (tmp </> logpath)

88+ openFile (tmp </> logpath </> logfile) WriteMode

89+

83 context "Passing examples" $

90 context "Passing examples" $

84 forM_ passingTestCases $ \testPurs ->

91 forM_ passingTestCases $ \testPurs ->

85 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

92 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

86− assertCompiles supportExterns testPurs

93+ assertCompiles supportExterns testPurs outputFile

87

94

88 context "Warning examples" $

95 context "Warning examples" $

89 forM_ warningTestCases $ \testPurs -> do

96 forM_ warningTestCases $ \testPurs -> do

@@ -169,20 +176,20 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi

169 where

176 where

170 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

177 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

171 getInputTimestamp mn

178 getInputTimestamp mn

172− | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

179+ | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)

173 | otherwise = return (Left P.RebuildAlways)

180 | otherwise = return (Left P.RebuildAlways)

174 where

181 where

175 isSupportModule = flip elem supportModules

182 isSupportModule = flip elem supportModules

176

183

177 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

184 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

178 getOutputTimestamp mn = do

185 getOutputTimestamp mn = do

179− let filePath = modulesDir </> P.runModuleName mn

186+ let filePath = modulesDir </> T.unpack (P.runModuleName mn)

180 exists <- liftIO $ doesDirectoryExist filePath

187 exists <- liftIO $ doesDirectoryExist filePath

181 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

188 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

182

189

183−readInput :: [FilePath] -> IO [(FilePath, String)]

190+readInput :: [FilePath] -> IO [(FilePath, T.Text)]

184readInput inputFiles = forM inputFiles $ \inputFile -> do

191readInput inputFiles = forM inputFiles $ \inputFile -> do

185− text <- readUTF8File inputFile

192+ text <- readUTF8FileT inputFile

186 return (inputFile, text)

193 return (inputFile, text)

187

194

188runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)

195runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)

@@ -195,7 +202,7 @@ compile

195 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

202 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

196compile supportExterns inputFiles check = silence $ runTest $ do

203compile supportExterns inputFiles check = silence $ runTest $ do

197 fs <- liftIO $ readInput inputFiles

204 fs <- liftIO $ readInput inputFiles

198− ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)

205+ ms <- P.parseModulesFromFiles id fs

199 foreigns <- inferForeignModules ms

206 foreigns <- inferForeignModules ms

200 liftIO (check (map snd ms))

207 liftIO (check (map snd ms))

201 let actions = makeActions foreigns

208 let actions = makeActions foreigns

@@ -222,15 +229,16 @@ checkMain ms =

222checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String

229checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String

223checkShouldFailWith expected errs =

230checkShouldFailWith expected errs =

224 let actual = map P.errorCode $ P.runMultipleErrors errs

231 let actual = map P.errorCode $ P.runMultipleErrors errs

225− in if sort expected == sort actual

232+ in if sort expected == sort (map T.unpack actual)

226 then Nothing

233 then Nothing

227 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

234 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

228

235

229assertCompiles

236assertCompiles

230 :: [(P.Module, P.ExternsFile)]

237 :: [(P.Module, P.ExternsFile)]

231 -> [FilePath]

238 -> [FilePath]

239+ -> Handle

232 -> Expectation

240 -> Expectation

233−assertCompiles supportExterns inputFiles =

241+assertCompiles supportExterns inputFiles outputFile =

234 assert supportExterns inputFiles checkMain $ \e ->

242 assert supportExterns inputFiles checkMain $ \e ->

235 case e of

243 case e of

236 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs

244 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs

@@ -239,10 +247,13 @@ assertCompiles supportExterns inputFiles =

239 let entryPoint = modulesDir </> "index.js"

247 let entryPoint = modulesDir </> "index.js"

240 writeFile entryPoint "require('Main').main()"

248 writeFile entryPoint "require('Main').main()"

241 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process

249 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process

250+ hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"

242 case result of

251 case result of

243 Just (ExitSuccess, out, err)

252 Just (ExitSuccess, out, err)

244 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err

253 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err

245− | not (null out) && trim (last (lines out)) == "Done" -> return Nothing

254+ | not (null out) && trim (last (lines out)) == "Done" -> do

255+ hPutStr outputFile out

256+ return Nothing

246 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

257 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

247 Just (ExitFailure _, _, err) -> return $ Just err

258 Just (ExitFailure _, _, err) -> return $ Just err

248 Nothing -> return $ Just "Couldn't find node.js executable"

259 Nothing -> return $ Just "Couldn't find node.js executable"

@@ -285,3 +296,9 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith =

285

296

286 where

297 where

287 noPreCheck = const (return ())

298 noPreCheck = const (return ())

299+

300+logpath :: FilePath

301+logpath = "purescript-output"

302+

303+logfile :: FilePath

304+logfile = "psc-tests.out"

tests/TestDocs.hs+30−6

@@ -13,6 +13,7 @@ import Data.Monoid

13import Data.Maybe (fromMaybe)

14import Data.List ((\\))

15import Data.Foldable

16+import qualified Data.Text as T

16import System.Exit

17import System.Exit

17

18

18import qualified Language.PureScript as P

19import qualified Language.PureScript as P

@@ -36,8 +37,8 @@ main = pushd "examples/docs" $ do

36 case res of

37 case res of

37 Left e -> Publish.printErrorToStdout e >> exitFailure

38 Left e -> Publish.printErrorToStdout e >> exitFailure

38 Right Docs.Package{..} ->

39 Right Docs.Package{..} ->

39− forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

40+ forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->

40− let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)

41+ let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))

41 (find ((==) mn . Docs.modName) pkgModules)

42 (find ((==) mn . Docs.modName) pkgModules)

42 in forM_ pragmas (`runAssertionIO` mdl)

43 in forM_ pragmas (`runAssertionIO` mdl)

43

44

@@ -57,6 +58,9 @@ data Assertion

57 -- | Assert that a particular declaration has a particular type class

58 -- | Assert that a particular declaration has a particular type class

58 -- constraint.

59 -- constraint.

59 | ShouldBeConstrained P.ModuleName String String

60 | ShouldBeConstrained P.ModuleName String String

61+ -- | Assert that a particular typeclass declaration has a functional

62+ -- dependency list.

63+ | ShouldHaveFunDeps P.ModuleName String [([String],[String])]

60 -- | Assert that a particular value declaration exists, and its type

64 -- | Assert that a particular value declaration exists, and its type

61 -- satisfies the given predicate.

65 -- satisfies the given predicate.

62 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

66 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

@@ -82,6 +86,8 @@ data AssertionFailure

82 | ChildDocumented P.ModuleName String String

86 | ChildDocumented P.ModuleName String String

83 -- | A constraint was missing.

87 -- | A constraint was missing.

84 | ConstraintMissing P.ModuleName String String

88 | ConstraintMissing P.ModuleName String String

89+ -- | A functional dependency was missing.

90+ | FunDepMissing P.ModuleName String [([String], [String])]

85 -- | A declaration had the wrong "type" (ie, value, type, type class)

91 -- | A declaration had the wrong "type" (ie, value, type, type class)

86 -- Fields: declaration title, expected "type", actual "type".

92 -- Fields: declaration title, expected "type", actual "type".

87 | WrongDeclarationType P.ModuleName String String String

93 | WrongDeclarationType P.ModuleName String String String

@@ -142,6 +148,20 @@ runAssertion assertion Docs.Module{..} =

142 Fail (WrongDeclarationType mn decl "value"

148 Fail (WrongDeclarationType mn decl "value"

143 (Docs.declInfoToString declInfo))

149 (Docs.declInfoToString declInfo))

144

150

151+ ShouldHaveFunDeps mn decl fds ->

152+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

153+ Nothing ->

154+ Fail (NotDocumented mn decl)

155+ Just Docs.Declaration{..} ->

156+ case declInfo of

157+ Docs.TypeClassDeclaration _ _ fundeps ->

158+ if fundeps == fds

159+ then Pass

160+ else Fail (FunDepMissing mn decl fds)

161+ _ ->

162+ Fail (WrongDeclarationType mn decl "value"

163+ (Docs.declInfoToString declInfo))

164+

145 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

165 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

146 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

166 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

147 Nothing ->

167 Nothing ->

@@ -197,11 +217,11 @@ checkConstrained ty tyClass =

197 False

217 False

198 where

218 where

199 matches className =

219 matches className =

200− (==) className . P.runProperName . P.disqualify . P.constraintClass

220+ (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass

201

221

202runAssertionIO :: Assertion -> Docs.Module -> IO ()

222runAssertionIO :: Assertion -> Docs.Module -> IO ()

203runAssertionIO assertion mdl = do

223runAssertionIO assertion mdl = do

204− putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)

224+ putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)

205 case runAssertion assertion mdl of

225 case runAssertion assertion mdl of

206 Pass -> pure ()

226 Pass -> pure ()

207 Fail reason -> do

227 Fail reason -> do

@@ -270,6 +290,10 @@ testCases =

270 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"

290 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"

271 ])

291 ])

272

292

293+ , ("TypeClassWithFunDeps",

294+ [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]

295+ ])

296+

273 , ("NewOperators",

297 , ("NewOperators",

274 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

298 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

275 ])

299 ])

@@ -298,12 +322,12 @@ testCases =

298 ]

322 ]

299

323

300 where

324 where

301− n = P.moduleNameFromString

325+ n = P.moduleNameFromString . T.pack

302

326

303 hasTypeVar varName =

327 hasTypeVar varName =

304 getAny . P.everythingOnTypes (<>) (Any . isVar varName)

328 getAny . P.everythingOnTypes (<>) (Any . isVar varName)

305

329

306− isVar varName (P.TypeVar name) | varName == name = True

330+ isVar varName (P.TypeVar name) | varName == T.unpack name = True

307 isVar _ _ = False

331 isVar _ _ = False

308

332

309 renderedType expected =

333 renderedType expected =

tests/TestPsci.hs+3−2

@@ -10,6 +10,7 @@ import Control.Monad.Trans.State.Strict (evalStateT)

10import Control.Monad (when)

11

12import Data.List (sort)

13+import qualified Data.Text as T

13

14

14import System.Exit (exitFailure)

15import System.Exit (exitFailure)

15import System.Console.Haskeline

16import System.Console.Haskeline

@@ -127,11 +128,11 @@ getPSCiState = do

127 Left err ->

128 Left err ->

128 print err >> exitFailure

129 print err >> exitFailure

129 Right modules ->

130 Right modules ->

130− let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]

131+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)]

131 dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"

132 dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"

132 in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))

133 in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))

133

134

134controlMonadSTasST :: ImportedModule

135controlMonadSTasST :: ImportedModule

135controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))

136controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))

136 where

137 where

137− s = P.moduleNameFromString

138+ s = P.moduleNameFromString . T.pack

tests/TestUtils.hs+2

@@ -104,6 +104,7 @@ supportModules =

104 , "Data.Ring"

105 , "Data.Semigroup"

106 , "Data.Semiring"

107+ , "Data.Symbol"

107 , "Data.Show"

108 , "Data.Show"

108 , "Data.Unit"

109 , "Data.Unit"

109 , "Data.Void"

110 , "Data.Void"

@@ -112,6 +113,7 @@ supportModules =

112 , "Prelude"

113 , "Prelude"

113 , "Test.Assert"

114 , "Test.Assert"

114 , "Test.Main"

115 , "Test.Main"

116+ , "Unsafe.Coerce"

115 ]

117 ]

116

118

117pushd :: forall a. FilePath -> IO a -> IO a

119pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json+3−1

@@ -9,6 +9,8 @@

9 "purescript-st": "1.0.0-rc.1",

10 "purescript-partial": "1.1.2",

11 "purescript-newtype": "0.1.0",

12− "purescript-generics-rep": "2.0.0"

12+ "purescript-generics-rep": "2.0.0",

13+ "purescript-symbols": "^1.0.1",

14+ "purescript-unsafe-coerce": "^1.0.0"

13 }

15 }

14}

16}