41c0f8f · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge branch 'master' into pure11

commit41c0f8fce6fa2755f3b6c795dfd6d8603924fef7 authorAndy Arvanitis <andyarvanitis@gmail.com> dateWed 14 Dec 2016, 19:43 (10 years ago) parent6e80b80 4c792a1

113 files changed+1688−1215

compare with golang

unifiedsplit

CONTRIBUTING.md+1−1

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

1212

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

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

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

1717

1818## Code Review

CONTRIBUTORS.md+1

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

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

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

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

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

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

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

1717## Resources

1818

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

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

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

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

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

2323

appveyor.yml+4−1

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

33environment:

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

55 STACK_ROOT: c:\s

6+ STACK_VER: 1.2.0

67 RELEASE_USER: purescript

78 RELEASE_REPO: purescript

89cache:

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

1516- ps: |

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

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

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

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

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

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

1922 pushd c:\tools

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

2124 popd

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

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

2+module TypeClassWithFunDeps where

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

4+x :: Char

5+x = '\x10000'

examples/failing/RowInInstanceNotDetermined0.pursnew file+9

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

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

4+import Prelude

6+-- no fundeps

7+class C a b

8+instance c :: C Unit {}

examples/failing/RowInInstanceNotDetermined1.pursnew file+9

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

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

4+import Prelude

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

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

8+instance c :: C Unit Unit {}

examples/failing/RowInInstanceNotDetermined2.pursnew file+9

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

1+-- @shouldFailWith InvalidInstanceHead

2+module Main where

4+import Prelude

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

examples/passing/2438.pursnew file+8

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

1+module Main where

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

5+done :: String

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

8+main = log done

examples/passing/RowInInstanceHeadDetermined.pursnew file+40

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

1+module Main where

3+import Prelude

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

6+data Empty = Empty

7+data Cons = Cons

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

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

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

3+import Data.Symbol

5+literalSymbol :: SProxy "literal"

6+literalSymbol = SProxy

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

9+libReflectSymbol = reflectSymbol

10+

examples/passing/StringEscapes.purs+15−6

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

11module Main where

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

4−import Test.Assert (assert)

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

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

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

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

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

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

1010surrogatePair = "\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

1117

1218main = do

13− assert singleCharacter

14− assert hex

15− assert decimal

16− assert surrogatePair

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

20+ assert' "hex escape sequences" hex

21+ assert' "decimal escape sequences" decimal

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

1726 log "Done"

examples/warning/2140.pursnew file+5

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

1+-- @shouldWarnWith ShadowedTypeVar

2+module Main where

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)

2525import Data.Foldable (for_)

2626import Data.Version (showVersion)

2727import Data.Monoid ((<>))

28+import qualified Data.Text as T

2829

2930import Options.Applicative (Parser)

3031import qualified Options.Applicative as Opts

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

5657 getCls = either id snd

5758

5859runModuleName :: 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)

6061

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

6263readInput paths = do

psc-bundle/Main.hs+2−2

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

2020import System.FilePath.Glob (glob)

2121import System.Exit (exitFailure)

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

23−import System.IO.UTF8 (readUTF8File)

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

2424import System.Directory (createDirectoryIfMissing)

2525

2626import Language.PureScript.Bundle

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

110110 case optionsOutputFile opts of

111111 Just outputFile -> do

112112 createDirectoryIfMissing True (takeDirectory outputFile)

113− writeFile outputFile js

113+ writeUTF8File outputFile js

114114 Nothing -> putStrLn js

115115 where

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

psc-docs/Main.hs+5−4

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

88import Control.Category ((>>>))

99import Control.Monad.Writer

1010import Data.Text (Text)

11+import qualified Data.Text as T

1112import Data.Function (on)

1213import Data.List

1314import Data.Maybe (fromMaybe)

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

8283 where

8384 guardMissing [] = return ()

8485 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) ++ "\"")

8687 exitFailure

8788 guardMissing mns = do

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

8990 forM_ mns $ \mn ->

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

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

9192 exitFailure

9293

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

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

186187parseItem s = case elemIndex ':' s of

187188 Just i ->

188189 s # splitAt i

189− >>> first P.moduleNameFromString

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

190191 >>> second (drop 1)

191192 >>> IToFile

192193 Nothing ->

193− IToStdOut (P.moduleNameFromString s)

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

194195

195196 where

196197 infixr 1 #

psc-docs/Tags.hs+3−1

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

11module Tags where

3+import Control.Arrow (first)

4+import qualified Data.Text as T

35import qualified Language.PureScript as P

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

6−tags = concatMap dtags . P.exportedDeclarations

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

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

810 where tag name = (name, line)

911 line = P.sourcePosLine $ P.spanStart sp

psc-ide-client/Main.hs−1

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

1−{-# LANGUAGE OverloadedStrings #-}

21module Main where

43import Prelude ()

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

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

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

3131import Data.Version (showVersion)

3232import Language.PureScript.Ide

33+import Language.PureScript.Ide.Command

3334import Language.PureScript.Ide.Util

3435import Language.PureScript.Ide.Error

3536import Language.PureScript.Ide.Types

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

4142import Options.Applicative (ParseError (..))

4243import qualified Options.Applicative as Opts

4344import System.Directory

45+import System.Info as SysInfo

4446import System.FilePath

4547import System.IO hiding (putStrLn, print)

4648import System.IO.Error (isEOFError)

47−

4849import qualified Paths_purescript as Paths

4950

5051listenOnLocalhost :: PortNumber -> IO Socket

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

6667 , optionsOutputPath :: FilePath

6768 , optionsPort :: PortNumber

6869 , optionsNoWatch :: Bool

70+ , optionsPolling :: Bool

6971 , optionsDebug :: Bool

70− }

72+ , optionsLoglevel :: IdeLogLevel

73+ } deriving (Show)

7174

7275main :: IO ()

7376main = 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')

7579 maybe (pure ()) setCurrentDirectory dir

7680 ideState <- newTVarIO emptyIdeState

7781 cwd <- getCurrentDirectory

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

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

8589

8690 unless noWatch $

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

88−

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

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

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

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

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

9195 startServer port env

9296 where

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

98102 <*> (fromIntegral <$>

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

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

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

101106 <*> 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\""))

102111 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

103118 version = Opts.abortOption

104119 (InfoMsg (showVersion Paths.version))

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

106121

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+

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

108127startServer port env = withSocketsDo $ do

109128 sock <- listenOnLocalhost port

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

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

111130 where

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

113−

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

115132 loop sock = do

116133 accepted <- runExceptT $ acceptCommand sock

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

119136 Right (cmd, h) -> do

120137 case decodeT cmd of

121138 Just cmd' -> do

122− result <- runExceptT (handleCommand cmd')

139+ let message duration =

140+ "Command " <> commandName cmd'

141+ <> " took "

142+ <> displayTimeSpec duration

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

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

124145 liftIO (hFlush stdout)

125146 case result of

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

132153 hFlush stdout

133154 liftIO (hClose h)

134155

135−

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

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

138158acceptCommand sock = do

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

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

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

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

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

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

2730- `--version`: Output psc-ide version

2831

purescript.cabal+5−2

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

11name: purescript

2−version: 0.10.2

2+version: 0.10.3

33cabal-version: >=1.8

44build-type: Simple

55license: BSD3

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

5050 , examples/passing/ResolvableScopeConflict2/*.purs

5151 , examples/passing/ResolvableScopeConflict3/*.purs

5252 , examples/passing/ShadowedModuleName/*.purs

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

5354 , examples/passing/TransitiveImport/*.purs

5455 , examples/passing/TypeOperators/*.purs

5556 , examples/passing/TypeWithoutParens/*.purs

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

292293 Language.PureScript.Ide.Conversions

293294 Language.PureScript.Ide.Externs

294295 Language.PureScript.Ide.Error

295− Language.PureScript.Ide.Imports

296296 Language.PureScript.Ide.Filter

297+ Language.PureScript.Ide.Imports

298+ Language.PureScript.Ide.Logging

297299 Language.PureScript.Ide.Matcher

298300 Language.PureScript.Ide.Pursuit

299301 Language.PureScript.Ide.Rebuild

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

333335 PatternSynonyms

334336 RankNTypes

335337 RecordWildCards

338+ OverloadedStrings

336339 ScopedTypeVariables

337340 TupleSections

338341 ViewPatterns

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

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

1212import Control.Monad.Supply

1313import Control.Monad.State

1414import Control.Monad.Writer

15+import Data.Text (Text, pack)

1516

1617class Monad m => MonadSupply m where

1718 fresh :: m Integer

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

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

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

3334

34−freshName :: MonadSupply m => m String

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

35+freshName :: MonadSupply m => m Text

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

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

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

1111

1212import Data.Aeson.TH

1313import qualified Data.Map as M

14+import Data.Text (Text)

1415

1516import Language.PureScript.AST.Binders

1617import Language.PureScript.AST.Literals

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

4748 | UnnecessaryFFIModule ModuleName FilePath

4849 | MissingFFIImplementations ModuleName [Ident]

4950 | UnusedFFIImplementations ModuleName [Ident]

50− | InvalidFFIIdentifier ModuleName String

51+ | InvalidFFIIdentifier ModuleName Text

5152 | CannotGetFileInfo FilePath

5253 | CannotReadFile FilePath

5354 | CannotWriteFile FilePath

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

6869 | DeclConflict Name Name

6970 | ExportConflict (Qualified Name) (Qualified Name)

7071 | DuplicateModule ModuleName [SourceSpan]

71− | DuplicateTypeArgument String

72+ | DuplicateTypeArgument Text

7273 | InvalidDoBind

7374 | InvalidDoLet

7475 | CycleInDeclaration Ident

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

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

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

9192 | CannotFindDerivingType (ProperName 'TypeName)

92− | DuplicateLabel String (Maybe Expr)

93+ | DuplicateLabel Text (Maybe Expr)

9394 | DuplicateValueDeclaration Ident

9495 | ArgListLengthsDiffer Ident

9596 | OverlappingArgNames (Maybe Ident)

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

9899 | ExpectedType Type Kind

99100 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

100101 | ExprDoesNotHaveType Expr Type

101− | PropertyIsMissing String

102− | AdditionalProperty String

102+ | PropertyIsMissing Text

103+ | AdditionalProperty Text

103104 | TypeSynonymInstance

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

105106 | InvalidNewtype (ProperName 'TypeName)

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

107108 | TransitiveExportError DeclarationRef [DeclarationRef]

108109 | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

109110 | ShadowedName Ident

110− | ShadowedTypeVar String

111− | UnusedTypeVar String

111+ | ShadowedTypeVar Text

112+ | UnusedTypeVar Text

112113 | WildcardInferredType Type Context

113− | HoleInferredType String Type Context TypeSearch

114+ | HoleInferredType Text Type Context TypeSearch

114115 | MissingTypeDeclaration Ident Type

115116 | OverlappingPattern [[Binder]] Bool

116117 | IncompleteExhaustivityCheck

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

124125 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

125126 | DuplicateImportRef Name

126127 | DuplicateExportRef Name

127− | IntOutOfRange Integer String Integer Integer

128+ | IntOutOfRange Integer Text Integer Integer

128129 | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

129130 | ImplicitImport ModuleName [DeclarationRef]

130131 | HidingImport ModuleName [DeclarationRef]

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

144145 | ErrorInModule ModuleName

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

146147 | ErrorInSubsumption Type Type

147− | ErrorCheckingAccessor Expr String

148+ | ErrorCheckingAccessor Expr Text

148149 | ErrorCheckingType Expr Type

149150 | ErrorCheckingKind Type

150151 | ErrorCheckingGuard

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

153154 | ErrorInDataConstructor (ProperName 'ConstructorName)

154155 | ErrorInTypeConstructor (ProperName 'TypeName)

155156 | ErrorInBindingGroup [Ident]

156− | ErrorInDataBindingGroup

157+ | ErrorInDataBindingGroup [ProperName 'TypeName]

157158 | ErrorInTypeSynonym (ProperName 'TypeName)

158159 | ErrorInValueDeclaration Ident

159160 | ErrorInTypeDeclaration Ident

161+ | ErrorInTypeClassDeclaration (ProperName 'ClassName)

160162 | ErrorInForeignImport Ident

161163 | ErrorSolvingConstraint Constraint

162164 | PositionedError SourceSpan

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

349351 -- |

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

351353 --

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

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

353355 -- |

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

355357 --

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

357359 -- |

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

359361 --

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

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

361363 -- |

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

363365 --

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

389391 -- |

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

391393 --

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

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

393395 -- |

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

395397 -- declarations)

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

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

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

549551 --

550− | Accessor String Expr

552+ | Accessor Text Expr

551553 -- |

552554 -- Partial record update

553555 --

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

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

555557 -- |

556558 -- Function introduction

557559 --

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

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

608610 --

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

611613 [ErrorMessageHint]

612614 -- |

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

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

624626 -- |

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

626628 --

627− | Hole String

629+ | Hole Text

628630 -- |

629631 -- A value with source position information

630632 --

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

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

44module Language.PureScript.AST.Literals where

66import Prelude.Compat

7+import Data.Text (Text)

89-- |

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

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

1718 -- |

1819 -- A string literal

1920 --

20− | StringLiteral String

21+ | StringLiteral Text

2122 -- |

2223 -- A character literal

2324 --

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

3334 -- |

3435 -- An object literal

3536 --

36− | ObjectLiteral [(String, a)]

37+ | ObjectLiteral [(Text, a)]

3738 deriving (Eq, Ord, Show, Functor)

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

31-- |

42-- Operators fixity and associativity

53--

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

31-- |

42-- Source position information

53--

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

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

119import qualified Data.Aeson as A

10+import Data.Monoid

11+import qualified Data.Text as T

12+import Data.Text (Text)

1213

1314-- |

1415-- Source position information

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

2425 , sourcePosColumn :: Int

2526 } deriving (Show, Eq, Ord)

2627

27−displaySourcePos :: SourcePos -> String

28+displaySourcePos :: SourcePos -> Text

2829displaySourcePos sp =

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

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

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

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

3132

3233instance A.ToJSON SourcePos where

3334 toJSON SourcePos{..} =

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

5253 , spanEnd :: SourcePos

5354 } deriving (Show, Eq, Ord)

5455

55−displayStartEndPos :: SourceSpan -> String

56+displayStartEndPos :: SourceSpan -> Text

5657displayStartEndPos sp =

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

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

5859 displaySourcePos (spanEnd sp)

5960

60−displaySourceSpan :: SourceSpan -> String

61+displaySourceSpan :: SourceSpan -> Text

6162displaySourceSpan sp =

62− spanName sp ++ " " ++

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

6364 displayStartEndPos sp

6465

6566instance A.ToJSON SourceSpan where

src/Language/PureScript/Bundle.hs+2

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

534534 where

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

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

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

537538

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

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

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

589590

590591 appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]

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

593+ appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a]

592594

593595 runMain :: String -> [JSStatement]

594596 runMain mn =

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

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

1010import Prelude.Compat

1111

1212import Control.Arrow ((&&&))

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

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

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

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

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

1616import Control.Monad.Supply.Class

1717

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

19−import Data.Maybe (isNothing, fromMaybe)

2019import qualified Data.Foldable as F

2120import qualified Data.Map as M

22−import qualified Data.Traversable as T

21+import Data.Maybe (fromMaybe, isNothing)

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

23+import Data.Text (Text)

24+import qualified Data.Text as T

2325

2426import Language.PureScript.AST.SourcePos

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

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

5153 rethrow (addHint (ErrorInModule mn)) $ do

5254 let usedNames = concatMap getNames decls

5355 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

5557 let decls' = renameModules mnLookup decls

5658 jsDecls <- mapM bindToJs decls'

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

59+ optimized <- traverse (traverse optimize) jsDecls

5860 F.traverse_ (F.traverse_ checkIntegers) optimized

5961 comments <- not <$> asks optionsNoComments

6062 let strict = JSStringLiteral Nothing "use strict"

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

9496

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

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

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

99101 then freshModuleName (i + 1) mn' used

100102 else newName

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

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

107109 importToJs mnLookup mn' = do

108110 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')))]

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

111113

112114 -- |

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

177179 accessor (Ident prop) = accessorString prop

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

179181

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

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

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

182184 | otherwise = JSAccessor Nothing prop

183185

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

234236 then foreignIdent ident

235237 else varToJs qi

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

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

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

240242 vals <- mapM valueToJs values

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

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

264266 ]

265267

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

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

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

268270

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

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

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

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

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

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

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

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

278280 -- |

279281 -- Shallow copy an object.

280282 --

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

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

282284 extendObj obj sts = do

283285 newObj <- freshName

284286 key <- freshName

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

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

332334 []

333335 where

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

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

335337 go _ done [] = return done

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

337339 done'' <- go vs done' bs

338340 binderToJs v done'' b

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

340342

341− failedPatternError :: [String] -> JS

343+ failedPatternError :: [Text] -> JS

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

343345

344− failedPatternMessage :: String

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

346+ failedPatternMessage :: Text

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

346348

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

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

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

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

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

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

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

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

359361

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

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

361363 binderToJs s done binder =

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

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

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

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

367369 -- binder.

368370 --

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

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

370372 binderToJs' _ done NullBinder{} = return done

371373 binderToJs' varName done (LiteralBinder _ l) =

372374 literalToBinderJS varName done l

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

396398 js <- binderToJs varName done binder

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

398400

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

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

400402 literalToBinderJS varName done (NumericLiteral num) =

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

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

404406 literalToBinderJS varName done (StringLiteral str) =

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

406408 literalToBinderJS varName done (BooleanLiteral True) =

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

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

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

411413 where

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

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

413415 go done' [] = return done'

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

415417 propVar <- freshName

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

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

66import Prelude.Compat

8−import Control.Monad.Identity

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

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

10+import Data.Text (Text)

911

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

1113import Language.PureScript.Comments

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

130132 -- |

131133 -- A string literal

132134 --

133− | JSStringLiteral (Maybe SourceSpan) String

135+ | JSStringLiteral (Maybe SourceSpan) Text

134136 -- |

135137 -- A boolean literal

136138 --

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

154156 -- |

155157 -- An object literal

156158 --

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

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

158160 -- |

159161 -- An object property accessor expression

160162 --

161− | JSAccessor (Maybe SourceSpan) String JS

163+ | JSAccessor (Maybe SourceSpan) Text JS

162164 -- |

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

164166 --

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

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

166168 -- |

167169 -- Function application

168170 --

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

170172 -- |

171173 -- Variable

172174 --

173− | JSVar (Maybe SourceSpan) String

175+ | JSVar (Maybe SourceSpan) Text

174176 -- |

175177 -- Conditional expression

176178 --

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

182184 -- |

183185 -- A variable introduction and optional initialization

184186 --

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

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

186188 -- |

187189 -- A variable assignment

188190 --

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

194196 -- |

195197 -- For loop

196198 --

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

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

198200 -- |

199201 -- ForIn loop

200202 --

201− | JSForIn (Maybe SourceSpan) String JS JS

203+ | JSForIn (Maybe SourceSpan) Text JS JS

202204 -- |

203205 -- If-then-else statement

204206 --

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

222224 -- |

223225 -- Labelled statement

224226 --

225− | JSLabel (Maybe SourceSpan) String JS

227+ | JSLabel (Maybe SourceSpan) Text JS

226228 -- |

227229 -- Break statement

228230 --

229− | JSBreak (Maybe SourceSpan) String

231+ | JSBreak (Maybe SourceSpan) Text

230232 -- |

231233 -- Continue statement

232234 --

233− | JSContinue (Maybe SourceSpan) String

235+ | JSContinue (Maybe SourceSpan) Text

234236 -- |

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

236238 --

237− | JSRaw (Maybe SourceSpan) String

239+ | JSRaw (Maybe SourceSpan) Text

238240 -- |

239241 -- Commented Javascript

240242 --

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

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

66import Prelude.Compat

88import Data.Char

9−import Data.List (intercalate)

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

10+import Data.Text (Text)

11+import qualified Data.Text as T

1012

1113import Language.PureScript.Crash

1214import Language.PureScript.Names

1315

14−moduleNameToJs :: ModuleName -> String

16+moduleNameToJs :: ModuleName -> Text

1517moduleNameToJs (ModuleName pns) =

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

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

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

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

1820

1921-- |

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

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

2527--

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

2729--

28−identToJs :: Ident -> String

30+identToJs :: Ident -> Text

2931identToJs (Ident name) = properToJs name

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

3133

32−properToJs :: String -> String

34+properToJs :: Text -> Text

3335properToJs name

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

35− | otherwise = concatMap identCharToString name

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

37+ | otherwise = T.concatMap identCharToText name

3638

3739-- |

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

3941--

40−identNeedsEscaping :: String -> Bool

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

42+identNeedsEscaping :: Text -> Bool

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

4244

4345-- |

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

4547-- ordinal value.

4648--

47−identCharToString :: Char -> String

48−identCharToString c | isAlphaNum c = [c]

49−identCharToString '_' = "_"

50−identCharToString '.' = "$dot"

51−identCharToString '$' = "$dollar"

52−identCharToString '~' = "$tilde"

53−identCharToString '=' = "$eq"

54−identCharToString '<' = "$less"

55−identCharToString '>' = "$greater"

56−identCharToString '!' = "$bang"

57−identCharToString '#' = "$hash"

58−identCharToString '%' = "$percent"

59−identCharToString '^' = "$up"

60−identCharToString '&' = "$amp"

61−identCharToString '|' = "$bar"

62−identCharToString '*' = "$times"

63−identCharToString '/' = "$div"

64−identCharToString '+' = "$plus"

65−identCharToString '-' = "$minus"

66−identCharToString ':' = "$colon"

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

68−identCharToString '?' = "$qmark"

69−identCharToString '@' = "$at"

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

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

49+identCharToText :: Char -> Text

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

51+identCharToText '_' = "_"

52+identCharToText '.' = "$dot"

53+identCharToText '$' = "$dollar"

54+identCharToText '~' = "$tilde"

55+identCharToText '=' = "$eq"

56+identCharToText '<' = "$less"

57+identCharToText '>' = "$greater"

58+identCharToText '!' = "$bang"

59+identCharToText '#' = "$hash"

60+identCharToText '%' = "$percent"

61+identCharToText '^' = "$up"

62+identCharToText '&' = "$amp"

63+identCharToText '|' = "$bar"

64+identCharToText '*' = "$times"

65+identCharToText '/' = "$div"

66+identCharToText '+' = "$plus"

67+identCharToText '-' = "$minus"

68+identCharToText ':' = "$colon"

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

70+identCharToText '?' = "$qmark"

71+identCharToText '@' = "$at"

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

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

7274

7375-- |

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

7577--

76−nameIsJsReserved :: String -> Bool

78+nameIsJsReserved :: Text -> Bool

7779nameIsJsReserved name =

7880 name `elem` jsAnyReserved

7981

8082-- |

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

8284--

83−nameIsJsBuiltIn :: String -> Bool

85+nameIsJsBuiltIn :: Text -> Bool

8486nameIsJsBuiltIn name =

8587 name `elem`

8688 [ "arguments"

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

138140 , "WeakSet"

139141 ]

140142

141−jsAnyReserved :: [String]

143+jsAnyReserved :: [Text]

142144jsAnyReserved =

143145 concat

144146 [ jsKeywords

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

149151 , jsLiterals

150152 ]

151153

152−jsKeywords :: [String]

154+jsKeywords :: [Text]

153155jsKeywords =

154156 [ "break"

155157 , "case"

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

185187 , "with"

186188 ]

187189

188−jsSometimesReserved :: [String]

190+jsSometimesReserved :: [Text]

189191jsSometimesReserved =

190192 [ "await"

191193 , "let"

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

193195 , "yield"

194196 ]

195197

196−jsFutureReserved :: [String]

198+jsFutureReserved :: [Text]

197199jsFutureReserved =

198200 [ "enum" ]

199201

200−jsFutureReservedStrict :: [String]

202+jsFutureReservedStrict :: [Text]

201203jsFutureReservedStrict =

202204 [ "implements"

203205 , "interface"

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

207209 , "public"

208210 ]

209211

210−jsOldReserved :: [String]

212+jsOldReserved :: [Text]

211213jsOldReserved =

212214 [ "abstract"

213215 , "boolean"

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

227229 , "volatile"

228230 ]

229231

230−jsLiterals :: [String]

232+jsLiterals :: [Text]

231233jsLiterals =

232234 [ "null"

233235 , "true"

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

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

66import Prelude.Compat

8+import Data.Text (Text)

9+import Data.List (foldl')

810import Data.Maybe (fromMaybe)

911

1012import Language.PureScript.Crash

1113import Language.PureScript.CodeGen.JS.AST

1214

1315applyAll :: [a -> a] -> a -> a

14−applyAll = foldl1 (.)

16+applyAll = foldl' (.) id

1517

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

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

1719replaceIdent var1 js = everywhereOnJS replace

1820 where

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

2022 replace other = other

2123

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

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

2325replaceIdents vars = everywhereOnJS replace

2426 where

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

2628 replace other = other

2729

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

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

2931isReassigned var1 = everythingOnJS (||) check

3032 where

3133 check :: JS -> Bool

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

4244 variablesOf (JSVar _ var) = [var]

4345 variablesOf _ = []

4446

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

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

4648isUsed var1 = everythingOnJS (||) check

4749 where

4850 check :: JS -> Bool

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

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

5153 check _ = False

5254

53−targetVariable :: JS -> String

55+targetVariable :: JS -> Text

5456targetVariable (JSVar _ var) = var

5557targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

5658targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

5759targetVariable _ = internalError "Invalid argument to targetVariable"

5860

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

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

6062isUpdated var1 = everythingOnJS (||) check

6163 where

6264 check :: JS -> Bool

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

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

6870removeFromBlock _ js = js

6971

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

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

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

7274 x == fnName && y == moduleName

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

7476 x == fnName && y == moduleName

7577isFn _ _ = False

7678

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

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

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

7981isDict _ _ = False

8082

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

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

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

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

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

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

1717

1818import Data.Maybe (fromMaybe)

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

20+import Data.Text (Text)

21+import qualified Data.Text as T

1922

2023import Language.PureScript.CodeGen.JS.AST

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

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

164167 ] ++

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

166169 where

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

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

168171 binary dict fns op = everywhereOnJS convert

169172 where

170173 convert :: JS -> JS

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

172175 convert other = other

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

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

174177 binary' moduleName opString op = everywhereOnJS convert

175178 where

176179 convert :: JS -> JS

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

178181 convert other = other

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

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

180183 unary dicts fns op = everywhereOnJS convert

181184 where

182185 convert :: JS -> JS

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

184187 convert other = other

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

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

186189 unary' moduleName fnName op = everywhereOnJS convert

187190 where

188191 convert :: JS -> JS

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

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

204207 Nothing -> orig

205208 convert other = other

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

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

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

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

209212 collectArgs _ _ _ = Nothing

210213

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

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

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

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

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

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

214217 isNFn _ _ _ = False

215218

216219 runFn :: Int -> JS -> JS

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

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

232235 convert other = other

233236

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

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

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

236239 isModFn _ _ = False

237240

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

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

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

240243 isModFnWithDict _ _ = False

241244

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

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

261264 isFnComposeFlipped :: JS -> JS -> Bool

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

263− fnCompose :: (String, String)

266+ fnCompose :: (Text, Text)

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

265− fnComposeFlipped :: (String, String)

268+ fnComposeFlipped :: (Text, Text)

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

267270

268−semiringNumber :: (String, String)

271+semiringNumber :: (Text, Text)

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

270273

271−semiringInt :: (String, String)

274+semiringInt :: (Text, Text)

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

273276

274−ringNumber :: (String, String)

277+ringNumber :: (Text, Text)

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

276279

277−ringInt :: (String, String)

280+ringInt :: (Text, Text)

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

279282

280−euclideanRingNumber :: (String, String)

283+euclideanRingNumber :: (Text, Text)

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

282285

283−euclideanRingInt :: (String, String)

286+euclideanRingInt :: (Text, Text)

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

285288

286−eqNumber :: (String, String)

289+eqNumber :: (Text, Text)

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

288291

289−eqInt :: (String, String)

292+eqInt :: (Text, Text)

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

291294

292−eqString :: (String, String)

295+eqString :: (Text, Text)

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

294297

295−eqChar :: (String, String)

298+eqChar :: (Text, Text)

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

297300

298−eqBoolean :: (String, String)

301+eqBoolean :: (Text, Text)

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

300303

301−ordBoolean :: (String, String)

304+ordBoolean :: (Text, Text)

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

303306

304−ordNumber :: (String, String)

307+ordNumber :: (Text, Text)

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

306309

307−ordInt :: (String, String)

310+ordInt :: (Text, Text)

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

309312

310−ordString :: (String, String)

313+ordString :: (Text, Text)

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

312315

313−ordChar :: (String, String)

316+ordChar :: (Text, Text)

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

315318

316−semigroupString :: (String, String)

319+semigroupString :: (Text, Text)

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

318321

319−boundedBoolean :: (String, String)

322+boundedBoolean :: (Text, Text)

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

321324

322−heytingAlgebraBoolean :: (String, String)

325+heytingAlgebraBoolean :: (Text, Text)

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

324327

325−semigroupoidFn :: (String, String)

328+semigroupoidFn :: (Text, Text)

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

327330

328−opAdd :: (String, String)

331+opAdd :: (Text, Text)

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

330333

331−opMul :: (String, String)

334+opMul :: (Text, Text)

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

333336

334−opEq :: (String, String)

337+opEq :: (Text, Text)

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

336339

337−opNotEq :: (String, String)

340+opNotEq :: (Text, Text)

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

339342

340−opLessThan :: (String, String)

343+opLessThan :: (Text, Text)

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

342345

343−opLessThanOrEq :: (String, String)

346+opLessThanOrEq :: (Text, Text)

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

345348

346−opGreaterThan :: (String, String)

349+opGreaterThan :: (Text, Text)

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

348351

349−opGreaterThanOrEq :: (String, String)

352+opGreaterThanOrEq :: (Text, Text)

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

351354

352−opAppend :: (String, String)

355+opAppend :: (Text, Text)

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

354357

355−opSub :: (String, String)

358+opSub :: (Text, Text)

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

357360

358−opNegate :: (String, String)

361+opNegate :: (Text, Text)

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

360363

361−opDiv :: (String, String)

364+opDiv :: (Text, Text)

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

363366

364−opMod :: (String, String)

367+opMod :: (Text, Text)

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

366369

367−opConj :: (String, String)

370+opConj :: (Text, Text)

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

369372

370−opDisj :: (String, String)

373+opDisj :: (Text, Text)

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

372375

373−opNot :: (String, String)

376+opNot :: (Text, Text)

374377opNot = (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

66import Prelude.Compat

8−import Data.Monoid

8+import Data.Text (Text)

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

910

1011import Language.PureScript.Options

1112import Language.PureScript.CodeGen.JS.AST

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

2021tco' :: JS -> JS

2122tco' = everywhereOnJS convert

2223 where

23− tcoLabel :: String

24+ tcoLabel :: Text

2425 tcoLabel = "tco"

2526

26− tcoVar :: String -> String

27− tcoVar arg = "__tco_" ++ arg

27+ tcoVar :: Text -> Text

28+ tcoVar arg = "__tco_" <> arg

2829

29− copyVar :: String -> String

30− copyVar arg = "__copy_" ++ arg

30+ copyVar :: Text -> Text

31+ copyVar arg = "__copy_" <> arg

3132

3233 convert :: JS -> JS

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

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

4243 | otherwise -> js

4344 convert js = js

4445

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

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

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

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

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

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

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

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

5556

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

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

5758 isTailCall ident js =

5859 let

5960 numSelfCalls = everythingOnJS (+) countSelfCalls js

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

8182 countSelfCallsWithFnArgs :: JS -> Int

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

8384

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

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

8586 toLoop ident allArgs js = JSBlock rootSS $

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

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

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

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

104105 collectSelfCallArgs allArgumentValues _ = allArgumentValues

105106

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

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

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

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

109110 isSelfCall _ _ = False

110111

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

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

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

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

114115 isSelfCallWithFnArgs _ _ _ = False

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

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

66module Language.PureScript.Comments where

88import Prelude.Compat

9+import Data.Text (Text)

910

1011import Data.Aeson.TH

1112

1213data Comment

13− = LineComment String

14− | BlockComment String

14+ = LineComment Text

15+ | BlockComment Text

1516 deriving (Show, Eq, Ord)

1617

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

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

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

22module Language.PureScript.Constants where

44import Prelude.Compat

5−

5+import Data.Text (Text)

66import Language.PureScript.Names

88-- Operators

10−($) :: String

10+($) :: Text

1111($) = "$"

1212

13−apply :: String

13+apply :: Text

1414apply = "apply"

1515

16−(#) :: String

16+(#) :: Text

1717(#) = "#"

1818

19−applyFlipped :: String

19+applyFlipped :: Text

2020applyFlipped = "applyFlipped"

2121

22−(<>) :: String

22+(<>) :: Text

2323(<>) = "<>"

2424

25−(++) :: String

25+(++) :: Text

2626(++) = "++"

2727

28−append :: String

28+append :: Text

2929append = "append"

3030

31−(>>=) :: String

31+(>>=) :: Text

3232(>>=) = ">>="

3333

34−bind :: String

34+bind :: Text

3535bind = "bind"

3636

37−(+) :: String

37+(+) :: Text

3838(+) = "+"

3939

40−add :: String

40+add :: Text

4141add = "add"

4242

43−(-) :: String

43+(-) :: Text

4444(-) = "-"

4545

46−sub :: String

46+sub :: Text

4747sub = "sub"

4848

49−(*) :: String

49+(*) :: Text

5050(*) = "*"

5151

52−mul :: String

52+mul :: Text

5353mul = "mul"

5454

55−(/) :: String

55+(/) :: Text

5656(/) = "/"

5757

58−div :: String

58+div :: Text

5959div = "div"

6060

61−(%) :: String

61+(%) :: Text

6262(%) = "%"

6363

64−mod :: String

64+mod :: Text

6565mod = "mod"

6666

67−(<) :: String

67+(<) :: Text

6868(<) = "<"

6969

70−lessThan :: String

70+lessThan :: Text

7171lessThan = "lessThan"

7272

73−(>) :: String

73+(>) :: Text

7474(>) = ">"

7575

76−greaterThan :: String

76+greaterThan :: Text

7777greaterThan = "greaterThan"

7878

79−(<=) :: String

79+(<=) :: Text

8080(<=) = "<="

8181

82−lessThanOrEq :: String

82+lessThanOrEq :: Text

8383lessThanOrEq = "lessThanOrEq"

8484

85−(>=) :: String

85+(>=) :: Text

8686(>=) = ">="

8787

88−greaterThanOrEq :: String

88+greaterThanOrEq :: Text

8989greaterThanOrEq = "greaterThanOrEq"

9090

91−(==) :: String

91+(==) :: Text

9292(==) = "=="

9393

94−eq :: String

94+eq :: Text

9595eq = "eq"

9696

97−(/=) :: String

97+(/=) :: Text

9898(/=) = "/="

9999

100−notEq :: String

100+notEq :: Text

101101notEq = "notEq"

102102

103−compare :: String

103+compare :: Text

104104compare = "compare"

105105

106−(&&) :: String

106+(&&) :: Text

107107(&&) = "&&"

108108

109−conj :: String

109+conj :: Text

110110conj = "conj"

111111

112−(||) :: String

112+(||) :: Text

113113(||) = "||"

114114

115−disj :: String

115+disj :: Text

116116disj = "disj"

117117

118−unsafeIndex :: String

118+unsafeIndex :: Text

119119unsafeIndex = "unsafeIndex"

120120

121−or :: String

121+or :: Text

122122or = "or"

123123

124−and :: String

124+and :: Text

125125and = "and"

126126

127−xor :: String

127+xor :: Text

128128xor = "xor"

129129

130−(<<<) :: String

130+(<<<) :: Text

131131(<<<) = "<<<"

132132

133−compose :: String

133+compose :: Text

134134compose = "compose"

135135

136−(>>>) :: String

136+(>>>) :: Text

137137(>>>) = ">>>"

138138

139−composeFlipped :: String

139+composeFlipped :: Text

140140composeFlipped = "composeFlipped"

141141

142142-- Functions

143143

144−negate :: String

144+negate :: Text

145145negate = "negate"

146146

147−not :: String

147+not :: Text

148148not = "not"

149149

150−shl :: String

150+shl :: Text

151151shl = "shl"

152152

153−shr :: String

153+shr :: Text

154154shr = "shr"

155155

156−zshr :: String

156+zshr :: Text

157157zshr = "zshr"

158158

159−complement :: String

159+complement :: Text

160160complement = "complement"

161161

162162-- Prelude Values

163163

164−zero :: String

164+zero :: Text

165165zero = "zero"

166166

167−one :: String

167+one :: Text

168168one = "one"

169169

170−bottom :: String

170+bottom :: Text

171171bottom = "bottom"

172172

173−top :: String

173+top :: Text

174174top = "top"

175175

176−return :: String

176+return :: Text

177177return = "return"

178178

179−pure' :: String

179+pure' :: Text

180180pure' = "pure"

181181

182−returnEscaped :: String

182+returnEscaped :: Text

183183returnEscaped = "$return"

184184

185−untilE :: String

185+untilE :: Text

186186untilE = "untilE"

187187

188−whileE :: String

188+whileE :: Text

189189whileE = "whileE"

190190

191−runST :: String

191+runST :: Text

192192runST = "runST"

193193

194−stRefValue :: String

194+stRefValue :: Text

195195stRefValue = "value"

196196

197−newSTRef :: String

197+newSTRef :: Text

198198newSTRef = "newSTRef"

199199

200−readSTRef :: String

200+readSTRef :: Text

201201readSTRef = "readSTRef"

202202

203−writeSTRef :: String

203+writeSTRef :: Text

204204writeSTRef = "writeSTRef"

205205

206−modifySTRef :: String

206+modifySTRef :: Text

207207modifySTRef = "modifySTRef"

208208

209−mkFn :: String

209+mkFn :: Text

210210mkFn = "mkFn"

211211

212−runFn :: String

212+runFn :: Text

213213runFn = "runFn"

214214

215−unit :: String

215+unit :: Text

216216unit = "unit"

217217

218218-- Prim values

219219

220−undefined :: String

220+undefined :: Text

221221undefined = "undefined"

222222

223223-- Type Class Dictionary Names

224224

225−monadEffDictionary :: String

225+monadEffDictionary :: Text

226226monadEffDictionary = "monadEff"

227227

228−applicativeEffDictionary :: String

228+applicativeEffDictionary :: Text

229229applicativeEffDictionary = "applicativeEff"

230230

231−bindEffDictionary :: String

231+bindEffDictionary :: Text

232232bindEffDictionary = "bindEff"

233233

234−semiringNumber :: String

234+semiringNumber :: Text

235235semiringNumber = "semiringNumber"

236236

237−semiringInt :: String

237+semiringInt :: Text

238238semiringInt = "semiringInt"

239239

240−ringNumber :: String

240+ringNumber :: Text

241241ringNumber = "ringNumber"

242242

243−ringInt :: String

243+ringInt :: Text

244244ringInt = "ringInt"

245245

246−moduloSemiringNumber :: String

246+moduloSemiringNumber :: Text

247247moduloSemiringNumber = "moduloSemiringNumber"

248248

249−moduloSemiringInt :: String

249+moduloSemiringInt :: Text

250250moduloSemiringInt = "moduloSemiringInt"

251251

252−euclideanRingNumber :: String

252+euclideanRingNumber :: Text

253253euclideanRingNumber = "euclideanRingNumber"

254254

255−euclideanRingInt :: String

255+euclideanRingInt :: Text

256256euclideanRingInt = "euclideanRingInt"

257257

258−ordBoolean :: String

258+ordBoolean :: Text

259259ordBoolean = "ordBoolean"

260260

261−ordNumber :: String

261+ordNumber :: Text

262262ordNumber = "ordNumber"

263263

264−ordInt :: String

264+ordInt :: Text

265265ordInt = "ordInt"

266266

267−ordString :: String

267+ordString :: Text

268268ordString = "ordString"

269269

270−ordChar :: String

270+ordChar :: Text

271271ordChar = "ordChar"

272272

273−eqNumber :: String

273+eqNumber :: Text

274274eqNumber = "eqNumber"

275275

276−eqInt :: String

276+eqInt :: Text

277277eqInt = "eqInt"

278278

279−eqString :: String

279+eqString :: Text

280280eqString = "eqString"

281281

282−eqChar :: String

282+eqChar :: Text

283283eqChar = "eqChar"

284284

285−eqBoolean :: String

285+eqBoolean :: Text

286286eqBoolean = "eqBoolean"

287287

288−boundedBoolean :: String

288+boundedBoolean :: Text

289289boundedBoolean = "boundedBoolean"

290290

291−booleanAlgebraBoolean :: String

291+booleanAlgebraBoolean :: Text

292292booleanAlgebraBoolean = "booleanAlgebraBoolean"

293293

294−heytingAlgebraBoolean :: String

294+heytingAlgebraBoolean :: Text

295295heytingAlgebraBoolean = "heytingAlgebraBoolean"

296296

297−semigroupString :: String

297+semigroupString :: Text

298298semigroupString = "semigroupString"

299299

300−semigroupoidFn :: String

300+semigroupoidFn :: Text

301301semigroupoidFn = "semigroupoidFn"

302302

303303-- Generic Deriving

304304

305−generic :: String

305+generic :: Text

306306generic = "Generic"

307307

308−toSpine :: String

308+toSpine :: Text

309309toSpine = "toSpine"

310310

311−fromSpine :: String

311+fromSpine :: Text

312312fromSpine = "fromSpine"

313313

314−toSignature :: String

314+toSignature :: Text

315315toSignature = "toSignature"

316316

317+-- IsSymbol class

318+

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

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

321+

317322-- Main module

318323

319−main :: String

324+main :: Text

320325main = "main"

321326

322327-- Prim

323328

324−partial :: String

329+partial :: Text

325330partial = "Partial"

326331

327332pattern Partial :: Qualified (ProperName 'ClassName)

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

332337

333338-- Code Generation

334339

335−__superclass_ :: String

340+__superclass_ :: Text

336341__superclass_ = "__superclass_"

337342

338−__unused :: String

343+__unused :: Text

339344__unused = "__unused"

340345

341346-- Modules

342347

343−prim :: String

348+prim :: Text

344349prim = "Prim"

345350

346−prelude :: String

351+prelude :: Text

347352prelude = "Prelude"

348353

349−dataArray :: String

354+dataArray :: Text

350355dataArray = "Data_Array"

351356

352−eff :: String

357+eff :: Text

353358eff = "Control_Monad_Eff"

354359

355−st :: String

360+st :: Text

356361st = "Control_Monad_ST"

357362

358−controlApplicative :: String

363+controlApplicative :: Text

359364controlApplicative = "Control_Applicative"

360365

361−controlSemigroupoid :: String

366+controlSemigroupoid :: Text

362367controlSemigroupoid = "Control_Semigroupoid"

363368

364−controlBind :: String

369+controlBind :: Text

365370controlBind = "Control_Bind"

366371

367−dataBounded :: String

372+dataBounded :: Text

368373dataBounded = "Data_Bounded"

369374

370−dataSemigroup :: String

375+dataSemigroup :: Text

371376dataSemigroup = "Data_Semigroup"

372377

373−dataHeytingAlgebra :: String

378+dataHeytingAlgebra :: Text

374379dataHeytingAlgebra = "Data_HeytingAlgebra"

375380

376−dataEq :: String

381+dataEq :: Text

377382dataEq = "Data_Eq"

378383

379−dataOrd :: String

384+dataOrd :: Text

380385dataOrd = "Data_Ord"

381386

382−dataSemiring :: String

387+dataSemiring :: Text

383388dataSemiring = "Data_Semiring"

384389

385−dataRing :: String

390+dataRing :: Text

386391dataRing = "Data_Ring"

387392

388−dataEuclideanRing :: String

393+dataEuclideanRing :: Text

389394dataEuclideanRing = "Data_EuclideanRing"

390395

391−dataFunction :: String

396+dataFunction :: Text

392397dataFunction = "Data_Function"

393398

394−dataFunctionUncurried :: String

399+dataFunctionUncurried :: Text

395400dataFunctionUncurried = "Data_Function_Uncurried"

396401

397−dataIntBits :: String

402+dataIntBits :: Text

398403dataIntBits = "Data_Int_Bits"

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

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

1313import Language.PureScript.AST.SourcePos

1414import Language.PureScript.AST.Traversals

1515import Language.PureScript.Comments

16+import qualified Language.PureScript.Constants as C

1617import Language.PureScript.CoreFn.Ann

1718import Language.PureScript.CoreFn.Binders

1819import Language.PureScript.CoreFn.Expr

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

110111 exprToCoreFn ss com (Just ty) v

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

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

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

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

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

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

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

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

211214 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

212220 fqValues _ = []

213221

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

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

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

66import Prelude.Compat

88import Control.Arrow ((***))

9+import Data.Text (Text)

910

1011import Language.PureScript.AST.Literals

1112import Language.PureScript.CoreFn.Binders

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

2627 -- |

2728 -- A record property accessor

2829 --

29− | Accessor a String (Expr a)

30+ | Accessor a Text (Expr a)

3031 -- |

3132 -- Partial record update

3233 --

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

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

3435 -- |

3536 -- Function introduction

3637 --

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

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

1+{-# LANGUAGE NoOverloadedStrings #-}

12-- |

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

34-- by third-party code generators

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

1011

1112import Data.Aeson

1213import Data.Version (Version, showVersion)

13−import Data.Text (pack)

14+import Data.Text (Text)

15+import qualified Data.Text as T

1416

1517import Language.PureScript.AST.Literals

1618import Language.PureScript.CoreFn

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

3133properNameToJSON :: ProperName a -> Value

3234properNameToJSON = toJSON . runProperName

3335

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

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

3537qualifiedToJSON f = toJSON . showQualified f

3638

3739moduleNameToJSON :: ModuleName -> Value

3840moduleNameToJSON = toJSON . runModuleName

3941

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

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

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

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

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

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

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

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

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

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

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

4648 ]

4749

4850bindToJSON :: Bind a -> Value

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

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

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

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

5153

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

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

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

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

5456

5557exprToJSON :: Expr a -> Value

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

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

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

1414

1515import Data.Foldable (for_)

1616import Data.List (partition)

17+import qualified Data.Text as T

1718

1819import Language.PureScript.Docs.RenderedCode

1920import Language.PureScript.Docs.Types

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

3738

3839moduleAsMarkdown :: Module -> Docs

3940moduleAsMarkdown Module{..} = do

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

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

4142 spacer

4243 for_ modComments tell'

4344 mapM_ (declAsMarkdown modName) modDeclarations

4445 spacer

4546 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) ++ ":"

4748 spacer

4849 mapM_ (declAsMarkdown mn) decls

4950

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

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

42-- from Language.PureScript.Docs.

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

1816import Control.Monad.State (runStateT)

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

2018import qualified Data.Map as Map

19+import qualified Data.Text as T

2120

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

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

@@ -170,7 +169,7 @@ insertValueTypes env m =

170169

171170runParser :: P.TokenParser a -> String -> Either String a

172171runParser p s = either (Left . show) Right $ do

173− ts <- P.lex "" s

172+ ts <- P.lex "" (T.pack s)

174173 P.runTokenParser "" (p <* eof) ts

175174

176175-- |

src/Language/PureScript/Docs/Convert/ReExports.hs+16−15

@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports

55import Prelude.Compat

7−import Control.Arrow ((&&&), second)

7+import Control.Arrow ((&&&), first, second)

88import Control.Monad

99import Control.Monad.Reader.Class (MonadReader, ask)

1010import Control.Monad.State.Class (MonadState, gets, modify)

@@ -16,6 +16,7 @@ import Data.Map (Map)

1616import Data.Maybe (mapMaybe)

1717import Data.Monoid ((<>))

1818import qualified Data.Map as Map

19+import qualified Data.Text as T

1920

2021import Language.PureScript.Docs.Types

2122import qualified Language.PureScript as P

@@ -52,7 +53,7 @@ updateReExports env order = execState action

5253 Just v' ->

5354 pure v'

5455 Nothing ->

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

56+ internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))

5657

5758-- |

5859-- Collect all of the re-exported declarations for a single module.

@@ -69,7 +70,7 @@ getReExports ::

6970getReExports env mn =

7071 case Map.lookup mn env of

7172 Nothing ->

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

73+ internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))

7374 Just (_, imports, exports) -> do

7475 allExports <- runReaderT (collectDeclarations imports exports) mn

7576 pure (filter notLocal allExports)

@@ -188,7 +189,7 @@ lookupValueDeclaration importedFrom ident = do

188189 decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom

189190 let

190191 rs =

191− filter (\d -> declTitle d == P.showIdent ident

192+ filter (\d -> declTitle d == T.unpack (P.showIdent ident)

192193 && (isValue d || isValueAlias d)) decls

193194 errOther other =

194195 internalErrorInModule

@@ -214,7 +215,7 @@ lookupValueDeclaration importedFrom ident = do

214215 (declChildren d))

215216

216217 matchesIdent cdecl =

217− cdeclTitle cdecl == P.showIdent ident

218+ cdeclTitle cdecl == T.unpack (P.showIdent ident)

218219

219220 matchesAndIsTypeClassMember =

220221 uncurry (&&) . (matchesIdent &&& isTypeClassMember)

@@ -238,7 +239,7 @@ lookupValueOpDeclaration

238239 -> m (P.ModuleName, [Declaration])

239240lookupValueOpDeclaration importedFrom op = do

240241 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

242243 [d] ->

243244 pure (importedFrom, [d])

244245 other ->

@@ -258,7 +259,7 @@ lookupTypeDeclaration ::

258259lookupTypeDeclaration importedFrom ty = do

259260 decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom

260261 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

262263 case ds of

263264 [d] ->

264265 pure (importedFrom, [d])

@@ -274,7 +275,7 @@ lookupTypeOpDeclaration

274275lookupTypeOpDeclaration importedFrom tyOp = do

275276 decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom

276277 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

278279 case ds of

279280 [d] ->

280281 pure (importedFrom, [d])

@@ -290,7 +291,7 @@ lookupTypeClassDeclaration

290291lookupTypeClassDeclaration importedFrom tyClass = do

291292 decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

292293 let

293− ds = filter (\d -> declTitle d == P.runProperName tyClass

294+ ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass)

294295 && isTypeClass d)

295296 decls

296297 case ds of

@@ -317,7 +318,7 @@ lookupModuleDeclarations definedIn moduleName = do

317318 Nothing ->

318319 internalErrorInModule

319320 (definedIn ++ ": module missing: "

320− ++ P.runModuleName moduleName)

321+ ++ T.unpack (P.runModuleName moduleName))

321322 Just mdl ->

322323 pure (allDeclarations mdl)

323324

@@ -447,7 +448,7 @@ filterDataConstructors

447448 -> Map P.ModuleName [Declaration]

448449 -> Map P.ModuleName [Declaration]

449450filterDataConstructors =

450− filterExportedChildren isDataConstructor P.runProperName

451+ filterExportedChildren isDataConstructor (T.unpack . P.runProperName)

451452

452453-- |

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

@@ -459,7 +460,7 @@ filterTypeClassMembers

459460 -> Map P.ModuleName [Declaration]

460461 -> Map P.ModuleName [Declaration]

461462filterTypeClassMembers =

462− filterExportedChildren isTypeClassMember P.showIdent

463+ filterExportedChildren isTypeClassMember (T.unpack . P.showIdent)

463464

464465filterExportedChildren

465466 :: (Functor f)

@@ -492,7 +493,7 @@ internalErrorInModule

492493internalErrorInModule msg = do

493494 mn <- ask

494495 internalError

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

496+ ("while collecting re-exports for module: " ++ T.unpack (P.runModuleName mn) ++

496497 ", " ++ msg)

497498

498499-- |

@@ -502,8 +503,8 @@ internalErrorInModule msg = do

502503typeClassConstraintFor :: Declaration -> Maybe P.Constraint

503504typeClassConstraintFor Declaration{..} =

504505 case declInfo of

505− TypeClassDeclaration tyArgs _ ->

506− Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)

506+ TypeClassDeclaration tyArgs _ _ ->

507+ Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing)

507508 _ ->

508509 Nothing

509510 where

src/Language/PureScript/Docs/Convert/Single.hs+40−17

@@ -5,16 +5,24 @@ module Language.PureScript.Docs.Convert.Single

66import Prelude.Compat

8+import Control.Arrow (first)

89import Control.Category ((>>>))

910import Control.Monad

1011

12+import Data.Bifunctor (bimap)

1113import Data.Either

1214import Data.List (nub)

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

1420

1521import Language.PureScript.Docs.Types

1622import qualified Language.PureScript as P

1723

24+-- TODO (Christoph): Get rid of the T.unpack s

25+

1826-- |

1927-- Convert a single Module, but ignore re-exports; any re-exported types or

2028-- values will not appear in the result.

@@ -75,7 +83,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =

7583 augmentWith (AugmentChild child) d =

7684 d { declChildren = declChildren d ++ [child] }

7785

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

86+getDeclarationTitle :: P.Declaration -> Maybe Text

7987getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

8088getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

8189getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

@@ -83,25 +91,25 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName nam

8391getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

8492getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)

8593getDeclarationTitle (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)

8795getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)

8896getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

8997getDeclarationTitle _ = Nothing

9098

9199-- | Create a basic Declaration value.

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

100+mkDeclaration :: Text -> DeclarationInfo -> Declaration

93101mkDeclaration title info =

94− Declaration { declTitle = title

102+ Declaration { declTitle = T.unpack title

95103 , declComments = Nothing

96104 , declSourceSpan = Nothing

97105 , declChildren = []

98106 , declInfo = info

99107 }

100108

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

109+basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration

102110basicDeclaration title info = Just $ Right $ mkDeclaration title info

103111

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

112+convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration

105113convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

106114 basicDeclaration title (ValueDeclaration ty)

107115convertDeclaration P.ValueDeclaration{} title =

@@ -113,27 +121,42 @@ convertDeclaration (P.ExternDeclaration _ ty) title =

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

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

115123 where

116− info = DataDeclaration dtype args

124+ info = DataDeclaration dtype (map (first T.unpack) args)

117125 children = map convertCtor ctors

118126 convertCtor (ctor', tys) =

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

127+ ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys)

120128convertDeclaration (P.ExternDataDeclaration _ kind') title =

121129 basicDeclaration title (ExternDataDeclaration kind')

122130convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

123− basicDeclaration title (TypeSynonymDeclaration args ty)

124−convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info

131+ basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)

132+convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =

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

126134 where

127− info = TypeClassDeclaration args implies

135+ info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps')

128136 children = map convertClassMember ds

129137 convertClassMember (P.PositionedDeclaration _ _ d) =

130138 convertClassMember d

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

133141 convertClassMember _ =

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

135158convertDeclaration (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))

137160 where

138161 classNameString = unQual className

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

@@ -142,7 +165,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

142165 extractProperNames (P.TypeConstructor n) = [unQual n]

143166 extractProperNames _ = []

144167

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

168+ childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp)

146169 classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys

147170convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =

148171 Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))

@@ -174,8 +197,8 @@ convertComments cs = do

174197 pure (unlines docs)

175198

176199 where

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

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

200+ toLines (P.LineComment s) = [T.unpack s]

201+ toLines (P.BlockComment s) = lines (T.unpack s)

179202

180203 stripPipe s' =

181204 case dropWhile (== ' ') s' of

@@ -196,5 +219,5 @@ collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

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

197220collectBookmarks' m =

198221 map (P.getModuleName m, )

199− (mapMaybe getDeclarationTitle

222+ (mapMaybe (fmap T.unpack . getDeclarationTitle)

200223 (P.exportedDeclarations m))

src/Language/PureScript/Docs/Render.hs+24−10

@@ -13,12 +13,16 @@ import Prelude.Compat

1313

1414import Data.Maybe (maybeToList)

1515import Data.Monoid ((<>))

16+import qualified Data.Text as T

17+import Data.Text (Text)

1618

1719import Language.PureScript.Docs.RenderedCode

1820import Language.PureScript.Docs.Types

1921import Language.PureScript.Docs.Utils.MonoidExtras

2022import qualified Language.PureScript as P

2123

24+-- TODO (Christoph): get rid of T.unpack's

25+

2226renderDeclaration :: Declaration -> RenderedCode

2327renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions

2428

@@ -31,7 +35,7 @@ renderDeclarationWithOptions opts Declaration{..} =

3135 , renderType' ty

3236 ]

3337 DataDeclaration dtype args ->

34− [ keyword (P.showDataDeclType dtype)

38+ [ keyword (T.unpack (P.showDataDeclType dtype))

3539 , renderType' (typeApp declTitle args)

3640 ]

3741 ExternDataDeclaration kind' ->

@@ -46,10 +50,11 @@ renderDeclarationWithOptions opts Declaration{..} =

4650 , syntax "="

4751 , renderType' ty

4852 ]

49− TypeClassDeclaration args implies ->

53+ TypeClassDeclaration args implies fundeps ->

5054 [ keywordClass ]

5155 ++ maybeToList superclasses

5256 ++ [renderType' (typeApp declTitle args)]

57+ ++ fundepsList

5358 ++ [keywordWhere | any isTypeClassMember declChildren]

5459

5560 where

@@ -60,6 +65,15 @@ renderDeclarationWithOptions opts Declaration{..} =

6065 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

6166 <> syntax ")" <> sp <> syntax "<="

6267

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+

6377 AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->

6478 [ keywordFixity associativity

6579 , syntax $ show precedence

@@ -74,15 +88,15 @@ renderDeclarationWithOptions opts Declaration{..} =

7488

7589 renderQualAlias :: FixityAlias -> String

7690 renderQualAlias (P.Qualified mn alias)

77− | mn == currentModule opts = renderAlias id alias

78− | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias

91+ | mn == currentModule opts = T.unpack (renderAlias id alias)

92+ | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias)

7993

8094 renderAlias

81− :: (forall a. (a -> String) -> a -> String)

95+ :: (forall a. (a -> Text) -> a -> Text)

8296 -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))

83− -> String

97+ -> Text

8498 renderAlias f

85− = either (("type " ++) . f P.runProperName)

99+ = either (("type " <>) . f P.runProperName)

86100 $ either (f P.runIdent) (f P.runProperName)

87101

88102 -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)

@@ -133,7 +147,7 @@ renderConstraintsWithOptions opts constraints

133147 (map (renderConstraintWithOptions opts) constraints)

134148

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

136−notQualified = P.Qualified Nothing . P.ProperName

150+notQualified = P.Qualified Nothing . P.ProperName . T.pack

137151

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

139153typeApp title typeArgs =

@@ -142,5 +156,5 @@ typeApp title typeArgs =

142156 (map toTypeVar typeArgs)

143157

144158toTypeVar :: (String, Maybe P.Kind) -> P.Type

145−toTypeVar (s, Nothing) = P.TypeVar s

146−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k

159+toTypeVar (s, Nothing) = P.TypeVar (T.pack s)

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

1414

1515import Data.Maybe (fromMaybe)

1616import Data.Monoid ((<>))

17+import qualified Data.Text as T

18+import Data.Text (Text)

1719

18−import Control.Arrow ((<+>))

20+import Control.Arrow ((<+>), first)

1921import Control.PatternArrows as PA

2022

2123import Language.PureScript.Crash

@@ -33,7 +35,7 @@ typeLiterals = mkPattern match

3335 match TypeWildcard{} =

3436 Just (syntax "_")

3537 match (TypeVar var) =

36− Just (ident var)

38+ Just (ident (T.unpack var))

3739 match (PrettyPrintObject row) =

3840 Just $ mintersperse sp

3941 [ syntax "{"

@@ -41,7 +43,7 @@ typeLiterals = mkPattern match

4143 , syntax "}"

4244 ]

4345 match (TypeConstructor (Qualified mn name)) =

44− Just (ctor (runProperName name) (maybeToContainingModule mn))

46+ Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn))

4547 match REmpty =

4648 Just (syntax "()")

4749 match row@RCons{} =

@@ -49,7 +51,7 @@ typeLiterals = mkPattern match

4951 match (BinaryNoParensType op l r) =

5052 Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r

5153 match (TypeOp (Qualified mn op)) =

52− Just (ident' (runOpName op) (maybeToContainingModule mn))

54+ Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn))

5355 match _ =

5456 Nothing

5557

@@ -74,8 +76,10 @@ renderConstraints deps ty =

7476-- Render code representing a Row

7577--

7678renderRow :: Type -> RenderedCode

77−renderRow = uncurry renderRow' . rowToList

79+renderRow = uncurry renderRow' . convertString . rowToList

7880 where

81+ convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type)

82+ convertString = first (map (first T.unpack))

7983 renderRow' h t = renderHead h <> renderTail t

8084

8185renderHead :: [(String, Type)] -> RenderedCode

@@ -144,7 +148,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

144148forall_ :: Pattern () Type ([String], Type)

145149forall_ = mkPattern match

146150 where

147− match (PrettyPrintForAll idents ty) = Just (idents, ty)

151+ match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)

148152 match _ = Nothing

149153

150154insertPlaceholders :: RenderTypeOptions -> Type -> Type

@@ -176,7 +180,7 @@ preprocessType opts = dePrim . insertPlaceholders opts

176180-- Render code representing a Kind

177181--

178182renderKind :: Kind -> RenderedCode

179−renderKind = kind . prettyPrintKind

183+renderKind = kind . T.unpack . prettyPrintKind

180184

181185-- |

182186-- Render code representing a Type, as it should appear inside parentheses

src/Language/PureScript/Docs/RenderedCode/Types.hs+2−2

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

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE OverloadedStrings #-}

43-- | Data types and functions for representing a simplified form of PureScript

54-- code, intended for use in e.g. HTML documentation.

@@ -38,6 +37,7 @@ import Control.Monad.Error.Class (MonadError(..))

3837

3938import Data.Aeson.BetterErrors

4039import qualified Data.Aeson as A

40+import qualified Data.Text as T

4141

4242import qualified Language.PureScript as P

4343

@@ -103,7 +103,7 @@ instance A.ToJSON ContainingModule where

103103

104104asContainingModule :: Parse e ContainingModule

105105asContainingModule =

106− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString)

106+ maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString)

107107

108108-- |

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

31module Language.PureScript.Docs.Types

42 ( module Language.PureScript.Docs.Types

53 , module ReExports

@@ -122,10 +120,10 @@ data DeclarationInfo

122120 | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type

123121

124122 -- |

125− -- A type class, with its type arguments and its superclasses. Instances and

126− -- members are represented as child declarations.

123+ -- A type class, with its type arguments, its superclasses and functional

124+ -- dependencies. Instances and members are represented as child declarations.

127125 --

128− | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

126+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])]

129127

130128 -- |

131129 -- An operator alias declaration, with the member the alias is for and the

@@ -141,7 +139,7 @@ declInfoToString (ValueDeclaration _) = "value"

141139declInfoToString (DataDeclaration _ _) = "data"

142140declInfoToString (ExternDataDeclaration _) = "externData"

143141declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

144−declInfoToString (TypeClassDeclaration _ _) = "typeClass"

142+declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

145143declInfoToString (AliasDeclaration _ _) = "alias"

146144

147145isTypeClass :: Declaration -> Bool

@@ -352,7 +350,7 @@ parseVersion' str =

352350

353351asModule :: Parse PackageError Module

354352asModule =

355− Module <$> key "name" (P.moduleNameFromString <$> asString)

353+ Module <$> key "name" (P.moduleNameFromString <$> asText)

356354 <*> key "comments" (perhaps asString)

357355 <*> key "declarations" (eachInArray asDeclaration)

358356 <*> key "reExports" (eachInArray asReExport)

@@ -413,6 +411,7 @@ asDeclarationInfo = do

413411 "typeClass" ->

414412 TypeClassDeclaration <$> key "arguments" asTypeArguments

415413 <*> key "superclasses" (eachInArray asConstraint)

414+ <*> keyOrDefault "fundeps" [] asFunDeps

416415 "alias" ->

417416 AliasDeclaration <$> key "fixity" asFixity

418417 <*> key "alias" asFixityAlias

@@ -430,6 +429,11 @@ asKind = fromAesonParser

430429asType :: Parse e P.Type

431430asType = fromAesonParser

432431

432+asFunDeps :: Parse PackageError [([String], [String])]

433+asFunDeps = eachInArray asFunDep

434+ where

435+ asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString)

436+

433437asDataDeclType :: Parse PackageError P.DataDeclType

434438asDataDeclType =

435439 withString $ \s -> case s of

@@ -478,7 +482,7 @@ asBookmarks = eachInArray asBookmark

478482

479483asBookmark :: Parse BowerError Bookmark

480484asBookmark =

481− asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

485+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)

482486 <*> nth 1 asString)

483487

484488asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

@@ -556,7 +560,7 @@ instance A.ToJSON DeclarationInfo where

556560 DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]

557561 ExternDataDeclaration kind -> ["kind" .= kind]

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

560564 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

561565

562566instance A.ToJSON ChildDeclarationInfo where

src/Language/PureScript/Environment.hs+62−11

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

1−{-# LANGUAGE OverloadedStrings #-}

21{-# LANGUAGE TemplateHaskell #-}

43module Language.PureScript.Environment where

@@ -6,10 +5,14 @@ module Language.PureScript.Environment where

65import Prelude.Compat

87import Data.Aeson.TH

9−import Data.Maybe (fromMaybe)

108import qualified Data.Aeson as A

119import qualified Data.Map as M

10+import qualified Data.Set as S

11+import Data.Maybe (fromMaybe)

12+import Data.Text (Text)

1213import qualified Data.Text as T

14+import Data.List (nub)

15+import qualified Data.Graph as G

1316

1417import Language.PureScript.Crash

1518import Language.PureScript.Kinds

@@ -27,9 +30,9 @@ data Environment = Environment

2730 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])

2831 -- ^ Data constructors currently in scope, along with their associated type

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

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

3336 -- ^ Available type class dictionaries

3437 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

3538 -- ^ Type classes

@@ -37,7 +40,7 @@ data Environment = Environment

3740

3841-- | Information about a type class

3942data TypeClassData = TypeClassData

40− { typeClassArguments :: [(String, Maybe Kind)]

43+ { typeClassArguments :: [(Text, Maybe Kind)]

4144 -- ^ A list of type argument names, and their kinds, where kind annotations

4245 -- were provided.

4346 , typeClassMembers :: [(Ident, Type)]

@@ -48,6 +51,10 @@ data TypeClassData = TypeClassData

4851 -- are considered bound in the types appearing in these constraints.

4952 , typeClassDependencies :: [FunctionalDependency]

5053 -- ^ 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.

5158 } deriving Show

5259

5360-- | A functional dependency indicates a relationship between two sets of

@@ -65,6 +72,50 @@ data FunctionalDependency = FunctionalDependency

6572initEnvironment :: Environment

6673initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

6774

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+

68119-- |

69120-- The visibility of a name in scope

70121--

@@ -105,7 +156,7 @@ data TypeKind

105156 -- |

106157 -- Data type

107158 --

108− = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

159+ = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

109160 -- |

110161 -- Type synonym

111162 --

@@ -138,7 +189,7 @@ data DataDeclType

138189 | Newtype

139190 deriving (Show, Eq, Ord)

140191

141−showDataDeclType :: DataDeclType -> String

192+showDataDeclType :: DataDeclType -> Text

142193showDataDeclType Data = "data"

143194showDataDeclType Newtype = "newtype"

144195

@@ -155,13 +206,13 @@ instance A.FromJSON DataDeclType where

155206-- |

156207-- Construct a ProperName in the Prim module

157208--

158−primName :: String -> Qualified (ProperName a)

209+primName :: Text -> Qualified (ProperName a)

159210primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

160211

161212-- |

162213-- Construct a type in the Prim module

163214--

164−primTy :: String -> Type

215+primTy :: Text -> Type

165216primTy = TypeConstructor . primName

166217

167218-- |

@@ -264,8 +315,8 @@ primTypes =

264315primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

265316primClasses =

266317 M.fromList

267− [ (primName "Partial", (TypeClassData [] [] [] []))

268− , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] []))

318+ [ (primName "Partial", (makeTypeClassData [] [] [] []))

319+ , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] []))

269320 ]

270321

271322-- |

src/Language/PureScript/Errors.hs+151−142

@@ -18,10 +18,12 @@ import Data.Char (isSpace)

1818import Data.Either (lefts, rights)

1919import Data.Foldable (fold)

2020import Data.Functor.Identity (Identity(..))

21−import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)

21+import Data.List (transpose, nub, nubBy, sortBy, partition)

2222import Data.Maybe (maybeToList, fromMaybe, mapMaybe)

2323import Data.Ord (comparing)

2424import qualified Data.Map as M

25+import qualified Data.Text as T

26+import Data.Text (Text)

2527

2628import Language.PureScript.AST

2729import Language.PureScript.Crash

@@ -43,7 +45,7 @@ import qualified Text.PrettyPrint.Boxes as Box

4345import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers

4446import Text.Parsec.Error (Message(..))

4547

46−newtype ErrorSuggestion = ErrorSuggestion String

48+newtype ErrorSuggestion = ErrorSuggestion Text

4749

4850-- | Get the source span for an error

4951errorSpan :: ErrorMessage -> Maybe SourceSpan

@@ -73,7 +75,7 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt

7375-- |

7476-- Get the error code for a particular error type

7577--

76−errorCode :: ErrorMessage -> String

78+errorCode :: ErrorMessage -> Text

7779errorCode em = case unwrapErrorMessage em of

7880 ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"

7981 ErrorParsingModule{} -> "ErrorParsingModule"

@@ -245,7 +247,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

245247 case M.lookup s (umSkolemMap m) of

246248 Nothing -> do

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

249251 return (Skolem name s' sko ss)

250252 Just (_, s', _) -> return (Skolem name s' sko ss)

251253 replaceTypes other = return other

@@ -287,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

287289 gTypeSearch (TSBefore env) = pure (TSBefore env)

288290 gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result

289291

290−wikiUri :: ErrorMessage -> String

291−wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

292+wikiUri :: ErrorMessage -> Text

293+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e

292294

293295-- TODO Other possible suggestions:

294296-- WildcardInferredType - source span not small enough

@@ -304,19 +306,19 @@ errorSuggestion err =

304306 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

305307 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

306308 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

307− MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty

308− WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty

309+ MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty)

310+ WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty)

309311 _ -> Nothing

310312 where

311313 emptySuggestion = Just $ ErrorSuggestion ""

312314 suggest = Just . ErrorSuggestion

313315

314− importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String

316+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text

315317 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

317319

318− qstr :: Maybe ModuleName -> String

319− qstr (Just mn) = " as " ++ runModuleName mn

320+ qstr :: Maybe ModuleName -> Text

321+ qstr (Just mn) = " as " <> runModuleName mn

320322 qstr Nothing = ""

321323

322324suggestionSpan :: ErrorMessage -> Maybe SourceSpan

@@ -330,7 +332,7 @@ suggestionSpan e =

330332 MissingTypeDeclaration{} -> startOnly ss

331333 _ -> ss

332334

333−showSuggestion :: SimpleErrorMessage -> String

335+showSuggestion :: SimpleErrorMessage -> Text

334336showSuggestion suggestion = case errorSuggestion suggestion of

335337 Just (ErrorSuggestion x) -> x

336338 _ -> ""

@@ -343,10 +345,10 @@ ansiColorReset :: String

343345ansiColorReset =

344346 ANSI.setSGRCode [ANSI.Reset]

345347

346−colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String

348+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text

347349colorCode codeColor code = case codeColor of

348350 Nothing -> code

349− Just cc -> concat [ansiColor cc, code, ansiColorReset]

351+ Just cc -> T.pack (ansiColor cc) <> code <> T.pack ansiColorReset

350352

351353colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box

352354colorCodeBox codeColor b = case codeColor of

@@ -403,8 +405,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

403405 ] ++

404406 maybe [] (return . Box.moveDown 1) typeInformation ++

405407 [ Box.moveDown 1 $ paras

406− [ line $ "See " ++ wikiUri e ++ " for more information, "

407− , line $ "or to contribute content related to this " ++ levelText ++ "."

408+ [ line $ "See " <> wikiUri e <> " for more information, "

409+ , line $ "or to contribute content related to this " <> levelText <> "."

408410 ]

409411 | showWiki

410412 ]

@@ -420,59 +422,59 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

420422 skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box

421423 skolemInfo (name, s, ss) =

422424 paras $

423− line (markCode (name ++ show s) ++ " is a rigid type variable")

424− : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss

425+ line (markCode (T.pack (name <> show s)) <> " is a rigid type variable")

426+ : foldMap (return . line . (" bound at " <>) . displayStartEndPos) ss

425427

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

428430

429431 renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box

430432 renderSimpleErrorMessage (CannotGetFileInfo path) =

431433 paras [ line "Unable to read file info: "

432− , indent . line $ path

434+ , indent . lineS $ path

433435 ]

434436 renderSimpleErrorMessage (CannotReadFile path) =

435437 paras [ line "Unable to read file: "

436− , indent . line $ path

438+ , indent . lineS $ path

437439 ]

438440 renderSimpleErrorMessage (CannotWriteFile path) =

439441 paras [ line "Unable to write file: "

440− , indent . line $ path

442+ , indent . lineS $ path

441443 ]

442444 renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =

443445 paras $ [ line "Unable to parse foreign module:"

444− , indent . line $ path

446+ , indent . lineS $ path

445447 ] ++

446− map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))

448+ map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra))

447449 renderSimpleErrorMessage (ErrorParsingModule err) =

448450 paras [ line "Unable to parse module: "

449451 , prettyPrintParseError err

450452 ]

451453 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."

453455 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

454− paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": "

455− , indent . line $ path

456− , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

456+ paras [ line $ "An unnecessary foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": "

457+ , indent . lineS $ path

458+ , line $ "Module " <> markCode (runModuleName mn) <> " does not contain any foreign import declarations, so a foreign module is not necessary."

457459 ]

458460 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) <> ": "

460462 , indent . paras $ map (line . runIdent) idents

461463 ]

462464 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: "

464466 , indent . paras $ map (line . runIdent) idents

465467 ]

466468 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) <> ":"

468470 , indent . paras $

469− [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."

471+ [ line $ "The identifier " <> markCode ident <> " is not valid in PureScript."

470472 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."

471473 ]

472474 ]

473475 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

474− paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": "

475− , indent . paras $ map line paths

476+ paras [ line $ "Multiple foreign module implementations have been provided for module " <> markCode (runModuleName mn) <> ": "

477+ , indent . paras $ map lineS paths

476478 ]

477479 renderSimpleErrorMessage InvalidDoBind =

478480 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

489491 , indent $ line $ markCode $ prettyPrintKind ki

490492 ]

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

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

495497 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."

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

499501 renderSimpleErrorMessage (UnknownName name) =

500− line $ "Unknown " ++ printName name

502+ line $ "Unknown " <> printName name

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

503505 , line "It either does not exist or the module does not export it."

504506 ]

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

507509 renderSimpleErrorMessage (UnknownExport name) =

508− line $ "Cannot export unknown " ++ printName (Qualified Nothing name)

510+ line $ "Cannot export unknown " <> printName (Qualified Nothing name)

509511 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."

511513 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:"

513515 , indent $ paras $ map (line . markCode . runModuleName) ms

514516 ]

515517 renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =

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

518− , line $ "These will be ignored and the " ++ case exmn of

519− Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."

518+ paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:"

519+ , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms

520+ , line $ "These will be ignored and the " <> case exmn of

521+ Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used."

520522 Nothing -> "local declaration will be used."

521523 ]

522524 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."

524526 renderSimpleErrorMessage (ExportConflict new existing) =

525− line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing

527+ line $ "Export for " <> printName new <> " conflicts with " <> runName existing

526528 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:")

528530 , indent . paras $ map (line . displaySourceSpan) ss

529531 ]

530532 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."

532534 renderSimpleErrorMessage (CycleInModules mns) =

533535 paras [ line "There is a cycle in module dependencies in these modules: "

534536 , indent $ paras (map (line . markCode . runModuleName) mns)

535537 ]

536538 renderSimpleErrorMessage (CycleInTypeSynonym name) =

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

539541 Nothing -> "A cycle appears in a set of type synonym definitions."

540542 , line "Cycles are disallowed because they can lead to loops in the type checker."

541543 , line "Consider using a 'newtype' instead."

542544 ]

543545 renderSimpleErrorMessage (NameIsUndefined ident) =

544− line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."

546+ line $ "Value " <> markCode (showIdent ident) <> " is undefined."

545547 renderSimpleErrorMessage (UndefinedTypeVariable name) =

546− line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."

548+ line $ "Type variable " <> markCode (runProperName name) <> " is undefined."

547549 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."

549551 , line "Type synonyms must be applied to all of their type arguments."

550552 ]

551553 renderSimpleErrorMessage (EscapedSkolem binding) =

@@ -561,12 +563,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

561563 sortRows t1 t2 = (t1, t2)

562564

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

565567 sortRows' (s1, r1) (s2, r2) =

566− let common :: [(String, (Type, Type))]

568+ let common :: [(Text, (Type, Type))]

567569 common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

568570

569− sd1, sd2 :: [(String, Type)]

571+ sd1, sd2 :: [(Text, Type)]

570572 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

571573 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

572574 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

597599 , Box.vcat Box.left (map typeAtomAsBox ts)

598600 ]

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

601603 , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."

602604 , line "They may be disallowed completely in a future version of the compiler."

603605 ]

@@ -667,26 +669,26 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

667669 , line "Make sure this is a newtype."

668670 ]

669671 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."

671673 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." ]

673675 <> foldMap (\expr' -> [ line "Relevant expression: "

674676 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

675677 ]) expr

676678 renderSimpleErrorMessage (DuplicateTypeArgument name) =

677− line $ "Type argument " ++ markCode name ++ " appears more than once."

679+ line $ "Type argument " <> markCode name <> " appears more than once."

678680 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

679− line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."

681+ line $ "Multiple value declarations exist for " <> markCode (showIdent nm) <> "."

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

682684 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

684686 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."

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

688690 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 "*" <> "."

690692 , line "The error arises from the type"

691693 , markCodeBox $ indent $ typeAsBox ty

692694 , line "having the kind"

@@ -694,7 +696,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

694696 , line "instead."

695697 ]

696698 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."

698700 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

699701 paras [ line "Expression"

700702 , markCodeBox $ indent $ prettyPrintValue valueDepth expr

@@ -702,13 +704,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

702704 , markCodeBox $ indent $ typeAsBox ty

703705 ]

704706 renderSimpleErrorMessage (PropertyIsMissing prop) =

705− line $ "Type of expression lacks required label " ++ markCode prop ++ "."

707+ line $ "Type of expression lacks required label " <> markCode prop <> "."

706708 renderSimpleErrorMessage (AdditionalProperty prop) =

707− line $ "Type of expression contains additional label " ++ markCode prop ++ "."

709+ line $ "Type of expression contains additional label " <> markCode prop <> "."

708710 renderSimpleErrorMessage TypeSynonymInstance =

709711 line "Type class instances for type synonyms are disallowed."

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

712714 , markCodeBox $ indent $ Box.hsep 1 Box.left

713715 [ line (showQualified runProperName cnm)

714716 , Box.vcat Box.left (map typeAtomAsBox ts)

@@ -718,38 +720,38 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

718720 , line "Consider moving the instance, if possible, or using a newtype wrapper."

719721 ]

720722 renderSimpleErrorMessage (InvalidNewtype name) =

721− paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."

723+ paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid."

722724 , line "Newtypes must define a single constructor with a single argument."

723725 ]

724726 renderSimpleErrorMessage (InvalidInstanceHead ty) =

725727 paras [ line "Type class instance head is invalid due to use of type"

726728 , 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."

728730 ]

729731 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: "

731733 , indent $ paras $ map (line . markCode . prettyPrintExport) ys

732734 ]

733735 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: "

735737 , indent $ line $ markCode $ runProperName ctor

736738 ]

737739 renderSimpleErrorMessage (ShadowedName nm) =

738− line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."

740+ line $ "Name " <> markCode (showIdent nm) <> " was shadowed."

739741 renderSimpleErrorMessage (ShadowedTypeVar tv) =

740− line $ "Type variable " ++ markCode tv ++ " was shadowed."

742+ line $ "Type variable " <> markCode tv <> " was shadowed."

741743 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."

743745 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."

745747 renderSimpleErrorMessage (ImportHidingModule name) =

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

748750 ]

749751 renderSimpleErrorMessage (WildcardInferredType ty ctx) =

750752 paras $ [ line "Wildcard type definition has the inferred type "

751753 , markCodeBox $ indent $ typeAsBox ty

752− ] ++ renderContext ctx

754+ ] <> renderContext ctx

753755 renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =

754756 let

755757 maxTSResults = 15

@@ -758,7 +760,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

758760 let

759761 formatTS (names, types) =

760762 let

761− idBoxes = Box.text . showQualified runIdent <$> names

763+ idBoxes = Box.text . T.unpack . showQualified runIdent <$> names

762764 tyBoxes = (\t -> BoxHelpers.indented

763765 (Box.text ":: " Box.<> typeAsBox t)) <$> types

764766 longestId = maximum (map Box.cols idBoxes)

@@ -772,13 +774,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

772774 ]

773775 _ -> []

774776 in

775− paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "

777+ paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type "

776778 , markCodeBox (indent (typeAsBox ty))

777779 ] ++ tsResult ++ renderContext ctx

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

780782 , 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:"

782784 , markCodeBox $ indent $ typeAsBox ty

783785 ]

784786 renderSimpleErrorMessage (OverlappingPattern bs b) =

@@ -791,70 +793,70 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

791793 , line "You may want to decompose your data types into smaller types."

792794 ]

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

795797

796798 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:"

798800 , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names

799801 , line "It could be replaced with:"

800802 , indent $ line $ markCode $ showSuggestion msg ]

801803

802804 renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =

803− paras [line $ "The import of type " ++ markCode (runProperName name)

804− ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used"

805+ paras [line $ "The import of type " <> markCode (runProperName name)

806+ <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used"

805807 , line "It could be replaced with:"

806808 , indent $ line $ markCode $ showSuggestion msg ]

807809

808810 renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =

809− paras [ line $ "The import of type " ++ markCode (runProperName name)

810− ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:"

811+ paras [ line $ "The import of type " <> markCode (runProperName name)

812+ <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:"

811813 , indent $ paras $ map (line . markCode . runProperName) names

812814 , line "It could be replaced with:"

813815 , indent $ line $ markCode $ showSuggestion msg ]

814816

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

817819

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

820822

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

823825

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

826828

827829 renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =

828− paras [ line $ "Integer value " ++ markCode (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)." ]

830+ paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend."

831+ , line $ "Acceptable values fall within the range " <> markCode (T.pack (show lo)) <> " to " <> markCode (T.pack (show hi)) <> " (inclusive)." ]

830832

831833 renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

832− 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:"

834+ paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports."

835+ , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:"

834836 , indent $ line $ markCode $ showSuggestion msg

835837 ]

836838

837839 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: "

839841 , indent $ line $ markCode $ showSuggestion msg

840842 ]

841843

842844 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: "

844846 , indent $ line $ markCode $ showSuggestion msg

845847 ]

846848

847849 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

848850 paras [ line "Binder list length differs in case alternative:"

849− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

850− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."

851+ , indent $ line $ T.intercalate ", " $ fmap prettyPrintBinderAtom bs

852+ , line $ "Expecting " <> T.pack (show l) <> " binder" <> (if l == 1 then "" else "s") <> "."

851853 ]

852854

853855 renderSimpleErrorMessage IncorrectAnonymousArgument =

854856 line "An anonymous function argument appears in an invalid context."

855857

856858 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 <> "."

858860 , line "Only aliases for data constructors may be used in patterns."

859861 ]

860862

@@ -862,18 +864,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

862864 line "The require-path option is deprecated and will be removed in PureScript 0.9."

863865

864866 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

865− paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."

866− , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"

867+ paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

868+ , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

867869 , markCodeBox $ indent $ typeAsBox ty

868870 , line "Try adding a type signature."

869871 ]

870872

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

873875 ]

874876

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

877879 ]

878880

879881 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

@@ -893,7 +895,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

893895 ]

894896 ]

895897 renderHint (ErrorInModule mn) detail =

896− paras [ line $ "in module " ++ markCode (runModuleName mn)

898+ paras [ line $ "in module " <> markCode (runModuleName mn)

897899 , detail

898900 ]

899901 renderHint (ErrorInSubsumption t1 t2) detail =

@@ -958,35 +960,39 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

958960 ]

959961 renderHint (ErrorInDataConstructor nm) detail =

960962 paras [ detail

961− , line $ "in data constructor " ++ markCode (runProperName nm)

963+ , line $ "in data constructor " <> markCode (runProperName nm)

962964 ]

963965 renderHint (ErrorInTypeConstructor nm) detail =

964966 paras [ detail

965− , line $ "in type constructor " ++ markCode (runProperName nm)

967+ , line $ "in type constructor " <> markCode (runProperName nm)

966968 ]

967969 renderHint (ErrorInBindingGroup nms) detail =

968970 paras [ detail

969− , line $ "in binding group " ++ intercalate ", " (map showIdent nms)

971+ , line $ "in binding group " <> T.intercalate ", " (map showIdent nms)

970972 ]

971− renderHint ErrorInDataBindingGroup detail =

973+ renderHint (ErrorInDataBindingGroup nms) detail =

972974 paras [ detail

973− , line "in data binding group"

975+ , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms)

974976 ]

975977 renderHint (ErrorInTypeSynonym name) detail =

976978 paras [ detail

977− , line $ "in type synonym " ++ markCode (runProperName name)

979+ , line $ "in type synonym " <> markCode (runProperName name)

978980 ]

979981 renderHint (ErrorInValueDeclaration n) detail =

980982 paras [ detail

981− , line $ "in value declaration " ++ markCode (showIdent n)

983+ , line $ "in value declaration " <> markCode (showIdent n)

982984 ]

983985 renderHint (ErrorInTypeDeclaration n) detail =

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

986992 ]

987993 renderHint (ErrorInForeignImport nm) detail =

988994 paras [ detail

989− , line $ "in foreign import " ++ markCode (showIdent nm)

995+ , line $ "in foreign import " <> markCode (showIdent nm)

990996 ]

991997 renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =

992998 paras [ detail

@@ -997,7 +1003,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

9971003 ]

9981004 ]

9991005 renderHint (PositionedError srcSpan) detail =

1000− paras [ line $ "at " ++ displaySourceSpan srcSpan

1006+ paras [ line $ "at " <> displaySourceSpan srcSpan

10011007 , detail

10021008 ]

10031009

@@ -1006,17 +1012,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

10061012 renderContext ctx =

10071013 [ line "in the following context:"

10081014 , indent $ paras

1009− [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")

1015+ [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ")

10101016 , markCodeBox $ typeAsBox ty'

10111017 ]

10121018 | (ident, ty') <- take 5 ctx

10131019 ]

10141020 ]

10151021

1016− printName :: Qualified Name -> String

1017− printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)

1022+ printName :: Qualified Name -> Text

1023+ printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn)

10181024

1019− nameType :: Name -> String

1025+ nameType :: Name -> Text

10201026 nameType (IdentName _) = "value"

10211027 nameType (ValOpName _) = "operator"

10221028 nameType (TyName _) = "type"

@@ -1025,7 +1031,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

10251031 nameType (TyClassName _) = "type class"

10261032 nameType (ModName _) = "module"

10271033

1028− runName :: Qualified Name -> String

1034+ runName :: Qualified Name -> Text

10291035 runName (Qualified mn (IdentName name)) =

10301036 showQualified showIdent (Qualified mn name)

10311037 runName (Qualified mn (ValOpName op)) =

@@ -1047,7 +1053,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

10471053 valueDepth | full = 1000

10481054 | otherwise = 3

10491055

1050− levelText :: String

1056+ levelText :: Text

10511057 levelText = case level of

10521058 Error -> "error"

10531059 Warning -> "warning"

@@ -1108,40 +1114,40 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

11081114 hintCategory _ = OtherHint

11091115

11101116-- Pretty print and export declaration

1111−prettyPrintExport :: DeclarationRef -> String

1117+prettyPrintExport :: DeclarationRef -> Text

11121118prettyPrintExport (TypeRef pn _) = runProperName pn

11131119prettyPrintExport ref =

11141120 fromMaybe

11151121 (internalError "prettyPrintRef returned Nothing in prettyPrintExport")

11161122 (prettyPrintRef ref)

11171123

1118−prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1124+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text

11191125prettyPrintImport mn idt qual =

11201126 let i = case idt of

11211127 Implicit -> runModuleName mn

1122− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"

1123− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"

1124− in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1128+ Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")"

1129+ Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate "," (mapMaybe prettyPrintRef refs) <> ")"

1130+ in i <> maybe "" (\q -> " as " <> runModuleName q) qual

11251131

1126−prettyPrintRef :: DeclarationRef -> Maybe String

1132+prettyPrintRef :: DeclarationRef -> Maybe Text

11271133prettyPrintRef (TypeRef pn Nothing) =

1128− Just $ runProperName pn ++ "(..)"

1134+ Just $ runProperName pn <> "(..)"

11291135prettyPrintRef (TypeRef pn (Just [])) =

11301136 Just $ runProperName pn

11311137prettyPrintRef (TypeRef pn (Just dctors)) =

1132− Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1138+ Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")"

11331139prettyPrintRef (TypeOpRef op) =

1134− Just $ "type " ++ showOp op

1140+ Just $ "type " <> showOp op

11351141prettyPrintRef (ValueRef ident) =

11361142 Just $ showIdent ident

11371143prettyPrintRef (ValueOpRef op) =

11381144 Just $ showOp op

11391145prettyPrintRef (TypeClassRef pn) =

1140− Just $ "class " ++ runProperName pn

1146+ Just $ "class " <> runProperName pn

11411147prettyPrintRef (TypeInstanceRef ident) =

11421148 Just $ showIdent ident

11431149prettyPrintRef (ModuleRef name) =

1144− Just $ "module " ++ runModuleName name

1150+ Just $ "module " <> runModuleName name

11451151prettyPrintRef (ReExportRef _ _) =

11461152 Nothing

11471153prettyPrintRef (PositionedDeclarationRef _ _ ref) =

@@ -1234,8 +1240,11 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

12341240indent :: Box.Box -> Box.Box

12351241indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2

12361242

1237−line :: String -> Box.Box

1238−line = Box.text

1243+line :: Text -> Box.Box

1244+line = Box.text . T.unpack

1245+

1246+lineS :: String -> Box.Box

1247+lineS = Box.text

12391248

12401249renderBox :: Box.Box -> String

12411250renderBox = unlines

@@ -1249,7 +1258,7 @@ renderBox = unlines

12491258 whiteSpace = all isSpace

12501259

12511260toTypelevelString :: Type -> Maybe Box.Box

1252−toTypelevelString (TypeLevelString s) = Just $ Box.text s

1261+toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s)

12531262toTypelevelString (TypeApp (TypeConstructor f) x)

12541263 | f == primName "TypeString" = Just $ typeAsBox x

12551264toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

src/Language/PureScript/Errors/JSON.hs+8−5

@@ -5,6 +5,9 @@ module Language.PureScript.Errors.JSON where

55import Prelude.Compat

77import qualified Data.Aeson.TH as A

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

9+import qualified Data.Text as T

10+import Data.Text (Text)

811

912import qualified Language.PureScript as P

1013

@@ -16,17 +19,17 @@ data ErrorPosition = ErrorPosition

1619 } deriving (Show, Eq, Ord)

1720

1821data ErrorSuggestion = ErrorSuggestion

19− { replacement :: String

22+ { replacement :: Text

2023 , replaceRange :: Maybe ErrorPosition

2124 } deriving (Show, Eq)

2225

2326data JSONError = JSONError

2427 { position :: Maybe ErrorPosition

2528 , message :: String

26− , errorCode :: String

27− , errorLink :: String

29+ , errorCode :: Text

30+ , errorLink :: Text

2831 , filename :: Maybe String

29− , moduleName :: Maybe String

32+ , moduleName :: Maybe Text

3033 , suggestion :: Maybe ErrorSuggestion

3134 } deriving (Show, Eq)

3235

@@ -70,4 +73,4 @@ toJSONError verbose level e =

7073 Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)

7174

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

1717import Prelude.Compat

1818

1919import Data.Aeson.TH

20+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)

21+import Data.List (foldl', find)

2022import Data.Foldable (fold)

21−import Data.List (find, foldl')

22−import Data.Maybe (mapMaybe, maybeToList, fromMaybe)

23+import Data.Text (Text)

24+import qualified Data.Text as T

2325import Data.Version (showVersion)

2426import qualified Data.Map as M

2527

@@ -37,7 +39,7 @@ import Paths_purescript as Paths

3739data ExternsFile = ExternsFile

3840 {

3941 -- | The externs version

40− efVersion :: String

42+ efVersion :: Text

4143 -- | Module name

4244 , efModuleName :: ModuleName

4345 -- | List of module exports

@@ -100,7 +102,7 @@ data ExternsDeclaration =

100102 -- | A type synonym

101103 | EDTypeSynonym

102104 { edTypeSynonymName :: ProperName 'TypeName

103− , edTypeSynonymArguments :: [(String, Maybe Kind)]

105+ , edTypeSynonymArguments :: [(Text, Maybe Kind)]

104106 , edTypeSynonymType :: Type

105107 }

106108 -- | A data construtor

@@ -119,7 +121,7 @@ data ExternsDeclaration =

119121 -- | A type class declaration

120122 | EDClass

121123 { edClassName :: ProperName 'ClassName

122− , edClassTypeArguments :: [(String, Maybe Kind)]

124+ , edClassTypeArguments :: [(Text, Maybe Kind)]

123125 , edClassMembers :: [(Ident, Type)]

124126 , edClassConstraints :: [Constraint]

125127 , edFunctionalDependencies :: [FunctionalDependency]

@@ -142,10 +144,10 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

142144 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }

143145 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

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

146148 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

147149 where

148− dict :: TypeClassDictionaryInScope

150+ dict :: NamedDict

149151 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs

150152

151153 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a

@@ -159,7 +161,7 @@ moduleToExternsFile :: Module -> Environment -> ExternsFile

159161moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"

160162moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

161163 where

162− efVersion = showVersion Paths.version

164+ efVersion = T.pack (showVersion Paths.version)

163165 efModuleName = mn

164166 efExports = exps

165167 efImports = mapMaybe importDecl ds

@@ -180,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

180182 typeFixityDecl _ = Nothing

181183

182184 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

184186

185187 importDecl :: Declaration -> Maybe ExternsImport

186188 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)

src/Language/PureScript/Ide.hs+8−11

@@ -12,7 +12,6 @@

1212-- Interface for the psc-ide-server

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

1615{-# LANGUAGE PackageImports #-}

1716{-# LANGUAGE TemplateHaskell #-}

1817

@@ -110,7 +109,7 @@ findPursuitPackages (PursuitQuery q) =

110109 PursuitResult <$> liftIO (findPackagesForModuleIdent q)

111110

112111printModules :: Ide m => m Success

113−printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames

112+printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames

114113

115114outputDirectory :: Ide m => m FilePath

116115outputDirectory = do

@@ -142,7 +141,7 @@ findAvailableExterns = do

142141 liftIO $ do

143142 directories <- getDirectoryContents oDir

144143 moduleNames <- filterM (containsExterns oDir) directories

145− pure (P.moduleNameFromString <$> moduleNames)

144+ pure (P.moduleNameFromString . toS <$> moduleNames)

146145 where

147146 -- Takes the output directory and a filepath like "Monad.Control.Eff" and

148147 -- looks up, whether that folder contains an externs.json

@@ -171,26 +170,24 @@ loadModules moduleNames = do

171170 -- We resolve all the modulenames to externs files and load these into memory.

172171 oDir <- outputDirectory

173172 let efPaths =

174− map (\mn -> oDir </> P.runModuleName mn </> "externs.json") moduleNames

173+ map (\mn -> oDir </> toS (P.runModuleName mn) </> "externs.json") moduleNames

175174 efiles <- traverse readExternFile efPaths

176175 traverse_ insertExterns efiles

177176

178− -- We parse all source files, log eventual parse failures if the debug flag

179− -- was set and insert the succesful parses into the state.

177+ -- We parse all source files, log eventual parse failures and insert the

178+ -- successful parses into the state.

180179 (failures, allModules) <-

181180 partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)

182181 unless (null failures) $

183− $(logDebug) ("Failed to parse: " <> show failures)

182+ $(logWarn) ("Failed to parse: " <> show failures)

184183 traverse_ insertModule allModules

185184

186185 -- Finally we kick off the worker with @async@ and return the number of

187186 -- successfully parsed modules.

188187 env <- ask

189− let runLogger =

190− runStdoutLoggingT

191− . filterLogger (\_ _ -> confDebug (ideConfiguration env))

188+ let ll = confLogLevel (ideConfiguration env)

192189 -- populateStage2 and 3 return Unit for now, so it's fine to discard this

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

195192 pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "

196193 <> show (length allModules) <> " source files."))

src/Language/PureScript/Ide/CaseSplit.hs+4−6

@@ -12,8 +12,6 @@

1212-- Casesplitting and adding function clauses

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

1715module Language.PureScript.Ide.CaseSplit

1816 ( WildcardAnnotations()

1917 , explicitAnnotations

@@ -84,9 +82,9 @@ splitTypeConstructor = go []

8482 go _ _ = throwError (GeneralError "Failed to read TypeConstructor")

8583

8684prettyCtor :: WildcardAnnotations -> Constructor -> Text

87−prettyCtor _ (ctorName, []) = runProperNameT ctorName

85+prettyCtor _ (ctorName, []) = P.runProperName ctorName

8886prettyCtor wsa (ctorName, ctorArgs) =

89− "("<> runProperNameT ctorName <> " "

87+ "("<> P.runProperName ctorName <> " "

9088 <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"

9189

9290prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text

@@ -111,9 +109,9 @@ addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Tex

111109addClause s wca = do

112110 (fName, fType) <- parseTypeDeclaration' s

113111 let args = splitFunctionType fType

114− template = runIdentT fName <> " " <>

112+ template = P.runIdent fName <> " " <>

115113 T.unwords (map (prettyPrintWildcard wca) args) <>

116− " = ?" <> (T.strip . runIdentT $ fName)

114+ " = ?" <> (T.strip . P.runIdent $ fName)

117115 pure [s, template]

118116

119117parseType' :: (MonadError PscIdeError m) =>

src/Language/PureScript/Ide/Command.hs+15−3

@@ -12,9 +12,6 @@

1212-- Datatypes for the commands psc-ide accepts

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

17−

1815module Language.PureScript.Ide.Command where

1916

2017import Protolude

@@ -61,6 +58,21 @@ data Command

6158 | Reset

6259 | Quit

6360

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+

6476data ImportCommand

6577 = AddImplicitImport P.ModuleName

6678 | AddImportForIdentifier Text

src/Language/PureScript/Ide/Completion.hs−1

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

1−{-# LANGUAGE OverloadedStrings #-}

21module Language.PureScript.Ide.Completion

32 ( getCompletions

43 , getExactMatches

src/Language/PureScript/Ide/Conversions.hs+4−16

@@ -15,27 +15,15 @@

1515module Language.PureScript.Ide.Conversions where

1616

1717import Control.Lens.Iso

18−import Data.Text (lines, strip, unwords)

18+import Data.Text (lines, strip, unwords, pack)

1919import qualified Language.PureScript as P

2020import Protolude

2121

22−runProperNameT :: P.ProperName a -> Text

23−runProperNameT = toS . P.runProperName

24−

2522properNameT :: Iso' (P.ProperName a) Text

26−properNameT = iso (toS . P.runProperName) (P.ProperName . toS)

27−

28−runIdentT :: P.Ident -> Text

29−runIdentT = toS . P.runIdent

23+properNameT = iso P.runProperName P.ProperName

3024

3125identT :: Iso' P.Ident Text

32−identT = iso (toS . P.runIdent) (P.Ident . toS)

33−

34−runOpNameT :: P.OpName a -> Text

35−runOpNameT = toS . P.runOpName

36−

37−runModuleNameT :: P.ModuleName -> Text

38−runModuleNameT = toS . P.runModuleName

26+identT = iso P.runIdent P.Ident

3927

4028prettyTypeT :: 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 @@

1212-- Error types for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

1615module Language.PureScript.Ide.Error

1716 ( PscIdeError(..)

1817 ) where

src/Language/PureScript/Ide/Externs.hs+25−13

@@ -12,8 +12,7 @@

1212-- Handles externs files for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE RecordWildCards #-}

15+{-# LANGUAGE PackageImports #-}

1716

1817module Language.PureScript.Ide.Externs

1918 ( readExternFile

@@ -23,25 +22,38 @@ module Language.PureScript.Ide.Externs

2322

2423import Protolude

2524

26−import Control.Lens ((^.))

27−import Data.Aeson (decodeStrict)

28−import qualified Data.ByteString as BS

29−import Data.List (nub)

30−import qualified Data.Map as Map

25+import Control.Lens ((^.))

26+import "monad-logger" Control.Monad.Logger

27+import Data.Aeson (decodeStrict)

28+import qualified Data.ByteString as BS

29+import qualified Data.Map as Map

30+import Data.Version (showVersion)

3131import Language.PureScript.Ide.Error (PscIdeError (..))

3232import Language.PureScript.Ide.Types

3333import Language.PureScript.Ide.Util

3434

35−import qualified Language.PureScript as P

35+import qualified Language.PureScript as P

3636

37−readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

37+readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>

3838 FilePath -> m P.ExternsFile

3939readExternFile fp = do

4040 parseResult <- liftIO (decodeStrict <$> BS.readFile fp)

4141 case parseResult of

42− Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"

42+ Nothing ->

43+ throwError (GeneralError

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)

4352 Just externs -> pure externs

4453

54+ where

55+ version = toS (showVersion P.version)

56+

4557convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])

4658convertExterns ef =

4759 ((P.efModuleName ef, decls), exportDecls)

@@ -55,7 +67,7 @@ convertExterns ef =

5567 declarations = mapMaybe convertDecl (P.efDeclarations ef)

5668

5769 typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)

58− cleanDeclarations = nub $ appEndo typeClassFilter declarations

70+ cleanDeclarations = ordNub (appEndo typeClassFilter declarations)

5971

6072removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]

6173removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)

@@ -120,13 +132,13 @@ annotateModule (defs, types) (moduleName, decls) =

120132 IdeDeclDataConstructor dtor ->

121133 annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)

122134 IdeDeclTypeClass i ->

123− annotateType (runProperNameT i) (IdeDeclTypeClass i)

135+ annotateType (i ^. properNameT) (IdeDeclTypeClass i)

124136 IdeDeclValueOperator op ->

125137 annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

126138 IdeDeclTypeOperator op ->

127139 annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

128140 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

130142 , annTypeAnnotation = Map.lookup x types

131143 })

132144 annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})

src/Language/PureScript/Ide/Filter.hs−1

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

1313-----------------------------------------------------------------------------

1414

1515{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16−{-# LANGUAGE OverloadedStrings #-}

1716

1817module Language.PureScript.Ide.Filter

1918 ( Filter

src/Language/PureScript/Ide/Imports.hs+5−7

@@ -12,8 +12,6 @@

1212-- Provides functionality to manage imports

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

1715module Language.PureScript.Ide.Imports

1816 ( addImplicitImport

1917 , addImportForIdentifier

@@ -145,7 +143,7 @@ step (Res start end) _ = Res start end

145143

146144moduleParse :: [Text] -> Either Text P.Module

147145moduleParse t = first show $ do

148− tokens <- (P.lex "" . T.unpack . T.unlines) t

146+ tokens <- P.lex "" (T.unlines t)

149147 P.runTokenParser "<psc-ide>" P.parseModule tokens

150148

151149-- | Adds an implicit import like @import Prelude@ to a Sourcefile.

@@ -210,7 +208,7 @@ addExplicitImport' decl moduleName imports =

210208 refFromDeclaration (IdeDeclTypeOperator op) =

211209 P.TypeOpRef (op ^. ideTypeOpName)

212210 refFromDeclaration d =

213− P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)

211+ P.ValueRef (P.Ident (identifierFromIdeDeclaration d))

214212

215213 -- | Adds a declaration to an import:

216214 -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)

@@ -304,9 +302,9 @@ addImportForIdentifier fp ident filters = do

304302prettyPrintImport' :: Import -> Text

305303-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs

306304prettyPrintImport' (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

308306prettyPrintImport' (Import mn idt qual) =

309− T.pack $ "import " ++ P.prettyPrintImport mn idt qual

307+ "import " <> P.prettyPrintImport mn idt qual

310308

311309prettyPrintImportSection :: [Import] -> [Text]

312310prettyPrintImportSection imports = map prettyPrintImport' (sort imports)

@@ -325,7 +323,7 @@ answerRequest outfp rs =

325323-- | Test and ghci helper

326324parseImport :: Text -> Maybe Import

327325parseImport t =

328− case P.lex "<psc-ide>" (T.unpack t)

326+ case P.lex "<psc-ide>" t

329327 >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of

330328 Right (mn, P.Explicit refs, mmn) ->

331329 Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)

src/Language/PureScript/Ide/Logging.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE PackageImports #-}

3+module Language.PureScript.Ide.Logging

4+ ( runLogger

5+ , logPerf

6+ , displayTimeSpec

7+ ) where

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

1414

1515{-# LANGUAGE FlexibleInstances #-}

1616{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17−{-# LANGUAGE OverloadedStrings #-}

1817

1918module Language.PureScript.Ide.Matcher

2019 ( Matcher

src/Language/PureScript/Ide/Pursuit.hs+1−3

@@ -12,8 +12,6 @@

1212-- Pursuit client for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

1715module Language.PureScript.Ide.Pursuit

1816 ( searchPursuitForDeclarations

1917 , findPackagesForModuleIdent

@@ -36,7 +34,7 @@ import qualified Pipes.Prelude as P

3634queryPursuit :: Text -> IO ByteString

3735queryPursuit q = do

3836 let qClean = T.dropWhileEnd (== '.') q

39− req' <- parseRequest "http://pursuit.purescript.org/search"

37+ req' <- parseRequest "https://pursuit.purescript.org/search"

4038 let req = req'

4139 { queryString= "q=" <> (fromString . T.unpack) qClean

4240 , requestHeaders=[(hAccept, "application/json")]

src/Language/PureScript/Ide/Rebuild.hs+1−5

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

1−{-# LANGUAGE OverloadedStrings #-}

21{-# LANGUAGE PackageImports #-}

3−{-# LANGUAGE RecordWildCards #-}

42{-# LANGUAGE TemplateHaskell #-}

5−{-# LANGUAGE TupleSections #-}

74module Language.PureScript.Ide.Rebuild

85 ( rebuildFile

@@ -20,7 +17,6 @@ import Language.PureScript.Errors.JSON

2017import Language.PureScript.Ide.Error

2118import Language.PureScript.Ide.State

2219import Language.PureScript.Ide.Types

23−import Language.PureScript.Ide.Util

2420import System.IO.UTF8 (readUTF8FileT)

2521

2622-- | Given a filepath performs the following steps:

@@ -96,7 +92,7 @@ rebuildModuleOpen makeEnv externs m = do

9692 throwError (GeneralError "Failed when rebuilding with open exports")

9793 Right result -> do

9894 $(logDebug)

99− ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result))

95+ ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result))

10096 cacheRebuild result

10197

10298-- | Parameters we can access while building our @MakeActions@

src/Language/PureScript/Ide/Reexports.hs+1−4

@@ -13,9 +13,6 @@

1313-- Resolves reexports for psc-ide

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE RecordWildCards #-}

18−

1916module Language.PureScript.Ide.Reexports

2017 ( resolveReexports

2118 , prettyPrintReexportResult

@@ -53,7 +50,7 @@ prettyPrintReexportResult f ReexportResult{..}

5350 | otherwise =

5451 "Failed to resolve reexports for "

5552 <> f reResolved

56− <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed

53+ <> foldMap (\(mn, ref) -> P.runModuleName mn <> show ref) reFailed

5754

5855-- | Whether any Refs couldn't be resolved

5956reexportHasFailures :: ReexportResult a -> Bool

src/Language/PureScript/Ide/SourceFile.hs+11−13

@@ -12,8 +12,6 @@

1212-- Getting declarations from PureScript sourcefiles

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

1715module Language.PureScript.Ide.SourceFile

1816 ( parseModule

1917 , getImportsForFile

@@ -60,9 +58,9 @@ getImportsForFile fp = do

6058 where

6159 mkModuleImport (mn, importType', qualifier) =

6260 ModuleImport

63− (runModuleNameT mn)

61+ (P.runModuleName mn)

6462 importType'

65− (runModuleNameT <$> qualifier)

63+ (P.runModuleName <$> qualifier)

6664 unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)

6765 unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)

6866 unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)

@@ -101,27 +99,27 @@ extractSpans ss d = case d of

10199 P.PositionedDeclaration ss' _ d' ->

102100 extractSpans ss' d'

103101 P.ValueDeclaration i _ _ _ ->

104− [(Left (runIdentT i), ss)]

102+ [(Left (P.runIdent i), ss)]

105103 P.TypeSynonymDeclaration name _ _ ->

106− [(Right (runProperNameT name), ss)]

104+ [(Right (P.runProperName name), ss)]

107105 P.TypeClassDeclaration name _ _ _ members ->

108− (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members

106+ (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members

109107 P.DataDeclaration _ name _ ctors ->

110− (Right (runProperNameT name), ss)

111− : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors

108+ (Right (P.runProperName name), ss)

109+ : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors

112110 P.ExternDeclaration ident _ ->

113− [(Left (runIdentT ident), ss)]

111+ [(Left (P.runIdent ident), ss)]

114112 P.ExternDataDeclaration name _ ->

115− [(Right (runProperNameT name), ss)]

113+ [(Right (P.runProperName name), ss)]

116114 _ -> []

117115 where

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

120118 -- declarations for non-typeclass members, which is why we can't handle them

121119 -- in extractSpans.

122120 extractSpans' ssP dP = case dP of

123121 P.PositionedDeclaration ssP' _ dP' ->

124122 extractSpans' ssP' dP'

125123 P.TypeDeclaration ident _ ->

126− [(Left (runIdentT ident), ssP)]

124+ [(Left (P.runIdent ident), ssP)]

127125 _ -> []

src/Language/PureScript/Ide/State.hs+5−16

@@ -12,7 +12,6 @@

1212-- Functions to access psc-ide's state

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

1615{-# LANGUAGE PackageImports #-}

1716{-# LANGUAGE TemplateHaskell #-}

1817

@@ -32,7 +31,6 @@ module Language.PureScript.Ide.State

3231 , resolveOperatorsForModule

3332 ) where

3433

35−import qualified Prelude

3634import Protolude

3735

3836import Control.Concurrent.STM

@@ -46,7 +44,6 @@ import Language.PureScript.Ide.Reexports

4644import Language.PureScript.Ide.SourceFile

4745import Language.PureScript.Ide.Types

4846import Language.PureScript.Ide.Util

49−import System.Clock

5047

5148-- | Resets all State inside psc-ide

5249resetIdeState :: Ide m => m ()

@@ -179,12 +176,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3

179176populateStage2 :: (Ide m, MonadLogger m) => m ()

180177populateStage2 = do

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

188181

189182-- | STM version of populateStage2

190183populateStage2STM :: TVar IdeState -> STM ()

@@ -197,15 +190,11 @@ populateStage2STM ref = do

197190populateStage3 :: (Ide m, MonadLogger m) => m ()

198191populateStage3 = do

199192 st <- ideStateVar <$> ask

200− (duration, results) <- liftIO $ do

201− start <- getTime Monotonic

202− results <- atomically (populateStage3STM st)

203− end <- getTime Monotonic

204− pure (Prelude.show (diffTimeSpec start end), results)

193+ let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration

194+ results <- logPerf message (liftIO (atomically (populateStage3STM st)))

205195 traverse_

206− (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))

196+ (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))

207197 (filter reexportHasFailures results)

208− $(logDebug) $ "Finished populating Stage3 in " <> toS duration

209198

210199-- | STM version of populateStage3

211200populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

src/Language/PureScript/Ide/Types.hs+9−8

@@ -12,9 +12,8 @@

1212-- Type definitions for psc-ide

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE DeriveFoldable #-}

16−{-# LANGUAGE OverloadedStrings #-}

17−{-# LANGUAGE TemplateHaskell #-}

15+{-# LANGUAGE DeriveFoldable #-}

16+{-# LANGUAGE TemplateHaskell #-}

1817

1918module Language.PureScript.Ide.Types where

2019

@@ -26,7 +25,6 @@ import Data.Aeson

2625import qualified Data.Map.Lazy as M

2726import qualified Language.PureScript as P

2827import qualified Language.PureScript.Errors.JSON as P

29−import Language.PureScript.Ide.Conversions

3028

3129type ModuleIdent = Text

3230

@@ -111,10 +109,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation

111109 -- annotations found in a module

112110 deriving (Show, Eq, Ord, Functor, Foldable)

113111

112+data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone

113+ deriving (Show, Eq)

114+

114115data Configuration =

115116 Configuration

116117 { confOutputPath :: FilePath

117− , confDebug :: Bool

118+ , confLogLevel :: IdeLogLevel

118119 , confGlobs :: [FilePath]

119120 }

120121

@@ -210,9 +211,9 @@ instance ToJSON ModuleImport where

210211 ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)

211212

212213identifierFromDeclarationRef :: P.DeclarationRef -> Text

213−identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name

214−identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident

215−identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name

214+identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name

215+identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident

216+identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name

216217identifierFromDeclarationRef _ = ""

217218

218219data Success =

src/Language/PureScript/Ide/Util.hs+15−14

@@ -12,8 +12,6 @@

1212-- Generally useful functions

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE OverloadedStrings #-}

16−

1715module Language.PureScript.Ide.Util

1816 ( identifierFromIdeDeclaration

1917 , unwrapMatch

@@ -27,17 +25,20 @@ module Language.PureScript.Ide.Util

2725 , valueOperatorAliasT

2826 , typeOperatorAliasT

2927 , module Language.PureScript.Ide.Conversions

28+ , module Language.PureScript.Ide.Logging

3029 ) where

3130

31+import Protolude hiding (decodeUtf8,

32+ encodeUtf8)

33+

3234import Control.Lens ((^.))

3335import Data.Aeson

3436import qualified Data.Text as T

3537import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

3638import qualified Language.PureScript as P

3739import Language.PureScript.Ide.Conversions

40+import Language.PureScript.Ide.Logging

3841import Language.PureScript.Ide.Types

39−import Protolude hiding (decodeUtf8,

40− encodeUtf8)

4142

4243identifierFromIdeDeclaration :: IdeDeclaration -> Text

4344identifierFromIdeDeclaration d = case d of

@@ -45,9 +46,9 @@ identifierFromIdeDeclaration d = case d of

4546 IdeDeclType t -> t ^. ideTypeName . properNameT

4647 IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT

4748 IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT

48− IdeDeclTypeClass name -> runProperNameT name

49− IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT

50− IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT

49+ IdeDeclTypeClass name -> P.runProperName name

50+ IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName

51+ IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName

5152

5253discardAnn :: IdeDeclarationAnn -> IdeDeclaration

5354discardAnn (IdeDeclarationAnn _ d) = d

@@ -67,13 +68,13 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

6768 IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )

6869 IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)

6970 IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)

70− IdeDeclTypeClass name -> (runProperNameT name, "class")

71+ IdeDeclTypeClass name -> (P.runProperName name, "class")

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

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

7576

76− complModule = runModuleNameT m

77+ complModule = P.runModuleName m

7778

7879 complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)

7980

@@ -86,17 +87,17 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

8687 P.Infix -> "infix"

8788 P.Infixl -> "infixl"

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

9091

9192valueOperatorAliasT

9293 :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text

9394valueOperatorAliasT i =

94− toS (P.showQualified (either P.runIdent P.runProperName) i)

95+ P.showQualified (either P.runIdent P.runProperName) i

9596

9697typeOperatorAliasT

9798 :: P.Qualified (P.ProperName 'P.TypeName) -> Text

9899typeOperatorAliasT i =

99− toS (P.showQualified P.runProperName i)

100+ P.showQualified P.runProperName i

100101

101102encodeT :: (ToJSON a) => a -> Text

102103encodeT = toS . decodeUtf8 . encode

src/Language/PureScript/Ide/Watcher.hs+12−8

@@ -22,6 +22,7 @@ import Control.Concurrent.STM

2222import Language.PureScript.Ide.Externs

2323import Language.PureScript.Ide.State

2424import Language.PureScript.Ide.Types

25+import Language.PureScript.Ide.Util

2526import System.FilePath

2627import System.FSNotify

2728

@@ -31,7 +32,7 @@ reloadFile :: TVar IdeState -> Event -> IO ()

3132reloadFile _ Removed{} = pure ()

3233reloadFile ref ev = do

3334 let fp = eventPath ev

34− ef' <- runExceptT (readExternFile fp)

35+ ef' <- runLogger LogDefault (runExceptT (readExternFile fp))

3536 case ef' of

3637 Left _ -> pure ()

3738 Right ef -> do

@@ -40,10 +41,13 @@ reloadFile ref ev = do

4041

4142-- | Installs filewatchers for the given directory and reloads ExternsFiles when

4243-- they change on disc

43−watcher :: TVar IdeState -> FilePath -> IO ()

44−watcher stateVar fp =

45− withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do

46− _ <- watchTree mgr fp

47− (\ev -> takeFileName (eventPath ev) == "externs.json")

48− (reloadFile stateVar)

49− forever (threadDelay 100000)

44+watcher :: Bool -> TVar IdeState -> FilePath -> IO ()

45+watcher polling stateVar fp =

46+ withManagerConf

47+ (defaultConfig { confDebounce = NoDebounce

48+ , confUsePolling = polling

49+ }) $ \mgr -> do

50+ _ <- watchTree mgr fp

51+ (\ev -> takeFileName (eventPath ev) == "externs.json")

52+ (reloadFile stateVar)

53+ forever (threadDelay 100000)

src/Language/PureScript/Interactive.hs+19−20

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

11{-# LANGUAGE DoAndIfThenElse #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TupleSections #-}

5−{-# LANGUAGE DataKinds #-}

73module Language.PureScript.Interactive

84 ( handleCommand

@@ -16,9 +12,12 @@ module Language.PureScript.Interactive

1612import Prelude ()

1713import Prelude.Compat

1814

19−import Data.List (intercalate, nub, sort, find, foldl')

15+import Data.List (nub, sort, find, foldl')

2016import Data.Maybe (mapMaybe)

2117import qualified Data.Map as M

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

19+import Data.Text (Text)

20+import qualified Data.Text as T

2221

2322import Control.Monad.IO.Class (MonadIO, liftIO)

2423import Control.Monad.State.Class

@@ -165,7 +164,7 @@ handleShowLoadedModules = do

165164 loadedModules <- gets psciLoadedExterns

166165 liftIO $ putStrLn (readModules loadedModules)

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

169168

170169-- | Show the imported modules in psci.

171170handleShowImportedModules

@@ -176,38 +175,38 @@ handleShowImportedModules = do

176175 liftIO $ showModules importedModules >>= putStrLn

177176 return ()

178177 where

179− showModules = return . unlines . sort . map showModule

178+ showModules = return . unlines . sort . map (T.unpack . showModule)

180179 showModule (mn, declType, asQ) =

181− "import " ++ N.runModuleName mn ++ showDeclType declType ++

182− foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ

180+ "import " <> N.runModuleName mn <> showDeclType declType <>

181+ foldMap (\mn' -> " as " <> N.runModuleName mn') asQ

183182

184183 showDeclType P.Implicit = ""

185184 showDeclType (P.Explicit refs) = refsList refs

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

187− refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"

185+ showDeclType (P.Hiding refs) = " hiding " <> refsList refs

186+ refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")"

188187

189− showRef :: P.DeclarationRef -> Maybe String

188+ showRef :: P.DeclarationRef -> Maybe Text

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

192191 showRef (P.TypeOpRef op) =

193− Just $ "type " ++ N.showOp op

192+ Just $ "type " <> N.showOp op

194193 showRef (P.ValueRef ident) =

195194 Just $ N.runIdent ident

196195 showRef (P.ValueOpRef op) =

197196 Just $ N.showOp op

198197 showRef (P.TypeClassRef pn) =

199− Just $ "class " ++ N.runProperName pn

198+ Just $ "class " <> N.runProperName pn

200199 showRef (P.TypeInstanceRef ident) =

201200 Just $ N.runIdent ident

202201 showRef (P.ModuleRef name) =

203− Just $ "module " ++ N.runModuleName name

202+ Just $ "module " <> N.runModuleName name

204203 showRef (P.ReExportRef _ _) =

205204 Nothing

206205 showRef (P.PositionedDeclarationRef _ _ ref) =

207206 showRef ref

208207

209− commaList :: [String] -> String

210− commaList = intercalate ", "

208+ commaList :: [Text] -> Text

209+ commaList = T.intercalate ", "

211210

212211-- | Imports a module, preserving the initial state on failure.

213212handleImport

@@ -260,7 +259,7 @@ handleKindOf typ = do

260259 check sew = fst . runWriter . runExceptT . runStateT sew

261260 case k of

262261 Left err -> printErrors err

263− Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind

262+ Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind

264263 Nothing -> liftIO $ putStrLn "Could not find kind"

265264

266265-- | Browse a module and displays its signature

@@ -284,6 +283,6 @@ handleBrowse moduleName = do

284283 isModInEnv modName =

285284 any ((== modName) . P.getModuleName . fst) . psciLoadedExterns

286285 failNotInEnv modName =

287− liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."

286+ liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."

288287 lookupUnQualifiedModName quaModName st =

289288 (\(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−

31module Language.PureScript.Interactive.Completion

42 ( CompletionM

53 , liftCompletionM

@@ -16,6 +14,8 @@ import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)

1614import Data.Function (on)

1715import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix)

1816import Data.Maybe (mapMaybe)

17+import Data.Text (Text)

18+import qualified Data.Text as T

1919import qualified Language.PureScript as P

2020import qualified Language.PureScript.Interactive.Directive as D

2121import Language.PureScript.Interactive.Types

@@ -145,7 +145,7 @@ getLoadedModules = asks (map fst . psciLoadedExterns)

145145getModuleNames :: CompletionM [String]

146146getModuleNames = moduleNames <$> getLoadedModules

147147

148−mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]

148+mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]

149149mapLoadedModulesAndQualify sho f = do

150150 ms <- getLoadedModules

151151 let argPairs = do m <- ms

@@ -165,14 +165,14 @@ getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls

165165-- | Given a module and a declaration in that module, return all possible ways

166166-- it could have been referenced given the current PSCiState - including fully

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

169169getAllQualifications sho m (declName, decl) = do

170170 imports <- getAllImportsOf m

171171 let fullyQualified = qualifyWith (Just (P.getModuleName m))

172172 let otherQuals = nub (concatMap qualificationsUsing imports)

173173 return $ fullyQualified : otherQuals

174174 where

175− qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName)

175+ qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName))

176176 referencedBy refs = P.isExported (Just refs) decl

177177

178178 qualificationsUsing (_, importType, asQ') =

@@ -220,4 +220,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

220220 go _ = []

221221

222222moduleNames :: [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)

1010import Data.Char (isSpace)

1111import Data.List (intercalate)

12+import qualified Data.Text as T

1213import Text.Parsec hiding ((<|>))

1314import qualified Language.PureScript as P

1415import qualified Language.PureScript.Interactive.Directive as D

@@ -26,7 +27,7 @@ parseCommand cmdString =

2627

2728parseRest :: P.TokenParser a -> String -> Either String a

2829parseRest p s = either (Left . show) Right $ do

29− ts <- P.lex "" s

30+ ts <- P.lex "" (T.pack s)

3031 P.runTokenParser "" (p <* eof) ts

3132

3233psciCommand :: P.TokenParser Command

src/Language/PureScript/Interactive/Printer.hs+16−12

@@ -1,6 +1,3 @@

1−{-# LANGUAGE RecordWildCards #-}

2−{-# LANGUAGE DataKinds #-}

3−

41module Language.PureScript.Interactive.Printer where

63import Prelude.Compat

@@ -8,9 +5,16 @@ import Prelude.Compat

85import Data.List (intersperse)

96import qualified Data.Map as M

107import Data.Maybe (mapMaybe)

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

9+import qualified Data.Text as T

10+import Data.Text (Text)

1111import qualified Language.PureScript as P

1212import qualified Text.PrettyPrint.Boxes as Box

1313

14+-- TODO (Christoph): Text version of boxes

15+textT :: Text -> Box.Box

16+textT = Box.text . T.unpack

17+

1418-- Printers

1519

1620-- |

@@ -40,7 +44,7 @@ printModuleSignatures moduleName P.Environment{..} =

4044 findNameType envNames m = (P.disqualify m, M.lookup m envNames)

4145

4246 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

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

4549

4650 findTypeClass

@@ -58,13 +62,13 @@ printModuleSignatures moduleName P.Environment{..} =

5862 if null typeClassSuperclasses

5963 then Box.text ""

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

6266 Box.<> Box.text ") <= "

6367 className =

64− Box.text (P.runProperName name)

65− Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments)

68+ textT (P.runProperName name)

69+ Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments)

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

6872

6973 in

7074 Just $

@@ -84,7 +88,7 @@ printModuleSignatures moduleName P.Environment{..} =

8488 showType

8589 :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData

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

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

8993 -> Maybe Box.Box

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

@@ -95,7 +99,7 @@ printModuleSignatures moduleName P.Environment{..} =

9599 Nothing

96100 else

97101 Just $

98− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

102+ textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars)

99103 Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

100104

101105 (Just (_, P.DataType typevars pt), _) ->

@@ -108,7 +112,7 @@ printModuleSignatures moduleName P.Environment{..} =

108112 _ -> "data"

109113

110114 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

112116

113117 _ ->

114118 Nothing

@@ -117,7 +121,7 @@ printModuleSignatures moduleName P.Environment{..} =

117121 Box.moveRight 2 $

118122 Box.vcat Box.left $

119123 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

121125

122126 prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

123127

src/Language/PureScript/Linter.hs+16−10

@@ -11,6 +11,7 @@ import Data.List (nub, (\\))

1111import Data.Maybe (mapMaybe)

1212import Data.Monoid

1313import qualified Data.Set as S

14+import Data.Text (Text)

1415

1516import Language.PureScript.AST

1617import Language.PureScript.Crash

@@ -44,9 +45,14 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

4445

4546 f :: Declaration -> MultipleErrors

4647 f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)

47− f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)

48− f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)

49− f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl 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)

53+ f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)

54+ f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)

55+ f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec

5056

5157 stepE :: S.Set Ident -> Expr -> MultipleErrors

5258 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

7076 | otherwise = mempty

7177 stepDo _ _ = mempty

7278

73− checkTypeVarsInDecl :: Declaration -> MultipleErrors

74− checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d

79+ checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors

80+ checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d

7581

76− checkTypeVars :: Type -> MultipleErrors

77− checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty

82+ checkTypeVars :: S.Set Text -> Type -> MultipleErrors

83+ checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty

7884 where

79− step :: S.Set String -> Type -> (S.Set String, MultipleErrors)

85+ step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors)

8086 step s (ForAll tv _ _) = bindVar s tv

8187 step s _ = (s, mempty)

82− bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)

88+ bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors)

8389 bindVar = bind ShadowedTypeVar

8490 findUnused :: Type -> MultipleErrors

8591 findUnused ty' =

@@ -88,7 +94,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

8894 unused = nub declared \\ nub used

8995 in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused

9096 where

91− go :: Type -> [String]

97+ go :: Type -> [Text]

9298 go (ForAll tv _ _) = [tv]

9399 go _ = []

94100

src/Language/PureScript/Linter/Exhaustive.hs+7−4

@@ -19,7 +19,10 @@ import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)

1919import Data.Function (on)

2020import Data.List (foldl', sortBy, nub)

2121import Data.Maybe (fromMaybe)

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

2223import qualified Data.Map as M

24+import Data.Text (Text)

25+import qualified Data.Text as T

2326

2427import Language.PureScript.AST.Binders

2528import Language.PureScript.AST.Declarations

@@ -77,7 +80,7 @@ getConstructors env defmn n = extractConstructors lnte

7780 getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

7881 getConsDataName con =

7982 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."

8184 Just (_, pm, _, _) -> qualifyName pm defmn con

8285

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

276279 -- and then included in the error message.

277280 addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr

278281 addPartialConstraint (bss, complete) e = do

279− tyVar <- ("p" ++) . show <$> fresh

282+ tyVar <- ("p" <>) . T.pack . show <$> fresh

280283 var <- freshName

281284 return $

282285 Let

283286 [ partial var tyVar ]

284287 $ App (Var (Qualified Nothing (Ident C.__unused))) e

285288 where

286− partial :: String -> String -> Declaration

289+ partial :: Text -> Text -> Declaration

287290 partial var tyVar =

288291 ValueDeclaration (Ident C.__unused) Private [] $ Right $

289292 TypedValue

@@ -291,7 +294,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (

291294 (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))

292295 (ty tyVar)

293296

294− ty :: String -> Type

297+ ty :: Text -> Type

295298 ty tyVar =

296299 ForAll tyVar

297300 ( ConstrainedType

src/Language/PureScript/Linter/Imports.hs+3−2

@@ -15,6 +15,7 @@ import Data.List (find, intersect, nub, groupBy, sortBy, (\\))

1515import Data.Maybe (mapMaybe, fromMaybe)

1616import Data.Monoid (Sum(..))

1717import Data.Traversable (forM)

18+import qualified Data.Text as T

1819import qualified Data.Map as M

1920

2021import Language.PureScript.AST.Declarations

@@ -329,8 +330,8 @@ findUsedRefs env mni qn names =

329330 Just (_, _, exps) ->

330331 case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of

331332 Just (ty, _) -> ty

332− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

333− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

333+ Nothing -> internalError $ "missing type for data constructor " ++ T.unpack (runProperName dctor) ++ " in findTypeForDctor"

334+ Nothing -> internalError $ "missing module " ++ T.unpack (runModuleName mn) ++ " in findTypeForDctor"

334335

335336matchName

336337 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

src/Language/PureScript/Make.hs+26−27

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

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

22{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE OverloadedStrings #-}

54module Language.PureScript.Make

65 (

@@ -38,13 +37,12 @@ import Control.Monad.Writer.Class (MonadWriter(..))

3837

3938import Data.Aeson (encode, decode)

4039import qualified Data.Aeson as Aeson

41−import Data.ByteString.Builder (toLazyByteString, stringUtf8)

4240import Data.Either (partitionEithers)

4341import Data.Function (on)

4442import Data.Foldable (for_)

4543import Data.List (foldl', sortBy, groupBy)

4644import Data.Maybe (fromMaybe, catMaybes)

47−import Data.String (fromString)

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

4846import Data.Time.Clock

4947import Data.Traversable (for)

5048import Data.Version (showVersion)

@@ -52,6 +50,8 @@ import qualified Data.ByteString.Lazy as B

5250import qualified Data.ByteString.UTF8 as BU8

5351import qualified Data.Map as M

5452import qualified Data.Set as S

53+import qualified Data.Text as T

54+import qualified Data.Text.Encoding as TE

5555

5656import Language.PureScript.AST

5757import Language.PureScript.Crash

@@ -83,7 +83,6 @@ import SourceMap.Types

8383import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

8484import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)

8585import System.IO.Error (tryIOError)

86−import System.IO.UTF8 (readUTF8File, writeUTF8File)

8786

8887import qualified Text.Parsec as Parsec

8988

@@ -94,7 +93,7 @@ data ProgressMessage

9493

9594-- | Render a progress message

9695renderProgressMessage :: ProgressMessage -> String

97−renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn

96+renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn)

9897

9998-- | Actions that require implementations when running in "make" mode.

10099--

@@ -125,7 +124,7 @@ data MakeActions m = MakeActions

125124-- |

126125-- Generated code for an externs file.

127126--

128−type Externs = String

127+type Externs = B.ByteString

129128

130129-- |

131130-- Determines when to rebuild a module

@@ -155,7 +154,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

155154 corefn = CF.moduleToCoreFn env' mod'

156155 [renamed] = renameInModules [corefn]

157156 exts = moduleToExternsFile mod' env'

158− evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts

157+ evalSupplyT nextVar . codegen renamed env' . encode $ exts

159158 return exts

160159

161160-- |

@@ -256,8 +255,8 @@ make ma@MakeActions{..} ms = do

256255

257256 decodeExterns :: Externs -> Maybe ExternsFile

258257 decodeExterns bs = do

259− externs <- decode (toLazyByteString (stringUtf8 bs))

260− guard $ efVersion externs == showVersion Paths.version

258+ externs <- decode bs

259+ guard $ T.unpack (efVersion externs) == showVersion Paths.version

261260 return externs

262261

263262importPrim :: Module -> Module

@@ -290,8 +289,8 @@ makeIO f io = do

290289

291290-- | Read a text file in the 'Make' monad, capturing any errors using the

292291-- 'MonadError' instance.

293−readTextFile :: FilePath -> Make String

294−readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

292+readTextFile :: FilePath -> Make B.ByteString

293+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path

295294

296295-- | Infer the module name for a module by looking for the same filename with

297296-- a .js extension.

@@ -332,14 +331,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

332331

333332 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)

334333 getOutputTimestamp mn = do

335− let filePath = runModuleName mn

334+ let filePath = T.unpack (runModuleName mn)

336335 jsFile = outputDir </> filePath </> "index.js"

337336 externsFile = outputDir </> filePath </> "externs.json"

338337 min <$> getTimestamp jsFile <*> getTimestamp externsFile

339338

340339 readExterns :: ModuleName -> Make (FilePath, Externs)

341340 readExterns mn = do

342− let path = outputDir </> runModuleName mn </> "externs.json"

341+ let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"

343342 (path, ) <$> readTextFile path

344343

345344 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()

@@ -359,16 +358,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

359358 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory

360359 sourceMaps <- lift $ asks optionsSourceMaps

361360 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])

362− let filePath = runModuleName mn

361+ let filePath = T.unpack (runModuleName mn)

363362 jsFile = outputDir </> filePath </> "index.js"

364363 mapFile = outputDir </> filePath </> "index.js.map"

365364 externsFile = outputDir </> filePath </> "externs.json"

366365 foreignFile = outputDir </> filePath </> "foreign.js"

367− prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

368− js = unlines $ map ("// " ++) prefix ++ [pjs]

366+ prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix]

367+ js = T.unlines $ map ("// " <>) prefix ++ [pjs]

369368 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

370369 lift $ do

371− writeTextFile jsFile (fromString $ js ++ mapRef)

370+ writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)

372371 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

373372 writeTextFile externsFile exts

374373 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings

@@ -376,14 +375,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

376375 when dumpCoreFn $ do

377376 let coreFnFile = outputDir </> filePath </> "corefn.json"

378377 let jsonPayload = CFJ.moduleToJSON Paths.version m

379− let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]

380− lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)

378+ let json = Aeson.object [ (runModuleName mn, jsonPayload) ]

379+ lift $ writeTextFile coreFnFile (encode json)

381380

382381 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()

383382 genSourceMap dir mapFile extraLines mappings = do

384383 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)

385384 sourceFile = case mappings of

386− (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file

385+ (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir (T.unpack file)

387386 _ -> Nothing

388387 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

389388 map (\(SMap _ orig gen) -> Mapping {

@@ -394,7 +393,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

394393 }) mappings

395394 }

396395 let mapping = generate rawMapping

397− writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping

396+ writeTextFile mapFile (encode mapping)

398397 where

399398 add :: Int -> Int -> SourcePos -> SourcePos

400399 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')

@@ -411,10 +410,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

411410 exists <- doesFileExist path

412411 traverse (const $ getModificationTime path) $ guard exists

413412

414− writeTextFile :: FilePath -> String -> Make ()

413+ writeTextFile :: FilePath -> B.ByteString -> Make ()

415414 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

416415 mkdirp path

417− writeUTF8File path text

416+ B.writeFile path text

418417 where

419418 mkdirp :: FilePath -> IO ()

420419 mkdirp = createDirectoryIfMissing True . takeDirectory

@@ -429,7 +428,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

429428checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

430429checkForeignDecls m path = do

431430 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

433432

434433 foreignIdentsStrs <- either errorParsingModule pure $ getExps js

435434 foreignIdents <- either

@@ -455,11 +454,11 @@ checkForeignDecls m path = do

455454 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just

456455

457456 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

458− getExps = Bundle.getExportedIdentifiers (runModuleName mname)

457+ getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))

459458

460459 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a

461460 errorInvalidForeignIdentifiers =

462− throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)

461+ throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)

463462

464463 parseIdents :: [String] -> Either [String] [Ident]

465464 parseIdents strs =

@@ -472,7 +471,7 @@ checkForeignDecls m path = do

472471 -- We ignore the error message here, just being told it's an invalid

473472 -- identifier should be enough.

474473 parseIdent :: String -> Either String Ident

475− parseIdent str = try str

474+ parseIdent str = try (T.pack str)

476475 where

477476 try s = either (const (Left str)) Right $ do

478477 ts <- PSParser.lex "" s

src/Language/PureScript/Names.hs+21−19

@@ -11,7 +11,9 @@ import Control.Monad.Supply.Class

1111

1212import Data.Aeson

1313import Data.Aeson.TH

14−import Data.List

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

15+import Data.Text (Text)

16+import qualified Data.Text as T

1517

1618-- | A sum of the possible name types, useful for error and lint messages.

1719data Name

@@ -59,22 +61,22 @@ data Ident

5961 -- |

6062 -- An alphanumeric identifier

6163 --

62− = Ident String

64+ = Ident Text

6365 -- |

6466 -- A generated name for an identifier

6567 --

66− | GenIdent (Maybe String) Integer

68+ | GenIdent (Maybe Text) Integer

6769 deriving (Show, Eq, Ord)

6870

69−runIdent :: Ident -> String

71+runIdent :: Ident -> Text

7072runIdent (Ident i) = i

71−runIdent (GenIdent Nothing n) = "$" ++ show n

72−runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n

73+runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)

74+runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)

7375

74−showIdent :: Ident -> String

76+showIdent :: Ident -> Text

7577showIdent = runIdent

7678

77−freshIdent :: MonadSupply m => String -> m Ident

79+freshIdent :: MonadSupply m => Text -> m Ident

7880freshIdent name = GenIdent (Just name) <$> fresh

7981

8082freshIdent' :: MonadSupply m => m Ident

@@ -83,7 +85,7 @@ freshIdent' = GenIdent Nothing <$> fresh

8385-- |

8486-- Operator alias names.

8587--

86−newtype OpName (a :: OpNameType) = OpName { runOpName :: String }

88+newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }

8789 deriving (Show, Eq, Ord)

8890

8991instance ToJSON (OpName a) where

@@ -92,8 +94,8 @@ instance ToJSON (OpName a) where

9294instance FromJSON (OpName a) where

9395 parseJSON = fmap OpName . parseJSON

9496

95−showOp :: OpName a -> String

96−showOp op = '(' : runOpName op ++ ")"

97+showOp :: OpName a -> Text

98+showOp op = "(" <> runOpName op <> ")"

9799

98100-- |

99101-- The closed set of operator alias types.

@@ -103,7 +105,7 @@ data OpNameType = ValueOpName | TypeOpName

103105-- |

104106-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

105107--

106−newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }

108+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }

107109 deriving (Show, Eq, Ord)

108110

109111instance ToJSON (ProperName a) where

@@ -131,16 +133,16 @@ coerceProperName = ProperName . runProperName

131133newtype ModuleName = ModuleName [ProperName 'Namespace]

132134 deriving (Show, Eq, Ord)

133135

134−runModuleName :: ModuleName -> String

135−runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

136+runModuleName :: ModuleName -> Text

137+runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns)

136138

137−moduleNameFromString :: String -> ModuleName

139+moduleNameFromString :: Text -> ModuleName

138140moduleNameFromString = ModuleName . splitProperNames

139141 where

140− splitProperNames s = case dropWhile (== '.') s of

142+ splitProperNames s = case T.dropWhile (== '.') s of

141143 "" -> []

142144 s' -> ProperName w : splitProperNames s''

143− where (w, s'') = break (== '.') s'

145+ where (w, s'') = T.break (== '.') s'

144146

145147-- |

146148-- A qualified name, i.e. a name with an optional module name

@@ -148,9 +150,9 @@ moduleNameFromString = ModuleName . splitProperNames

148150data Qualified a = Qualified (Maybe ModuleName) a

149151 deriving (Show, Eq, Ord, Functor)

150152

151−showQualified :: (a -> String) -> Qualified a -> String

153+showQualified :: (a -> Text) -> Qualified a -> Text

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

154156

155157getQual :: Qualified a -> Maybe ModuleName

156158getQual (Qualified mn _) = mn

src/Language/PureScript/Parser/Common.hs+12−9

@@ -5,8 +5,11 @@ module Language.PureScript.Parser.Common where

66import Prelude.Compat

8−import Control.Applicative

8+import Control.Applicative ((<|>))

99import Control.Monad (guard)

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

11+import Data.Text (Text)

12+import qualified Data.Text as T

1013

1114import Language.PureScript.AST.SourcePos

1215import Language.PureScript.Comments

@@ -79,8 +82,8 @@ augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

7982-- Run the first parser, then match the second zero or more times, applying the specified function for each match

8083--

8184fold :: 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

83− a <- first

85+fold first' more combine = do

86+ a <- first'

8487 bs <- P.many more

8588 return $ foldl combine a bs

8689

@@ -88,8 +91,8 @@ fold first more combine = do

8891-- Build a parser from a smaller parser and a list of parsers for postfix operators

8992--

9093buildPostfixParser :: 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

92− a <- first

94+buildPostfixParser fs first' = do

95+ a <- first'

9396 go a

9497 where

9598 go a = do

@@ -114,25 +117,25 @@ mark p = do

114117-- Check that the current identation level matches a predicate

115118--

116119checkIndentation

117− :: (P.Column -> String)

120+ :: (P.Column -> Text)

118121 -> (P.Column -> P.Column -> Bool)

119122 -> P.Parsec s ParseState ()

120123checkIndentation mkMsg rel = do

121124 col <- P.sourceColumn <$> P.getPosition

122125 current <- indentationLevel <$> P.getState

123− guard (col `rel` current) P.<?> mkMsg current

126+ guard (col `rel` current) P.<?> T.unpack (mkMsg current)

124127

125128-- |

126129-- Check that the current indentation level is past the current mark

127130--

128131indented :: P.Parsec s ParseState ()

129−indented = checkIndentation (("indentation past column " ++) . show) (>)

132+indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)

130133

131134-- |

132135-- Check that the current indentation level is at the same indentation as the current mark

133136--

134137same :: P.Parsec s ParseState ()

135−same = checkIndentation (("indentation at column " ++) . show) (==)

138+same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)

136139

137140-- |

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

6161 let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end')

6262 return $ f sp comments x

6363

64−kindedIdent :: TokenParser (String, Maybe Kind)

64+kindedIdent :: TokenParser (Text, Maybe Kind)

6565kindedIdent = (, Nothing) <$> identifier

6666 <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

6767

@@ -303,7 +303,7 @@ parseModuleFromFile

303303 -> Either P.ParseError (k, Module)

304304parseModuleFromFile toFilePath (k, content) = do

305305 let filename = toFilePath k

306− ts <- lex' filename content

306+ ts <- lex filename content

307307 m <- runTokenParser filename parseModule ts

308308 pure (k, m)

309309

@@ -333,10 +333,10 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

333333parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

334334parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

335335

336−parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)

336+parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a)

337337parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

338338

339−parseIdentifierAndValue :: TokenParser (String, Expr)

339+parseIdentifierAndValue :: TokenParser (Text, Expr)

340340parseIdentifierAndValue =

341341 do

342342 name <- C.indented *> lname

@@ -423,7 +423,7 @@ parseInfixExpr

423423parseHole :: TokenParser Expr

424424parseHole = Hole <$> holeLit

425425

426−parsePropertyUpdate :: TokenParser (String, Expr)

426+parsePropertyUpdate :: TokenParser (Text, Expr)

427427parsePropertyUpdate = do

428428 name <- lname <|> stringLiteral

429429 _ <- C.indented *> equals

@@ -515,7 +515,7 @@ parseVarOrNamedBinder = do

515515parseNullBinder :: TokenParser Binder

516516parseNullBinder = underscore *> return NullBinder

517517

518−parseIdentifierAndBinder :: TokenParser (String, Binder)

518+parseIdentifierAndBinder :: TokenParser (Text, Binder)

519519parseIdentifierAndBinder =

520520 do name <- lname

521521 b <- P.option (VarBinder (Ident name)) rest

src/Language/PureScript/Parser/Lexer.hs+94−77

@@ -6,7 +6,6 @@ module Language.PureScript.Parser.Lexer

66 , Token()

77 , TokenParser()

88 , lex

9− , lex'

109 , anyToken

1110 , token

1211 , match

@@ -63,13 +62,13 @@ module Language.PureScript.Parser.Lexer

6362 )

6463 where

6564

66−import Prelude hiding (lex)

65+import Prelude.Compat hiding (lex)

6766

68−import Control.Applicative

67+import Control.Applicative ((<|>))

6968import Control.Monad (void, guard)

70−

69+import Control.Monad.Identity (Identity)

7170import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

72−import Data.Functor.Identity

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

7372import Data.Text (Text)

7473import qualified Data.Text as T

7574

@@ -101,17 +100,17 @@ data Token

101100 | Semi

102101 | At

103102 | Underscore

104− | LName String

105− | UName String

106− | Qualifier String

107− | Symbol String

103+ | LName Text

104+ | UName Text

105+ | Qualifier Text

106+ | Symbol Text

108107 | CharLiteral Char

109− | StringLiteral String

108+ | StringLiteral Text

110109 | Number (Either Integer Double)

111− | HoleLit String

110+ | HoleLit Text

112111 deriving (Show, Eq, Ord)

113112

114−prettyPrintToken :: Token -> String

113+prettyPrintToken :: Token -> Text

115114prettyPrintToken LParen = "("

116115prettyPrintToken RParen = ")"

117116prettyPrintToken LBrace = "{"

@@ -132,15 +131,15 @@ prettyPrintToken Comma = ","

132131prettyPrintToken Semi = ";"

133132prettyPrintToken At = "@"

134133prettyPrintToken Underscore = "_"

135−prettyPrintToken (Indent n) = "indentation at level " ++ show n

136−prettyPrintToken (LName s) = show s

137−prettyPrintToken (UName s) = show s

134+prettyPrintToken (Indent n) = "indentation at level " <> T.pack (show n)

135+prettyPrintToken (LName s) = T.pack (show s)

136+prettyPrintToken (UName s) = T.pack (show s)

138137prettyPrintToken (Qualifier _) = "qualifier"

139138prettyPrintToken (Symbol s) = s

140−prettyPrintToken (CharLiteral c) = show c

141−prettyPrintToken (StringLiteral s) = show s

142−prettyPrintToken (Number n) = either show show n

143−prettyPrintToken (HoleLit name) = "?" ++ name

139+prettyPrintToken (CharLiteral c) = T.pack (show c)

140+prettyPrintToken (StringLiteral s) = T.pack (show s)

141+prettyPrintToken (Number n) = T.pack (either show show n)

142+prettyPrintToken (HoleLit name) = "?" <> name

144143

145144data PositionedToken = PositionedToken

146145 { -- | Start position of this token

@@ -155,15 +154,12 @@ data PositionedToken = PositionedToken

155154

156155-- Parsec requires this instance for various token-level combinators

157156instance Show PositionedToken where

158− show = prettyPrintToken . ptToken

157+ show = T.unpack . prettyPrintToken . ptToken

159158

160159type Lexer u a = P.Parsec Text u a

161160

162−lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

163−lex fp = lex' fp . T.pack

164−

165−lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]

166−lex' f s = updatePositions <$> P.parse parseTokens f s

161+lex :: FilePath -> Text -> Either P.ParseError [PositionedToken]

162+lex f s = updatePositions <$> P.parse parseTokens f s

167163

168164updatePositions :: [PositionedToken] -> [PositionedToken]

169165updatePositions [] = []

@@ -180,11 +176,11 @@ whitespace = P.skipMany (P.satisfy isSpace)

180176parseComment :: Lexer u Comment

181177parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

182178 where

183− blockComment :: Lexer u String

184− blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))

179+ blockComment :: Lexer u Text

180+ blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}")))

185181

186− lineComment :: Lexer u String

187− lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))

182+ lineComment :: Lexer u Text

183+ lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)))

188184

189185parsePositionedToken :: Lexer u PositionedToken

190186parsePositionedToken = P.try $ do

@@ -222,11 +218,11 @@ parseToken = P.choice

222218 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

223219 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

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

226222 , LName <$> parseLName

227223 , parseUName >>= \uName ->

228− (guard (validModuleName uName) >> Qualifier uName <$ P.char '.')

229− <|> pure (UName uName)

224+ guard (validModuleName uName) *> (Qualifier uName <$ P.char '.')

225+ <|> pure (UName uName)

230226 , Symbol <$> parseSymbol

231227 , CharLiteral <$> parseCharLiteral

232228 , StringLiteral <$> parseStringLiteral

@@ -234,14 +230,14 @@ parseToken = P.choice

234230 ]

235231

236232 where

237− parseLName :: Lexer u String

238− parseLName = (:) <$> identStart <*> P.many identLetter

233+ parseLName :: Lexer u Text

234+ parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter)

239235

240− parseUName :: Lexer u String

241− parseUName = (:) <$> P.upper <*> P.many identLetter

236+ parseUName :: Lexer u Text

237+ parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter)

242238

243− parseSymbol :: Lexer u String

244− parseSymbol = P.many1 symbolChar

239+ parseSymbol :: Lexer u Text

240+ parseSymbol = T.pack <$> P.many1 symbolChar

245241

246242 identStart :: Lexer u Char

247243 identStart = P.lower <|> P.oneOf "_"

@@ -252,24 +248,41 @@ parseToken = P.choice

252248 symbolChar :: Lexer u Char

253249 symbolChar = P.satisfy isSymbolChar

254250

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+

255263 parseCharLiteral :: Lexer u Char

256− parseCharLiteral = PT.charLiteral tokenParser

264+ parseCharLiteral = P.try $ do {

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

257270

258− parseStringLiteral :: Lexer u String

259− parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

271+ parseStringLiteral :: Lexer u Text

272+ parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser

260273 where

261274 delimiter = P.try (P.string "\"\"\"")

262− blockString = delimiter >> P.manyTill P.anyChar delimiter

275+ blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter)

263276

264277 parseNumber :: Lexer u (Either Integer Double)

265− parseNumber = (consumeLeadingZero >> P.parserZero) <|>

278+ parseNumber = (consumeLeadingZero *> P.parserZero) <|>

266279 (Right <$> P.try (PT.float tokenParser) <|>

267280 Left <$> P.try (PT.natural tokenParser))

268281 P.<?> "number"

269282 where

270283 -- lookAhead doesn't consume any input if its parser succeeds

271284 -- 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' *>

273286 (P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))

274287

275288-- |

@@ -283,10 +296,10 @@ langDef = PT.LanguageDef

283296 , PT.commentEnd = ""

284297 , PT.commentLine = ""

285298 , PT.nestedComments = True

286− , PT.identStart = fail "Identifiers not supported"

287− , PT.identLetter = fail "Identifiers not supported"

288− , PT.opStart = fail "Operators not supported"

289− , PT.opLetter = fail "Operators not supported"

299+ , PT.identStart = P.parserFail "Identifiers not supported"

300+ , PT.identLetter = P.parserFail "Identifiers not supported"

301+ , PT.opStart = P.parserFail "Operators not supported"

302+ , PT.opLetter = P.parserFail "Operators not supported"

290303 , PT.caseSensitive = True

291304 }

292305

@@ -299,13 +312,13 @@ tokenParser = PT.makeTokenParser langDef

299312type TokenParser a = P.Parsec [PositionedToken] ParseState a

300313

301314anyToken :: TokenParser PositionedToken

302−anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just

315+anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just

303316

304317token :: (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)

306319

307320match :: 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)

309322

310323lparen :: TokenParser ()

311324lparen = match LParen

@@ -388,7 +401,7 @@ at = match At

388401underscore :: TokenParser ()

389402underscore = match Underscore

390403

391−holeLit :: TokenParser String

404+holeLit :: TokenParser Text

392405holeLit = token go P.<?> "hole literal"

393406 where

394407 go (HoleLit n) = Just n

@@ -418,62 +431,62 @@ commaSep = flip P.sepBy comma

418431commaSep1 :: TokenParser a -> TokenParser [a]

419432commaSep1 = flip P.sepBy1 comma

420433

421−lname :: TokenParser String

434+lname :: TokenParser Text

422435lname = token go P.<?> "identifier"

423436 where

424437 go (LName s) = Just s

425438 go _ = Nothing

426439

427−lname' :: String -> TokenParser ()

440+lname' :: Text -> TokenParser ()

428441lname' s = token go P.<?> show s

429442 where

430443 go (LName s') | s == s' = Just ()

431444 go _ = Nothing

432445

433−qualifier :: TokenParser String

446+qualifier :: TokenParser Text

434447qualifier = token go P.<?> "qualifier"

435448 where

436449 go (Qualifier s) = Just s

437450 go _ = Nothing

438451

439−reserved :: String -> TokenParser ()

452+reserved :: Text -> TokenParser ()

440453reserved s = token go P.<?> show s

441454 where

442455 go (LName s') | s == s' = Just ()

443456 go (Symbol s') | s == s' = Just ()

444457 go _ = Nothing

445458

446−uname :: TokenParser String

459+uname :: TokenParser Text

447460uname = token go P.<?> "proper name"

448461 where

449462 go (UName s) | validUName s = Just s

450463 go _ = Nothing

451464

452−uname' :: String -> TokenParser ()

465+uname' :: Text -> TokenParser ()

453466uname' s = token go P.<?> "proper name"

454467 where

455468 go (UName s') | s == s' = Just ()

456469 go _ = Nothing

457470

458−tyname :: TokenParser String

471+tyname :: TokenParser Text

459472tyname = token go P.<?> "type name"

460473 where

461474 go (UName s) = Just s

462475 go _ = Nothing

463476

464−dconsname :: TokenParser String

477+dconsname :: TokenParser Text

465478dconsname = token go P.<?> "data constructor name"

466479 where

467480 go (UName s) = Just s

468481 go _ = Nothing

469482

470−mname :: TokenParser String

483+mname :: TokenParser Text

471484mname = token go P.<?> "module name"

472485 where

473486 go (UName s) | validModuleName s = Just s

474487 go _ = Nothing

475488

476−symbol :: TokenParser String

489+symbol :: TokenParser Text

477490symbol = token go P.<?> "symbol"

478491 where

479492 go (Symbol s) = Just s

@@ -482,7 +495,7 @@ symbol = token go P.<?> "symbol"

482495 go At = Just "@"

483496 go _ = Nothing

484497

485−symbol' :: String -> TokenParser ()

498+symbol' :: Text -> TokenParser ()

486499symbol' s = token go P.<?> show s

487500 where

488501 go (Symbol s') | s == s' = Just ()

@@ -496,7 +509,7 @@ charLiteral = token go P.<?> "char literal"

496509 go (CharLiteral c) = Just c

497510 go _ = Nothing

498511

499−stringLiteral :: TokenParser String

512+stringLiteral :: TokenParser Text

500513stringLiteral = token go P.<?> "string literal"

501514 where

502515 go (StringLiteral s) = Just s

@@ -514,22 +527,25 @@ natural = token go P.<?> "natural"

514527 go (Number (Left n)) = Just n

515528 go _ = Nothing

516529

517−identifier :: TokenParser String

530+identifier :: TokenParser Text

518531identifier = token go P.<?> "identifier"

519532 where

520533 go (LName s) | s `notElem` reservedPsNames = Just s

521534 go _ = Nothing

522535

523−validModuleName :: String -> Bool

524−validModuleName s = '_' `notElem` s

536+validModuleName :: Text -> Bool

537+validModuleName s = '_' `notElemT` s

538+

539+validUName :: Text -> Bool

540+validUName s = '\'' `notElemT` s

525541

526−validUName :: String -> Bool

527−validUName s = '\'' `notElem` s

542+notElemT :: Char -> Text -> Bool

543+notElemT c = not . T.any (== c)

528544

529545-- |

530546-- A list of purescript reserved identifiers

531547--

532−reservedPsNames :: [String]

548+reservedPsNames :: [Text]

533549reservedPsNames = [ "data"

534550 , "newtype"

535551 , "type"

@@ -555,14 +571,14 @@ reservedPsNames = [ "data"

555571 , "where"

556572 ]

557573

558−reservedTypeNames :: [String]

574+reservedTypeNames :: [Text]

559575reservedTypeNames = [ "forall", "where" ]

560576

561577-- |

562578-- The characters allowed for use in operators

563579--

564580isSymbolChar :: Char -> Bool

565−isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)

581+isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c)

566582

567583

568584-- |

@@ -575,12 +591,13 @@ isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c

575591-- The characters allowed in the tail of an unquoted record key

576592--

577593isUnquotedKeyTailChar :: Char -> Bool

578−isUnquotedKeyTailChar c = (c `elem` "_'") || isAlphaNum c

594+isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c

579595

580596-- |

581597-- Strings allowed to be left unquoted in a record key

582598--

583−isUnquotedKey :: String -> Bool

584−isUnquotedKey [] = False

585−isUnquotedKey (hd : tl) = isUnquotedKeyHeadChar hd &&

586− all isUnquotedKeyTailChar tl

599+isUnquotedKey :: Text -> Bool

600+isUnquotedKey t = case T.uncons t of

601+ Nothing -> False

602+ Just (hd, tl) -> isUnquotedKeyHeadChar hd &&

603+ T.all isUnquotedKeyTailChar tl

src/Language/PureScript/Parser/Types.hs+7−5

@@ -7,8 +7,10 @@ module Language.PureScript.Parser.Types

88import Prelude.Compat

10−import Control.Applicative

1110import Control.Monad (when, unless)

11+import Control.Applicative ((<|>))

12+import Data.Text (Text)

13+import qualified Data.Text as T

1214

1315import Language.PureScript.AST.SourcePos

1416import Language.PureScript.Environment

@@ -21,7 +23,7 @@ import qualified Text.Parsec as P

2123import qualified Text.Parsec.Expr as P

2224

2325parseFunction :: TokenParser Type

24−parseFunction = parens rarrow >> return tyFunction

26+parseFunction = parens rarrow *> return tyFunction

2527

2628parseObject :: TokenParser Type

2729parseObject = braces $ TypeApp tyRecord <$> parseRow

@@ -39,7 +41,7 @@ parseTypeWildcard = do

3941parseTypeVariable :: TokenParser Type

4042parseTypeVariable = do

4143 ident <- identifier

42− when (ident `elem` reservedTypeNames) $ P.unexpected ident

44+ when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident)

4345 return $ TypeVar ident

4446

4547parseTypeConstructor :: TokenParser Type

@@ -87,7 +89,7 @@ parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTabl

8789 , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->

8890 return (BinaryNoParensType (TypeOp ident))) P.AssocRight

8991 ]

90− , [ P.Infix (rarrow >> return function) P.AssocRight ]

92+ , [ P.Infix (rarrow *> return function) P.AssocRight ]

9193 ]

9294 postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)

9395 ]

@@ -116,7 +118,7 @@ noWildcards p = do

116118 when (containsWildcards ty) $ P.unexpected "type wildcard"

117119 return ty

118120

119−parseNameAndType :: TokenParser t -> TokenParser (String, t)

121+parseNameAndType :: TokenParser t -> TokenParser (Text, t)

120122parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p

121123

122124parseRowEnding :: TokenParser Type

src/Language/PureScript/Pretty/Common.hs+28−20

@@ -10,20 +10,27 @@ import Prelude.Compat

1010import Control.Monad.State (StateT, modify, get)

1111

1212import Data.List (elemIndices, intersperse)

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

14+import Data.Text (Text)

15+import qualified Data.Text as T

1316

1417import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

1518import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey)

1619

17−import Text.PrettyPrint.Boxes

20+import Text.PrettyPrint.Boxes hiding ((<>))

21+import qualified Text.PrettyPrint.Boxes as Box

1822

1923-- |

2024-- Wrap a string in parentheses

2125--

2226parens :: String -> String

23−parens s = '(':s ++ ")"

27+parens s = "(" <> s <> ")"

28+

29+parensT :: Text -> Text

30+parensT s = "(" <> s <> ")"

2431

2532parensPos :: (Emit gen) => gen -> gen

26−parensPos s = emit "(" `mappend` s `mappend` emit ")"

33+parensPos s = emit "(" <> s <> emit ")"

2734

2835-- |

2936-- Generalize intercalate slightly for monoids

@@ -32,15 +39,15 @@ intercalate :: Monoid m => m -> [m] -> m

3239intercalate x xs = mconcat (intersperse x xs)

3340

3441class (Monoid gen) => Emit gen where

35− emit :: String -> gen

42+ emit :: Text -> gen

3643 addMapping :: SourceSpan -> gen

3744

38−data SMap = SMap String SourcePos SourcePos

45+data SMap = SMap Text SourcePos SourcePos

3946

4047-- |

4148-- String with length and source-map entries

4249--

43−newtype StrPos = StrPos (SourcePos, String, [SMap])

50+newtype StrPos = StrPos (SourcePos, Text, [SMap])

4451

4552-- |

4653-- Make a monoid where append consists of concatenating the string part, adding the lengths

@@ -50,10 +57,10 @@ newtype StrPos = StrPos (SourcePos, String, [SMap])

5057instance Monoid StrPos where

5158 mempty = StrPos (SourcePos 0 0, "", [])

5259

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

5461

5562 mconcat ms =

56− let s' = concatMap (\(StrPos(_, s, _)) -> s) ms

63+ let s' = foldMap (\(StrPos(_, s, _)) -> s) ms

5764 (p, maps) = foldl plus (SourcePos 0 0, []) ms

5865 in

5966 StrPos (p, s', concat $ reverse maps)

@@ -66,22 +73,23 @@ instance Emit StrPos where

6673 -- Augment a string with its length (rows/column)

6774 --

6875 emit str =

69− let newlines = elemIndices '\n' str

76+ -- TODO(Christoph): get rid of T.unpack

77+ let newlines = elemIndices '\n' (T.unpack str)

7078 index = if null newlines then 0 else last newlines + 1

7179 in

72− StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])

80+ StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = T.length str - index }, str, [])

7381

7482 -- |

7583 -- Add a new mapping entry for given source position with initially zero generated position

7684 --

7785 addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])

7886 where

79− mapping = SMap file startPos zeroPos

87+ mapping = SMap (T.pack file) startPos zeroPos

8088 zeroPos = SourcePos 0 0

8189

82−newtype PlainString = PlainString String deriving Monoid

90+newtype PlainString = PlainString Text deriving Monoid

8391

84−runPlainString :: PlainString -> String

92+runPlainString :: PlainString -> Text

8593runPlainString (PlainString s) = s

8694

8795instance Emit PlainString where

@@ -127,7 +135,7 @@ withIndent action = do

127135currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

128136currentIndent = do

129137 current <- get

130− return $ emit $ replicate (indent current) ' '

138+ return $ emit $ T.replicate (indent current) " "

131139

132140-- |

133141-- Print many lines

@@ -141,19 +149,19 @@ prettyPrintMany f xs = do

141149-- |

142150-- Prints an object key, escaping reserved names.

143151--

144−prettyPrintObjectKey :: String -> String

145−prettyPrintObjectKey s | s `elem` reservedPsNames = show s

152+prettyPrintObjectKey :: Text -> Text

153+prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s)

146154 | isUnquotedKey s = s

147− | otherwise = show s

155+ | otherwise = T.pack (show s)

148156

149157-- | Place a box before another, vertically when the first box takes up multiple lines.

150158before :: Box -> Box -> Box

151159before b1 b2 | rows b1 > 1 = b1 // b2

152− | otherwise = b1 <> b2

160+ | otherwise = b1 Box.<> b2

153161

154162beforeWithSpace :: Box -> Box -> Box

155−beforeWithSpace b1 = before (b1 <> text " ")

163+beforeWithSpace b1 = before (b1 Box.<> text " ")

156164

157165-- | Place a Box on the bottom right of another

158166endWith :: 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

99import Prelude.Compat

1010

1111import Control.Arrow ((<+>))

12−import Control.Monad.State hiding (sequence)

12+import Control.Monad (forM, mzero)

13+import Control.Monad.State (StateT, evalStateT)

1314import Control.PatternArrows

1415import qualified Control.Arrow as A

1516

1617import Data.Maybe (fromMaybe)

17−import Data.Monoid

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

19+import Data.Text (Text)

20+import qualified Data.Text as T

1821

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

2023import Language.PureScript.CodeGen.JS.AST

@@ -25,6 +28,8 @@ import Language.PureScript.Pretty.Common

2528

2629import Numeric

2730

31+-- TODO (Christoph): Get rid of T.unpack / pack

32+

2833literals :: (Emit gen) => Pattern PrinterState JS gen

2934literals = mkPattern' match'

3035 where

@@ -32,7 +37,7 @@ literals = mkPattern' match'

3237 match' js = (addMapping' (getSourceSpan js) <>) <$> match js

3338

3439 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

3641 match (JSStringLiteral _ s) = return $ string s

3742 match (JSBooleanLiteral _ True) = return $ emit "true"

3843 match (JSBooleanLiteral _ False) = return $ emit "false"

@@ -53,8 +58,8 @@ literals = mkPattern' match'

5358 , return $ emit "}"

5459 ]

5560 where

56− objectPropertyToString :: (Emit gen) => String -> gen

57− objectPropertyToString s | identNeedsEscaping s = emit $ show s

61+ objectPropertyToString :: (Emit gen) => Text -> gen

62+ objectPropertyToString s | identNeedsEscaping s = string s

5863 | otherwise = emit s

5964 match (JSBlock _ sts) = mconcat <$> sequence

6065 [ return $ emit "{\n"

@@ -65,7 +70,7 @@ literals = mkPattern' match'

6570 ]

6671 match (JSVar _ ident) = return $ emit ident

6772 match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

68− [ return $ emit $ "var " ++ ident

73+ [ return $ emit $ "var " <> ident

6974 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

7075 ]

7176 match (JSAssignment _ target value) = mconcat <$> sequence

@@ -80,15 +85,15 @@ literals = mkPattern' match'

8085 , prettyPrintJS' sts

8186 ]

8287 match (JSFor _ ident start end sts) = mconcat <$> sequence

83− [ return $ emit $ "for (var " ++ ident ++ " = "

88+ [ return $ emit $ "for (var " <> ident <> " = "

8489 , prettyPrintJS' start

85− , return $ emit $ "; " ++ ident ++ " < "

90+ , return $ emit $ "; " <> ident <> " < "

8691 , prettyPrintJS' end

87− , return $ emit $ "; " ++ ident ++ "++) "

92+ , return $ emit $ "; " <> ident <> "++) "

8893 , prettyPrintJS' sts

8994 ]

9095 match (JSForIn _ ident obj sts) = mconcat <$> sequence

91− [ return $ emit $ "for (var " ++ ident ++ " in "

96+ [ return $ emit $ "for (var " <> ident <> " in "

9297 , prettyPrintJS' obj

9398 , return $ emit ") "

9499 , prettyPrintJS' sts

@@ -108,10 +113,10 @@ literals = mkPattern' match'

108113 [ return $ emit "throw "

109114 , prettyPrintJS' value

110115 ]

111− match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl

112− match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl

116+ match (JSBreak _ lbl) = return $ emit $ "break " <> lbl

117+ match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl

113118 match (JSLabel _ lbl js) = mconcat <$> sequence

114− [ return $ emit $ lbl ++ ": "

119+ [ return $ emit $ lbl <> ": "

115120 , prettyPrintJS' js

116121 ]

117122 match (JSComment _ com js) = fmap mconcat $ sequence $

@@ -126,27 +131,29 @@ literals = mkPattern' match'

126131 , prettyPrintJS' js

127132 ]

128133 where

129− commentLines :: Comment -> [String]

134+ commentLines :: Comment -> [Text]

130135 commentLines (LineComment s) = [s]

131− commentLines (BlockComment s) = lines s

136+ commentLines (BlockComment s) = T.lines s

132137

133− asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen

138+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

134139 asLine s = do

135140 i <- currentIndent

136141 return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

137142

138− removeComments :: String -> String

139− removeComments ('*' : '/' : s) = removeComments s

140− removeComments (c : s) = c : removeComments s

141−

142− removeComments [] = []

143+ removeComments :: Text -> Text

144+ removeComments t =

145+ case T.stripPrefix "*/" t of

146+ Just rest -> removeComments rest

147+ Nothing -> case T.uncons t of

148+ Just (x, xs) -> x `T.cons` removeComments xs

149+ Nothing -> ""

143150 match (JSRaw _ js) = return $ emit js

144151 match _ = mzero

145152

146−string :: (Emit gen) => String -> gen

147−string s = emit $ '"' : concatMap encodeChar s ++ "\""

153+string :: (Emit gen) => Text -> gen

154+string s = emit $ "\"" <> T.concatMap encodeChar s <> "\""

148155 where

149− encodeChar :: Char -> String

156+ encodeChar :: Char -> Text

150157 encodeChar '\b' = "\\b"

151158 encodeChar '\t' = "\\t"

152159 encodeChar '\n' = "\\n"

@@ -155,16 +162,16 @@ string s = emit $ '"' : concatMap encodeChar s ++ "\""

155162 encodeChar '\r' = "\\r"

156163 encodeChar '"' = "\\\""

157164 encodeChar '\\' = "\\\\"

158− encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "")

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

164− encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""

165− encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) ""

166− encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

167− encodeChar c = [c]

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.

167+ encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD"

168+ encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) ""

169+ encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) ""

170+ encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) ""

171+ encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) ""

172+ encodeChar c = T.singleton c

173+

174+ showHex' a b = T.pack (showHex a b)

168175

169176conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

170177conditional = mkPattern match

@@ -185,7 +192,7 @@ indexer = mkPattern' match

185192

186193 match _ = mzero

187194

188−lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)

195+lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)

189196lam = mkPattern match

190197 where

191198 match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

@@ -211,7 +218,7 @@ instanceOf = mkPattern match

211218 match (JSInstanceOf _ val ty) = Just (val, ty)

212219 match _ = Nothing

213220

214−unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen

221+unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen

215222unary' op mkStr = Wrap match (<>)

216223 where

217224 match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

@@ -220,7 +227,7 @@ unary' op mkStr = Wrap match (<>)

220227 match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

221228 match' _ = Nothing

222229

223−unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen

230+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen

224231unary op str = unary' op (const str)

225232

226233negateOperator :: (Emit gen) => Operator PrinterState JS gen

@@ -229,8 +236,8 @@ negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

229236 isNegate (JSUnary _ Negate _) = True

230237 isNegate _ = False

231238

232−binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen

233−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)

239+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen

240+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

234241 where

235242 match :: Pattern PrinterState JS (JS, JS)

236243 match = mkPattern match'

@@ -253,12 +260,12 @@ prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalState

253260-- |

254261-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

255262--

256−prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])

263+prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap])

257264prettyPrintJSWithSourceMaps js =

258265 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js

259266 in (s, mp)

260267

261−prettyPrintJS :: [JS] -> String

268+prettyPrintJS :: [JS] -> Text

262269prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

263270-- |

264271-- Generate an indented, pretty-printed string representing a Javascript expression

@@ -276,8 +283,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

276283 , [ unary JSNew "new " ]

277284 , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

278285 emit ("function "

279− ++ fromMaybe "" name

280− ++ "(" ++ intercalate ", " args ++ ") ")

286+ <> fromMaybe "" name

287+ <> "(" <> intercalate ", " args <> ") ")

281288 <> ret ]

282289 , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

283290 , [ unary Not "!"

src/Language/PureScript/Pretty/Kinds.hs+6−2

@@ -11,6 +11,8 @@ import Control.Arrow (ArrowPlus(..))

1111import Control.PatternArrows as PA

1212

1313import Data.Maybe (fromMaybe)

14+import qualified Data.Text as T

15+import Data.Text (Text)

1416

1517import Language.PureScript.Crash

1618import Language.PureScript.Kinds

@@ -38,9 +40,11 @@ funKind = mkPattern match

3840 match _ = Nothing

3941

4042-- | Generate a pretty-printed string representing a Kind

41−prettyPrintKind :: Kind -> String

43+prettyPrintKind :: Kind -> Text

4244prettyPrintKind

43− = fromMaybe (internalError "Incomplete pattern")

45+ -- TODO(Christoph): get rid of T.pack

46+ = T.pack

47+ . fromMaybe (internalError "Incomplete pattern")

4448 . PA.pattern matchKind ()

4549 where

4650 matchKind :: Pattern () Kind String

src/Language/PureScript/Pretty/Types.hs+12−9

@@ -18,6 +18,7 @@ import Control.Arrow ((<+>))

1818import Control.PatternArrows as PA

1919

2020import Data.Maybe (fromMaybe)

21+import qualified Data.Text as T

2122

2223import Language.PureScript.Crash

2324import Language.PureScript.Environment

@@ -29,6 +30,8 @@ import Language.PureScript.Types

2930

3031import Text.PrettyPrint.Boxes hiding ((<+>))

3132

33+-- TODO(Christoph): get rid of T.unpack s

34+

3235constraintsAsBox :: [Constraint] -> Box -> Box

3336constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)

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

4346prettyPrintRowWith open close = uncurry listToBox . toList []

4447 where

4548 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

4750

4851 tailToPs :: Type -> Box

4952 tailToPs REmpty = nullBox

@@ -57,7 +60,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList []

5760 [ tailToPs rest, text [close] ]

5861

5962 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

6164 toList tys r = (reverse tys, r)

6265

6366prettyPrintRow :: Type -> String

@@ -112,21 +115,21 @@ matchTypeAtom suggesting =

112115 typeLiterals :: Pattern () Type Box

113116 typeLiterals = mkPattern match where

114117 match TypeWildcard{} = Just $ text "_"

115− match (TypeVar var) = Just $ text var

118+ match (TypeVar var) = Just $ text $ T.unpack var

116119 match (TypeLevelString s) = Just . text $ show s

117120 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

119122 match (TUnknown u)

120123 | suggesting = Just $ text "_"

121124 | otherwise = Just $ text $ 't' : show u

122125 match (Skolem name s _ _)

123− | suggesting = Just $ text name

124− | otherwise = Just $ text $ name ++ show s

126+ | suggesting = Just $ text $ T.unpack name

127+ | otherwise = Just $ text $ T.unpack name ++ show s

125128 match REmpty = Just $ text "()"

126129 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

127130 match (BinaryNoParensType op l r) =

128131 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

130133 match _ = Nothing

131134

132135matchType :: Bool -> Pattern () Type Box

@@ -137,7 +140,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where

137140 , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]

138141 , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]

139142 , [ 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))) ]

141144 , [ Wrap explicitParens $ \_ ty -> ty ]

142145 ]

143146

@@ -151,7 +154,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where

151154forall_ :: Pattern () Type ([String], Type)

152155forall_ = mkPattern match

153156 where

154− match (PrettyPrintForAll idents ty) = Just (idents, ty)

157+ match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)

155158 match _ = Nothing

156159

157160typeAtomAsBox :: Type -> Box

src/Language/PureScript/Pretty/Values.hs+46−36

@@ -11,6 +11,11 @@ import Prelude.Compat

1111

1212import Control.Arrow (second)

1313

14+import qualified Data.Monoid as Monoid ((<>))

15+

16+import qualified Data.Text as T

17+import Data.Text (Text)

18+

1419import Language.PureScript.AST

1520import Language.PureScript.Crash

1621import Language.PureScript.Names

@@ -20,6 +25,11 @@ import Language.PureScript.Types (Constraint(..))

2025

2126import Text.PrettyPrint.Boxes

2227

28+-- TODO(Christoph): remove T.unpack s

29+

30+textT :: Text -> Box

31+textT = text . T.unpack

32+

2333-- | Render an aligned list of items separated with commas

2434list :: Char -> Char -> (a -> Box) -> [a] -> Box

2535list open close _ [] = text [open, close]

@@ -30,11 +40,11 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl

3040ellipsis :: Box

3141ellipsis = text "..."

3242

33−prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box

43+prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box

3444prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

3545 where

36− prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

37− prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

46+ prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box

47+ prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

3848

3949-- | Pretty-print an expression

4050prettyPrintValue :: Int -> Expr -> Box

@@ -44,13 +54,13 @@ prettyPrintValue d (IfThenElse cond th el) =

4454 // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th

4555 , text "else " <> prettyPrintValueAtom (d - 1) el

4656 ])

47−prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ prettyPrintObjectKey prop)

48−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

57+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop)

58+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps

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

51−prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder 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)

61+prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

5262prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

53− text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

63+ text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps

5464prettyPrintValue d (Case values binders) =

5565 (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //

5666 moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))

@@ -60,14 +70,14 @@ prettyPrintValue d (Let ds val) =

6070 (text "in " <> prettyPrintValue (d - 1) val)

6171prettyPrintValue d (Do els) =

6272 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

64−prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

73+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys

74+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name))

6575prettyPrintValue _ (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 ">"

6777prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

6878prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

6979prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

70−prettyPrintValue _ (Hole name) = text "?" <> text name

80+prettyPrintValue _ (Hole name) = text "?" <> textT name

7181prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

7282prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

7383prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

@@ -80,12 +90,12 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

8090prettyPrintValueAtom :: Int -> Expr -> Box

8191prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

8292prettyPrintValueAtom _ AnonymousArgument = text "_"

83−prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

84−prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

93+prettyPrintValueAtom _ (Constructor name) = text $ T.unpack $ runProperName (disqualify name)

94+prettyPrintValueAtom _ (Var ident) = text $ T.unpack $ showIdent (disqualify ident)

8595prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

8696 prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

8797 where

88− printOp (Op (Qualified _ name)) = text (runOpName name)

98+ printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name

8999 printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

90100prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

91101prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

@@ -105,9 +115,9 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon

105115prettyPrintDeclaration :: Int -> Declaration -> Box

106116prettyPrintDeclaration d _ | d < 0 = ellipsis

107117prettyPrintDeclaration _ (TypeDeclaration ident ty) =

108− text (showIdent ident ++ " :: ") <> typeAsBox ty

118+ text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty

109119prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =

110− text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val

120+ text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val

111121prettyPrintDeclaration d (BindingGroupDeclaration ds) =

112122 vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)

113123 where

@@ -118,7 +128,7 @@ prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDecla

118128prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box

119129prettyPrintCaseAlternative d _ | d < 0 = ellipsis

120130prettyPrintCaseAlternative d (CaseAlternative binders result) =

121− text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

131+ text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result

122132 where

123133 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

124134 prettyPrintResult (Left gs) =

@@ -138,50 +148,50 @@ prettyPrintDoNotationElement d _ | d < 0 = ellipsis

138148prettyPrintDoNotationElement d (DoNotationValue val) =

139149 prettyPrintValue d val

140150prettyPrintDoNotationElement d (DoNotationBind binder val) =

141− text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val

151+ textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val

142152prettyPrintDoNotationElement d (DoNotationLet ds) =

143153 text "let" //

144154 moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))

145155prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el

146156

147−prettyPrintBinderAtom :: Binder -> String

157+prettyPrintBinderAtom :: Binder -> Text

148158prettyPrintBinderAtom NullBinder = "_"

149159prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

150160prettyPrintBinderAtom (VarBinder ident) = showIdent ident

151161prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

152−prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

153−prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

162+prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b)

163+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder

154164prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

155165prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

156166prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op)

157167prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

158− prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

159−prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

168+ prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2

169+prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b)

160170

161−prettyPrintLiteralBinder :: Literal Binder -> String

162−prettyPrintLiteralBinder (StringLiteral str) = show str

163−prettyPrintLiteralBinder (CharLiteral c) = show c

164−prettyPrintLiteralBinder (NumericLiteral num) = either show show num

171+prettyPrintLiteralBinder :: Literal Binder -> Text

172+prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str)

173+prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)

174+prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num

165175prettyPrintLiteralBinder (BooleanLiteral True) = "true"

166176prettyPrintLiteralBinder (BooleanLiteral False) = "false"

167177prettyPrintLiteralBinder (ObjectLiteral bs) =

168178 "{ "

169− ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

170− ++ " }"

179+ Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)

180+ Monoid.<> " }"

171181 where

172− prettyPrintObjectPropertyBinder :: (String, Binder) -> String

173− prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

182+ prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text

183+ prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder

174184prettyPrintLiteralBinder (ArrayLiteral bs) =

175185 "[ "

176− ++ intercalate ", " (map prettyPrintBinder bs)

177− ++ " ]"

186+ Monoid.<> T.intercalate ", " (map prettyPrintBinder bs)

187+ Monoid.<> " ]"

178188

179189-- |

180190-- Generate a pretty-printed string representing a Binder

181191--

182−prettyPrintBinder :: Binder -> String

192+prettyPrintBinder :: Binder -> Text

183193prettyPrintBinder (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)

185195prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder

186196prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder

187197prettyPrintBinder b = prettyPrintBinderAtom b

src/Language/PureScript/Publish.hs−1

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

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE OverloadedStrings #-}

43module Language.PureScript.Publish

54 ( preparePackage

src/Language/PureScript/Publish/ErrorsWarnings.hs−2

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

31module Language.PureScript.Publish.ErrorsWarnings

42 ( PackageError(..)

53 , PackageWarning(..)

src/Language/PureScript/Renamer.hs+4−2

@@ -10,7 +10,9 @@ import Control.Monad.State

1010import Data.List (find)

1111import Data.Maybe (fromJust, fromMaybe)

1212import qualified Data.Map as M

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

1314import qualified Data.Set as S

15+import qualified Data.Text as T

1416

1517import Language.PureScript.CoreFn

1618import Language.PureScript.Names

@@ -80,7 +82,7 @@ updateScope ident =

8082 getNewName usedNames name =

8183 fromJust $ find

8284 (`S.notMember` usedNames)

83− [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]

85+ [ Ident (runIdent name <> T.pack (show (i :: Int))) | i <- [1..] ]

8486

8587-- |

8688-- Finds the new name to use for an ident.

@@ -91,7 +93,7 @@ lookupIdent name = do

9193 name' <- gets $ M.lookup name . rsBoundNames

9294 case name' of

9395 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) ++ "'"

9597

9698-- |

9799-- Finds idents introduced by declarations.

src/Language/PureScript/Sugar/ObjectWildcards.hs+4−3

@@ -11,6 +11,7 @@ import Control.Monad.Supply.Class

1111

1212import Data.List (partition)

1313import Data.Maybe (catMaybes)

14+import Data.Text (Text)

1415

1516import Language.PureScript.AST

1617import Language.PureScript.Errors

@@ -61,7 +62,7 @@ desugarDecl other = fn other

6162 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

6263 desugarExpr e = return e

6364

64− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

65+ wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr

6566 wrapLambda mkVal ps =

6667 let (args, props) = partition (isAnonymousArgument . snd) ps

6768 in if null args

@@ -74,7 +75,7 @@ desugarDecl other = fn other

7475 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

7576 stripPositionInfo e = e

7677

77− peelAnonAccessorChain :: Expr -> Maybe [String]

78+ peelAnonAccessorChain :: Expr -> Maybe [Text]

7879 peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e

7980 peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e

8081 peelAnonAccessorChain AnonymousArgument = Just []

@@ -85,7 +86,7 @@ desugarDecl other = fn other

8586 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

8687 isAnonymousArgument _ = False

8788

88− mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

89+ mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr))

8990 mkProp (name, e) = do

9091 arg <- freshIfAnon e

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

2727import Control.Monad.State

2828import Data.List ((\\), find, sortBy)

2929import Data.Maybe (catMaybes, mapMaybe, isJust)

30−

3130import qualified Data.Map as M

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

32+import Data.Text (Text)

33+import qualified Data.Text as T

3234

3335type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData

3436

@@ -55,11 +57,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu

5557 -> ExternsDeclaration

5658 -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)

5759 fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where

58− typeClass = TypeClassData { typeClassArguments = args

59− , typeClassMembers = members

60− , typeClassSuperclasses = implies

61− , typeClassDependencies = deps

62− }

60+ typeClass = makeTypeClassData args members implies deps

6361 fromExternsDecl _ _ = Nothing

6462

6563desugarModule

@@ -180,7 +178,7 @@ desugarDecl

180178desugarDecl mn exps = go

181179 where

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

184182 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

185183 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"

186184 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

@@ -231,7 +229,7 @@ memberToNameAndType _ = internalError "Invalid declaration in type class definit

231229

232230typeClassDictionaryDeclaration

233231 :: ProperName 'ClassName

234− -> [(String, Maybe Kind)]

232+ -> [(Text, Maybe Kind)]

235233 -> [Constraint]

236234 -> [Declaration]

237235 -> Declaration

@@ -247,7 +245,7 @@ typeClassDictionaryDeclaration name args implies members =

247245typeClassMemberToDictionaryAccessor

248246 :: ModuleName

249247 -> ProperName 'ClassName

250− -> [(String, Maybe Kind)]

248+ -> [(Text, Maybe Kind)]

251249 -> Declaration

252250 -> Declaration

253251typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

@@ -323,14 +321,14 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

323321 return (PositionedValue pos com val)

324322 memberToValue _ _ = internalError "Invalid declaration in type instance definition"

325323

326−typeClassMemberName :: Declaration -> String

324+typeClassMemberName :: Declaration -> Text

327325typeClassMemberName (TypeDeclaration ident _) = runIdent ident

328326typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

329327typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

330328typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"

331329

332−superClassDictionaryNames :: [Constraint] -> [String]

330+superClassDictionaryNames :: [Constraint] -> [Text]

333331superClassDictionaryNames supers =

334− [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)

332+ [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer))

335333 | (index, Constraint pn _ _) <- zip [0..] supers

336334 ]

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+8−10

@@ -1,6 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE PatternGuards #-}

3−

41-- |

52-- This module implements the generic deriving elaboration that takes place during desugaring.

63--

@@ -16,6 +13,7 @@ import Control.Monad.Supply.Class (MonadSupply)

1613import Data.List (foldl', find, sortBy, unzip5)

1714import Data.Maybe (fromMaybe)

1815import Data.Ord (comparing)

16+import Data.Text (Text)

1917

2018import Language.PureScript.AST

2119import Language.PureScript.Crash

@@ -118,7 +116,7 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do

118116 takeReverse :: Int -> [a] -> [a]

119117 takeReverse n = take n . reverse

120118

121− stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type

119+ stripRight :: [(Text, Maybe kind)] -> Type -> Maybe Type

122120 stripRight [] ty = Just ty

123121 stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))

124122 | arg == arg' = stripRight args t

@@ -285,14 +283,14 @@ deriveGeneric mn ds tyConNm dargs = do

285283 (App e unitVal)

286284 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal)

287285

288− mkRecCase :: [(String, Type)] -> CaseAlternative

286+ mkRecCase :: [(Text, Type)] -> CaseAlternative

289287 mkRecCase rs =

290288 CaseAlternative

291289 [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

292290 . Right

293291 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

294292

295− mkRecFun :: [(String, Type)] -> Expr

293+ mkRecFun :: [(Text, Type)] -> Expr

296294 mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs

297295 where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

298296 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

@@ -576,13 +574,13 @@ deriveOrd mn ds tyConNm = do

576574 where

577575 catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ"))

578576

579− orderingName :: String -> Qualified (ProperName a)

577+ orderingName :: Text -> Qualified (ProperName a)

580578 orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName

581579

582− orderingCtor :: String -> Expr

580+ orderingCtor :: Text -> Expr

583581 orderingCtor = Constructor . orderingName

584582

585− orderingBinder :: String -> Binder

583+ orderingBinder :: Text -> Binder

586584 orderingBinder name = ConstructorBinder (orderingName name) []

587585

588586 ordCompare :: Expr -> Expr -> Expr

@@ -700,7 +698,7 @@ objectType :: Type -> Maybe Type

700698objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec

701699objectType _ = Nothing

702700

703−decomposeRec :: Type -> [(String, Type)]

701+decomposeRec :: Type -> [(Text, Type)]

704702decomposeRec = sortBy (comparing fst) . go

705703 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

706704 go _ = []

src/Language/PureScript/TypeChecker.hs+49−34

@@ -16,11 +16,16 @@ import Control.Monad.Error.Class (MonadError(..))

1616import Control.Monad.State.Class (MonadState(..), modify)

1717import Control.Monad.Supply.Class (MonadSupply)

1818import Control.Monad.Writer.Class (MonadWriter(..))

19+import Control.Lens ((^..), _1, _2)

1920

2021import Data.Foldable (for_, traverse_)

2122import Data.List (nub, nubBy, (\\), sort, group)

2223import Data.Maybe

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

2429

2530import Language.PureScript.AST

2631import Language.PureScript.Crash

@@ -42,7 +47,7 @@ addDataType

4247 => ModuleName

4348 -> DataDeclType

4449 -> ProperName 'TypeName

45− -> [(String, Maybe Kind)]

50+ -> [(Text, Maybe Kind)]

4651 -> [(ProperName 'ConstructorName, [Type])]

4752 -> Kind

4853 -> m ()

@@ -58,7 +63,7 @@ addDataConstructor

5863 => ModuleName

5964 -> DataDeclType

6065 -> ProperName 'TypeName

61− -> [String]

66+ -> [Text]

6267 -> ProperName 'ConstructorName

6368 -> [Type]

6469 -> m ()

@@ -68,14 +73,14 @@ addDataConstructor moduleName dtype name args dctor tys = do

6873 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

6974 let dctorTy = foldr function retTy tys

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

7277 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

7378

7479addTypeSynonym

7580 :: (MonadState CheckState m, MonadError MultipleErrors m)

7681 => ModuleName

7782 -> ProperName 'TypeName

78− -> [(String, Maybe Kind)]

83+ -> [(Text, Maybe Kind)]

7984 -> Type

8085 -> Kind

8186 -> m ()

@@ -111,7 +116,7 @@ addTypeClass

111116 :: (MonadState CheckState m)

112117 => ModuleName

113118 -> ProperName 'ClassName

114− -> [(String, Maybe Kind)]

119+ -> [(Text, Maybe Kind)]

115120 -> [Constraint]

116121 -> [FunctionalDependency]

117122 -> [Declaration]

@@ -120,12 +125,7 @@ addTypeClass moduleName pn args implies dependencies ds =

120125 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }

121126 where

122127 newClass :: TypeClassData

123− newClass =

124− TypeClassData { typeClassArguments = args

125− , typeClassMembers = map toPair ds

126− , typeClassSuperclasses = implies

127− , typeClassDependencies = dependencies

128− }

128+ newClass = makeTypeClassData args (map toPair ds) implies dependencies

129129

130130 toPair (TypeDeclaration ident ty) = (ident, ty)

131131 toPair (PositionedDeclaration _ _ d) = toPair d

@@ -134,7 +134,7 @@ addTypeClass moduleName pn args implies dependencies ds =

134134addTypeClassDictionaries

135135 :: (MonadState CheckState m)

136136 => Maybe ModuleName

137− -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

137+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)

138138 -> m ()

139139addTypeClassDictionaries mn entries =

140140 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

@@ -142,27 +142,37 @@ addTypeClassDictionaries mn entries =

142142

143143checkDuplicateTypeArguments

144144 :: (MonadState CheckState m, MonadError MultipleErrors m)

145− => [String]

145+ => [Text]

146146 -> m ()

147147checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

148148 throwError . errorMessage $ DuplicateTypeArgument dup

149149 where

150− firstDup :: Maybe String

150+ firstDup :: Maybe Text

151151 firstDup = listToMaybe $ args \\ nub args

152152

153153checkTypeClassInstance

154− :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

155− => ModuleName

154+ :: (MonadState CheckState m, MonadError MultipleErrors m)

155+ => TypeClassData

156+ -> Int -- ^ index of type class argument

156157 -> Type

157158 -> m ()

158−checkTypeClassInstance _ (TypeVar _) = return ()

159−checkTypeClassInstance _ (TypeLevelString _) = return ()

160−checkTypeClassInstance _ (TypeConstructor ctor) = do

161− env <- getEnv

162− when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance

163− return ()

164−checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2

165−checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

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

167+ TypeLevelString _ -> return ()

168+ TypeConstructor ctor -> do

169+ env <- getEnv

170+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance

171+ return ()

172+ TypeApp t1 t2 -> check t1 >> check t2

173+ REmpty | isFunDepDetermined -> return ()

174+ RCons _ hd tl | isFunDepDetermined -> check hd >> check tl

175+ ty -> throwError . errorMessage $ InvalidInstanceHead ty

166176

167177-- |

168178-- Check that type synonyms are fully-applied in a type

@@ -205,9 +215,10 @@ typeCheckAll moduleName _ = traverse go

205215 addDataType moduleName dtype name args' dctors ctorKind

206216 return $ DataDeclaration dtype name args dctors

207217 go (d@(DataBindingGroupDeclaration tys)) = do

208− warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

209− let syns = mapMaybe toTypeSynonym tys

210− let dataDecls = mapMaybe toDataDecl tys

218+ let syns = mapMaybe toTypeSynonym tys

219+ dataDecls = mapMaybe toDataDecl tys

220+ bindingGroupNames = nub ((syns^..traverse._1) ++ (dataDecls^..traverse._2))

221+ warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do

211222 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

212223 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do

213224 when (dtype == Newtype) $ checkNewtype name dctors

@@ -278,12 +289,16 @@ typeCheckAll moduleName _ = traverse go

278289 addTypeClass moduleName pn args implies deps tys

279290 return d

280291 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

281− traverse_ (checkTypeClassInstance moduleName) tys

282− checkOrphanInstance dictName className tys

283− _ <- traverseTypeInstanceBody checkInstanceMembers body

284− let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

285− addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict

286− return d

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

296+ sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

297+ checkOrphanInstance dictName className tys

298+ _ <- traverseTypeInstanceBody checkInstanceMembers body

299+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

300+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict

301+ return d

287302 go (PositionedDeclaration pos com d) =

288303 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

289304

@@ -323,7 +338,7 @@ typeCheckAll moduleName _ = traverse go

323338 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

324339 -- extracted from the kind of the type constructor itself.

325340 --

326− withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]

341+ withKinds :: [(Text, Maybe Kind)] -> Kind -> [(Text, Maybe Kind)]

327342 withKinds [] _ = []

328343 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

329344 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

1919import Control.Monad.Supply.Class (MonadSupply(..))

2020import Control.Monad.Writer

2121

22−import Data.Foldable (for_)

22+import Data.Foldable (for_, fold, toList)

2323import Data.Function (on)

2424import Data.List (minimumBy, nub)

2525import Data.Maybe (fromMaybe, maybeToList, mapMaybe)

2626import qualified Data.Map as M

2727import qualified Data.Set as S

28+import qualified Data.Text as T

29+import Data.Text (Text)

2830

2931import Language.PureScript.AST

3032import Language.PureScript.Crash

@@ -37,17 +39,32 @@ import Language.PureScript.TypeClassDictionaries

3739import Language.PureScript.Types

3840import qualified Language.PureScript.Constants as C

3941

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+

4058-- | The 'InstanceContext' tracks those constraints which can be satisfied.

4159type InstanceContext = M.Map (Maybe ModuleName)

4260 (M.Map (Qualified (ProperName 'ClassName))

43− (M.Map (Qualified Ident)

44− TypeClassDictionaryInScope))

61+ (M.Map (Qualified Ident) NamedDict))

4562

4663-- | A type substitution which makes an instance head match a list of types.

4764--

4865-- Note: we store many types per type variable name. For any name, all types

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

5168

5269combineContexts :: InstanceContext -> InstanceContext -> InstanceContext

5370combineContexts = M.unionWith (M.unionWith M.union)

@@ -88,7 +105,7 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d

88105

89106-- | Three options for how we can handle a constraint, depending on the mode we're in.

90107data EntailsResult a

91− = Solved a TypeClassDictionaryInScope

108+ = Solved a TypeClassDict

92109 -- ^ We solved this constraint

93110 | Unsolved Constraint

94111 -- ^ We couldn't solve this constraint right now, it will be generalized

@@ -120,7 +137,8 @@ entails

120137entails SolverOptions{..} constraint context hints =

121138 solve constraint

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

124142 forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))

125143 forClassName _ _ _ = internalError "forClassName: expected qualified class name"

126144

@@ -130,8 +148,8 @@ entails SolverOptions{..} constraint context hints =

130148 ctorModules (TypeApp ty _) = ctorModules ty

131149 ctorModules _ = Nothing

132150

133− findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

134− findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

151+ findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]

152+ findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

135153

136154 valUndefined :: Expr

137155 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))

@@ -181,12 +199,12 @@ entails SolverOptions{..} constraint context hints =

181199 -- Solve any necessary subgoals

182200 args <- solveSubgoals subst'' (tcdDependencies tcd)

183201 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

184− (mkDictionary (tcdName tcd) args)

202+ (mkDictionary (tcdValue tcd) args)

185203 (tcdPath tcd)

186204 return match

187205 Unsolved unsolved -> do

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

190208 let qident = Qualified Nothing ident

191209 -- Store the new dictionary in the InstanceContext so that we can solve this goal in

192210 -- future.

@@ -213,7 +231,7 @@ entails SolverOptions{..} constraint context hints =

213231 -- fresh type variables. This function extends a substitution with fresh type variables

214232 -- as necessary, based on the types in the instance head.

215233 withFreshTypes

216− :: TypeClassDictionaryInScope

234+ :: TypeClassDict

217235 -> Matching Type

218236 -> m (Matching Type)

219237 withFreshTypes TypeClassDictionaryInScope{..} subst = do

@@ -232,7 +250,7 @@ entails SolverOptions{..} constraint context hints =

232250 t <- freshType

233251 return (s, t)

234252

235− unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)

253+ unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a)

236254 unique tyArgs []

237255 | solverDeferErrors = return Deferred

238256 -- We need a special case for nullary type classes, since we want

@@ -242,7 +260,7 @@ entails SolverOptions{..} constraint context hints =

242260 unique _ [(a, dict)] = return $ Solved a dict

243261 unique tyArgs tcds

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

246264 return $ uncurry Solved (head tcds)

247265 | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)

248266

@@ -255,12 +273,12 @@ entails SolverOptions{..} constraint context hints =

255273 --

256274 -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have

257275 -- been caught when constructing superclass dictionaries.

258− overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool

276+ overlapping :: TypeClassDict -> TypeClassDict -> Bool

259277 overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False

260278 overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False

261279 overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False

262280 overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False

263− overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2

281+ overlapping tcd1 tcd2 = tcdValue tcd1 /= tcdValue tcd2

264282

265283 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

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

271289 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

272290

273291 -- Make a dictionary from subgoal dictionaries by applying the correct function

274− mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr

275− mkDictionary fnName Nothing = Var fnName

276− mkDictionary fnName (Just []) = Var fnName

277− mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts

292+ mkDictionary :: Evidence -> Maybe [Expr] -> Expr

293+ mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

294+ mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where

295+ fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))

296+ ]

278297

279298 -- Turn a DictionaryValue into a Expr

280299 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

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

283302 dict)

284303 valUndefined

285304

286305-- Check if an instance matches our list of types, allowing for types

287306-- to be solved via functional dependencies. If the types match, we return a

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

290309matches deps TypeClassDictionaryInScope{..} tys = do

291310 -- First, find those types which match exactly

292311 let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes

@@ -345,7 +364,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

345364 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

346365 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

347366

348− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type])

367+ go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])

349368 go [] REmpty [] REmpty = (True, M.empty)

350369 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)

351370 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)

@@ -383,7 +402,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

383402 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

384403 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

385404 where

386− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

405+ go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool

387406 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

388407 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

389408 go [] REmpty [] REmpty = True

@@ -402,7 +421,7 @@ newDictionaries

402421 => [(Qualified (ProperName 'ClassName), Integer)]

403422 -> Qualified Ident

404423 -> Constraint

405− -> m [TypeClassDictionaryInScope]

424+ -> m [NamedDict]

406425newDictionaries path name (Constraint className instanceTy _) = do

407426 tcs <- gets (typeClasses . checkEnv)

408427 let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

@@ -413,12 +432,12 @@ newDictionaries path name (Constraint className instanceTy _) = do

413432 ) typeClassSuperclasses [0..]

414433 return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)

415434 where

416− instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

435+ instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type]

417436 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

418437

419−mkContext :: [TypeClassDictionaryInScope] -> InstanceContext

438+mkContext :: [NamedDict] -> InstanceContext

420439mkContext = 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))

422441

423442-- | Check all pairs of values in a list match a predicate

424443pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool

src/Language/PureScript/TypeChecker/Kinds.hs+8−7

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

1818import Control.Monad.State

1919

2020import qualified Data.Map as M

21+import Data.Text (Text)

2122

2223import Language.PureScript.Crash

2324import Language.PureScript.Environment

@@ -104,7 +105,7 @@ kindOf ty = fst <$> kindOfWithScopedVars ty

104105kindOfWithScopedVars ::

105106 (MonadError MultipleErrors m, MonadState CheckState m) =>

106107 Type ->

107− m (Kind, [(String, Kind)])

108+ m (Kind, [(Text, Kind)])

108109kindOfWithScopedVars ty =

109110 withErrorMessageHint (ErrorCheckingKind ty) $

110111 fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty

@@ -119,7 +120,7 @@ kindsOf

119120 => Bool

120121 -> ModuleName

121122 -> ProperName 'TypeName

122− -> [(String, Maybe Kind)]

123+ -> [(Text, Maybe Kind)]

123124 -> [Type]

124125 -> m Kind

125126kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

@@ -134,7 +135,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . c

134135

135136freshKindVar

136137 :: (MonadError MultipleErrors m, MonadState CheckState m)

137− => (String, Maybe Kind)

138+ => (Text, Maybe Kind)

138139 -> Kind

139140 -> m (ProperName 'TypeName, Kind)

140141freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

@@ -146,8 +147,8 @@ freshKindVar (arg, Just kind') kind = do

146147kindsOfAll

147148 :: (MonadError MultipleErrors m, MonadState CheckState m)

148149 => ModuleName

149− -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

150− -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

150+ -> [(ProperName 'TypeName, [(Text, Maybe Kind)], Type)]

151+ -> [(ProperName 'TypeName, [(Text, Maybe Kind)], [Type])]

151152 -> m ([Kind], [Kind])

152153kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do

153154 synVars <- replicateM (length syns) freshKind

@@ -198,14 +199,14 @@ starIfUnknown k = k

198199infer

199200 :: (MonadError MultipleErrors m, MonadState CheckState m)

200201 => Type

201− -> m (Kind, [(String, Kind)])

202+ -> m (Kind, [(Text, Kind)])

202203infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty

203204

204205infer'

205206 :: forall m

206207 . (MonadError MultipleErrors m, MonadState CheckState m)

207208 => Type

208− -> m (Kind, [(String, Kind)])

209+ -> m (Kind, [(Text, Kind)])

209210infer' (ForAll ident ty _) = do

210211 k1 <- freshKind

211212 Just moduleName <- checkCurrentModule <$> get

src/Language/PureScript/TypeChecker/Monad.hs+6−5

@@ -15,6 +15,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor)

1515

1616import Data.Maybe

1717import qualified Data.Map as M

18+import Data.Text (Text)

1819

1920import Language.PureScript.Environment

2021import Language.PureScript.Errors

@@ -93,7 +94,7 @@ bindTypes newNames action = do

9394withScopedTypeVars

9495 :: (MonadState CheckState m, MonadWriter MultipleErrors m)

9596 => ModuleName

96− -> [(String, Kind)]

97+ -> [(Text, Kind)]

9798 -> m a

9899 -> m a

99100withScopedTypeVars mn ks ma = do

@@ -133,12 +134,12 @@ warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition

133134-- | Temporarily make a collection of type class dictionaries available

134135withTypeClassDictionaries

135136 :: MonadState CheckState m

136− => [TypeClassDictionaryInScope]

137+ => [NamedDict]

137138 -> m a

138139 -> m a

139140withTypeClassDictionaries entries action = do

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

142143 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }

143144 a <- action

144145 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

@@ -147,14 +148,14 @@ withTypeClassDictionaries entries action = do

147148-- | Get the currently available map of type class dictionaries

148149getTypeClassDictionaries

149150 :: (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)))

151152getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

152153

153154-- | Lookup type class dictionaries in a module.

154155lookupTypeClassDictionaries

155156 :: (MonadState CheckState m)

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

158159lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

159160

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

1818import Data.Functor.Identity (Identity(), runIdentity)

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

2020import Data.Monoid

21+import Data.Text (Text)

2122

2223import Language.PureScript.AST

2324import Language.PureScript.Crash

@@ -56,7 +57,7 @@ newSkolemScope = do

5657-- |

5758-- Skolemize a type variable by replacing its instances with fresh skolem constants

5859--

59−skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type

60+skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type

6061skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

6162

6263-- |

@@ -64,25 +65,25 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

6465-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the

6566-- only example of scoped type variables.

6667--

67−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

68+skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

6869skolemizeTypesInValue ident sko scope ss =

6970 let

7071 (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS

7172 in runIdentity . f

7273 where

73− onExpr :: [String] -> Expr -> Identity ([String], Expr)

74+ onExpr :: [Text] -> Expr -> Identity ([Text], Expr)

7475 onExpr sco (DeferredDictionary c ts)

7576 | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))

7677 onExpr sco (TypedValue check val ty)

7778 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))

7879 onExpr sco other = return (sco, other)

7980

80− onBinder :: [String] -> Binder -> Identity ([String], Binder)

81+ onBinder :: [Text] -> Binder -> Identity ([Text], Binder)

8182 onBinder sco (TypedBinder ty b)

8283 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)

8384 onBinder sco other = return (sco, other)

8485

85− peelTypeVars :: Type -> [String]

86+ peelTypeVars :: Type -> [Text]

8687 peelTypeVars (ForAll i ty _) = i : peelTypeVars ty

8788 peelTypeVars _ = []

8889

src/Language/PureScript/TypeChecker/Subsumption.hs−1

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

1−{-# LANGUAGE DataKinds #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE TypeFamilies #-}

src/Language/PureScript/TypeChecker/TypeSearch.hs−4

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

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−

51module Language.PureScript.TypeChecker.TypeSearch

62 ( typeSearch

73 ) where

src/Language/PureScript/TypeChecker/Types.hs+7−7

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE OverloadedStrings #-}

31{-# LANGUAGE NamedFieldPuns #-}

53-- |

@@ -40,8 +38,10 @@ import Data.Either (lefts, rights)

4038import Data.Functor (($>))

4139import Data.List (transpose, nub, (\\), partition, delete)

4240import Data.Maybe (fromMaybe)

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

4342import qualified Data.Map as M

4443import qualified Data.Set as S

44+import Data.Text (Text)

4545

4646import Language.PureScript.AST

4747import Language.PureScript.Crash

@@ -442,7 +442,7 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do

442442 unifyTypes val (TypeApp tyRecord row)

443443 return m1

444444 where

445− inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type)

445+ inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)

446446 inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty

447447 inferRowProperties nrow row ((name, binder):binders) = do

448448 propTy <- freshType

@@ -559,7 +559,7 @@ check' val (ForAll ident ty _) = do

559559 return $ TypedValue True val' (ForAll ident ty (Just scope))

560560check' val t@(ConstrainedType constraints ty) = do

561561 dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) ->

562− freshIdent ("dict" ++ className)

562+ freshIdent ("dict" <> className)

563563 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

564564 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

565565 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

@@ -681,10 +681,10 @@ check' val ty = do

681681checkProperties ::

682682 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

683683 Expr ->

684− [(String, Expr)] ->

684+ [(Text, Expr)] ->

685685 Type ->

686686 Bool ->

687− m [(String, Expr)]

687+ m [(Text, Expr)]

688688checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where

689689 go [] [] REmpty = return []

690690 go [] [] u@(TUnknown _)

@@ -771,7 +771,7 @@ checkFunctionApplication' fn u arg = do

771771-- |

772772-- Ensure a set of property names and value does not contain duplicate labels

773773--

774−ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()

774+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m ()

775775ensureNoDuplicateProperties ps =

776776 let ls = map fst ps in

777777 case ls \\ nub ls of

src/Language/PureScript/TypeChecker/Unify.hs+5−3

@@ -24,6 +24,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))

2424

2525import Data.List (nub, sort)

2626import qualified Data.Map as M

27+import Data.Text (Text)

28+import qualified Data.Text as T

2729

2830import Language.PureScript.Crash

2931import Language.PureScript.Errors

@@ -137,7 +139,7 @@ unifyRows r1 r2 =

137139 forM_ int (uncurry unifyTypes)

138140 unifyRows' sd1 r1' sd2 r2'

139141 where

140− unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m ()

142+ unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m ()

141143 unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r))

142144 unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r))

143145 unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do

@@ -155,7 +157,7 @@ unifyRows r1 r2 =

155157-- |

156158-- Replace a single type variable with a new unification variable

157159--

158−replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type

160+replaceVarWithUnknown :: (MonadState CheckState m) => Text -> Type -> m Type

159161replaceVarWithUnknown ident ty = do

160162 tu <- freshType

161163 return $ replaceTypeVars ident tu ty

@@ -179,7 +181,7 @@ replaceTypeWildcards = everywhereOnTypesM replace

179181varIfUnknown :: Type -> Type

180182varIfUnknown ty =

181183 let unks = nub $ unknownsInType ty

182− toName = (:) 't' . show

184+ toName = T.cons 't' . T.pack . show

183185 ty' = everywhereOnTypes typeToVar ty

184186 typeToVar :: Type -> Type

185187 typeToVar (TUnknown u) = TypeVar (toName u)

src/Language/PureScript/TypeClassDictionaries.hs+9−4

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

1+{-# LANGUAGE DeriveFoldable #-}

2+{-# LANGUAGE DeriveTraversable #-}

13module Language.PureScript.TypeClassDictionaries where

35import Prelude.Compat

@@ -8,10 +10,10 @@ import Language.PureScript.Types

810-- |

911-- Data representing a type class dictionary which is in scope

1012--

11−data TypeClassDictionaryInScope

13+data TypeClassDictionaryInScope v

1214 = TypeClassDictionaryInScope {

13− -- | The identifier with which the dictionary can be accessed at runtime

14− tcdName :: Qualified Ident

15+ -- | The value with which the dictionary can be accessed at runtime

16+ tcdValue :: v

1517 -- | How to obtain this instance via superclass relationships

1618 , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

1719 -- | The name of the type class to which this type class instance applies

@@ -21,4 +23,7 @@ data TypeClassDictionaryInScope

2123 -- | Type class dependencies which must be satisfied to construct this dictionary

2224 , tcdDependencies :: Maybe [Constraint]

2325 }

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

99import Prelude.Compat

1010

1111import Control.Monad ((<=<))

12−

13−import Data.List (nub)

14−import Data.Maybe (fromMaybe)

1512import qualified Data.Aeson as A

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

1719

1820import Language.PureScript.AST.SourcePos

1921import Language.PureScript.Kinds

@@ -32,9 +34,9 @@ data Type

3234 -- | A unification variable of type Type

3335 = TUnknown Int

3436 -- | A named type variable

35− | TypeVar String

37+ | TypeVar Text

3638 -- | A type-level string

37− | TypeLevelString String

39+ | TypeLevelString Text

3840 -- | A type wildcard, as would appear in a partial type synonym

3941 | TypeWildcard SourceSpan

4042 -- | A type constructor

@@ -45,15 +47,15 @@ data Type

4547 -- | A type application

4648 | TypeApp Type Type

4749 -- | Forall quantifier

48− | ForAll String Type (Maybe SkolemScope)

50+ | ForAll Text Type (Maybe SkolemScope)

4951 -- | A type with a set of type class constraints

5052 | ConstrainedType [Constraint] Type

5153 -- | A skolem constant

52− | Skolem String Int SkolemScope (Maybe SourceSpan)

54+ | Skolem Text Int SkolemScope (Maybe SourceSpan)

5355 -- | An empty row

5456 | REmpty

5557 -- | A non-empty row

56− | RCons String Type Type

58+ | RCons Text Type Type

5759 -- | A type with a kind annotation

5860 | KindedType Type Kind

5961 -- | A placeholder used in pretty printing

@@ -61,7 +63,7 @@ data Type

6163 -- | A placeholder used in pretty printing

6264 | PrettyPrintObject Type

6365 -- | A placeholder used in pretty printing

64− | PrettyPrintForAll [String] Type

66+ | PrettyPrintForAll [Text] Type

6567 -- | Binary operator application. During the rebracketing phase of desugaring,

6668 -- this data constructor will be removed.

6769 | BinaryNoParensType Type Type Type

@@ -75,7 +77,7 @@ data Type

7577

7678-- | Additional data relevant to type class constraints

7779data ConstraintData

78− = PartialConstraintData [[String]] Bool

80+ = PartialConstraintData [[Text]] Bool

7981 -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.

8082 -- It contains (rendered) binder information for those binders which were

8183 -- not matched, and a flag indicating whether the list was truncated or not.

@@ -106,7 +108,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData)

106108-- |

107109-- Convert a row to a list of pairs of labels and types

108110--

109−rowToList :: Type -> ([(String, Type)], Type)

111+rowToList :: Type -> ([(Text, Type)], Type)

110112rowToList (RCons name ty row) = let (tys, rest) = rowToList row

111113 in ((name, ty):tys, rest)

112114rowToList r = ([], r)

@@ -114,7 +116,7 @@ rowToList r = ([], r)

114116-- |

115117-- Convert a list of labels and types to a row

116118--

117−rowFromList :: ([(String, Type)], Type) -> Type

119+rowFromList :: ([(Text, Type)], Type) -> Type

118120rowFromList ([], r) = r

119121rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

120122

@@ -128,23 +130,23 @@ isMonoType _ = True

128130-- |

129131-- Universally quantify a type

130132--

131−mkForAll :: [String] -> Type -> Type

133+mkForAll :: [Text] -> Type -> Type

132134mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

133135

134136-- |

135137-- Replace a type variable, taking into account variable shadowing

136138--

137−replaceTypeVars :: String -> Type -> Type -> Type

139+replaceTypeVars :: Text -> Type -> Type -> Type

138140replaceTypeVars v r = replaceAllTypeVars [(v, r)]

139141

140142-- |

141143-- Replace named type variables with types

142144--

143−replaceAllTypeVars :: [(String, Type)] -> Type -> Type

145+replaceAllTypeVars :: [(Text, Type)] -> Type -> Type

144146replaceAllTypeVars = go []

145147 where

146148

147− go :: [String] -> [(String, Type)] -> Type -> Type

149+ go :: [Text] -> [(Text, Type)] -> Type -> Type

148150 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)

149151 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)

150152 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f

@@ -163,16 +165,16 @@ replaceAllTypeVars = go []

163165 go bs m (ParensInType t) = ParensInType (go bs m t)

164166 go _ _ ty = ty

165167

166− genName orig inUse = try 0

168+ genName orig inUse = try' 0

167169 where

168− try :: Integer -> String

169− try n | (orig ++ show n) `elem` inUse = try (n + 1)

170− | otherwise = orig ++ show n

170+ try' :: Integer -> Text

171+ try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1)

172+ | otherwise = orig <> T.pack (show n)

171173

172174-- |

173175-- Collect all type variables appearing in a type

174176--

175−usedTypeVariables :: Type -> [String]

177+usedTypeVariables :: Type -> [Text]

176178usedTypeVariables = nub . everythingOnTypes (++) go

177179 where

178180 go (TypeVar v) = [v]

@@ -181,10 +183,10 @@ usedTypeVariables = nub . everythingOnTypes (++) go

181183-- |

182184-- Collect all free type variables appearing in a type

183185--

184−freeTypeVariables :: Type -> [String]

186+freeTypeVariables :: Type -> [Text]

185187freeTypeVariables = nub . go []

186188 where

187− go :: [String] -> Type -> [String]

189+ go :: [Text] -> Type -> [Text]

188190 go bound (TypeVar v) | v `notElem` bound = [v]

189191 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

190192 go bound (ForAll v t _) = go (v : bound) t

@@ -292,32 +294,32 @@ everywhereOnTypesTopDownM f = go <=< f

292294 go other = f other

293295

294296everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

295−everythingOnTypes (<>) f = go

297+everythingOnTypes (<+>) f = go

296298 where

297− go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

298− go t@(ForAll _ ty _) = f t <> go ty

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

301− go t@(KindedType ty _) = f t <> go ty

302− go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

303− go t@(PrettyPrintObject t1) = f t <> go t1

304− go t@(PrettyPrintForAll _ t1) = f t <> go t1

305− go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3

306− go t@(ParensInType t1) = f t <> go t1

299+ go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2

300+ go t@(ForAll _ ty _) = f t <+> go ty

301+ go t@(ConstrainedType cs ty) = foldl (<+>) (f t) (map go $ concatMap constraintArgs cs) <+> go ty

302+ go t@(RCons _ ty rest) = f t <+> go ty <+> go rest

303+ go t@(KindedType ty _) = f t <+> go ty

304+ go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2

305+ go t@(PrettyPrintObject t1) = f t <+> go t1

306+ go t@(PrettyPrintForAll _ t1) = f t <+> go t1

307+ go t@(BinaryNoParensType t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3

308+ go t@(ParensInType t1) = f t <+> go t1

307309 go other = f other

308310

309311everythingWithContextOnTypes :: 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

311313 where

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

314+ go' s t = let (s', r) = f s t in r <+> go s' t

315+ go s (TypeApp t1 t2) = go' s t1 <+> go' s t2

314316 go s (ForAll _ ty _) = go' s ty

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

317+ go s (ConstrainedType cs ty) = foldl (<+>) r0 (map (go' s) $ concatMap constraintArgs cs) <+> go' s ty

318+ go s (RCons _ ty rest) = go' s ty <+> go' s rest

317319 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

319321 go s (PrettyPrintObject t1) = go' s t1

320322 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

322324 go s (ParensInType t1) = go' s t1

323325 go _ _ = r0

stack-ghc-8.0.yaml+1−1

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

1−resolver: nightly-2016-07-19

1+resolver: lts-7.9

22packages:

33- '.'

44extra-deps:

tests/Language/PureScript/Ide/ReexportsSpec.hs+1−2

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

22{-# LANGUAGE NoImplicitPrelude #-}

33module Language.PureScript.Ide.ReexportsSpec where

5−import qualified Prelude

65import Protolude

87import qualified Data.Map as Map

@@ -11,7 +10,7 @@ import Language.PureScript.Ide.Types

1110import qualified Language.PureScript as P

1211import Test.Hspec

1312

14−m :: Prelude.String -> P.ModuleName

13+m :: Text -> P.ModuleName

1514m = P.moduleNameFromString

1615

1716d :: IdeDeclaration -> IdeDeclarationAnn

tests/TestCompiler.hs+28−11

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

22{-# LANGUAGE DoAndIfThenElse #-}

33{-# LANGUAGE TupleSections #-}

44{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE OverloadedStrings #-}

67module TestCompiler where

@@ -30,8 +31,8 @@ import Data.Function (on)

3031import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy)

3132import Data.Maybe (mapMaybe)

3233import Data.Time.Clock (UTCTime())

33−import Data.Tuple (swap)

3434import qualified Data.Text as T

35+import Data.Tuple (swap)

3536

3637import qualified Data.Map as M

3738

@@ -46,6 +47,7 @@ import System.Exit

4647import System.Process hiding (cwd)

4748import System.FilePath

4849import System.Directory

50+import System.IO

4951import System.IO.UTF8

5052import System.IO.Silently

5153import qualified System.FilePath.Glob as Glob

@@ -72,7 +74,7 @@ spec = do

7274 supportPurs <- supportFiles "purs"

7375 supportPursFiles <- readInput supportPurs

7476 supportExterns <- runExceptT $ do

75− modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)

77+ modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles

7678 foreigns <- inferForeignModules modules

7779 externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)

7880 return (zip (map snd modules) externs)

@@ -80,10 +82,15 @@ spec = do

8082 Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)

8183 Right externs -> return (externs, passingFiles, warningFiles, failingFiles)

8284

85+ outputFile <- runIO $ do

86+ tmp <- getTemporaryDirectory

87+ createDirectoryIfMissing False (tmp </> logpath)

88+ openFile (tmp </> logpath </> logfile) WriteMode

89+

8390 context "Passing examples" $

8491 forM_ passingTestCases $ \testPurs ->

8592 it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $

86− assertCompiles supportExterns testPurs

93+ assertCompiles supportExterns testPurs outputFile

8794

8895 context "Warning examples" $

8996 forM_ warningTestCases $ \testPurs -> do

@@ -169,20 +176,20 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi

169176 where

170177 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))

171178 getInputTimestamp mn

172− | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)

179+ | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)

173180 | otherwise = return (Left P.RebuildAlways)

174181 where

175182 isSupportModule = flip elem supportModules

176183

177184 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)

178185 getOutputTimestamp mn = do

179− let filePath = modulesDir </> P.runModuleName mn

186+ let filePath = modulesDir </> T.unpack (P.runModuleName mn)

180187 exists <- liftIO $ doesDirectoryExist filePath

181188 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

182189

183−readInput :: [FilePath] -> IO [(FilePath, String)]

190+readInput :: [FilePath] -> IO [(FilePath, T.Text)]

184191readInput inputFiles = forM inputFiles $ \inputFile -> do

185− text <- readUTF8File inputFile

192+ text <- readUTF8FileT inputFile

186193 return (inputFile, text)

187194

188195runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)

@@ -195,7 +202,7 @@ compile

195202 -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)

196203compile supportExterns inputFiles check = silence $ runTest $ do

197204 fs <- liftIO $ readInput inputFiles

198− ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)

205+ ms <- P.parseModulesFromFiles id fs

199206 foreigns <- inferForeignModules ms

200207 liftIO (check (map snd ms))

201208 let actions = makeActions foreigns

@@ -222,15 +229,16 @@ checkMain ms =

222229checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String

223230checkShouldFailWith expected errs =

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

226233 then Nothing

227234 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual

228235

229236assertCompiles

230237 :: [(P.Module, P.ExternsFile)]

231238 -> [FilePath]

239+ -> Handle

232240 -> Expectation

233−assertCompiles supportExterns inputFiles =

241+assertCompiles supportExterns inputFiles outputFile =

234242 assert supportExterns inputFiles checkMain $ \e ->

235243 case e of

236244 Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs

@@ -239,10 +247,13 @@ assertCompiles supportExterns inputFiles =

239247 let entryPoint = modulesDir </> "index.js"

240248 writeFile entryPoint "require('Main').main()"

241249 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process

250+ hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"

242251 case result of

243252 Just (ExitSuccess, out, err)

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

246257 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

247258 Just (ExitFailure _, _, err) -> return $ Just err

248259 Nothing -> return $ Just "Couldn't find node.js executable"

@@ -285,3 +296,9 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith =

285296

286297 where

287298 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

1313import Data.Maybe (fromMaybe)

1414import Data.List ((\\))

1515import Data.Foldable

16+import qualified Data.Text as T

1617import System.Exit

1718

1819import qualified Language.PureScript as P

@@ -36,8 +37,8 @@ main = pushd "examples/docs" $ do

3637 case res of

3738 Left e -> Publish.printErrorToStdout e >> exitFailure

3839 Right Docs.Package{..} ->

39− forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

40− let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)

40+ forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->

41+ let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))

4142 (find ((==) mn . Docs.modName) pkgModules)

4243 in forM_ pragmas (`runAssertionIO` mdl)

4344

@@ -57,6 +58,9 @@ data Assertion

5758 -- | Assert that a particular declaration has a particular type class

5859 -- constraint.

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

6064 -- | Assert that a particular value declaration exists, and its type

6165 -- satisfies the given predicate.

6266 | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))

@@ -82,6 +86,8 @@ data AssertionFailure

8286 | ChildDocumented P.ModuleName String String

8387 -- | A constraint was missing.

8488 | ConstraintMissing P.ModuleName String String

89+ -- | A functional dependency was missing.

90+ | FunDepMissing P.ModuleName String [([String], [String])]

8591 -- | A declaration had the wrong "type" (ie, value, type, type class)

8692 -- Fields: declaration title, expected "type", actual "type".

8793 | WrongDeclarationType P.ModuleName String String String

@@ -142,6 +148,20 @@ runAssertion assertion Docs.Module{..} =

142148 Fail (WrongDeclarationType mn decl "value"

143149 (Docs.declInfoToString declInfo))

144150

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+

145165 ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->

146166 case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

147167 Nothing ->

@@ -197,11 +217,11 @@ checkConstrained ty tyClass =

197217 False

198218 where

199219 matches className =

200− (==) className . P.runProperName . P.disqualify . P.constraintClass

220+ (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass

201221

202222runAssertionIO :: Assertion -> Docs.Module -> IO ()

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

205225 case runAssertion assertion mdl of

206226 Pass -> pure ()

207227 Fail reason -> do

@@ -270,6 +290,10 @@ testCases =

270290 , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"

271291 ])

272292

293+ , ("TypeClassWithFunDeps",

294+ [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]

295+ ])

296+

273297 , ("NewOperators",

274298 [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

275299 ])

@@ -298,12 +322,12 @@ testCases =

298322 ]

299323

300324 where

301− n = P.moduleNameFromString

325+ n = P.moduleNameFromString . T.pack

302326

303327 hasTypeVar varName =

304328 getAny . P.everythingOnTypes (<>) (Any . isVar varName)

305329

306− isVar varName (P.TypeVar name) | varName == name = True

330+ isVar varName (P.TypeVar name) | varName == T.unpack name = True

307331 isVar _ _ = False

308332

309333 renderedType expected =

tests/TestPsci.hs+3−2

@@ -10,6 +10,7 @@ import Control.Monad.Trans.State.Strict (evalStateT)

1010import Control.Monad (when)

1111

1212import Data.List (sort)

13+import qualified Data.Text as T

1314

1415import System.Exit (exitFailure)

1516import System.Console.Haskeline

@@ -127,11 +128,11 @@ getPSCiState = do

127128 Left err ->

128129 print err >> exitFailure

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

131132 dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"

132133 in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))

133134

134135controlMonadSTasST :: ImportedModule

135136controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))

136137 where

137− s = P.moduleNameFromString

138+ s = P.moduleNameFromString . T.pack

tests/TestUtils.hs+2

@@ -104,6 +104,7 @@ supportModules =

104104 , "Data.Ring"

105105 , "Data.Semigroup"

106106 , "Data.Semiring"

107+ , "Data.Symbol"

107108 , "Data.Show"

108109 , "Data.Unit"

109110 , "Data.Void"

@@ -112,6 +113,7 @@ supportModules =

112113 , "Prelude"

113114 , "Test.Assert"

114115 , "Test.Main"

116+ , "Unsafe.Coerce"

115117 ]

116118

117119pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json+3−1

@@ -9,6 +9,8 @@

99 "purescript-st": "1.0.0-rc.1",

1010 "purescript-partial": "1.1.2",

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

1315 }

1416}