purescript 0.10.2 → 0.10.3

raw patch · 113 files changed

+1714/−1220 lines, 113 files

Files

CONTRIBUTING.md +1/−1
CONTRIBUTORS.md +2/−0
README.md +1/−1
examples/docs/src/TypeClassWithFunDeps.purs +5/−0
examples/failing/2434.purs +5/−0
examples/failing/RowInInstanceNotDetermined0.purs +9/−0
examples/failing/RowInInstanceNotDetermined1.purs +9/−0
examples/failing/RowInInstanceNotDetermined2.purs +9/−0
examples/passing/2438.purs +8/−0
examples/passing/RowInInstanceHeadDetermined.purs +40/−0
examples/passing/SolvingIsSymbol.purs +13/−0
examples/passing/SolvingIsSymbol/Lib.purs +10/−0
examples/passing/StringEscapes.purs +15/−6
examples/warning/2140.purs +5/−0
hierarchy/Main.hs +2/−1
psc-bundle/Main.hs +2/−2
psc-docs/Main.hs +5/−4
psc-docs/Tags.hs +3/−1
psc-ide-client/Main.hs +0/−1
psc-ide-server/Main.hs +31/−11
psc-package/Main.hs +24/−1
purescript.cabal +5/−2
src/Control/Monad/Supply/Class.hs +6/−4
src/Language/PureScript/AST/Declarations.hs +20/−18
src/Language/PureScript/AST/Literals.hs +3/−2
src/Language/PureScript/AST/Operators.hs +0/−2
src/Language/PureScript/AST/SourcePos.hs +10/−9
src/Language/PureScript/Bundle.hs +2/−0
src/Language/PureScript/CodeGen/JS.hs +25/−23
src/Language/PureScript/CodeGen/JS/AST.hs +15/−13
src/Language/PureScript/CodeGen/JS/Common.hs +46/−44
src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +12/−10
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +51/−48
src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +12/−11
src/Language/PureScript/Comments.hs +3/−2
src/Language/PureScript/Constants.hs +128/−123
src/Language/PureScript/CoreFn/Desugar.hs +9/−1
src/Language/PureScript/CoreFn/Expr.hs +3/−2
src/Language/PureScript/CoreFn/ToJSON.hs +13/−11
src/Language/PureScript/Docs/AsMarkdown.hs +3/−2
src/Language/PureScript/Docs/Convert.hs +2/−3
src/Language/PureScript/Docs/Convert/ReExports.hs +16/−15
src/Language/PureScript/Docs/Convert/Single.hs +40/−17
src/Language/PureScript/Docs/Render.hs +24/−10
src/Language/PureScript/Docs/RenderedCode/Render.hs +11/−7
src/Language/PureScript/Docs/RenderedCode/Types.hs +2/−2
src/Language/PureScript/Docs/Types.hs +13/−9
src/Language/PureScript/Environment.hs +62/−11
src/Language/PureScript/Errors.hs +152/−143
src/Language/PureScript/Errors/JSON.hs +8/−5
src/Language/PureScript/Externs.hs +11/−9
src/Language/PureScript/Ide.hs +8/−11
src/Language/PureScript/Ide/CaseSplit.hs +4/−6
src/Language/PureScript/Ide/Command.hs +15/−3
src/Language/PureScript/Ide/Completion.hs +0/−1
src/Language/PureScript/Ide/Conversions.hs +4/−16
src/Language/PureScript/Ide/Error.hs +0/−1
src/Language/PureScript/Ide/Externs.hs +25/−13
src/Language/PureScript/Ide/Filter.hs +0/−1
src/Language/PureScript/Ide/Imports.hs +5/−7
src/Language/PureScript/Ide/Logging.hs +37/−0
src/Language/PureScript/Ide/Matcher.hs +0/−1
src/Language/PureScript/Ide/Pursuit.hs +1/−3
src/Language/PureScript/Ide/Rebuild.hs +1/−5
src/Language/PureScript/Ide/Reexports.hs +1/−4
src/Language/PureScript/Ide/SourceFile.hs +11/−13
src/Language/PureScript/Ide/State.hs +5/−16
src/Language/PureScript/Ide/Types.hs +9/−8
src/Language/PureScript/Ide/Util.hs +15/−14
src/Language/PureScript/Ide/Watcher.hs +12/−8
src/Language/PureScript/Interactive.hs +19/−20
src/Language/PureScript/Interactive/Completion.hs +6/−6
src/Language/PureScript/Interactive/Parser.hs +2/−1
src/Language/PureScript/Interactive/Printer.hs +16/−12
src/Language/PureScript/Linter.hs +16/−10
src/Language/PureScript/Linter/Exhaustive.hs +7/−4
src/Language/PureScript/Linter/Imports.hs +3/−2
src/Language/PureScript/Make.hs +26/−27
src/Language/PureScript/Names.hs +21/−19
src/Language/PureScript/Parser/Common.hs +12/−9
src/Language/PureScript/Parser/Declarations.hs +8/−8
src/Language/PureScript/Parser/Lexer.hs +94/−77
src/Language/PureScript/Parser/Types.hs +7/−5
src/Language/PureScript/Pretty/Common.hs +28/−20
src/Language/PureScript/Pretty/JS.hs +50/−43
src/Language/PureScript/Pretty/Kinds.hs +6/−2
src/Language/PureScript/Pretty/Types.hs +12/−9
src/Language/PureScript/Pretty/Values.hs +46/−36
src/Language/PureScript/Publish.hs +0/−1
src/Language/PureScript/Publish/ErrorsWarnings.hs +0/−2
src/Language/PureScript/Renamer.hs +4/−2
src/Language/PureScript/Sugar/ObjectWildcards.hs +4/−3
src/Language/PureScript/Sugar/Operators/Expr.hs +3/−1
src/Language/PureScript/Sugar/TypeClasses.hs +10/−12
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +8/−10
src/Language/PureScript/TypeChecker.hs +49/−34
src/Language/PureScript/TypeChecker/Entailment.hs +46/−27
src/Language/PureScript/TypeChecker/Kinds.hs +8/−7
src/Language/PureScript/TypeChecker/Monad.hs +6/−5
src/Language/PureScript/TypeChecker/Skolems.hs +6/−5
src/Language/PureScript/TypeChecker/Subsumption.hs +0/−1
src/Language/PureScript/TypeChecker/TypeSearch.hs +0/−4
src/Language/PureScript/TypeChecker/Types.hs +7/−7
src/Language/PureScript/TypeChecker/Unify.hs +5/−3
src/Language/PureScript/TypeClassDictionaries.hs +9/−4
src/Language/PureScript/Types.hs +43/−41
stack.yaml +1/−1
tests/Language/PureScript/Ide/ReexportsSpec.hs +1/−2
tests/TestCompiler.hs +28/−11
tests/TestDocs.hs +30/−6
tests/TestPsci.hs +3/−2
tests/TestUtils.hs +2/−0
tests/support/bower.json +3/−1

CONTRIBUTING.md view

@@ -12,7 +12,7 @@  - Add at least a test to `examples/passing/` and possibly to `examples/failing`. - Build the binaries and libs with `stack build`-- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests.+- Run the test suite with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. - Build the core libraries by running the script in `core-tests`.  ## Code Review

CONTRIBUTORS.md view

@@ -78,12 +78,14 @@ - [@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). - [@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). - [@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).+- [@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). - [@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). - [@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). - [@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. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, 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). - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, 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).+- [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, 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).  ### Companies

README.md view

@@ -17,7 +17,7 @@ ## Resources  - [PureScript book](https://leanpub.com/purescript/read)-- [Wiki](http://wiki.purescript.org)+- [Documentation](https://github.com/purescript/documentation) - [Try PureScript](http://try.purescript.org) - [Pursuit Package Index](http://pursuit.purescript.org/)

+ examples/docs/src/TypeClassWithFunDeps.purs view

@@ -0,0 +1,5 @@++module TypeClassWithFunDeps where++class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where+  aMember :: a

+ examples/failing/2434.purs view

@@ -0,0 +1,5 @@+-- @shouldFailWith ErrorParsingModule+module Main where++x :: Char+x = '\x10000'

+ examples/failing/RowInInstanceNotDetermined0.purs view

@@ -0,0 +1,9 @@+-- @shouldFailWith InvalidInstanceHead+module Main where++import Prelude++-- no fundeps+class C a b+instance c :: C Unit {}+

+ examples/failing/RowInInstanceNotDetermined1.purs view

@@ -0,0 +1,9 @@+-- @shouldFailWith InvalidInstanceHead+module Main where++import Prelude++-- `c` not mentioned in any fundeps+class C a b c | a -> b+instance c :: C Unit Unit {}+

+ examples/failing/RowInInstanceNotDetermined2.purs view

@@ -0,0 +1,9 @@+-- @shouldFailWith InvalidInstanceHead+module Main where++import Prelude++-- `b` isn't determined by anything that `b` doesn't determine+class C a b | a -> b, b -> a+instance c :: C Unit {}+

+ examples/passing/2438.purs view

@@ -0,0 +1,8 @@+module Main where++import Control.Monad.Eff.Console (log)++done :: String+done = {"𝌆": "Done"}."𝌆"++main = log done

+ examples/passing/RowInInstanceHeadDetermined.purs view

@@ -0,0 +1,40 @@+module Main where++import Prelude+import Control.Monad.Eff.Console (log)++data Empty = Empty+data Cons = Cons+++-- simple case+class Simple a b | a -> b where c :: a -> b+instance simple0 :: Simple Empty {} where c _ = {}+instance simple1 :: Simple Cons {foo :: Cons} where c cons = {foo: cons}+++-- simple transitive example+class Transitive a b c | a -> b, b -> c where d :: a -> c+instance transitive :: Transitive Empty {} {} where d _ = {}+++-- transitive example with cycles+class Cyclic a b c d | a -> b, b -> a+                     , a -> c+                     , c -> d, d -> c+instance cyclic :: Cyclic Empty Empty {} {}+++-- Determined cycle+class DeterminedCycle a b c | a -> b+                            , b -> c, c -> b+instance determinedCycle :: DeterminedCycle Empty {} {}+++-- multiple determiners+class MultipleDeterminers a b c d | a b -> c d+instance multipleDeterminers :: MultipleDeterminers Empty Empty {} {}+++main = log "Done"+

+ examples/passing/SolvingIsSymbol.purs view

@@ -0,0 +1,13 @@+module Main where++import Prelude+import Control.Monad.Eff+import Control.Monad.Eff.Console++-- Here we import as alias of reflectSymbol without importing Data.Symbol. However,+-- Data.Symbol should be implicitly imported as we have an instance of IsSymbol solved.+import SolvingIsSymbol.Lib (literalSymbol, libReflectSymbol)++main = do+  let lit = libReflectSymbol literalSymbol+  when (lit == "literal") (log "Done")

+ examples/passing/SolvingIsSymbol/Lib.purs view

@@ -0,0 +1,10 @@+module SolvingIsSymbol.Lib where++import Data.Symbol++literalSymbol :: SProxy "literal"+literalSymbol = SProxy++libReflectSymbol :: forall s. IsSymbol s => SProxy s -> String+libReflectSymbol = reflectSymbol+

examples/passing/StringEscapes.purs view

@@ -1,17 +1,26 @@ module Main where
 
-import Prelude ((==), bind)
-import Test.Assert (assert)
+import Prelude ((==), (/=), (<>), bind)
+import Test.Assert (assert, assert')
 import Control.Monad.Eff.Console (log)
 
 singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C"
 hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0"
 decimal  = "\119558\9731\966\224\0" == "𝌆☃φà\0"
 surrogatePair = "\xD834\xDF06" == "\x1D306"
+highSurrogate = "\xD834"
+lowSurrogate = "\xDF06"
+loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306"
+outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834"
+replacement = "\xFFFD"
+notReplacing = replacement /= highSurrogate
 
 main = do
-  assert singleCharacter
-  assert hex
-  assert decimal
-  assert surrogatePair
+  assert' "single-character escape sequences" singleCharacter
+  assert' "hex escape sequences" hex
+  assert' "decimal escape sequences" decimal
+  assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair
+  assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates
+  assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates
+  -- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing
   log "Done"

+ examples/warning/2140.purs view

@@ -0,0 +1,5 @@+-- @shouldWarnWith ShadowedTypeVar+module Main where++class Test a where+  f :: (forall a. a -> a) -> a -> a

hierarchy/Main.hs view

@@ -25,6 +25,7 @@ import Data.Foldable (for_) import Data.Version (showVersion) import Data.Monoid ((<>))+import qualified Data.Text as T  import Options.Applicative (Parser) import qualified Options.Applicative as Opts@@ -56,7 +57,7 @@       getCls = either id snd  runModuleName :: P.ModuleName -> String-runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)+runModuleName (P.ModuleName pns) = intercalate "_" ((T.unpack . P.runProperName) `map` pns)  readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do

psc-bundle/Main.hs view

@@ -20,7 +20,7 @@ import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)-import System.IO.UTF8 (readUTF8File)+import System.IO.UTF8 (readUTF8File, writeUTF8File) import System.Directory (createDirectoryIfMissing)  import Language.PureScript.Bundle@@ -110,7 +110,7 @@       case optionsOutputFile opts of         Just outputFile -> do           createDirectoryIfMissing True (takeDirectory outputFile)-          writeFile outputFile js+          writeUTF8File outputFile js         Nothing -> putStrLn js   where   infoModList = Opts.fullDesc <> headerInfo <> footerInfo

psc-docs/Main.hs view

@@ -8,6 +8,7 @@ import Control.Category ((>>>)) import Control.Monad.Writer import Data.Text (Text)+import qualified Data.Text as T import Data.Function (on) import Data.List import Data.Maybe (fromMaybe)@@ -82,12 +83,12 @@   where   guardMissing [] = return ()   guardMissing [mn] = do-    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")+    hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"")     exitFailure   guardMissing mns = do     hPutStrLn stderr "psc-docs: error: unknown modules:"     forM_ mns $ \mn ->-      hPutStrLn stderr ("  * " ++ P.runModuleName mn)+      hPutStrLn stderr ("  * " ++ T.unpack (P.runModuleName mn))     exitFailure    successOrExit :: Either P.MultipleErrors a -> IO a@@ -186,11 +187,11 @@ parseItem s = case elemIndex ':' s of   Just i ->     s # splitAt i-        >>> first P.moduleNameFromString+        >>> first (P.moduleNameFromString . T.pack)         >>> second (drop 1)         >>> IToFile   Nothing ->-    IToStdOut (P.moduleNameFromString s)+    IToStdOut (P.moduleNameFromString (T.pack s))    where   infixr 1 #

psc-docs/Tags.hs view

@@ -1,9 +1,11 @@ module Tags where +import Control.Arrow (first)+import qualified Data.Text as T import qualified Language.PureScript as P  tags :: P.Module -> [(String, Int)]-tags = concatMap dtags . P.exportedDeclarations+tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations   where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d           where tag name = (name, line)                 line = P.sourcePosLine $ P.spanStart sp

psc-ide-client/Main.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Main where  import           Prelude             ()

psc-ide-server/Main.hs view

@@ -30,6 +30,7 @@ import qualified Data.ByteString.Lazy.Char8        as BS8 import           Data.Version                      (showVersion) import           Language.PureScript.Ide+import           Language.PureScript.Ide.Command import           Language.PureScript.Ide.Util import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.Types@@ -41,10 +42,10 @@ import           Options.Applicative               (ParseError (..)) import qualified Options.Applicative               as Opts import           System.Directory+import           System.Info                       as SysInfo import           System.FilePath import           System.IO                         hiding (putStrLn, print) import           System.IO.Error                   (isEOFError)- import qualified Paths_purescript                  as Paths  listenOnLocalhost :: PortNumber -> IO Socket@@ -66,12 +67,15 @@   , optionsOutputPath :: FilePath   , optionsPort       :: PortNumber   , optionsNoWatch    :: Bool+  , optionsPolling    :: Bool   , optionsDebug      :: Bool-  }+  , optionsLoglevel   :: IdeLogLevel+  } deriving (Show)  main :: IO () main = do-  Options dir globs outputPath port noWatch debug <- Opts.execParser opts+  opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts+  when debug (putText "Parsed Options:" *> print opts')   maybe (pure ()) setCurrentDirectory dir   ideState <- newTVarIO emptyIdeState   cwd <- getCurrentDirectory@@ -84,9 +88,9 @@     putText "psc-ide needs you to compile your project (for example by running pulp build)"    unless noWatch $-    void (forkFinally (watcher ideState fullOutputPath) print)--  let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs}+    void (forkFinally (watcher polling ideState fullOutputPath) print)+  -- TODO: deprecate and get rid of `debug`+  let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs}       env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}   startServer port env   where@@ -98,19 +102,32 @@         <*> (fromIntegral <$>              Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))         <*> Opts.switch (Opts.long "no-watch")+        <*> flipIfWindows (Opts.switch (Opts.long "polling"))         <*> Opts.switch (Opts.long "debug")+        <*> (parseLogLevel <$> Opts.strOption+             (Opts.long "log-level"+              `mappend` Opts.value ""+              `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))     opts = Opts.info (version <*> Opts.helper <*> parser) mempty+    parseLogLevel s = case s of+      "debug" -> LogDebug+      "perf" -> LogPerf+      "all" -> LogAll+      "none" -> LogNone+      _ -> LogDefault     version = Opts.abortOption       (InfoMsg (showVersion Paths.version))       (Opts.long "version" `mappend` Opts.help "Show the version number") +    -- polling is the default on Windows and the flag turns it off. See+    -- #2209 and #2414 for explanations+    flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)+ startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do   sock <- listenOnLocalhost port-  runLogger (runReaderT (forever (loop sock)) env)+  runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)   where-    runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env))-     loop :: (Ide m, MonadLogger m) => Socket -> m ()     loop sock = do       accepted <- runExceptT $ acceptCommand sock@@ -119,7 +136,11 @@         Right (cmd, h) -> do           case decodeT cmd of             Just cmd' -> do-              result <- runExceptT (handleCommand cmd')+              let message duration =+                    "Command " <> commandName cmd'+                    <> " took "+                    <> displayTimeSpec duration+              result <- logPerf message (runExceptT (handleCommand cmd'))               -- $(logDebug) ("Answer was: " <> T.pack (show result))               liftIO (hFlush stdout)               case result of@@ -131,7 +152,6 @@                 T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))                 hFlush stdout           liftIO (hClose h)-  acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)                  => Socket -> m (Text, Handle)

psc-package/Main.hs view

@@ -119,7 +119,7 @@   let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"   exists <- testfile dbFile   unless exists $ do-    echo "packages.json does not exist"+    echo $ format (fp%" does not exist") dbFile     exit (ExitFailure 1)   mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile   case mdb of@@ -181,6 +181,14 @@   writePackageFile pkg'   echo "psc-package.json file was updated" +uninstall :: String -> IO ()+uninstall pkgName = do+  pkg <- readPackageFile+  let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }+  updateImpl pkg'+  writePackageFile pkg'+  echo "psc-package.json file was updated"+ listDependencies :: IO () listDependencies = do   pkg@PackageConfig{ depends } <- readPackageFile@@ -188,6 +196,15 @@   trans <- getTransitiveDeps db depends   traverse_ (echo . fst) trans +listPackages :: IO ()+listPackages = do+  pkg <- readPackageFile+  db <- readPackageSet pkg+  traverse_ echo (fmt <$> Map.assocs db)+  where+  fmt :: (Text, PackageInfo) -> Text+  fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"+ getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath] getSourcePaths PackageConfig{..} db pkgNames = do   trans <- getTransitiveDeps db pkgNames@@ -240,6 +257,9 @@         , Opts.command "update"             (Opts.info (pure update)             (Opts.progDesc "Update dependencies"))+        , Opts.command "uninstall"+            (Opts.info (uninstall <$> pkg)+            (Opts.progDesc "Uninstall the named package"))         , Opts.command "install"             (Opts.info (install <$> pkg)             (Opts.progDesc "Install the named package"))@@ -252,6 +272,9 @@         , Opts.command "sources"             (Opts.info (pure listSourcePaths)             (Opts.progDesc "List all (active) source paths for dependencies"))+        , Opts.command "available"+            (Opts.info (pure listPackages)+            (Opts.progDesc "List all packages available in the package set"))         ]       where         pkg = Opts.strArgument $

purescript.cabal view

@@ -1,5 +1,5 @@ name: purescript-version: 0.10.2+version: 0.10.3 cabal-version: >=1.8 build-type: Simple license: BSD3@@ -50,6 +50,7 @@                   , examples/passing/ResolvableScopeConflict2/*.purs                   , examples/passing/ResolvableScopeConflict3/*.purs                   , examples/passing/ShadowedModuleName/*.purs+                  , examples/passing/SolvingIsSymbol/*.purs                   , examples/passing/TransitiveImport/*.purs                   , examples/passing/TypeOperators/*.purs                   , examples/passing/TypeWithoutParens/*.purs@@ -270,8 +271,9 @@                      Language.PureScript.Ide.Conversions                      Language.PureScript.Ide.Externs                      Language.PureScript.Ide.Error-                     Language.PureScript.Ide.Imports                      Language.PureScript.Ide.Filter+                     Language.PureScript.Ide.Imports+                     Language.PureScript.Ide.Logging                      Language.PureScript.Ide.Matcher                      Language.PureScript.Ide.Pursuit                      Language.PureScript.Ide.Rebuild@@ -311,6 +313,7 @@                      PatternSynonyms                      RankNTypes                      RecordWildCards+                     OverloadedStrings                      ScopedTypeVariables                      TupleSections                      ViewPatterns

src/Control/Monad/Supply/Class.hs view

@@ -3,6 +3,7 @@ --  {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}  module Control.Monad.Supply.Class where @@ -11,13 +12,14 @@ import Control.Monad.Supply import Control.Monad.State import Control.Monad.Writer+import Data.Text (Text, pack)  class Monad m => MonadSupply m where   fresh :: m Integer   peek :: m Integer-  default fresh :: MonadTrans t => t m Integer+  default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer   fresh = lift fresh-  default peek :: MonadTrans t => t m Integer+  default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer   peek = lift peek  instance Monad m => MonadSupply (SupplyT m) where@@ -30,5 +32,5 @@ instance MonadSupply m => MonadSupply (StateT s m) instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) -freshName :: MonadSupply m => m String-freshName = fmap (('$' :) . show) fresh+freshName :: MonadSupply m => m Text+freshName = fmap (("$" <> ) . pack . show) fresh

src/Language/PureScript/AST/Declarations.hs view

@@ -11,6 +11,7 @@  import Data.Aeson.TH import qualified Data.Map as M+import Data.Text (Text)  import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals@@ -47,7 +48,7 @@   | UnnecessaryFFIModule ModuleName FilePath   | MissingFFIImplementations ModuleName [Ident]   | UnusedFFIImplementations ModuleName [Ident]-  | InvalidFFIIdentifier ModuleName String+  | InvalidFFIIdentifier ModuleName Text   | CannotGetFileInfo FilePath   | CannotReadFile FilePath   | CannotWriteFile FilePath@@ -68,7 +69,7 @@   | DeclConflict Name Name   | ExportConflict (Qualified Name) (Qualified Name)   | DuplicateModule ModuleName [SourceSpan]-  | DuplicateTypeArgument String+  | DuplicateTypeArgument Text   | InvalidDoBind   | InvalidDoLet   | CycleInDeclaration Ident@@ -89,7 +90,7 @@   | CannotDerive (Qualified (ProperName 'ClassName)) [Type]   | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]   | CannotFindDerivingType (ProperName 'TypeName)-  | DuplicateLabel String (Maybe Expr)+  | DuplicateLabel Text (Maybe Expr)   | DuplicateValueDeclaration Ident   | ArgListLengthsDiffer Ident   | OverlappingArgNames (Maybe Ident)@@ -98,8 +99,8 @@   | ExpectedType Type Kind   | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))   | ExprDoesNotHaveType Expr Type-  | PropertyIsMissing String-  | AdditionalProperty String+  | PropertyIsMissing Text+  | AdditionalProperty Text   | TypeSynonymInstance   | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]   | InvalidNewtype (ProperName 'TypeName)@@ -107,10 +108,10 @@   | TransitiveExportError DeclarationRef [DeclarationRef]   | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)   | ShadowedName Ident-  | ShadowedTypeVar String-  | UnusedTypeVar String+  | ShadowedTypeVar Text+  | UnusedTypeVar Text   | WildcardInferredType Type Context-  | HoleInferredType String Type Context TypeSearch+  | HoleInferredType Text Type Context TypeSearch   | MissingTypeDeclaration Ident Type   | OverlappingPattern [[Binder]] Bool   | IncompleteExhaustivityCheck@@ -124,7 +125,7 @@   | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)   | DuplicateImportRef Name   | DuplicateExportRef Name-  | IntOutOfRange Integer String Integer Integer+  | IntOutOfRange Integer Text Integer Integer   | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]   | ImplicitImport ModuleName [DeclarationRef]   | HidingImport ModuleName [DeclarationRef]@@ -144,7 +145,7 @@   | ErrorInModule ModuleName   | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]   | ErrorInSubsumption Type Type-  | ErrorCheckingAccessor Expr String+  | ErrorCheckingAccessor Expr Text   | ErrorCheckingType Expr Type   | ErrorCheckingKind Type   | ErrorCheckingGuard@@ -153,10 +154,11 @@   | ErrorInDataConstructor (ProperName 'ConstructorName)   | ErrorInTypeConstructor (ProperName 'TypeName)   | ErrorInBindingGroup [Ident]-  | ErrorInDataBindingGroup+  | ErrorInDataBindingGroup [ProperName 'TypeName]   | ErrorInTypeSynonym (ProperName 'TypeName)   | ErrorInValueDeclaration Ident   | ErrorInTypeDeclaration Ident+  | ErrorInTypeClassDeclaration (ProperName 'ClassName)   | ErrorInForeignImport Ident   | ErrorSolvingConstraint Constraint   | PositionedError SourceSpan@@ -349,7 +351,7 @@   -- |   -- A data type declaration (data or newtype, name, arguments, data constructors)   ---  = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]+  = DataDeclaration DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]   -- |   -- A minimal mutually recursive set of data type declarations   --@@ -357,7 +359,7 @@   -- |   -- A type synonym declaration (name, arguments, type)   ---  | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type+  | TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type   -- |   -- A type declaration for a value (name, ty)   --@@ -389,7 +391,7 @@   -- |   -- A type class declaration (name, argument, implies, member declarations)   ---  | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]+  | TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]   -- |   -- A type instance declaration (name, dependencies, class name, instance types, member   -- declarations)@@ -547,11 +549,11 @@   -- Anonymous arguments will be removed during desugaring and expanded   -- into a lambda that reads a property from a record.   ---  | Accessor String Expr+  | Accessor Text Expr   -- |   -- Partial record update   ---  | ObjectUpdate Expr [(String, Expr)]+  | ObjectUpdate Expr [(Text, Expr)]   -- |   -- Function introduction   --@@ -607,7 +609,7 @@   -- instance type, and the type class dictionaries in scope.   --   | TypeClassDictionary Constraint-                        (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))+                        (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)))                         [ErrorMessageHint]   -- |   -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.@@ -624,7 +626,7 @@   -- |   -- A typed hole that will be turned into a hint/error duing typechecking   ---  | Hole String+  | Hole Text   -- |   -- A value with source position information   --

src/Language/PureScript/AST/Literals.hs view

@@ -4,6 +4,7 @@ module Language.PureScript.AST.Literals where  import Prelude.Compat+import Data.Text (Text)  -- | -- Data type for literal values. Parameterised so it can be used for Exprs and@@ -17,7 +18,7 @@   -- |   -- A string literal   ---  | StringLiteral String+  | StringLiteral Text   -- |   -- A character literal   --@@ -33,5 +34,5 @@   -- |   -- An object literal   ---  | ObjectLiteral [(String, a)]+  | ObjectLiteral [(Text, a)]   deriving (Eq, Ord, Show, Functor)

src/Language/PureScript/AST/Operators.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | -- Operators fixity and associativity --

src/Language/PureScript/AST/SourcePos.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | -- Source position information --@@ -9,6 +7,9 @@  import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A+import Data.Monoid+import qualified Data.Text as T+import Data.Text (Text)  -- | -- Source position information@@ -24,10 +25,10 @@   , sourcePosColumn :: Int   } deriving (Show, Eq, Ord) -displaySourcePos :: SourcePos -> String+displaySourcePos :: SourcePos -> Text displaySourcePos sp =-  "line " ++ show (sourcePosLine sp) ++-    ", column " ++ show (sourcePosColumn sp)+  "line " <> T.pack (show (sourcePosLine sp)) <>+    ", column " <> T.pack (show (sourcePosColumn sp))  instance A.ToJSON SourcePos where   toJSON SourcePos{..} =@@ -52,14 +53,14 @@   , spanEnd :: SourcePos   } deriving (Show, Eq, Ord) -displayStartEndPos :: SourceSpan -> String+displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp =-  displaySourcePos (spanStart sp) ++ " - " +++  displaySourcePos (spanStart sp) <> " - " <>   displaySourcePos (spanEnd sp) -displaySourceSpan :: SourceSpan -> String+displaySourceSpan :: SourceSpan -> Text displaySourceSpan sp =-  spanName sp ++ " " +++  T.pack (spanName sp) <> " " <>     displayStartEndPos sp  instance A.ToJSON SourceSpan where

src/Language/PureScript/Bundle.hs view

@@ -534,6 +534,7 @@     where     squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) []     squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)+    squash JSAnnotSpace = JSAnnot (TokenPn 0 0 2) []      splat (CommentA pos s) = CommentA (keepCol pos) s     splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w@@ -589,6 +590,7 @@        appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]       appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty "  "])+      appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a]    runMain :: String -> [JSStatement]   runMain mn =

src/Language/PureScript/CodeGen/JS.hs view

@@ -10,16 +10,18 @@ import Prelude.Compat  import Control.Arrow ((&&&))-import Control.Monad (replicateM, forM, void)-import Control.Monad.Error.Class (MonadError(..))+import Control.Monad (forM, replicateM, void)+import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class  import Data.List ((\\), delete, intersect, nub)-import Data.Maybe (isNothing, fromMaybe) import qualified Data.Foldable as F import qualified Data.Map as M-import qualified Data.Traversable as T+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST@@ -51,10 +53,10 @@   rethrow (addHint (ErrorInModule mn)) $ do     let usedNames = concatMap getNames decls     let mnLookup = renameImports usedNames imps-    jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps+    jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps     let decls' = renameModules mnLookup decls     jsDecls <- mapM bindToJs decls'-    optimized <- T.traverse (T.traverse optimize) jsDecls+    optimized <- traverse (traverse optimize) jsDecls     F.traverse_ (F.traverse_ checkIntegers) optimized     comments <- not <$> asks optionsNoComments     let strict = JSStringLiteral Nothing "use strict"@@ -94,7 +96,7 @@      freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName     freshModuleName i mn'@(ModuleName pns) used =-      let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]+      let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]       in if Ident (runModuleName newName) `elem` used          then freshModuleName (i + 1) mn' used          else newName@@ -106,7 +108,7 @@   importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS   importToJs mnLookup mn' = do     let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup-    let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." </> runModuleName mn')]+    let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (T.pack (".." </> T.unpack (runModuleName mn')))]     withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)    -- |@@ -177,7 +179,7 @@   accessor (Ident prop) = accessorString prop   accessor (GenIdent _ _) = internalError "GenIdent in accessor" -  accessorString :: String -> JS -> JS+  accessorString :: Text -> JS -> JS   accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)                       | otherwise = JSAccessor Nothing prop @@ -234,7 +236,7 @@              then foreignIdent ident              else varToJs qi   valueToJs' (Var (_, _, _, Just IsForeign) ident) =-    error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident+    internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)   valueToJs' (Var _ ident) = return $ varToJs ident   valueToJs' (Case (maybeSpan, _, _, _) values binders) = do     vals <- mapM valueToJs values@@ -263,14 +265,14 @@                           , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn                           ] -  iife :: String -> [JS] -> JS+  iife :: Text -> [JS] -> JS   iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []    literalToValueJS :: Literal (Expr Ann) -> m JS   literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)   literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)   literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s-  literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]+  literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (T.singleton c)   literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b   literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs   literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps@@ -278,7 +280,7 @@   -- |   -- Shallow copy an object.   ---  extendObj :: JS -> [(String, JS)] -> m JS+  extendObj :: JS -> [(Text, JS)] -> m JS   extendObj obj sts = do     newObj <- freshName     key <- freshName@@ -331,20 +333,20 @@     return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))                    []     where-      go :: [String] -> [JS] -> [Binder Ann] -> m [JS]+      go :: [Text] -> [JS] -> [Binder Ann] -> m [JS]       go _ done [] = return done       go (v:vs) done' (b:bs) = do         done'' <- go vs done' bs         binderToJs v done'' b       go _ _ _ = internalError "Invalid arguments to bindersToJs" -      failedPatternError :: [String] -> JS+      failedPatternError :: [Text] -> JS       failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] -      failedPatternMessage :: String-      failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "+      failedPatternMessage :: Text+      failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " -      valueError :: String -> JS -> JS+      valueError :: Text -> JS -> JS       valueError _ l@(JSNumericLiteral _ _) = l       valueError _ l@(JSStringLiteral _ _)  = l       valueError _ l@(JSBooleanLiteral _ _) = l@@ -357,7 +359,7 @@         return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing       guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v -  binderToJs :: String -> [JS] -> Binder Ann -> m [JS]+  binderToJs :: Text -> [JS] -> Binder Ann -> m [JS]   binderToJs s done binder =     let (ss, _, _, _) = extractBinderAnn binder in     traverse (withPos ss) =<< binderToJs' s done binder@@ -366,7 +368,7 @@   -- Generate code in the simplified Javascript intermediate representation for a pattern match   -- binder.   ---  binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]+  binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS]   binderToJs' _ done NullBinder{} = return done   binderToJs' varName done (LiteralBinder _ l) =     literalToBinderJS varName done l@@ -396,11 +398,11 @@     js <- binderToJs varName done binder     return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js) -  literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]+  literalToBinderJS :: Text -> [JS] -> Literal (Binder Ann) -> m [JS]   literalToBinderJS varName done (NumericLiteral num) =     return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (CharLiteral c) =-    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]+    return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (T.singleton c))) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (StringLiteral str) =     return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (BooleanLiteral True) =@@ -409,7 +411,7 @@     return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]   literalToBinderJS varName done (ObjectLiteral bs) = go done bs     where-    go :: [JS] -> [(String, Binder Ann)] -> m [JS]+    go :: [JS] -> [(Text, Binder Ann)] -> m [JS]     go done' [] = return done'     go done' ((prop, binder):bs') = do       propVar <- freshName

src/Language/PureScript/CodeGen/JS/AST.hs view

@@ -5,7 +5,9 @@  import Prelude.Compat -import Control.Monad.Identity+import Control.Monad ((>=>))+import Control.Monad.Identity (Identity(..), runIdentity)+import Data.Text (Text)  import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments@@ -130,7 +132,7 @@   -- |   -- A string literal   ---  | JSStringLiteral (Maybe SourceSpan) String+  | JSStringLiteral (Maybe SourceSpan) Text   -- |   -- A boolean literal   --@@ -154,15 +156,15 @@   -- |   -- An object literal   ---  | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]+  | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)]   -- |   -- An object property accessor expression   ---  | JSAccessor (Maybe SourceSpan) String JS+  | JSAccessor (Maybe SourceSpan) Text JS   -- |   -- A function introduction (optional name, arguments, body)   ---  | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS+  | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS   -- |   -- Function application   --@@ -170,7 +172,7 @@   -- |   -- Variable   ---  | JSVar (Maybe SourceSpan) String+  | JSVar (Maybe SourceSpan) Text   -- |   -- Conditional expression   --@@ -182,7 +184,7 @@   -- |   -- A variable introduction and optional initialization   ---  | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)+  | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS)   -- |   -- A variable assignment   --@@ -194,11 +196,11 @@   -- |   -- For loop   ---  | JSFor (Maybe SourceSpan) String JS JS JS+  | JSFor (Maybe SourceSpan) Text JS JS JS   -- |   -- ForIn loop   ---  | JSForIn (Maybe SourceSpan) String JS JS+  | JSForIn (Maybe SourceSpan) Text JS JS   -- |   -- If-then-else statement   --@@ -222,19 +224,19 @@   -- |   -- Labelled statement   ---  | JSLabel (Maybe SourceSpan) String JS+  | JSLabel (Maybe SourceSpan) Text JS   -- |   -- Break statement   ---  | JSBreak (Maybe SourceSpan) String+  | JSBreak (Maybe SourceSpan) Text   -- |   -- Continue statement   ---  | JSContinue (Maybe SourceSpan) String+  | JSContinue (Maybe SourceSpan) Text   -- |   -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)   ---  | JSRaw (Maybe SourceSpan) String+  | JSRaw (Maybe SourceSpan) Text   -- |   -- Commented Javascript   --

src/Language/PureScript/CodeGen/JS/Common.hs view

@@ -6,15 +6,17 @@ import Prelude.Compat  import Data.Char-import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.Crash import Language.PureScript.Names -moduleNameToJs :: ModuleName -> String+moduleNameToJs :: ModuleName -> Text moduleNameToJs (ModuleName pns) =-  let name = intercalate "_" (runProperName `map` pns)-  in if nameIsJsBuiltIn name then "$$" ++ name else name+  let name = T.intercalate "_" (runProperName `map` pns)+  in if nameIsJsBuiltIn name then "$$" <> name else name  -- | -- Convert an Ident into a valid Javascript identifier:@@ -25,62 +27,62 @@ -- --  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. ---identToJs :: Ident -> String+identToJs :: Ident -> Text identToJs (Ident name) = properToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -properToJs :: String -> String+properToJs :: Text -> Text properToJs name-  | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name-  | otherwise = concatMap identCharToString name+  | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name+  | otherwise = T.concatMap identCharToText name  -- | -- Test if a string is a valid JS identifier without escaping. ---identNeedsEscaping :: String -> Bool-identNeedsEscaping s = s /= identToJs (Ident s) || null s+identNeedsEscaping :: Text -> Bool+identNeedsEscaping s = s /= properToJs s || T.null s  -- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. ---identCharToString :: Char -> String-identCharToString c | isAlphaNum c = [c]-identCharToString '_' = "_"-identCharToString '.' = "$dot"-identCharToString '$' = "$dollar"-identCharToString '~' = "$tilde"-identCharToString '=' = "$eq"-identCharToString '<' = "$less"-identCharToString '>' = "$greater"-identCharToString '!' = "$bang"-identCharToString '#' = "$hash"-identCharToString '%' = "$percent"-identCharToString '^' = "$up"-identCharToString '&' = "$amp"-identCharToString '|' = "$bar"-identCharToString '*' = "$times"-identCharToString '/' = "$div"-identCharToString '+' = "$plus"-identCharToString '-' = "$minus"-identCharToString ':' = "$colon"-identCharToString '\\' = "$bslash"-identCharToString '?' = "$qmark"-identCharToString '@' = "$at"-identCharToString '\'' = "$prime"-identCharToString c = '$' : show (ord c)+identCharToText :: Char -> Text+identCharToText c | isAlphaNum c = T.singleton c+identCharToText '_' = "_"+identCharToText '.' = "$dot"+identCharToText '$' = "$dollar"+identCharToText '~' = "$tilde"+identCharToText '=' = "$eq"+identCharToText '<' = "$less"+identCharToText '>' = "$greater"+identCharToText '!' = "$bang"+identCharToText '#' = "$hash"+identCharToText '%' = "$percent"+identCharToText '^' = "$up"+identCharToText '&' = "$amp"+identCharToText '|' = "$bar"+identCharToText '*' = "$times"+identCharToText '/' = "$div"+identCharToText '+' = "$plus"+identCharToText '-' = "$minus"+identCharToText ':' = "$colon"+identCharToText '\\' = "$bslash"+identCharToText '?' = "$qmark"+identCharToText '@' = "$at"+identCharToText '\'' = "$prime"+identCharToText c = '$' `T.cons` T.pack (show (ord c))  -- | -- Checks whether an identifier name is reserved in Javascript. ---nameIsJsReserved :: String -> Bool+nameIsJsReserved :: Text -> Bool nameIsJsReserved name =   name `elem` jsAnyReserved  -- | -- Checks whether a name matches a built-in value in Javascript. ---nameIsJsBuiltIn :: String -> Bool+nameIsJsBuiltIn :: Text -> Bool nameIsJsBuiltIn name =   name `elem`     [ "arguments"@@ -138,7 +140,7 @@     , "WeakSet"     ] -jsAnyReserved :: [String]+jsAnyReserved :: [Text] jsAnyReserved =   concat     [ jsKeywords@@ -149,7 +151,7 @@     , jsLiterals     ] -jsKeywords :: [String]+jsKeywords :: [Text] jsKeywords =   [ "break"   , "case"@@ -185,7 +187,7 @@   , "with"   ] -jsSometimesReserved :: [String]+jsSometimesReserved :: [Text] jsSometimesReserved =   [ "await"   , "let"@@ -193,11 +195,11 @@   , "yield"   ] -jsFutureReserved :: [String]+jsFutureReserved :: [Text] jsFutureReserved =   [ "enum" ] -jsFutureReservedStrict :: [String]+jsFutureReservedStrict :: [Text] jsFutureReservedStrict =   [ "implements"   , "interface"@@ -207,7 +209,7 @@   , "public"   ] -jsOldReserved :: [String]+jsOldReserved :: [Text] jsOldReserved =   [ "abstract"   , "boolean"@@ -227,7 +229,7 @@   , "volatile"   ] -jsLiterals :: [String]+jsLiterals :: [Text] jsLiterals =   [ "null"   , "true"

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs view

@@ -5,27 +5,29 @@  import Prelude.Compat +import Data.Text (Text)+import Data.List (foldl') import Data.Maybe (fromMaybe)  import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST  applyAll :: [a -> a] -> a -> a-applyAll = foldl1 (.)+applyAll = foldl' (.) id -replaceIdent :: String -> JS -> JS -> JS+replaceIdent :: Text -> JS -> JS -> JS replaceIdent var1 js = everywhereOnJS replace   where   replace (JSVar _ var2) | var1 == var2 = js   replace other = other -replaceIdents :: [(String, JS)] -> JS -> JS+replaceIdents :: [(Text, JS)] -> JS -> JS replaceIdents vars = everywhereOnJS replace   where   replace v@(JSVar _ var) = fromMaybe v $ lookup var vars   replace other = other -isReassigned :: String -> JS -> Bool+isReassigned :: Text -> JS -> Bool isReassigned var1 = everythingOnJS (||) check   where   check :: JS -> Bool@@ -42,7 +44,7 @@   variablesOf (JSVar _ var) = [var]   variablesOf _ = [] -isUsed :: String -> JS -> Bool+isUsed :: Text -> JS -> Bool isUsed var1 = everythingOnJS (||) check   where   check :: JS -> Bool@@ -50,13 +52,13 @@   check (JSAssignment _ target _) | var1 == targetVariable target = True   check _ = False -targetVariable :: JS -> String+targetVariable :: JS -> Text targetVariable (JSVar _ var) = var targetVariable (JSAccessor _ _ tgt) = targetVariable tgt targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable" -isUpdated :: String -> JS -> Bool+isUpdated :: Text -> JS -> Bool isUpdated var1 = everythingOnJS (||) check   where   check :: JS -> Bool@@ -67,16 +69,16 @@ removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _  js = js -isFn :: (String, String) -> JS -> Bool+isFn :: (Text, Text) -> JS -> Bool isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =   x == fnName && y == moduleName isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =   x == fnName && y == moduleName isFn _ _ = False -isDict :: (String, String) -> JS -> Bool+isDict :: (Text, Text) -> JS -> Bool isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False -isDict' :: [(String, String)] -> JS -> Bool+isDict' :: [(Text, Text)] -> JS -> Bool isDict' xs js = any (`isDict` js) xs

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs view

@@ -16,6 +16,9 @@ import Control.Monad.Supply.Class (MonadSupply, freshName)  import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common@@ -164,25 +167,25 @@   ] ++   [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]   where-  binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS+  binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS   binary dict fns op = everywhereOnJS convert     where     convert :: JS -> JS     convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y     convert other = other-  binary' :: String -> String -> BinaryOperator -> JS -> JS+  binary' :: Text -> Text -> BinaryOperator -> JS -> JS   binary' moduleName opString op = everywhereOnJS convert     where     convert :: JS -> JS     convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y     convert other = other-  unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS+  unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS   unary dicts fns op = everywhereOnJS convert     where     convert :: JS -> JS     convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x     convert other = other-  unary' :: String -> String -> UnaryOperator -> JS -> JS+  unary' :: Text -> Text -> UnaryOperator -> JS -> JS   unary' moduleName fnName op = everywhereOnJS convert     where     convert :: JS -> JS@@ -203,14 +206,14 @@         Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)         Nothing -> orig     convert other = other-    collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])+    collectArgs :: Int -> [Text] -> JS -> Maybe ([Text], [JS])     collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)     collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret     collectArgs _ _   _ = Nothing -  isNFn :: String -> Int -> JS -> Bool-  isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)-  isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix ++ show n)+  isNFn :: Text -> Int -> JS -> Bool+  isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))+  isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))   isNFn _ _ _ = False    runFn :: Int -> JS -> JS@@ -231,11 +234,11 @@     convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y     convert other = other -  isModFn :: (String, String) -> JS -> Bool+  isModFn :: (Text, Text) -> JS -> Bool   isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'   isModFn _ _ = False -  isModFnWithDict :: (String, String) -> JS -> Bool+  isModFnWithDict :: (Text, Text) -> JS -> Bool   isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'   isModFnWithDict _ _ = False @@ -260,115 +263,115 @@   isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn   isFnComposeFlipped :: JS -> JS -> Bool   isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn-  fnCompose :: (String, String)+  fnCompose :: (Text, Text)   fnCompose = (C.controlSemigroupoid, C.compose)-  fnComposeFlipped :: (String, String)+  fnComposeFlipped :: (Text, Text)   fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: (String, String)+semiringNumber :: (Text, Text) semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: (String, String)+semiringInt :: (Text, Text) semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: (String, String)+ringNumber :: (Text, Text) ringNumber = (C.dataRing, C.ringNumber) -ringInt :: (String, String)+ringInt :: (Text, Text) ringInt = (C.dataRing, C.ringInt) -euclideanRingNumber :: (String, String)+euclideanRingNumber :: (Text, Text) euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: (String, String)+euclideanRingInt :: (Text, Text) euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: (String, String)+eqNumber :: (Text, Text) eqNumber = (C.dataEq, C.eqNumber) -eqInt :: (String, String)+eqInt :: (Text, Text) eqInt = (C.dataEq, C.eqInt) -eqString :: (String, String)+eqString :: (Text, Text) eqString = (C.dataEq, C.eqString) -eqChar :: (String, String)+eqChar :: (Text, Text) eqChar = (C.dataEq, C.eqChar) -eqBoolean :: (String, String)+eqBoolean :: (Text, Text) eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: (String, String)+ordBoolean :: (Text, Text) ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: (String, String)+ordNumber :: (Text, Text) ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: (String, String)+ordInt :: (Text, Text) ordInt = (C.dataOrd, C.ordInt) -ordString :: (String, String)+ordString :: (Text, Text) ordString = (C.dataOrd, C.ordString) -ordChar :: (String, String)+ordChar :: (Text, Text) ordChar = (C.dataOrd, C.ordChar) -semigroupString :: (String, String)+semigroupString :: (Text, Text) semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: (String, String)+boundedBoolean :: (Text, Text) boundedBoolean = (C.dataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: (String, String)+heytingAlgebraBoolean :: (Text, Text) heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: (String, String)+semigroupoidFn :: (Text, Text) semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: (String, String)+opAdd :: (Text, Text) opAdd = (C.dataSemiring, C.add) -opMul :: (String, String)+opMul :: (Text, Text) opMul = (C.dataSemiring, C.mul) -opEq :: (String, String)+opEq :: (Text, Text) opEq = (C.dataEq, C.eq) -opNotEq :: (String, String)+opNotEq :: (Text, Text) opNotEq = (C.dataEq, C.notEq) -opLessThan :: (String, String)+opLessThan :: (Text, Text) opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: (String, String)+opLessThanOrEq :: (Text, Text) opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: (String, String)+opGreaterThan :: (Text, Text) opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: (String, String)+opGreaterThanOrEq :: (Text, Text) opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: (String, String)+opAppend :: (Text, Text) opAppend = (C.dataSemigroup, C.append) -opSub :: (String, String)+opSub :: (Text, Text) opSub = (C.dataRing, C.sub) -opNegate :: (String, String)+opNegate :: (Text, Text) opNegate = (C.dataRing, C.negate) -opDiv :: (String, String)+opDiv :: (Text, Text) opDiv = (C.dataEuclideanRing, C.div) -opMod :: (String, String)+opMod :: (Text, Text) opMod = (C.dataEuclideanRing, C.mod) -opConj :: (String, String)+opConj :: (Text, Text) opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: (String, String)+opDisj :: (Text, Text) opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: (String, String)+opNot :: (Text, Text) opNot = (C.dataHeytingAlgebra, C.not)

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs view

@@ -5,7 +5,8 @@  import Prelude.Compat -import Data.Monoid+import Data.Text (Text)+import Data.Monoid ((<>), getAny, Any(..))  import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST@@ -20,14 +21,14 @@ tco' :: JS -> JS tco' = everywhereOnJS convert   where-  tcoLabel :: String+  tcoLabel :: Text   tcoLabel = "tco" -  tcoVar :: String -> String-  tcoVar arg = "__tco_" ++ arg+  tcoVar :: Text -> Text+  tcoVar arg = "__tco_" <> arg -  copyVar :: String -> String-  copyVar arg = "__copy_" ++ arg+  copyVar :: Text -> Text+  copyVar arg = "__copy_" <> arg    convert :: JS -> JS   convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =@@ -42,7 +43,7 @@         | otherwise -> js   convert js = js -  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)+  collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS)   collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =     collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body   collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =@@ -53,7 +54,7 @@     (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))   collectAllFunctionArgs allArgs f body = (allArgs, body, f) -  isTailCall :: String -> JS -> Bool+  isTailCall :: Text -> JS -> Bool   isTailCall ident js =     let       numSelfCalls = everythingOnJS (+) countSelfCalls js@@ -81,7 +82,7 @@     countSelfCallsWithFnArgs :: JS -> Int     countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0 -  toLoop :: String -> [String] -> JS -> JS+  toLoop :: Text -> [Text] -> JS -> JS   toLoop ident allArgs js = JSBlock rootSS $         map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++         [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]@@ -103,12 +104,12 @@     collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn     collectSelfCallArgs allArgumentValues _ = allArgumentValues -  isSelfCall :: String -> JS -> Bool+  isSelfCall :: Text -> JS -> Bool   isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'   isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn   isSelfCall _ _ = False -  isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool+  isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool   isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True   isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)   isSelfCallWithFnArgs _ _ _ = False

src/Language/PureScript/Comments.hs view

@@ -6,12 +6,13 @@ module Language.PureScript.Comments where  import Prelude.Compat+import Data.Text (Text)  import Data.Aeson.TH  data Comment-  = LineComment String-  | BlockComment String+  = LineComment Text+  | BlockComment Text   deriving (Show, Eq, Ord)  $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

src/Language/PureScript/Constants.hs view

@@ -2,326 +2,331 @@ module Language.PureScript.Constants where  import Prelude.Compat-+import Data.Text (Text) import Language.PureScript.Names  -- Operators -($) :: String+($) :: Text ($) = "$" -apply :: String+apply :: Text apply = "apply" -(#) :: String+(#) :: Text (#) = "#" -applyFlipped :: String+applyFlipped :: Text applyFlipped = "applyFlipped" -(<>) :: String+(<>) :: Text (<>) = "<>" -(++) :: String+(++) :: Text (++) = "++" -append :: String+append :: Text append = "append" -(>>=) :: String+(>>=) :: Text (>>=) = ">>=" -bind :: String+bind :: Text bind = "bind" -(+) :: String+(+) :: Text (+) = "+" -add :: String+add :: Text add = "add" -(-) :: String+(-) :: Text (-) = "-" -sub :: String+sub :: Text sub = "sub" -(*) :: String+(*) :: Text (*) = "*" -mul :: String+mul :: Text mul = "mul" -(/) :: String+(/) :: Text (/) = "/" -div :: String+div :: Text div = "div" -(%) :: String+(%) :: Text (%) = "%" -mod :: String+mod :: Text mod = "mod" -(<) :: String+(<) :: Text (<) = "<" -lessThan :: String+lessThan :: Text lessThan = "lessThan" -(>) :: String+(>) :: Text (>) = ">" -greaterThan :: String+greaterThan :: Text greaterThan = "greaterThan" -(<=) :: String+(<=) :: Text (<=) = "<=" -lessThanOrEq :: String+lessThanOrEq :: Text lessThanOrEq = "lessThanOrEq" -(>=) :: String+(>=) :: Text (>=) = ">=" -greaterThanOrEq :: String+greaterThanOrEq :: Text greaterThanOrEq = "greaterThanOrEq" -(==) :: String+(==) :: Text (==) = "==" -eq :: String+eq :: Text eq = "eq" -(/=) :: String+(/=) :: Text (/=) = "/=" -notEq :: String+notEq :: Text notEq = "notEq" -compare :: String+compare :: Text compare = "compare" -(&&) :: String+(&&) :: Text (&&) = "&&" -conj :: String+conj :: Text conj = "conj" -(||) :: String+(||) :: Text (||) = "||" -disj :: String+disj :: Text disj = "disj" -unsafeIndex :: String+unsafeIndex :: Text unsafeIndex = "unsafeIndex" -or :: String+or :: Text or = "or" -and :: String+and :: Text and = "and" -xor :: String+xor :: Text xor = "xor" -(<<<) :: String+(<<<) :: Text (<<<) = "<<<" -compose :: String+compose :: Text compose = "compose" -(>>>) :: String+(>>>) :: Text (>>>) = ">>>" -composeFlipped :: String+composeFlipped :: Text composeFlipped = "composeFlipped"  -- Functions -negate :: String+negate :: Text negate = "negate" -not :: String+not :: Text not = "not" -shl :: String+shl :: Text shl = "shl" -shr :: String+shr :: Text shr = "shr" -zshr :: String+zshr :: Text zshr = "zshr" -complement :: String+complement :: Text complement = "complement"  -- Prelude Values -zero :: String+zero :: Text zero = "zero" -one :: String+one :: Text one = "one" -bottom :: String+bottom :: Text bottom = "bottom" -top :: String+top :: Text top = "top" -return :: String+return :: Text return = "return" -pure' :: String+pure' :: Text pure' = "pure" -returnEscaped :: String+returnEscaped :: Text returnEscaped = "$return" -untilE :: String+untilE :: Text untilE = "untilE" -whileE :: String+whileE :: Text whileE = "whileE" -runST :: String+runST :: Text runST = "runST" -stRefValue :: String+stRefValue :: Text stRefValue = "value" -newSTRef :: String+newSTRef :: Text newSTRef = "newSTRef" -readSTRef :: String+readSTRef :: Text readSTRef = "readSTRef" -writeSTRef :: String+writeSTRef :: Text writeSTRef = "writeSTRef" -modifySTRef :: String+modifySTRef :: Text modifySTRef = "modifySTRef" -mkFn :: String+mkFn :: Text mkFn = "mkFn" -runFn :: String+runFn :: Text runFn = "runFn" -unit :: String+unit :: Text unit = "unit"  -- Prim values -undefined :: String+undefined :: Text undefined = "undefined"  -- Type Class Dictionary Names -monadEffDictionary :: String+monadEffDictionary :: Text monadEffDictionary = "monadEff" -applicativeEffDictionary :: String+applicativeEffDictionary :: Text applicativeEffDictionary = "applicativeEff" -bindEffDictionary :: String+bindEffDictionary :: Text bindEffDictionary = "bindEff" -semiringNumber :: String+semiringNumber :: Text semiringNumber = "semiringNumber" -semiringInt :: String+semiringInt :: Text semiringInt = "semiringInt" -ringNumber :: String+ringNumber :: Text ringNumber = "ringNumber" -ringInt :: String+ringInt :: Text ringInt = "ringInt" -moduloSemiringNumber :: String+moduloSemiringNumber :: Text moduloSemiringNumber = "moduloSemiringNumber" -moduloSemiringInt :: String+moduloSemiringInt :: Text moduloSemiringInt = "moduloSemiringInt" -euclideanRingNumber :: String+euclideanRingNumber :: Text euclideanRingNumber = "euclideanRingNumber" -euclideanRingInt :: String+euclideanRingInt :: Text euclideanRingInt = "euclideanRingInt" -ordBoolean :: String+ordBoolean :: Text ordBoolean = "ordBoolean" -ordNumber :: String+ordNumber :: Text ordNumber = "ordNumber" -ordInt :: String+ordInt :: Text ordInt = "ordInt" -ordString :: String+ordString :: Text ordString = "ordString" -ordChar :: String+ordChar :: Text ordChar = "ordChar" -eqNumber :: String+eqNumber :: Text eqNumber = "eqNumber" -eqInt :: String+eqInt :: Text eqInt = "eqInt" -eqString :: String+eqString :: Text eqString = "eqString" -eqChar :: String+eqChar :: Text eqChar = "eqChar" -eqBoolean :: String+eqBoolean :: Text eqBoolean = "eqBoolean" -boundedBoolean :: String+boundedBoolean :: Text boundedBoolean = "boundedBoolean" -booleanAlgebraBoolean :: String+booleanAlgebraBoolean :: Text booleanAlgebraBoolean = "booleanAlgebraBoolean" -heytingAlgebraBoolean :: String+heytingAlgebraBoolean :: Text heytingAlgebraBoolean = "heytingAlgebraBoolean" -semigroupString :: String+semigroupString :: Text semigroupString = "semigroupString" -semigroupoidFn :: String+semigroupoidFn :: Text semigroupoidFn = "semigroupoidFn"  -- Generic Deriving -generic :: String+generic :: Text generic = "Generic" -toSpine :: String+toSpine :: Text toSpine = "toSpine" -fromSpine :: String+fromSpine :: Text fromSpine = "fromSpine" -toSignature :: String+toSignature :: Text toSignature = "toSignature" +-- IsSymbol class++pattern IsSymbol :: Qualified (ProperName 'ClassName)+pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol")+ -- Main module -main :: String+main :: Text main = "main"  -- Prim -partial :: String+partial :: Text partial = "Partial"  pattern Partial :: Qualified (ProperName 'ClassName)@@ -332,67 +337,67 @@  -- Code Generation -__superclass_ :: String+__superclass_ :: Text __superclass_ = "__superclass_" -__unused :: String+__unused :: Text __unused = "__unused"  -- Modules -prim :: String+prim :: Text prim = "Prim" -prelude :: String+prelude :: Text prelude = "Prelude" -dataArray :: String+dataArray :: Text dataArray = "Data_Array" -eff :: String+eff :: Text eff = "Control_Monad_Eff" -st :: String+st :: Text st = "Control_Monad_ST" -controlApplicative :: String+controlApplicative :: Text controlApplicative = "Control_Applicative" -controlSemigroupoid :: String+controlSemigroupoid :: Text controlSemigroupoid = "Control_Semigroupoid" -controlBind :: String+controlBind :: Text controlBind = "Control_Bind" -dataBounded :: String+dataBounded :: Text dataBounded = "Data_Bounded" -dataSemigroup :: String+dataSemigroup :: Text dataSemigroup = "Data_Semigroup" -dataHeytingAlgebra :: String+dataHeytingAlgebra :: Text dataHeytingAlgebra = "Data_HeytingAlgebra" -dataEq :: String+dataEq :: Text dataEq = "Data_Eq" -dataOrd :: String+dataOrd :: Text dataOrd = "Data_Ord" -dataSemiring :: String+dataSemiring :: Text dataSemiring = "Data_Semiring" -dataRing :: String+dataRing :: Text dataRing = "Data_Ring" -dataEuclideanRing :: String+dataEuclideanRing :: Text dataEuclideanRing = "Data_EuclideanRing" -dataFunction :: String+dataFunction :: Text dataFunction = "Data_Function" -dataFunctionUncurried :: String+dataFunctionUncurried :: Text dataFunctionUncurried = "Data_Function_Uncurried" -dataIntBits :: String+dataIntBits :: Text dataIntBits = "Data_Int_Bits"

src/Language/PureScript/CoreFn/Desugar.hs view

@@ -13,6 +13,7 @@ import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals import Language.PureScript.Comments+import qualified Language.PureScript.Constants as C import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr@@ -110,7 +111,9 @@     exprToCoreFn ss com (Just ty) v   exprToCoreFn ss com ty (A.Let ds v) =     Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)-  exprToCoreFn ss com _  (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =+  exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) =+    exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit)+  exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) =     let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs         ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)     in foldl (App (ss, com, Nothing, Nothing)) ctor args@@ -209,6 +212,11 @@   fqValues :: A.Expr -> [ModuleName]   fqValues (A.Var q) = getQual' q   fqValues (A.Constructor q) = getQual' q+  -- IsSymbol instances for literal symbols are automatically solved and the type+  -- class dictionaries are built inline instead of having a named instance defined+  -- and imported.  We therefore need to import the IsSymbol constructor from+  -- Data.Symbol if it hasn't already been imported.+  fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol   fqValues _ = []    fqBinders :: A.Binder -> [ModuleName]

src/Language/PureScript/CoreFn/Expr.hs view

@@ -6,6 +6,7 @@ import Prelude.Compat  import Control.Arrow ((***))+import Data.Text (Text)  import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders@@ -26,11 +27,11 @@   -- |   -- A record property accessor   ---  | Accessor a String (Expr a)+  | Accessor a Text (Expr a)   -- |   -- Partial record update   ---  | ObjectUpdate a (Expr a) [(String, Expr a)]+  | ObjectUpdate a (Expr a) [(Text, Expr a)]   -- |   -- Function introduction   --

src/Language/PureScript/CoreFn/ToJSON.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE NoOverloadedStrings #-} -- | -- Dump the core functional representation in JSON format for consumption -- by third-party code generators@@ -10,7 +11,8 @@  import Data.Aeson import Data.Version (Version, showVersion)-import Data.Text (pack)+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.Literals import Language.PureScript.CoreFn@@ -31,26 +33,26 @@ properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName -qualifiedToJSON :: (a -> String) -> Qualified a -> Value+qualifiedToJSON :: (a -> Text) -> Qualified a -> Value qualifiedToJSON f = toJSON . showQualified f  moduleNameToJSON :: ModuleName -> Value moduleNameToJSON = toJSON . runModuleName  moduleToJSON :: Version -> Module a -> Value-moduleToJSON v m = object [ pack "imports"   .= map (moduleNameToJSON . snd) (moduleImports m)-                          , pack "exports"   .= map identToJSON (moduleExports m)-                          , pack "foreign"   .= map (identToJSON . fst) (moduleForeign m)-                          , pack "decls"     .= map bindToJSON (moduleDecls m)-                          , pack "builtWith" .= toJSON (showVersion v)+moduleToJSON v m = object [ T.pack "imports"   .= map (moduleNameToJSON . snd) (moduleImports m)+                          , T.pack "exports"   .= map identToJSON (moduleExports m)+                          , T.pack "foreign"   .= map (identToJSON . fst) (moduleForeign m)+                          , T.pack "decls"     .= map bindToJSON (moduleDecls m)+                          , T.pack "builtWith" .= toJSON (showVersion v)                           ]  bindToJSON :: Bind a -> Value-bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]-bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs+bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]+bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs -recordToJSON :: (a -> Value) -> [(String, a)] -> Value-recordToJSON f = object . map (\(label, a) -> pack label .= f a)+recordToJSON :: (a -> Value) -> [(Text, a)] -> Value+recordToJSON f = object . map (\(label, a) -> label .= f a)  exprToJSON :: Expr a -> Value exprToJSON (Var _ i)              = toJSON ( "Var"

src/Language/PureScript/Docs/AsMarkdown.hs view

@@ -14,6 +14,7 @@  import Data.Foldable (for_) import Data.List (partition)+import qualified Data.Text as T  import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types@@ -37,13 +38,13 @@  moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do-  headerLevel 2 $ "Module " ++ P.runModuleName modName+  headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName)   spacer   for_ modComments tell'   mapM_ (declAsMarkdown modName) modDeclarations   spacer   for_ modReExports $ \(mn, decls) -> do-    headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"+    headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":"     spacer     mapM_ (declAsMarkdown mn) decls

src/Language/PureScript/Docs/Convert.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs. @@ -18,6 +16,7 @@ import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) import qualified Data.Map as Map+import qualified Data.Text as T  import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)@@ -170,7 +169,7 @@  runParser :: P.TokenParser a -> String -> Either String a runParser p s = either (Left . show) Right $ do-  ts <- P.lex "" s+  ts <- P.lex "" (T.pack s)   P.runTokenParser "" (p <* eof) ts  -- |

src/Language/PureScript/Docs/Convert/ReExports.hs view

@@ -4,7 +4,7 @@  import Prelude.Compat -import Control.Arrow ((&&&), second)+import Control.Arrow ((&&&), first, second) import Control.Monad import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify)@@ -16,6 +16,7 @@ import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import qualified Data.Map as Map+import qualified Data.Text as T  import Language.PureScript.Docs.Types import qualified Language.PureScript as P@@ -52,7 +53,7 @@       Just v' ->         pure v'       Nothing ->-        internalError ("Module missing: " ++ P.runModuleName mn)+        internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))  -- | -- Collect all of the re-exported declarations for a single module.@@ -69,7 +70,7 @@ getReExports env mn =   case Map.lookup mn env of     Nothing ->-      internalError ("Module missing: " ++ P.runModuleName mn)+      internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))     Just (_, imports, exports) -> do       allExports <- runReaderT (collectDeclarations imports exports) mn       pure (filter notLocal allExports)@@ -188,7 +189,7 @@   decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom   let     rs =-      filter (\d -> declTitle d == P.showIdent ident+      filter (\d -> declTitle d == T.unpack (P.showIdent ident)                     && (isValue d || isValueAlias d)) decls     errOther other =       internalErrorInModule@@ -214,7 +215,7 @@                     (declChildren d))          matchesIdent cdecl =-          cdeclTitle cdecl == P.showIdent ident+          cdeclTitle cdecl == T.unpack (P.showIdent ident)          matchesAndIsTypeClassMember =           uncurry (&&) . (matchesIdent &&& isTypeClassMember)@@ -238,7 +239,7 @@   -> m (P.ModuleName, [Declaration]) lookupValueOpDeclaration importedFrom op = do   decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom-  case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of+  case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of     [d] ->       pure (importedFrom, [d])     other ->@@ -258,7 +259,7 @@ lookupTypeDeclaration importedFrom ty = do   decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom   let-    ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls+    ds = filter (\d -> declTitle d == T.unpack (P.runProperName ty) && isType d) decls   case ds of     [d] ->       pure (importedFrom, [d])@@ -274,7 +275,7 @@ lookupTypeOpDeclaration importedFrom tyOp = do   decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom   let-    ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls+    ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls   case ds of     [d] ->       pure (importedFrom, [d])@@ -290,7 +291,7 @@ lookupTypeClassDeclaration importedFrom tyClass = do   decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom   let-    ds = filter (\d -> declTitle d == P.runProperName tyClass+    ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass)                        && isTypeClass d)                 decls   case ds of@@ -317,7 +318,7 @@     Nothing ->       internalErrorInModule         (definedIn ++ ": module missing: "-         ++ P.runModuleName moduleName)+         ++ T.unpack (P.runModuleName moduleName))     Just mdl ->       pure (allDeclarations mdl) @@ -447,7 +448,7 @@   -> Map P.ModuleName [Declaration]   -> Map P.ModuleName [Declaration] filterDataConstructors =-  filterExportedChildren isDataConstructor P.runProperName+  filterExportedChildren isDataConstructor (T.unpack . P.runProperName)  -- | -- Given a list of exported type class member names, remove any data@@ -459,7 +460,7 @@   -> Map P.ModuleName [Declaration]   -> Map P.ModuleName [Declaration] filterTypeClassMembers =-  filterExportedChildren isTypeClassMember P.showIdent+  filterExportedChildren isTypeClassMember (T.unpack . P.showIdent)  filterExportedChildren   :: (Functor f)@@ -492,7 +493,7 @@ internalErrorInModule msg = do   mn <- ask   internalError-    ("while collecting re-exports for module: " ++ P.runModuleName mn +++    ("while collecting re-exports for module: " ++ T.unpack (P.runModuleName mn) ++      ", " ++ msg)  -- |@@ -502,8 +503,8 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} =   case declInfo of-    TypeClassDeclaration tyArgs _ ->-      Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)+    TypeClassDeclaration tyArgs _ _ ->+      Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing)     _ ->       Nothing   where

src/Language/PureScript/Docs/Convert/Single.hs view

@@ -5,16 +5,24 @@  import Prelude.Compat +import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad +import Data.Bifunctor (bimap) import Data.Either import Data.List (nub) import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V  import Language.PureScript.Docs.Types import qualified Language.PureScript as P +-- TODO (Christoph): Get rid of the T.unpack s+ -- | -- Convert a single Module, but ignore re-exports; any re-exported types or -- values will not appear in the result.@@ -75,7 +83,7 @@   augmentWith (AugmentChild child) d =     d { declChildren = declChildren d ++ [child] } -getDeclarationTitle :: P.Declaration -> Maybe String+getDeclarationTitle :: P.Declaration -> Maybe Text getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)@@ -83,25 +91,25 @@ getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)-getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)+getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing  -- | Create a basic Declaration value.-mkDeclaration :: String -> DeclarationInfo -> Declaration+mkDeclaration :: Text -> DeclarationInfo -> Declaration mkDeclaration title info =-  Declaration { declTitle      = title+  Declaration { declTitle      = T.unpack title               , declComments   = Nothing               , declSourceSpan = Nothing               , declChildren   = []               , declInfo       = info               } -basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration+basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration basicDeclaration title info = Just $ Right $ mkDeclaration title info -convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration+convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =   basicDeclaration title (ValueDeclaration ty) convertDeclaration P.ValueDeclaration{} title =@@ -113,27 +121,42 @@ convertDeclaration (P.DataDeclaration dtype _ args ctors) title =   Just (Right (mkDeclaration title info) { declChildren = children })   where-  info = DataDeclaration dtype args+  info = DataDeclaration dtype (map (first T.unpack) args)   children = map convertCtor ctors   convertCtor (ctor', tys) =-    ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)+    ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title =   basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =-  basicDeclaration title (TypeSynonymDeclaration args ty)-convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info+  basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)+convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =   Just (Right (mkDeclaration title info) { declChildren = children })   where-  info = TypeClassDeclaration args implies+  info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps')   children = map convertClassMember ds   convertClassMember (P.PositionedDeclaration _ _ d) =     convertClassMember d   convertClassMember (P.TypeDeclaration ident' ty) =-    ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)+    ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty)   convertClassMember _ =     P.internalError "convertDeclaration: Invalid argument to convertClassMember."+  fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps+    where+      argsVec = V.fromList (map fst args)+      getArg i =+        maybe+          (P.internalError $ unlines+            [ "convertDeclaration: Functional dependency index"+            , show i+            , "is bigger than arguments list"+            , show (map fst args)+            , "Functional dependencies are"+            , show fundeps+            ]+          ) id $ argsVec V.!? i+      toArgs from to = (map getArg from, map getArg to) convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =-  Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))+  Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl))   where   classNameString = unQual className   typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)@@ -142,7 +165,7 @@   extractProperNames (P.TypeConstructor n) = [unQual n]   extractProperNames _ = [] -  childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)+  childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp)   classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =   Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))@@ -174,8 +197,8 @@   pure (unlines docs)    where-  toLines (P.LineComment s) = [s]-  toLines (P.BlockComment s) = lines s+  toLines (P.LineComment s) = [T.unpack s]+  toLines (P.BlockComment s) = lines (T.unpack s)    stripPipe s' =     case dropWhile (== ' ') s' of@@ -196,5 +219,5 @@ collectBookmarks' :: P.Module -> [(P.ModuleName, String)] collectBookmarks' m =   map (P.getModuleName m, )-      (mapMaybe getDeclarationTitle+      (mapMaybe (fmap T.unpack . getDeclarationTitle)                 (P.exportedDeclarations m))

src/Language/PureScript/Docs/Render.hs view

@@ -13,12 +13,16 @@  import Data.Maybe (maybeToList) import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text)  import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras import qualified Language.PureScript as P +-- TODO (Christoph): get rid of T.unpack's+ renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions @@ -31,7 +35,7 @@       , renderType' ty       ]     DataDeclaration dtype args ->-      [ keyword (P.showDataDeclType dtype)+      [ keyword (T.unpack (P.showDataDeclType dtype))       , renderType' (typeApp declTitle args)       ]     ExternDataDeclaration kind' ->@@ -46,10 +50,11 @@       , syntax "="       , renderType' ty       ]-    TypeClassDeclaration args implies ->+    TypeClassDeclaration args implies fundeps ->       [ keywordClass ]       ++ maybeToList superclasses       ++ [renderType' (typeApp declTitle args)]+      ++ fundepsList       ++ [keywordWhere | any isTypeClassMember declChildren]        where@@ -60,6 +65,15 @@             <> mintersperse (syntax "," <> sp) (map renderConstraint implies)             <> syntax ")" <> sp <> syntax "<=" +      fundepsList =+           [syntax "|" | not (null fundeps)]+        ++ [mintersperse+             (syntax "," <> sp)+             [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]+           ]+        where+          idents = mintersperse sp . map ident+     AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->       [ keywordFixity associativity       , syntax $ show precedence@@ -74,15 +88,15 @@    renderQualAlias :: FixityAlias -> String   renderQualAlias (P.Qualified mn alias)-    | mn == currentModule opts = renderAlias id alias-    | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias+    | mn == currentModule opts = T.unpack (renderAlias id alias)+    | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias)    renderAlias-    :: (forall a. (a -> String) -> a -> String)+    :: (forall a. (a -> Text) -> a -> Text)     -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))-    -> String+    -> Text   renderAlias f-    = either (("type " ++) . f P.runProperName)+    = either (("type " <>) . f P.runProperName)     $ either (f P.runIdent) (f P.runProperName)    -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)@@ -133,7 +147,7 @@                  (map (renderConstraintWithOptions opts) constraints)  notQualified :: String -> P.Qualified (P.ProperName a)-notQualified = P.Qualified Nothing . P.ProperName+notQualified = P.Qualified Nothing . P.ProperName . T.pack  typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type typeApp title typeArgs =@@ -142,5 +156,5 @@         (map toTypeVar typeArgs)  toTypeVar :: (String, Maybe P.Kind) -> P.Type-toTypeVar (s, Nothing) = P.TypeVar s-toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k+toTypeVar (s, Nothing) = P.TypeVar (T.pack s)+toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k

src/Language/PureScript/Docs/RenderedCode/Render.hs view

@@ -14,8 +14,10 @@  import Data.Maybe (fromMaybe) import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text) -import Control.Arrow ((<+>))+import Control.Arrow ((<+>), first) import Control.PatternArrows as PA  import Language.PureScript.Crash@@ -33,7 +35,7 @@   match TypeWildcard{} =     Just (syntax "_")   match (TypeVar var) =-    Just (ident var)+    Just (ident (T.unpack var))   match (PrettyPrintObject row) =     Just $ mintersperse sp               [ syntax "{"@@ -41,7 +43,7 @@               , syntax "}"               ]   match (TypeConstructor (Qualified mn name)) =-    Just (ctor (runProperName name) (maybeToContainingModule mn))+    Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn))   match REmpty =     Just (syntax "()")   match row@RCons{} =@@ -49,7 +51,7 @@   match (BinaryNoParensType op l r) =     Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r   match (TypeOp (Qualified mn op)) =-    Just (ident' (runOpName op) (maybeToContainingModule mn))+    Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn))   match _ =     Nothing @@ -74,8 +76,10 @@ -- Render code representing a Row -- renderRow :: Type -> RenderedCode-renderRow = uncurry renderRow' . rowToList+renderRow = uncurry renderRow' . convertString . rowToList   where+  convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type)+  convertString = first (map (first T.unpack))   renderRow' h t = renderHead h <> renderTail t  renderHead :: [(String, Type)] -> RenderedCode@@ -144,7 +148,7 @@ forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match   where-  match (PrettyPrintForAll idents ty) = Just (idents, ty)+  match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)   match _ = Nothing  insertPlaceholders :: RenderTypeOptions -> Type -> Type@@ -176,7 +180,7 @@ -- Render code representing a Kind -- renderKind :: Kind -> RenderedCode-renderKind = kind . prettyPrintKind+renderKind = kind . T.unpack . prettyPrintKind  -- | -- Render code representing a Type, as it should appear inside parentheses

src/Language/PureScript/Docs/RenderedCode/Types.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}  -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation.@@ -38,6 +37,7 @@  import Data.Aeson.BetterErrors import qualified Data.Aeson as A+import qualified Data.Text as T  import qualified Language.PureScript as P @@ -103,7 +103,7 @@  asContainingModule :: Parse e ContainingModule asContainingModule =-  maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString)+  maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString)  -- | -- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious

src/Language/PureScript/Docs/Types.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Docs.Types   ( module Language.PureScript.Docs.Types   , module ReExports@@ -122,10 +120,10 @@   | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type    -- |-  -- A type class, with its type arguments and its superclasses. Instances and-  -- members are represented as child declarations.+  -- A type class, with its type arguments, its superclasses and functional+  -- dependencies. Instances and members are represented as child declarations.   ---  | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]+  | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])]    -- |   -- An operator alias declaration, with the member the alias is for and the@@ -141,7 +139,7 @@ declInfoToString (DataDeclaration _ _) = "data" declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"-declInfoToString (TypeClassDeclaration _ _) = "typeClass"+declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias"  isTypeClass :: Declaration -> Bool@@ -352,7 +350,7 @@  asModule :: Parse PackageError Module asModule =-  Module <$> key "name" (P.moduleNameFromString <$> asString)+  Module <$> key "name" (P.moduleNameFromString <$> asText)          <*> key "comments" (perhaps asString)          <*> key "declarations" (eachInArray asDeclaration)          <*> key "reExports" (eachInArray asReExport)@@ -413,6 +411,7 @@     "typeClass" ->       TypeClassDeclaration <$> key "arguments" asTypeArguments                            <*> key "superclasses" (eachInArray asConstraint)+                           <*> keyOrDefault "fundeps" [] asFunDeps     "alias" ->       AliasDeclaration <$> key "fixity" asFixity                        <*> key "alias" asFixityAlias@@ -430,6 +429,11 @@ asType :: Parse e P.Type asType = fromAesonParser +asFunDeps :: Parse PackageError [([String], [String])]+asFunDeps = eachInArray asFunDep+  where+  asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString)+ asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType =   withString $ \s -> case s of@@ -478,7 +482,7 @@  asBookmark :: Parse BowerError Bookmark asBookmark =-  asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)+  asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)                    <*> nth 1 asString)  asResolvedDependencies :: Parse PackageError [(PackageName, Version)]@@ -556,7 +560,7 @@       DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]       ExternDataDeclaration kind -> ["kind" .= kind]       TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]-      TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]+      TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]       AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]  instance A.ToJSON ChildDeclarationInfo where

src/Language/PureScript/Environment.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}  module Language.PureScript.Environment where@@ -6,10 +5,14 @@ import Prelude.Compat  import Data.Aeson.TH-import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe (fromMaybe)+import Data.Text (Text) import qualified Data.Text as T+import Data.List (nub)+import qualified Data.Graph as G  import Language.PureScript.Crash import Language.PureScript.Kinds@@ -27,9 +30,9 @@   , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])   -- ^ Data constructors currently in scope, along with their associated type   -- constructor name, argument types and return type.-  , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)+  , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)   -- ^ Type synonyms currently in scope-  , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))+  , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))   -- ^ Available type class dictionaries   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData   -- ^ Type classes@@ -37,7 +40,7 @@  -- | Information about a type class data TypeClassData = TypeClassData-  { typeClassArguments :: [(String, Maybe Kind)]+  { typeClassArguments :: [(Text, Maybe Kind)]   -- ^ A list of type argument names, and their kinds, where kind annotations   -- were provided.   , typeClassMembers :: [(Ident, Type)]@@ -48,6 +51,10 @@   -- are considered bound in the types appearing in these constraints.   , typeClassDependencies :: [FunctionalDependency]   -- ^ A list of functional dependencies for the type arguments of this class.+  , typeClassDeterminedArguments :: S.Set Int+  -- ^ A set of indexes of type argument that are fully determined by other+  -- arguments via functional dependencies. This can be computed from both+  -- typeClassArguments and typeClassDependencies.   } deriving Show  -- | A functional dependency indicates a relationship between two sets of@@ -66,6 +73,50 @@ initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses  -- |+-- A constructor for TypeClassData that computes which type class arguments are fully determined.+-- Fully determined means that this argument cannot be used when selecting a type class instance.+--+-- An example of the difference between determined and fully determined would be with the class:+-- ```class C a b c | a -> b, b -> a, b -> c```+-- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other.+-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is+-- fully determined by `a` and `b`.+--+-- Define a graph of type class arguments with edges being fundep determiners to determined.+-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.+-- An argument is not fully determined otherwise.+--+-- The way we compute this is by saying: an argument X is fully determined if there are arguments that+-- determine X that X does not determine. This is the same thing: everything X determines includes everything+-- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC.+makeTypeClassData+  :: [(Text, Maybe Kind)]+  -> [(Ident, Type)]+  -> [Constraint]+  -> [FunctionalDependency]+  -> TypeClassData+makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs+  where+    -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined+    contributingDeps = M.fromListWith (++) $ do+      fd <- deps+      src <- fdDeterminers fd+      (src, fdDetermined fd) : map (, []) (fdDetermined fd)++    -- here we build a graph of which arguments determine other arguments+    (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)++    -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to+    isFunDepDetermined arg = case fromKey arg of+      Nothing -> False -- not mentioned in fundeps+      Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v+                    varContributesTo = G.reachable depGraph v+                in any (\r -> not (r `elem` varContributesTo)) contributesToVar++    -- find all the arguments that are determined+    determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]++-- | -- The visibility of a name in scope -- data NameVisibility@@ -105,7 +156,7 @@   -- |   -- Data type   ---  = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]+  = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]   -- |   -- Type synonym   --@@ -138,7 +189,7 @@   | Newtype   deriving (Show, Eq, Ord) -showDataDeclType :: DataDeclType -> String+showDataDeclType :: DataDeclType -> Text showDataDeclType Data = "data" showDataDeclType Newtype = "newtype" @@ -155,13 +206,13 @@ -- | -- Construct a ProperName in the Prim module ---primName :: String -> Qualified (ProperName a)+primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName  -- | -- Construct a type in the Prim module ---primTy :: String -> Type+primTy :: Text -> Type primTy = TypeConstructor . primName  -- |@@ -264,8 +315,8 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses =   M.fromList-    [ (primName "Partial", (TypeClassData [] [] [] []))-    , (primName "Fail",    (TypeClassData [("message", Just Symbol)] [] [] []))+    [ (primName "Partial", (makeTypeClassData [] [] [] []))+    , (primName "Fail",    (makeTypeClassData [("message", Just Symbol)] [] [] []))     ]  -- |

src/Language/PureScript/Errors.hs view

@@ -18,10 +18,12 @@ import Data.Either (lefts, rights) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..))-import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition)+import Data.List (transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -43,7 +45,7 @@ import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import Text.Parsec.Error (Message(..)) -newtype ErrorSuggestion = ErrorSuggestion String+newtype ErrorSuggestion = ErrorSuggestion Text  -- | Get the source span for an error errorSpan :: ErrorMessage -> Maybe SourceSpan@@ -73,7 +75,7 @@ -- | -- Get the error code for a particular error type ---errorCode :: ErrorMessage -> String+errorCode :: ErrorMessage -> Text errorCode em = case unwrapErrorMessage em of   ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"   ErrorParsingModule{} -> "ErrorParsingModule"@@ -245,7 +247,7 @@     case M.lookup s (umSkolemMap m) of       Nothing -> do         let s' = umNextIndex m-        put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }+        put $ m { umSkolemMap = M.insert s (T.unpack name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 }         return (Skolem name s' sko ss)       Just (_, s', _) -> return (Skolem name s' sko ss)   replaceTypes other = return other@@ -287,8 +289,8 @@   gTypeSearch (TSBefore env) = pure (TSBefore env)   gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result -wikiUri :: ErrorMessage -> String-wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e+wikiUri :: ErrorMessage -> Text+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e  -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough@@ -304,19 +306,19 @@       ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing       ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)       HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing-      MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty-      WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty+      MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty)+      WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty)       _ -> Nothing   where     emptySuggestion = Just $ ErrorSuggestion ""     suggest = Just . ErrorSuggestion -    importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String+    importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text     importSuggestion mn refs qual =-      "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual+      "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual -    qstr :: Maybe ModuleName -> String-    qstr (Just mn) = " as " ++ runModuleName mn+    qstr :: Maybe ModuleName -> Text+    qstr (Just mn) = " as " <> runModuleName mn     qstr Nothing = ""  suggestionSpan :: ErrorMessage -> Maybe SourceSpan@@ -330,7 +332,7 @@         MissingTypeDeclaration{} -> startOnly ss         _ -> ss -showSuggestion :: SimpleErrorMessage -> String+showSuggestion :: SimpleErrorMessage -> Text showSuggestion suggestion = case errorSuggestion suggestion of   Just (ErrorSuggestion x) -> x   _ -> ""@@ -343,10 +345,10 @@ ansiColorReset =    ANSI.setSGRCode [ANSI.Reset] -colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String+colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text colorCode codeColor code = case codeColor of   Nothing -> code-  Just cc -> concat [ansiColor cc, code, ansiColorReset]+  Just cc -> T.pack (ansiColor cc) <> code <> T.pack ansiColorReset  colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box colorCodeBox codeColor b = case codeColor of@@ -403,8 +405,8 @@       ] ++       maybe [] (return . Box.moveDown 1) typeInformation ++       [ Box.moveDown 1 $ paras-          [ line $ "See " ++ wikiUri e ++ " for more information, "-          , line $ "or to contribute content related to this " ++ levelText ++ "."+          [ line $ "See " <> wikiUri e <> " for more information, "+          , line $ "or to contribute content related to this " <> levelText <> "."           ]       | showWiki       ]@@ -420,59 +422,59 @@       skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box       skolemInfo (name, s, ss) =         paras $-          line (markCode (name ++ show s) ++ " is a rigid type variable")-          : foldMap (return . line . ("  bound at " ++) . displayStartEndPos) ss+          line (markCode (T.pack (name <> show s)) <> " is a rigid type variable")+          : foldMap (return . line . ("  bound at " <>) . displayStartEndPos) ss        unknownInfo :: Int -> Box.Box-      unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type"+      unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"      renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box     renderSimpleErrorMessage (CannotGetFileInfo path) =       paras [ line "Unable to read file info: "-            , indent . line $ path+            , indent . lineS $ path             ]     renderSimpleErrorMessage (CannotReadFile path) =       paras [ line "Unable to read file: "-            , indent . line $ path+            , indent . lineS $ path             ]     renderSimpleErrorMessage (CannotWriteFile path) =       paras [ line "Unable to write file: "-            , indent . line $ path+            , indent . lineS $ path             ]     renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =       paras $ [ line "Unable to parse foreign module:"-              , indent . line $ path+              , indent . lineS $ path               ] ++-              map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))+              map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra))     renderSimpleErrorMessage (ErrorParsingModule err) =       paras [ line "Unable to parse module: "             , prettyPrintParseError err             ]     renderSimpleErrorMessage (MissingFFIModule mn) =-      line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing."+      line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing."     renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =-      paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": "-            , indent . line $ path-            , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary."+      paras [ line $ "An unnecessary foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": "+            , indent . lineS $ path+            , line $ "Module " <> markCode (runModuleName mn) <> " does not contain any foreign import declarations, so a foreign module is not necessary."             ]     renderSimpleErrorMessage (MissingFFIImplementations mn idents) =-      paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": "+      paras [ line $ "The following values are not defined in the foreign module for module " <> markCode (runModuleName mn) <> ": "             , indent . paras $ map (line . runIdent) idents             ]     renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =-      paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: "+      paras [ line $ "The following definitions in the foreign module for module " <> markCode (runModuleName mn) <> " are unused: "             , indent . paras $ map (line . runIdent) idents             ]     renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) =-      paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":"+      paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":"             , indent . paras $-                [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript."+                [ line $ "The identifier " <> markCode ident <> " is not valid in PureScript."                 , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers."                 ]             ]     renderSimpleErrorMessage (MultipleFFIModules mn paths) =-      paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": "-            , indent . paras $ map line paths+      paras [ line $ "Multiple foreign module implementations have been provided for module " <> markCode (runModuleName mn) <> ": "+            , indent . paras $ map lineS paths             ]     renderSimpleErrorMessage InvalidDoBind =       line "The last statement in a 'do' block must be an expression, but this block ends with a binder."@@ -489,63 +491,63 @@             , indent $ line $ markCode $ prettyPrintKind ki             ]     renderSimpleErrorMessage (MultipleValueOpFixities op) =-      line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op)+      line $ "There are multiple fixity/precedence declarations for operator " <> markCode (showOp op)     renderSimpleErrorMessage (MultipleTypeOpFixities op) =-      line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)+      line $ "There are multiple fixity/precedence declarations for type operator " <> markCode (showOp op)     renderSimpleErrorMessage (OrphanTypeDeclaration nm) =-      line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."+      line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition."     renderSimpleErrorMessage (RedefinedIdent name) =-      line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"+      line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times"     renderSimpleErrorMessage (UnknownName name) =-      line $ "Unknown " ++ printName name+      line $ "Unknown " <> printName name     renderSimpleErrorMessage (UnknownImport mn name) =-      paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn)+      paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn)             , line "It either does not exist or the module does not export it."             ]     renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =-      line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon)+      line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon)     renderSimpleErrorMessage (UnknownExport name) =-      line $ "Cannot export unknown " ++ printName (Qualified Nothing name)+      line $ "Cannot export unknown " <> printName (Qualified Nothing name)     renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =-      line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared."+      line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared."     renderSimpleErrorMessage (ScopeConflict nm ms) =-      paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:"+      paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following modules:"             , indent $ paras $ map (line . markCode . runModuleName) ms             ]     renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =-      paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:"-            , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms-            , line $ "These will be ignored and the " ++ case exmn of-                Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used."+      paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:"+            , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms+            , line $ "These will be ignored and the " <> case exmn of+                Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used."                 Nothing -> "local declaration will be used."             ]     renderSimpleErrorMessage (DeclConflict new existing) =-      line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."+      line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name."     renderSimpleErrorMessage (ExportConflict new existing) =-      line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing+      line $ "Export for " <> printName new <> " conflicts with " <> runName existing     renderSimpleErrorMessage (DuplicateModule mn ss) =-      paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:")+      paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:")             , indent . paras $ map (line . displaySourceSpan) ss             ]     renderSimpleErrorMessage (CycleInDeclaration nm) =-      line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."+      line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."     renderSimpleErrorMessage (CycleInModules mns) =       paras [ line "There is a cycle in module dependencies in these modules: "             , indent $ paras (map (line . markCode . runModuleName) mns)             ]     renderSimpleErrorMessage (CycleInTypeSynonym name) =       paras [ line $ case name of-                       Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn)+                       Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn)                        Nothing -> "A cycle appears in a set of type synonym definitions."             , line "Cycles are disallowed because they can lead to loops in the type checker."             , line "Consider using a 'newtype' instead."             ]     renderSimpleErrorMessage (NameIsUndefined ident) =-      line $ "Value " ++ markCode (showIdent ident) ++ " is undefined."+      line $ "Value " <> markCode (showIdent ident) <> " is undefined."     renderSimpleErrorMessage (UndefinedTypeVariable name) =-      line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined."+      line $ "Type variable " <> markCode (runProperName name) <> " is undefined."     renderSimpleErrorMessage (PartiallyAppliedSynonym name) =-      paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied."+      paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied."             , line "Type synonyms must be applied to all of their type arguments."             ]     renderSimpleErrorMessage (EscapedSkolem binding) =@@ -561,12 +563,12 @@             sortRows t1 t2 = (t1, t2)              -- Put the common labels last-            sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)+            sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type)             sortRows' (s1, r1) (s2, r2) =-              let common :: [(String, (Type, Type))]+              let common :: [(Text, (Type, Type))]                   common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] -                  sd1, sd2 :: [(String, Type)]+                  sd1, sd2 :: [(Text, Type)]                   sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]                   sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]               in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)@@ -597,7 +599,7 @@                 , Box.vcat Box.left (map typeAtomAsBox ts)                 ]             , line "The following instances were found:"-            , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)+            , indent $ paras (line (showQualified showIdent d <> " (chosen)") : map (line . showQualified showIdent) ds)             , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."             , line "They may be disallowed completely in a future version of the compiler."             ]@@ -640,7 +642,7 @@         go _ = False     renderSimpleErrorMessage (AmbiguousTypeVariables t _) =       paras [ line "The inferred type"-            , indent $ line $ markCode $ prettyPrintType t+            , markCodeBox $ indent $ typeAsBox t             , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."             ]     renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =@@ -667,26 +669,26 @@             , line "Make sure this is a newtype."             ]     renderSimpleErrorMessage (CannotFindDerivingType nm) =-      line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."+      line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found."     renderSimpleErrorMessage (DuplicateLabel l expr) =-      paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ]+      paras $ [ line $ "Label " <> markCode l <> " appears more than once in a row type." ]                        <> foldMap (\expr' -> [ line "Relevant expression: "                                              , markCodeBox $ indent $ prettyPrintValue valueDepth expr'                                              ]) expr     renderSimpleErrorMessage (DuplicateTypeArgument name) =-      line $ "Type argument " ++ markCode name ++ " appears more than once."+      line $ "Type argument " <> markCode name <> " appears more than once."     renderSimpleErrorMessage (DuplicateValueDeclaration nm) =-      line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "."+      line $ "Multiple value declarations exist for " <> markCode (showIdent nm) <> "."     renderSimpleErrorMessage (ArgListLengthsDiffer ident) =-      line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident)+      line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident)     renderSimpleErrorMessage (OverlappingArgNames ident) =-      line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident+      line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident     renderSimpleErrorMessage (MissingClassMember ident) =-      line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented."+      line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented."     renderSimpleErrorMessage (ExtraneousClassMember ident className) =-      line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className)+      line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)     renderSimpleErrorMessage (ExpectedType ty kind) =-      paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "."+      paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."             , line "The error arises from the type"             , markCodeBox $ indent $ typeAsBox ty             , line "having the kind"@@ -694,7 +696,7 @@             , line "instead."             ]     renderSimpleErrorMessage (IncorrectConstructorArity nm) =-      line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression."+      line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given the wrong number of arguments in a case expression."     renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =       paras [ line "Expression"             , markCodeBox $ indent $ prettyPrintValue valueDepth expr@@ -702,13 +704,13 @@             , markCodeBox $ indent $ typeAsBox ty             ]     renderSimpleErrorMessage (PropertyIsMissing prop) =-      line $ "Type of expression lacks required label " ++ markCode prop ++ "."+      line $ "Type of expression lacks required label " <> markCode prop <> "."     renderSimpleErrorMessage (AdditionalProperty prop) =-      line $ "Type of expression contains additional label " ++ markCode prop ++ "."+      line $ "Type of expression contains additional label " <> markCode prop <> "."     renderSimpleErrorMessage TypeSynonymInstance =       line "Type class instances for type synonyms are disallowed."     renderSimpleErrorMessage (OrphanInstance nm cnm ts) =-      paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for "+      paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for "             , markCodeBox $ indent $ Box.hsep 1 Box.left                 [ line (showQualified runProperName cnm)                 , Box.vcat Box.left (map typeAtomAsBox ts)@@ -718,38 +720,38 @@             , line "Consider moving the instance, if possible, or using a newtype wrapper."             ]     renderSimpleErrorMessage (InvalidNewtype name) =-      paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid."+      paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid."             , line "Newtypes must define a single constructor with a single argument."             ]     renderSimpleErrorMessage (InvalidInstanceHead ty) =       paras [ line "Type class instance head is invalid due to use of type"             , markCodeBox $ indent $ typeAsBox ty-            , 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."+            , 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."             ]     renderSimpleErrorMessage (TransitiveExportError x ys) =-      paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: "+      paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: "             , indent $ paras $ map (line . markCode . prettyPrintExport) ys             ]     renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =-      paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: "+      paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor to also be exported: "             , indent $ line $ markCode $ runProperName ctor             ]     renderSimpleErrorMessage (ShadowedName nm) =-      line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed."+      line $ "Name " <> markCode (showIdent nm) <> " was shadowed."     renderSimpleErrorMessage (ShadowedTypeVar tv) =-      line $ "Type variable " ++ markCode tv ++ " was shadowed."+      line $ "Type variable " <> markCode tv <> " was shadowed."     renderSimpleErrorMessage (UnusedTypeVar tv) =-      line $ "Type variable " ++ markCode tv ++ " was declared but not used."+      line $ "Type variable " <> markCode tv <> " was declared but not used."     renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =-      line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors."+      line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors."     renderSimpleErrorMessage (ImportHidingModule name) =       paras [ line "hiding imports cannot be used to hide modules."-            , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name)+            , line $ "An attempt was made to hide the import of " <> markCode (runModuleName name)             ]     renderSimpleErrorMessage (WildcardInferredType ty ctx) =       paras $ [ line "Wildcard type definition has the inferred type "               , markCodeBox $ indent $ typeAsBox ty-              ] ++ renderContext ctx+              ] <> renderContext ctx     renderSimpleErrorMessage (HoleInferredType name ty ctx ts) =       let         maxTSResults = 15@@ -758,7 +760,7 @@             let               formatTS (names, types) =                 let-                  idBoxes = Box.text . showQualified runIdent <$> names+                  idBoxes = Box.text . T.unpack . showQualified runIdent <$> names                   tyBoxes = (\t -> BoxHelpers.indented                               (Box.text ":: " Box.<> typeAsBox t)) <$> types                   longestId = maximum (map Box.cols idBoxes)@@ -772,13 +774,13 @@                ]           _ -> []       in-        paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type "+        paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type "                 , markCodeBox (indent (typeAsBox ty))                 ] ++ tsResult ++ renderContext ctx     renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =-      paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "."+      paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "."             , line "It is good practice to provide type declarations as a form of documentation."-            , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"+            , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"             , markCodeBox $ indent $ typeAsBox ty             ]     renderSimpleErrorMessage (OverlappingPattern bs b) =@@ -791,70 +793,70 @@             , line "You may want to decompose your data types into smaller types."             ]     renderSimpleErrorMessage (UnusedImport name) =-      line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant"+      line $ "The import of module " <> markCode (runModuleName name) <> " is redundant"      renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =-      paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"+      paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:"             , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names             , line "It could be replaced with:"             , indent $ line $ markCode $ showSuggestion msg ]      renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =-      paras [line $ "The import of type " ++ markCode (runProperName name)-                    ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used"+      paras [line $ "The import of type " <> markCode (runProperName name)+                    <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used"             , line "It could be replaced with:"             , indent $ line $ markCode $ showSuggestion msg ]      renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =-      paras [ line $ "The import of type " ++ markCode (runProperName name)-                     ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:"+      paras [ line $ "The import of type " <> markCode (runProperName name)+                     <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:"             , indent $ paras $ map (line . markCode . runProperName) names             , line "It could be replaced with:"             , indent $ line $ markCode $ showSuggestion msg ]      renderSimpleErrorMessage (DuplicateSelectiveImport name) =-      line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"+      line $ "There is an existing import of " <> markCode (runModuleName name) <> ", consider merging the import lists"      renderSimpleErrorMessage (DuplicateImport name imp qual) =-      line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual)+      line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual)      renderSimpleErrorMessage (DuplicateImportRef name) =-      line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name)+      line $ "Import list contains multiple references to " <> printName (Qualified Nothing name)      renderSimpleErrorMessage (DuplicateExportRef name) =-      line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name)+      line $ "Export list contains multiple references to " <> printName (Qualified Nothing name)      renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =-      paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend."-            , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ]+      paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend."+            , line $ "Acceptable values fall within the range " <> markCode (T.pack (show lo)) <> " to " <> markCode (T.pack (show hi)) <> " (inclusive)." ]      renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =-      paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports."-            , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:"+      paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports."+            , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:"             , indent $ line $ markCode $ showSuggestion msg             ]      renderSimpleErrorMessage msg@(ImplicitImport mn _) =-      paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: "+      paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: "             , indent $ line $ markCode $ showSuggestion msg             ]      renderSimpleErrorMessage msg@(HidingImport mn _) =-      paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: "+      paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the inclusive form: "             , indent $ line $ markCode $ showSuggestion msg             ]      renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =       paras [ line "Binder list length differs in case alternative:"-            , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs-            , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."+            , indent $ line $ T.intercalate ", " $ fmap prettyPrintBinderAtom bs+            , line $ "Expecting " <> T.pack (show l) <> " binder" <> (if l == 1 then "" else "s") <> "."             ]      renderSimpleErrorMessage IncorrectAnonymousArgument =       line "An anonymous function argument appears in an invalid context."      renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =-      paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "."+      paras [ line $ "Operator " <> markCode (showQualified showOp op) <> " cannot be used in a pattern as it is an alias for function " <> showQualified showIdent fn <> "."             , line "Only aliases for data constructors may be used in patterns."             ] @@ -862,18 +864,18 @@       line "The require-path option is deprecated and will be removed in PureScript 0.9."      renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =-      paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "."-            , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:"+      paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."+            , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"             , markCodeBox $ indent $ typeAsBox ty             , line "Try adding a type signature."             ]      renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =-      paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."+      paras [ line $ "Cannot derive an instance of the " <> markCode "Newtype" <> " class for non-newtype " <> markCode (runProperName tyName) <> "."             ]      renderSimpleErrorMessage (ExpectedWildcard tyName) =-      paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "."+      paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."             ]      renderHint :: ErrorMessageHint -> Box.Box -> Box.Box@@ -893,7 +895,7 @@                                  ]             ]     renderHint (ErrorInModule mn) detail =-      paras [ line $ "in module " ++ markCode (runModuleName mn)+      paras [ line $ "in module " <> markCode (runModuleName mn)             , detail             ]     renderHint (ErrorInSubsumption t1 t2) detail =@@ -958,35 +960,39 @@             ]     renderHint (ErrorInDataConstructor nm) detail =       paras [ detail-            , line $ "in data constructor " ++ markCode (runProperName nm)+            , line $ "in data constructor " <> markCode (runProperName nm)             ]     renderHint (ErrorInTypeConstructor nm) detail =       paras [ detail-            , line $ "in type constructor " ++ markCode (runProperName nm)+            , line $ "in type constructor " <> markCode (runProperName nm)             ]     renderHint (ErrorInBindingGroup nms) detail =       paras [ detail-            , line $ "in binding group " ++ intercalate ", " (map showIdent nms)+            , line $ "in binding group " <> T.intercalate ", " (map showIdent nms)             ]-    renderHint ErrorInDataBindingGroup detail =+    renderHint (ErrorInDataBindingGroup nms) detail =       paras [ detail-            , line "in data binding group"+            , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms)             ]     renderHint (ErrorInTypeSynonym name) detail =       paras [ detail-            , line $ "in type synonym " ++ markCode (runProperName name)+            , line $ "in type synonym " <> markCode (runProperName name)             ]     renderHint (ErrorInValueDeclaration n) detail =       paras [ detail-            , line $ "in value declaration " ++ markCode (showIdent n)+            , line $ "in value declaration " <> markCode (showIdent n)             ]     renderHint (ErrorInTypeDeclaration n) detail =       paras [ detail-            , line $ "in type declaration for " ++ markCode (showIdent n)+            , line $ "in type declaration for " <> markCode (showIdent n)             ]+    renderHint (ErrorInTypeClassDeclaration name) detail =+      paras [ detail+            , line $ "in type class declaration for " <> markCode (runProperName name)+            ]     renderHint (ErrorInForeignImport nm) detail =       paras [ detail-            , line $ "in foreign import " ++ markCode (showIdent nm)+            , line $ "in foreign import " <> markCode (showIdent nm)             ]     renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =       paras [ detail@@ -997,7 +1003,7 @@                 ]             ]     renderHint (PositionedError srcSpan) detail =-      paras [ line $ "at " ++ displaySourceSpan srcSpan+      paras [ line $ "at " <> displaySourceSpan srcSpan             , detail             ] @@ -1006,17 +1012,17 @@     renderContext ctx =       [ line "in the following context:"       , indent $ paras-          [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ")+          [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ")                               , markCodeBox $ typeAsBox ty'                               ]           | (ident, ty') <- take 5 ctx           ]       ] -    printName :: Qualified Name -> String-    printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn)+    printName :: Qualified Name -> Text+    printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn) -    nameType :: Name -> String+    nameType :: Name -> Text     nameType (IdentName _) = "value"     nameType (ValOpName _) = "operator"     nameType (TyName _) = "type"@@ -1025,7 +1031,7 @@     nameType (TyClassName _) = "type class"     nameType (ModName _) = "module" -    runName :: Qualified Name -> String+    runName :: Qualified Name -> Text     runName (Qualified mn (IdentName name)) =       showQualified showIdent (Qualified mn name)     runName (Qualified mn (ValOpName op)) =@@ -1047,7 +1053,7 @@   valueDepth | full = 1000              | otherwise = 3 -  levelText :: String+  levelText :: Text   levelText = case level of     Error -> "error"     Warning -> "warning"@@ -1108,40 +1114,40 @@   hintCategory _                                    = OtherHint  -- Pretty print and export declaration-prettyPrintExport :: DeclarationRef -> String+prettyPrintExport :: DeclarationRef -> Text prettyPrintExport (TypeRef pn _) = runProperName pn prettyPrintExport ref =   fromMaybe     (internalError "prettyPrintRef returned Nothing in prettyPrintExport")     (prettyPrintRef ref) -prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text prettyPrintImport mn idt qual =   let i = case idt of             Implicit -> runModuleName mn-            Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")"-            Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")"-  in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual+            Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")"+            Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate "," (mapMaybe prettyPrintRef refs) <> ")"+  in i <> maybe "" (\q -> " as " <> runModuleName q) qual -prettyPrintRef :: DeclarationRef -> Maybe String+prettyPrintRef :: DeclarationRef -> Maybe Text prettyPrintRef (TypeRef pn Nothing) =-  Just $ runProperName pn ++ "(..)"+  Just $ runProperName pn <> "(..)" prettyPrintRef (TypeRef pn (Just [])) =   Just $ runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) =-  Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"+  Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")" prettyPrintRef (TypeOpRef op) =-  Just $ "type " ++ showOp op+  Just $ "type " <> showOp op prettyPrintRef (ValueRef ident) =   Just $ showIdent ident prettyPrintRef (ValueOpRef op) =   Just $ showOp op prettyPrintRef (TypeClassRef pn) =-  Just $ "class " ++ runProperName pn+  Just $ "class " <> runProperName pn prettyPrintRef (TypeInstanceRef ident) =   Just $ showIdent ident prettyPrintRef (ModuleRef name) =-  Just $ "module " ++ runModuleName name+  Just $ "module " <> runModuleName name prettyPrintRef (ReExportRef _ _) =   Nothing prettyPrintRef (PositionedDeclarationRef _ _ ref) =@@ -1234,9 +1240,12 @@ indent :: Box.Box -> Box.Box indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 -line :: String -> Box.Box-line = Box.text+line :: Text -> Box.Box+line = Box.text . T.unpack +lineS :: String -> Box.Box+lineS = Box.text+ renderBox :: Box.Box -> String renderBox = unlines             . map (dropWhileEnd isSpace)@@ -1249,7 +1258,7 @@   whiteSpace = all isSpace  toTypelevelString :: Type -> Maybe Box.Box-toTypelevelString (TypeLevelString s) = Just $ Box.text s+toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s) toTypelevelString (TypeApp (TypeConstructor f) x)   | f == primName "TypeString" = Just $ typeAsBox x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

src/Language/PureScript/Errors/JSON.hs view

@@ -5,6 +5,9 @@ import Prelude.Compat  import qualified Data.Aeson.TH as A+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text)  import qualified Language.PureScript as P @@ -16,17 +19,17 @@   } deriving (Show, Eq, Ord)  data ErrorSuggestion = ErrorSuggestion-  { replacement :: String+  { replacement :: Text   , replaceRange :: Maybe ErrorPosition   } deriving (Show, Eq)  data JSONError = JSONError   { position :: Maybe ErrorPosition   , message :: String-  , errorCode :: String-  , errorLink :: String+  , errorCode :: Text+  , errorLink :: Text   , filename :: Maybe String-  , moduleName :: Maybe String+  , moduleName :: Maybe Text   , suggestion :: Maybe ErrorSuggestion   } deriving (Show, Eq) @@ -70,4 +73,4 @@       Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)    -- TODO: Adding a newline because source spans chomp everything up to the next character-  suggestionText (P.ErrorSuggestion s) = if null s then s else s ++ "\n"+  suggestionText (P.ErrorSuggestion s) = if T.null s then s else s <> "\n"

src/Language/PureScript/Externs.hs view

@@ -17,9 +17,11 @@ import Prelude.Compat  import Data.Aeson.TH+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)+import Data.List (foldl', find) import Data.Foldable (fold)-import Data.List (find, foldl')-import Data.Maybe (mapMaybe, maybeToList, fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M @@ -37,7 +39,7 @@ data ExternsFile = ExternsFile   {   -- | The externs version-    efVersion :: String+    efVersion :: Text   -- | Module name   , efModuleName :: ModuleName   -- | List of module exports@@ -100,7 +102,7 @@   -- | A type synonym   | EDTypeSynonym       { edTypeSynonymName         :: ProperName 'TypeName-      , edTypeSynonymArguments    :: [(String, Maybe Kind)]+      , edTypeSynonymArguments    :: [(Text, Maybe Kind)]       , edTypeSynonymType         :: Type       }   -- | A data construtor@@ -119,7 +121,7 @@   -- | A type class declaration   | EDClass       { edClassName               :: ProperName 'ClassName-      , edClassTypeArguments      :: [(String, Maybe Kind)]+      , edClassTypeArguments      :: [(Text, Maybe Kind)]       , edClassMembers            :: [(Ident, Type)]       , edClassConstraints        :: [Constraint]       , edFunctionalDependencies  :: [FunctionalDependency]@@ -142,10 +144,10 @@   applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }   applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }   applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }-  applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) }+  applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }   applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }     where-    dict :: TypeClassDictionaryInScope+    dict :: NamedDict     dict = TypeClassDictionaryInScope (qual ident) [] className tys cs      updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a@@ -159,7 +161,7 @@ moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}   where-  efVersion       = showVersion Paths.version+  efVersion       = T.pack (showVersion Paths.version)   efModuleName    = mn   efExports       = exps   efImports       = mapMaybe importDecl ds@@ -180,7 +182,7 @@   typeFixityDecl _ = Nothing    findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool-  findOp get op = maybe False (== op) . get+  findOp g op = maybe False (== op) . g    importDecl :: Declaration -> Maybe ExternsImport   importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)

src/Language/PureScript/Ide.hs view

@@ -12,7 +12,6 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PackageImports        #-} {-# LANGUAGE TemplateHaskell       #-} @@ -110,7 +109,7 @@   PursuitResult <$> liftIO (findPackagesForModuleIdent q)  printModules :: Ide m => m Success-printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames+printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames  outputDirectory :: Ide m => m FilePath outputDirectory = do@@ -142,7 +141,7 @@   liftIO $ do     directories <- getDirectoryContents oDir     moduleNames <- filterM (containsExterns oDir) directories-    pure (P.moduleNameFromString <$> moduleNames)+    pure (P.moduleNameFromString . toS <$> moduleNames)   where     -- Takes the output directory and a filepath like "Monad.Control.Eff" and     -- looks up, whether that folder contains an externs.json@@ -171,26 +170,24 @@   -- We resolve all the modulenames to externs files and load these into memory.   oDir <- outputDirectory   let efPaths =-        map (\mn -> oDir </> P.runModuleName mn </> "externs.json") moduleNames+        map (\mn -> oDir </> toS (P.runModuleName mn) </> "externs.json") moduleNames   efiles <- traverse readExternFile efPaths   traverse_ insertExterns efiles -  -- We parse all source files, log eventual parse failures if the debug flag-  -- was set and insert the succesful parses into the state.+  -- We parse all source files, log eventual parse failures and insert the+  -- successful parses into the state.   (failures, allModules) <-     partitionEithers <$> (traverse parseModule =<< findAllSourceFiles)   unless (null failures) $-    $(logDebug) ("Failed to parse: " <> show failures)+    $(logWarn) ("Failed to parse: " <> show failures)   traverse_ insertModule allModules    -- Finally we kick off the worker with @async@ and return the number of   -- successfully parsed modules.   env <- ask-  let runLogger =-        runStdoutLoggingT-        . filterLogger (\_ _ -> confDebug (ideConfiguration env))+  let ll = confLogLevel (ideConfiguration env)   -- populateStage2 and 3 return Unit for now, so it's fine to discard this   -- result. We might want to block on this in a benchmarking situation.-  _ <- liftIO (async (runLogger (runReaderT (populateStage2 *> populateStage3) env)))+  _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))   pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "                     <> show (length allModules) <> " source files."))

src/Language/PureScript/Ide/CaseSplit.hs view

@@ -12,8 +12,6 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Ide.CaseSplit        ( WildcardAnnotations()        , explicitAnnotations@@ -84,9 +82,9 @@     go _ _ = throwError (GeneralError "Failed to read TypeConstructor")  prettyCtor :: WildcardAnnotations -> Constructor -> Text-prettyCtor _ (ctorName, []) = runProperNameT ctorName+prettyCtor _ (ctorName, []) = P.runProperName ctorName prettyCtor wsa (ctorName, ctorArgs) =-  "("<> runProperNameT ctorName <> " "+  "("<> P.runProperName ctorName <> " "   <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"  prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text@@ -111,9 +109,9 @@ addClause s wca = do   (fName, fType) <- parseTypeDeclaration' s   let args = splitFunctionType fType-      template = runIdentT fName <> " " <>+      template = P.runIdent fName <> " " <>         T.unwords (map (prettyPrintWildcard wca) args) <>-        " = ?" <> (T.strip . runIdentT $ fName)+        " = ?" <> (T.strip . P.runIdent $ fName)   pure [s, template]  parseType' :: (MonadError PscIdeError m) =>

src/Language/PureScript/Ide/Command.hs view

@@ -12,9 +12,6 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}-- module Language.PureScript.Ide.Command where  import           Protolude@@ -60,6 +57,21 @@     | Cwd     | Reset     | Quit++commandName :: Command -> Text+commandName c = case c of+  Load{} -> "Load"+  Type{} -> "Type"+  Complete{} -> "Complete"+  Pursuit{} -> "Pursuit"+  CaseSplit{} -> "CaseSplit"+  AddClause{} -> "AddClause"+  Import{} -> "Import"+  List{} -> "List"+  Rebuild{} -> "Rebuild"+  Cwd{} -> "Cwd"+  Reset{} -> "Reset"+  Quit{} -> "Quit"  data ImportCommand   = AddImplicitImport P.ModuleName

src/Language/PureScript/Ide/Completion.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Completion        ( getCompletions        , getExactMatches

src/Language/PureScript/Ide/Conversions.hs view

@@ -15,27 +15,15 @@ module Language.PureScript.Ide.Conversions where  import           Control.Lens.Iso-import           Data.Text           (lines, strip, unwords)+import           Data.Text           (lines, strip, unwords, pack) import qualified Language.PureScript as P import           Protolude -runProperNameT :: P.ProperName a -> Text-runProperNameT = toS . P.runProperName- properNameT :: Iso' (P.ProperName a) Text-properNameT = iso (toS . P.runProperName) (P.ProperName . toS)--runIdentT :: P.Ident -> Text-runIdentT = toS . P.runIdent+properNameT = iso P.runProperName P.ProperName  identT :: Iso' P.Ident Text-identT = iso (toS . P.runIdent) (P.Ident . toS)--runOpNameT :: P.OpName a -> Text-runOpNameT = toS . P.runOpName--runModuleNameT :: P.ModuleName -> Text-runModuleNameT = toS . P.runModuleName+identT = iso P.runIdent P.Ident  prettyTypeT :: P.Type -> Text-prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType+prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType

src/Language/PureScript/Ide/Error.hs view

@@ -12,7 +12,6 @@ -- Error types for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error        ( PscIdeError(..)        ) where

src/Language/PureScript/Ide/Externs.hs view

@@ -12,8 +12,7 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE PackageImports  #-}  module Language.PureScript.Ide.Externs   ( readExternFile@@ -23,25 +22,38 @@  import           Protolude -import           Control.Lens                  ((^.))-import           Data.Aeson                    (decodeStrict)-import qualified Data.ByteString               as BS-import           Data.List                     (nub)-import qualified Data.Map                      as Map+import           Control.Lens ((^.))+import           "monad-logger" Control.Monad.Logger+import           Data.Aeson (decodeStrict)+import qualified Data.ByteString as BS+import qualified Data.Map as Map+import           Data.Version (showVersion) import           Language.PureScript.Ide.Error (PscIdeError (..)) import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util -import qualified Language.PureScript           as P+import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError PscIdeError m) =>+readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>                   FilePath -> m P.ExternsFile readExternFile fp = do    parseResult <- liftIO (decodeStrict <$> BS.readFile fp)    case parseResult of-     Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed"+     Nothing ->+       throwError (GeneralError+                   ("Parsing the extern at: " <> toS fp <> " failed"))+     Just externs+       | P.efVersion externs /= version -> do+           let errMsg = "Version mismatch for the externs at: " <> toS fp+                        <> " Expected: " <> version+                        <> " Found: " <> P.efVersion externs+           logErrorN errMsg+           throwError (GeneralError errMsg)      Just externs -> pure externs +     where+       version = toS (showVersion P.version)+ convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)]) convertExterns ef =   ((P.efModuleName ef, decls), exportDecls)@@ -55,7 +67,7 @@     declarations = mapMaybe convertDecl (P.efDeclarations ef)      typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations)-    cleanDeclarations = nub $ appEndo typeClassFilter declarations+    cleanDeclarations = ordNub (appEndo typeClassFilter declarations)  removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)@@ -120,13 +132,13 @@       IdeDeclDataConstructor dtor ->         annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)       IdeDeclTypeClass i ->-        annotateType (runProperNameT i) (IdeDeclTypeClass i)+        annotateType (i ^. properNameT) (IdeDeclTypeClass i)       IdeDeclValueOperator op ->         annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)       IdeDeclTypeOperator op ->         annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)       where-        annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs+        annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs                                                     , annTypeAnnotation = Map.lookup x types                                                     })         annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})

src/Language/PureScript/Ide/Filter.hs view

@@ -13,7 +13,6 @@ -----------------------------------------------------------------------------  {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}  module Language.PureScript.Ide.Filter        ( Filter

src/Language/PureScript/Ide/Imports.hs view

@@ -12,8 +12,6 @@ -- Provides functionality to manage imports ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-}- module Language.PureScript.Ide.Imports        ( addImplicitImport        , addImportForIdentifier@@ -145,7 +143,7 @@  moduleParse :: [Text] -> Either Text P.Module moduleParse t = first show $ do-  tokens <- (P.lex "" . T.unpack . T.unlines) t+  tokens <- P.lex "" (T.unlines t)   P.runTokenParser "<psc-ide>" P.parseModule tokens  -- | Adds an implicit import like @import Prelude@ to a Sourcefile.@@ -210,7 +208,7 @@     refFromDeclaration (IdeDeclTypeOperator op) =       P.TypeOpRef (op ^. ideTypeOpName)     refFromDeclaration d =-      P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)+      P.ValueRef (P.Ident (identifierFromIdeDeclaration d))      -- | Adds a declaration to an import:     -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe)@@ -304,9 +302,9 @@ prettyPrintImport' :: Import -> Text -- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs prettyPrintImport' (Import mn (P.Explicit refs) qual) =-  T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual+  "import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual prettyPrintImport' (Import mn idt qual) =-  T.pack $ "import " ++ P.prettyPrintImport mn idt qual+  "import " <> P.prettyPrintImport mn idt qual  prettyPrintImportSection :: [Import] -> [Text] prettyPrintImportSection imports = map prettyPrintImport' (sort imports)@@ -325,7 +323,7 @@ -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t =-  case P.lex "<psc-ide>" (T.unpack t)+  case P.lex "<psc-ide>" t        >>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of     Right (mn, P.Explicit refs, mmn) ->       Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)

+ src/Language/PureScript/Ide/Logging.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE PackageImports        #-}++module Language.PureScript.Ide.Logging+       ( runLogger+       , logPerf+       , displayTimeSpec+       ) where++import           Protolude++import           "monad-logger" Control.Monad.Logger+import qualified Data.Text as T+import           Language.PureScript.Ide.Types+import           System.Clock+import           Text.Printf++runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a+runLogger logLevel' =+  runStdoutLoggingT . filterLogger (\_ logLevel ->+                                       case logLevel' of+                                         LogAll -> True+                                         LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)+                                         LogNone -> False+                                         LogDebug -> not (logLevel == LevelOther "perf")+                                         LogPerf -> logLevel == LevelOther "perf")++logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t+logPerf format f = do+  start <- liftIO (getTime Monotonic)+  result <- f+  end <- liftIO (getTime Monotonic)+  logOtherN (LevelOther "perf") (format (diffTimeSpec start end))+  pure result++displayTimeSpec :: TimeSpec -> Text+displayTimeSpec ts =+  T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms"

src/Language/PureScript/Ide/Matcher.hs view

@@ -14,7 +14,6 @@  {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}  module Language.PureScript.Ide.Matcher        ( Matcher

src/Language/PureScript/Ide/Pursuit.hs view

@@ -12,8 +12,6 @@ -- Pursuit client for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Ide.Pursuit   ( searchPursuitForDeclarations   , findPackagesForModuleIdent@@ -36,7 +34,7 @@ queryPursuit :: Text -> IO ByteString queryPursuit q = do   let qClean = T.dropWhileEnd (== '.') q-  req' <- parseRequest "http://pursuit.purescript.org/search"+  req' <- parseRequest "https://pursuit.purescript.org/search"   let req = req'         { queryString= "q=" <> (fromString . T.unpack) qClean         , requestHeaders=[(hAccept, "application/json")]

src/Language/PureScript/Ide/Rebuild.hs view

@@ -1,8 +1,5 @@-{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PackageImports        #-}-{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TupleSections         #-}  module Language.PureScript.Ide.Rebuild   ( rebuildFile@@ -20,7 +17,6 @@ import           Language.PureScript.Ide.Error import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types-import           Language.PureScript.Ide.Util import           System.IO.UTF8                  (readUTF8FileT)  -- | Given a filepath performs the following steps:@@ -96,7 +92,7 @@       throwError (GeneralError "Failed when rebuilding with open exports")     Right result -> do       $(logDebug)-        ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result))+        ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result))       cacheRebuild result  -- | Parameters we can access while building our @MakeActions@

src/Language/PureScript/Ide/Reexports.hs view

@@ -13,9 +13,6 @@ -- Resolves reexports for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}- module Language.PureScript.Ide.Reexports   ( resolveReexports   , prettyPrintReexportResult@@ -53,7 +50,7 @@   | otherwise =       "Failed to resolve reexports for "       <> f reResolved-      <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed+      <> foldMap (\(mn, ref) -> P.runModuleName mn <> show ref) reFailed  -- | Whether any Refs couldn't be resolved reexportHasFailures :: ReexportResult a -> Bool

src/Language/PureScript/Ide/SourceFile.hs view

@@ -12,8 +12,6 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Ide.SourceFile   ( parseModule   , getImportsForFile@@ -60,9 +58,9 @@       where         mkModuleImport (mn, importType', qualifier) =           ModuleImport-          (runModuleNameT mn)+          (P.runModuleName mn)           importType'-          (runModuleNameT <$> qualifier)+          (P.runModuleName <$> qualifier)         unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)         unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)         unwrapImportType (P.Hiding decls)   = P.Hiding (map unwrapPositionedRef decls)@@ -101,27 +99,27 @@   P.PositionedDeclaration ss' _ d' ->     extractSpans ss' d'   P.ValueDeclaration i _ _ _ ->-    [(Left (runIdentT i), ss)]+    [(Left (P.runIdent i), ss)]   P.TypeSynonymDeclaration name _ _ ->-    [(Right (runProperNameT name), ss)]+    [(Right (P.runProperName name), ss)]   P.TypeClassDeclaration name _ _ _ members ->-    (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members+    (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members   P.DataDeclaration _ name _ ctors ->-    (Right (runProperNameT name), ss)-    : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors+    (Right (P.runProperName name), ss)+    : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors   P.ExternDeclaration ident _ ->-    [(Left (runIdentT ident), ss)]+    [(Left (P.runIdent ident), ss)]   P.ExternDataDeclaration name _ ->-    [(Right (runProperNameT name), ss)]+    [(Right (P.runProperName name), ss)]   _ -> []   where     -- We need this special case to be able to also get the position info for-    -- typeclass member functions. Typedeclaratations would clash with value+    -- typeclass member functions. Typedeclarations would clash with value     -- declarations for non-typeclass members, which is why we can't handle them     -- in extractSpans.     extractSpans' ssP dP = case dP of       P.PositionedDeclaration ssP' _ dP' ->         extractSpans' ssP' dP'       P.TypeDeclaration ident _ ->-        [(Left (runIdentT ident), ssP)]+        [(Left (P.runIdent ident), ssP)]       _ -> []

src/Language/PureScript/Ide/State.hs view

@@ -12,7 +12,6 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE PackageImports        #-} {-# LANGUAGE TemplateHaskell       #-} @@ -32,7 +31,6 @@   , resolveOperatorsForModule   ) where -import qualified Prelude import           Protolude  import           Control.Concurrent.STM@@ -46,7 +44,6 @@ import           Language.PureScript.Ide.SourceFile import           Language.PureScript.Ide.Types import           Language.PureScript.Ide.Util-import           System.Clock  -- | Resets all State inside psc-ide resetIdeState :: Ide m => m ()@@ -179,12 +176,8 @@ populateStage2 :: (Ide m, MonadLogger m) => m () populateStage2 = do   st <- ideStateVar <$> ask-  duration <- liftIO $ do-    start <- getTime Monotonic-    atomically (populateStage2STM st)-    end <- getTime Monotonic-    pure (Prelude.show (diffTimeSpec start end))-  $(logDebug) $ "Finished populating Stage2 in " <> toS duration+  let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration+  logPerf message (liftIO (atomically (populateStage2STM st)))  -- | STM version of populateStage2 populateStage2STM :: TVar IdeState -> STM ()@@ -197,15 +190,11 @@ populateStage3 :: (Ide m, MonadLogger m) => m () populateStage3 = do   st <- ideStateVar <$> ask-  (duration, results) <- liftIO $ do-    start <- getTime Monotonic-    results <- atomically (populateStage3STM st)-    end <- getTime Monotonic-    pure (Prelude.show (diffTimeSpec start end), results)+  let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration+  results <- logPerf message (liftIO (atomically (populateStage3STM st)))   traverse_-    (logWarnN . prettyPrintReexportResult (runModuleNameT . fst))+    (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))     (filter reexportHasFailures results)-  $(logDebug) $ "Finished populating Stage3 in " <> toS duration  -- | STM version of populateStage3 populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]

src/Language/PureScript/Ide/Types.hs view

@@ -12,9 +12,8 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveFoldable    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveFoldable  #-}+{-# LANGUAGE TemplateHaskell #-}  module Language.PureScript.Ide.Types where @@ -26,7 +25,6 @@ import qualified Data.Map.Lazy                       as M import qualified Language.PureScript                 as P import qualified Language.PureScript.Errors.JSON     as P-import           Language.PureScript.Ide.Conversions  type ModuleIdent = Text @@ -111,10 +109,13 @@   -- annotations found in a module   deriving (Show, Eq, Ord, Functor, Foldable) +data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone+  deriving (Show, Eq)+ data Configuration =   Configuration   { confOutputPath :: FilePath-  , confDebug      :: Bool+  , confLogLevel   :: IdeLogLevel   , confGlobs      :: [FilePath]   } @@ -210,9 +211,9 @@              ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)  identifierFromDeclarationRef :: P.DeclarationRef -> Text-identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name-identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident-identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name+identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name+identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident+identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name identifierFromDeclarationRef _ = ""  data Success =

src/Language/PureScript/Ide/Util.hs view

@@ -12,8 +12,6 @@ -- Generally useful functions ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Ide.Util   ( identifierFromIdeDeclaration   , unwrapMatch@@ -27,17 +25,20 @@   , valueOperatorAliasT   , typeOperatorAliasT   , module Language.PureScript.Ide.Conversions+  , module Language.PureScript.Ide.Logging   ) where +import           Protolude                           hiding (decodeUtf8,+                                                      encodeUtf8)+ import           Control.Lens                        ((^.)) import           Data.Aeson import qualified Data.Text                           as T import           Data.Text.Lazy.Encoding             (decodeUtf8, encodeUtf8) import qualified Language.PureScript                 as P import           Language.PureScript.Ide.Conversions+import           Language.PureScript.Ide.Logging import           Language.PureScript.Ide.Types-import           Protolude                           hiding (decodeUtf8,-                                                      encodeUtf8)  identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of@@ -45,9 +46,9 @@   IdeDeclType t -> t ^. ideTypeName . properNameT   IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT   IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT-  IdeDeclTypeClass name -> runProperNameT name-  IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT-  IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT+  IdeDeclTypeClass name -> P.runProperName name+  IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName+  IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName  discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d@@ -67,13 +68,13 @@       IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )       IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)       IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)-      IdeDeclTypeClass name -> (runProperNameT name, "class")+      IdeDeclTypeClass name -> (P.runProperName name, "class")       IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->-        (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)+        (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)       IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->-        (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)+        (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) -    complModule = runModuleNameT m+    complModule = P.runModuleName m      complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann) @@ -86,17 +87,17 @@             P.Infix -> "infix"             P.Infixl -> "infixl"             P.Infixr -> "infixr"-      in T.unwords [asso, show p, r, "as", runOpNameT o]+      in T.unwords [asso, show p, r, "as", P.runOpName o]  valueOperatorAliasT   :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text valueOperatorAliasT i =-  toS (P.showQualified (either P.runIdent P.runProperName) i)+  P.showQualified (either P.runIdent P.runProperName) i  typeOperatorAliasT   :: P.Qualified (P.ProperName 'P.TypeName) -> Text typeOperatorAliasT i =-  toS (P.showQualified P.runProperName i)+  P.showQualified P.runProperName i  encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode

src/Language/PureScript/Ide/Watcher.hs view

@@ -22,6 +22,7 @@ import           Language.PureScript.Ide.Externs import           Language.PureScript.Ide.State import           Language.PureScript.Ide.Types+import           Language.PureScript.Ide.Util import           System.FilePath import           System.FSNotify @@ -31,7 +32,7 @@ reloadFile _ Removed{} = pure () reloadFile ref ev = do   let fp = eventPath ev-  ef' <- runExceptT (readExternFile fp)+  ef' <- runLogger LogDefault (runExceptT (readExternFile fp))   case ef' of     Left _ -> pure ()     Right ef -> do@@ -40,10 +41,13 @@  -- | Installs filewatchers for the given directory and reloads ExternsFiles when -- they change on disc-watcher :: TVar IdeState -> FilePath -> IO ()-watcher stateVar fp =-  withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do-    _ <- watchTree mgr fp-      (\ev -> takeFileName (eventPath ev) == "externs.json")-      (reloadFile stateVar)-    forever (threadDelay 100000)+watcher :: Bool -> TVar IdeState -> FilePath -> IO ()+watcher polling stateVar fp =+  withManagerConf+    (defaultConfig { confDebounce = NoDebounce+                   , confUsePolling = polling+                   }) $ \mgr -> do+      _ <- watchTree mgr fp+        (\ev -> takeFileName (eventPath ev) == "externs.json")+        (reloadFile stateVar)+      forever (threadDelay 100000)

src/Language/PureScript/Interactive.hs view

@@ -1,8 +1,4 @@ {-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DataKinds #-}  module Language.PureScript.Interactive   ( handleCommand@@ -16,9 +12,12 @@ import           Prelude () import           Prelude.Compat -import           Data.List (intercalate, nub, sort, find, foldl')+import           Data.List (nub, sort, find, foldl') import           Data.Maybe (mapMaybe) import qualified Data.Map as M+import           Data.Monoid ((<>))+import           Data.Text (Text)+import qualified Data.Text as T  import           Control.Monad.IO.Class (MonadIO, liftIO) import           Control.Monad.State.Class@@ -165,7 +164,7 @@     loadedModules <- gets psciLoadedExterns     liftIO $ putStrLn (readModules loadedModules)   where-    readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)+    readModules = unlines . sort . nub . map (T.unpack . P.runModuleName . P.getModuleName . fst)  -- | Show the imported modules in psci. handleShowImportedModules@@ -176,38 +175,38 @@   liftIO $ showModules importedModules >>= putStrLn   return ()   where-  showModules = return . unlines . sort . map showModule+  showModules = return . unlines . sort . map (T.unpack . showModule)   showModule (mn, declType, asQ) =-    "import " ++ N.runModuleName mn ++ showDeclType declType ++-    foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ+    "import " <> N.runModuleName mn <> showDeclType declType <>+    foldMap (\mn' -> " as " <> N.runModuleName mn') asQ    showDeclType P.Implicit = ""   showDeclType (P.Explicit refs) = refsList refs-  showDeclType (P.Hiding refs) = " hiding " ++ refsList refs-  refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"+  showDeclType (P.Hiding refs) = " hiding " <> refsList refs+  refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")" -  showRef :: P.DeclarationRef -> Maybe String+  showRef :: P.DeclarationRef -> Maybe Text   showRef (P.TypeRef pn dctors) =-    Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"+    Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")"   showRef (P.TypeOpRef op) =-    Just $ "type " ++ N.showOp op+    Just $ "type " <> N.showOp op   showRef (P.ValueRef ident) =     Just $ N.runIdent ident   showRef (P.ValueOpRef op) =     Just $ N.showOp op   showRef (P.TypeClassRef pn) =-    Just $ "class " ++ N.runProperName pn+    Just $ "class " <> N.runProperName pn   showRef (P.TypeInstanceRef ident) =     Just $ N.runIdent ident   showRef (P.ModuleRef name) =-    Just $ "module " ++ N.runModuleName name+    Just $ "module " <> N.runModuleName name   showRef (P.ReExportRef _ _) =     Nothing   showRef (P.PositionedDeclarationRef _ _ ref) =     showRef ref -  commaList :: [String] -> String-  commaList = intercalate ", "+  commaList :: [Text] -> Text+  commaList = T.intercalate ", "  -- | Imports a module, preserving the initial state on failure. handleImport@@ -260,7 +259,7 @@               check sew = fst . runWriter . runExceptT . runStateT sew           case k of             Left err        -> printErrors err-            Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind+            Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind         Nothing -> liftIO $ putStrLn "Could not find kind"  -- | Browse a module and displays its signature@@ -284,6 +283,6 @@     isModInEnv modName =         any ((== modName) . P.getModuleName . fst) . psciLoadedExterns     failNotInEnv modName =-        liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."+        liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."     lookupUnQualifiedModName quaModName st =         (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

src/Language/PureScript/Interactive/Completion.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE DataKinds #-}- module Language.PureScript.Interactive.Completion   ( CompletionM   , liftCompletionM@@ -16,6 +14,8 @@ import           Data.Function (on) import           Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix) import           Data.Maybe (mapMaybe)+import           Data.Text (Text)+import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D import           Language.PureScript.Interactive.Types@@ -145,7 +145,7 @@ getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules -mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]+mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] mapLoadedModulesAndQualify sho f = do   ms <- getLoadedModules   let argPairs = do m <- ms@@ -165,14 +165,14 @@ -- | Given a module and a declaration in that module, return all possible ways -- it could have been referenced given the current PSCiState - including fully -- qualified, qualified using an alias, and unqualified.-getAllQualifications :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String]+getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> CompletionM [String] getAllQualifications sho m (declName, decl) = do   imports <- getAllImportsOf m   let fullyQualified = qualifyWith (Just (P.getModuleName m))   let otherQuals = nub (concatMap qualificationsUsing imports)   return $ fullyQualified : otherQuals   where-  qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName)+  qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName))   referencedBy refs = P.isExported (Just refs) decl    qualificationsUsing (_, importType, asQ') =@@ -220,4 +220,4 @@   go _ = []  moduleNames :: [P.Module] -> [String]-moduleNames = nub . map (P.runModuleName . P.getModuleName)+moduleNames = nub . map (T.unpack . P.runModuleName . P.getModuleName)

src/Language/PureScript/Interactive/Parser.hs view

@@ -9,6 +9,7 @@  import           Data.Char (isSpace) import           Data.List (intercalate)+import qualified Data.Text as T import           Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D@@ -26,7 +27,7 @@  parseRest :: P.TokenParser a -> String -> Either String a parseRest p s = either (Left . show) Right $ do-  ts <- P.lex "" s+  ts <- P.lex "" (T.pack s)   P.runTokenParser "" (p <* eof) ts  psciCommand :: P.TokenParser Command

src/Language/PureScript/Interactive/Printer.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DataKinds #-}- module Language.PureScript.Interactive.Printer where  import           Prelude.Compat@@ -8,9 +5,16 @@ import           Data.List (intersperse) import qualified Data.Map as M import           Data.Maybe (mapMaybe)+import           Data.Monoid ((<>))+import qualified Data.Text as T+import           Data.Text (Text) import qualified Language.PureScript as P import qualified Text.PrettyPrint.Boxes as Box +-- TODO (Christoph): Text version of boxes+textT :: Text -> Box.Box+textT = Box.text . T.unpack+ -- Printers  -- |@@ -40,7 +44,7 @@         findNameType envNames m = (P.disqualify m, M.lookup m envNames)          showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box-        showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType+        showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox mType         showNameType _ = P.internalError "The impossible happened in printModuleSignatures."          findTypeClass@@ -58,13 +62,13 @@                     if null typeClassSuperclasses                     then Box.text ""                     else Box.text "("-                         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)+                         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)                          Box.<> Box.text ") <= "                 className =-                    Box.text (P.runProperName name)-                    Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments)+                    textT (P.runProperName name)+                    Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments)                 classBody =-                    Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers)+                    Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox t) typeClassMembers)              in               Just $@@ -84,7 +88,7 @@         showType           :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData           -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])-          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)+          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.Kind)], P.Type)           -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))           -> Maybe Box.Box         showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =@@ -95,7 +99,7 @@                   Nothing                 else                   Just $-                    Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)+                    textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars)                     Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)              (Just (_, P.DataType typevars pt), _) ->@@ -108,7 +112,7 @@                       _ -> "data"                in-                Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt+                Just $ textT (prefix <> " " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// printCons pt              _ ->               Nothing@@ -117,7 +121,7 @@                     Box.moveRight 2 $                     Box.vcat Box.left $                     mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $-                    map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt+                    map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt                  prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

src/Language/PureScript/Linter.hs view

@@ -11,6 +11,7 @@ import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.Set as S+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -44,10 +45,15 @@      f :: Declaration -> MultipleErrors     f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)-    f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)-    f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)-    f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec+    f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs)+    f dec = f' S.empty dec +    f' :: S.Set Text -> Declaration -> MultipleErrors+    f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec)+    f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec)+    f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty)+    f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec+     stepE :: S.Set Ident -> Expr -> MultipleErrors     stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)     stepE s (Let ds' _) = foldMap go ds'@@ -70,16 +76,16 @@            | otherwise = mempty     stepDo _ _ = mempty -  checkTypeVarsInDecl :: Declaration -> MultipleErrors-  checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d+  checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors+  checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d -  checkTypeVars :: Type -> MultipleErrors-  checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty+  checkTypeVars :: S.Set Text -> Type -> MultipleErrors+  checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty     where-    step :: S.Set String -> Type -> (S.Set String, MultipleErrors)+    step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors)     step s (ForAll tv _ _) = bindVar s tv     step s _ = (s, mempty)-    bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)+    bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors)     bindVar = bind ShadowedTypeVar     findUnused :: Type -> MultipleErrors     findUnused ty' =@@ -88,7 +94,7 @@           unused = nub declared \\ nub used       in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused       where-      go :: Type -> [String]+      go :: Type -> [Text]       go (ForAll tv _ _) = [tv]       go _ = []

src/Language/PureScript/Linter/Exhaustive.hs view

@@ -19,7 +19,10 @@ import Data.Function (on) import Data.List (foldl', sortBy, nub) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations@@ -77,7 +80,7 @@   getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)   getConsDataName con =     case getConsInfo con of-      Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."+      Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName."       Just (_, pm, _, _) -> qualifyName pm defmn con    getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])@@ -276,14 +279,14 @@   -- and then included in the error message.   addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr   addPartialConstraint (bss, complete) e = do-    tyVar <- ("p" ++) . show <$> fresh+    tyVar <- ("p" <>) . T.pack . show <$> fresh     var <- freshName     return $       Let         [ partial var tyVar ]         $ App (Var (Qualified Nothing (Ident C.__unused))) e     where-      partial :: String -> String -> Declaration+      partial :: Text -> Text -> Declaration       partial var tyVar =         ValueDeclaration (Ident C.__unused) Private [] $ Right $           TypedValue@@ -291,7 +294,7 @@             (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))             (ty tyVar) -      ty :: String -> Type+      ty :: Text -> Type       ty tyVar =         ForAll tyVar           ( ConstrainedType

src/Language/PureScript/Linter/Imports.hs view

@@ -15,6 +15,7 @@ import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM)+import qualified Data.Text as T import qualified Data.Map as M  import Language.PureScript.AST.Declarations@@ -329,8 +330,8 @@       Just (_, _, exps) ->         case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of           Just (ty, _) -> ty-          Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"-      Nothing -> internalError $ "missing module " ++ runModuleName mn  ++ " in findTypeForDctor"+          Nothing -> internalError $ "missing type for data constructor " ++ T.unpack (runProperName dctor) ++ " in findTypeForDctor"+      Nothing -> internalError $ "missing module " ++ T.unpack (runModuleName mn)  ++ " in findTypeForDctor"  matchName   :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

src/Language/PureScript/Make.hs view

@@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.Make   (@@ -38,13 +37,12 @@  import Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson-import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy, groupBy) import Data.Maybe (fromMaybe, catMaybes)-import Data.String (fromString)+import Data.Monoid ((<>)) import Data.Time.Clock import Data.Traversable (for) import Data.Version (showVersion)@@ -52,6 +50,8 @@ import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE  import Language.PureScript.AST import Language.PureScript.Crash@@ -83,7 +83,6 @@ import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) import System.IO.Error (tryIOError)-import System.IO.UTF8 (readUTF8File, writeUTF8File)  import qualified Text.Parsec as Parsec @@ -94,7 +93,7 @@  -- | Render a progress message renderProgressMessage :: ProgressMessage -> String-renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn+renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn)  -- | Actions that require implementations when running in "make" mode. --@@ -125,7 +124,7 @@ -- | -- Generated code for an externs file. ---type Externs = String+type Externs = B.ByteString  -- | -- Determines when to rebuild a module@@ -155,7 +154,7 @@       corefn = CF.moduleToCoreFn env' mod'       [renamed] = renameInModules [corefn]       exts = moduleToExternsFile mod' env'-  evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts+  evalSupplyT nextVar . codegen renamed env' . encode $ exts   return exts  -- |@@ -256,8 +255,8 @@    decodeExterns :: Externs -> Maybe ExternsFile   decodeExterns bs = do-    externs <- decode (toLazyByteString (stringUtf8 bs))-    guard $ efVersion externs == showVersion Paths.version+    externs <- decode bs+    guard $ T.unpack (efVersion externs) == showVersion Paths.version     return externs  importPrim :: Module -> Module@@ -290,8 +289,8 @@  -- | Read a text file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance.-readTextFile :: FilePath -> Make String-readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path+readTextFile :: FilePath -> Make B.ByteString+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path  -- | Infer the module name for a module by looking for the same filename with -- a .js extension.@@ -332,14 +331,14 @@    getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)   getOutputTimestamp mn = do-    let filePath = runModuleName mn+    let filePath = T.unpack (runModuleName mn)         jsFile = outputDir </> filePath </> "index.js"         externsFile = outputDir </> filePath </> "externs.json"     min <$> getTimestamp jsFile <*> getTimestamp externsFile    readExterns :: ModuleName -> Make (FilePath, Externs)   readExterns mn = do-    let path = outputDir </> runModuleName mn </> "externs.json"+    let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"     (path, ) <$> readTextFile path    codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()@@ -359,16 +358,16 @@     dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory     sourceMaps <- lift $ asks optionsSourceMaps     let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])-    let filePath = runModuleName mn+    let filePath = T.unpack (runModuleName mn)         jsFile = outputDir </> filePath </> "index.js"         mapFile = outputDir </> filePath </> "index.js.map"         externsFile = outputDir </> filePath </> "externs.json"         foreignFile = outputDir </> filePath </> "foreign.js"-        prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]-        js = unlines $ map ("// " ++) prefix ++ [pjs]+        prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix]+        js = T.unlines $ map ("// " <>) prefix ++ [pjs]         mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""     lift $ do-      writeTextFile jsFile (fromString $ js ++ mapRef)+      writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)       for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)       writeTextFile externsFile exts     lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings@@ -376,14 +375,14 @@     when dumpCoreFn $ do       let coreFnFile = outputDir </> filePath </> "corefn.json"       let jsonPayload = CFJ.moduleToJSON Paths.version m-      let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]-      lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)+      let json = Aeson.object [  (runModuleName mn, jsonPayload) ]+      lift $ writeTextFile coreFnFile (encode json)    genSourceMap :: String -> String -> Int -> [SMap] -> Make ()   genSourceMap dir mapFile extraLines mappings = do     let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)         sourceFile = case mappings of-                      (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file+                      (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir (T.unpack file)                       _ -> Nothing     let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =       map (\(SMap _ orig gen) -> Mapping {@@ -394,7 +393,7 @@         }) mappings     }     let mapping = generate rawMapping-    writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping+    writeTextFile mapFile (encode mapping)     where     add :: Int -> Int -> SourcePos -> SourcePos     add n m (SourcePos n' m') = SourcePos (n+n') (m+m')@@ -411,10 +410,10 @@     exists <- doesFileExist path     traverse (const $ getModificationTime path) $ guard exists -  writeTextFile :: FilePath -> String -> Make ()+  writeTextFile :: FilePath -> B.ByteString -> Make ()   writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do     mkdirp path-    writeUTF8File path text+    B.writeFile path text     where     mkdirp :: FilePath -> IO ()     mkdirp = createDirectoryIfMissing True . takeDirectory@@ -429,7 +428,7 @@ checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () checkForeignDecls m path = do   jsStr <- lift $ readTextFile path-  js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path+  js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path    foreignIdentsStrs <- either errorParsingModule pure $ getExps js   foreignIdents <- either@@ -455,11 +454,11 @@   errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just    getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]-  getExps = Bundle.getExportedIdentifiers (runModuleName mname)+  getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))    errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a   errorInvalidForeignIdentifiers =-    throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)+    throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)    parseIdents :: [String] -> Either [String] [Ident]   parseIdents strs =@@ -472,7 +471,7 @@   -- We ignore the error message here, just being told it's an invalid   -- identifier should be enough.   parseIdent :: String -> Either String Ident-  parseIdent str = try str+  parseIdent str = try (T.pack str)     where     try s = either (const (Left str)) Right $ do       ts <- PSParser.lex "" s

src/Language/PureScript/Names.hs view

@@ -11,7 +11,9 @@  import Data.Aeson import Data.Aeson.TH-import Data.List+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  -- | A sum of the possible name types, useful for error and lint messages. data Name@@ -59,22 +61,22 @@   -- |   -- An alphanumeric identifier   ---  = Ident String+  = Ident Text   -- |   -- A generated name for an identifier   ---  | GenIdent (Maybe String) Integer+  | GenIdent (Maybe Text) Integer   deriving (Show, Eq, Ord) -runIdent :: Ident -> String+runIdent :: Ident -> Text runIdent (Ident i) = i-runIdent (GenIdent Nothing n) = "$" ++ show n-runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n+runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)+runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) -showIdent :: Ident -> String+showIdent :: Ident -> Text showIdent = runIdent -freshIdent :: MonadSupply m => String -> m Ident+freshIdent :: MonadSupply m => Text -> m Ident freshIdent name = GenIdent (Just name) <$> fresh  freshIdent' :: MonadSupply m => m Ident@@ -83,7 +85,7 @@ -- | -- Operator alias names. ---newtype OpName (a :: OpNameType) = OpName { runOpName :: String }+newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }   deriving (Show, Eq, Ord)  instance ToJSON (OpName a) where@@ -92,8 +94,8 @@ instance FromJSON (OpName a) where   parseJSON = fmap OpName . parseJSON -showOp :: OpName a -> String-showOp op = '(' : runOpName op ++ ")"+showOp :: OpName a -> Text+showOp op = "(" <> runOpName op <> ")"  -- | -- The closed set of operator alias types.@@ -103,7 +105,7 @@ -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. ---newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }   deriving (Show, Eq, Ord)  instance ToJSON (ProperName a) where@@ -131,16 +133,16 @@ newtype ModuleName = ModuleName [ProperName 'Namespace]   deriving (Show, Eq, Ord) -runModuleName :: ModuleName -> String-runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)+runModuleName :: ModuleName -> Text+runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns) -moduleNameFromString :: String -> ModuleName+moduleNameFromString :: Text -> ModuleName moduleNameFromString = ModuleName . splitProperNames   where-  splitProperNames s = case dropWhile (== '.') s of+  splitProperNames s = case T.dropWhile (== '.') s of     "" -> []     s' -> ProperName w : splitProperNames s''-      where (w, s'') = break (== '.') s'+      where (w, s'') = T.break (== '.') s'  -- | -- A qualified name, i.e. a name with an optional module name@@ -148,9 +150,9 @@ data Qualified a = Qualified (Maybe ModuleName) a   deriving (Show, Eq, Ord, Functor) -showQualified :: (a -> String) -> Qualified a -> String+showQualified :: (a -> Text) -> Qualified a -> Text showQualified f (Qualified Nothing a) = f a-showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a+showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a  getQual :: Qualified a -> Maybe ModuleName getQual (Qualified mn _) = mn

src/Language/PureScript/Parser/Common.hs view

@@ -5,8 +5,11 @@  import Prelude.Compat -import Control.Applicative+import Control.Applicative ((<|>)) import Control.Monad (guard)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.SourcePos import Language.PureScript.Comments@@ -79,8 +82,8 @@ -- Run the first parser, then match the second zero or more times, applying the specified function for each match -- fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a-fold first more combine = do-  a <- first+fold first' more combine = do+  a <- first'   bs <- P.many more   return $ foldl combine a bs @@ -88,8 +91,8 @@ -- Build a parser from a smaller parser and a list of parsers for postfix operators -- buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a-buildPostfixParser fs first = do-  a <- first+buildPostfixParser fs first' = do+  a <- first'   go a   where   go a = do@@ -114,25 +117,25 @@ -- Check that the current identation level matches a predicate -- checkIndentation-  :: (P.Column -> String)+  :: (P.Column -> Text)   -> (P.Column -> P.Column -> Bool)   -> P.Parsec s ParseState () checkIndentation mkMsg rel = do   col <- P.sourceColumn <$> P.getPosition   current <- indentationLevel <$> P.getState-  guard (col `rel` current) P.<?> mkMsg current+  guard (col `rel` current) P.<?> T.unpack (mkMsg current)  -- | -- Check that the current indentation level is past the current mark -- indented :: P.Parsec s ParseState ()-indented = checkIndentation (("indentation past column " ++) . show) (>)+indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)  -- | -- Check that the current indentation level is at the same indentation as the current mark -- same :: P.Parsec s ParseState ()-same = checkIndentation (("indentation at column " ++) . show) (==)+same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)  -- | -- Read the comments from the the next token, without consuming it

src/Language/PureScript/Parser/Declarations.hs view

@@ -61,7 +61,7 @@   let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end')   return $ f sp comments x -kindedIdent :: TokenParser (String, Maybe Kind)+kindedIdent :: TokenParser (Text, Maybe Kind) kindedIdent = (, Nothing) <$> identifier           <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) @@ -303,7 +303,7 @@   -> Either P.ParseError (k, Module) parseModuleFromFile toFilePath (k, content) = do     let filename = toFilePath k-    ts <- lex' filename content+    ts <- lex filename content     m <- runTokenParser filename parseModule ts     pure (k, m) @@ -333,10 +333,10 @@ parseArrayLiteral :: TokenParser a -> TokenParser (Literal a) parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p) -parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)+parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a) parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) -parseIdentifierAndValue :: TokenParser (String, Expr)+parseIdentifierAndValue :: TokenParser (Text, Expr) parseIdentifierAndValue =   do     name <- C.indented *> lname@@ -392,7 +392,7 @@   return $ Let ds result  parseValueAtom :: TokenParser Expr-parseValueAtom = P.choice+parseValueAtom = withSourceSpan PositionedValue $ P.choice                  [ parseAnonymousArgument                  , Literal <$> parseNumericLiteral                  , Literal <$> parseCharLiteral@@ -418,12 +418,12 @@ parseInfixExpr :: TokenParser Expr parseInfixExpr   = P.between tick tick parseValue-  <|> Op <$> parseQualified parseOperator+  <|> withSourceSpan PositionedValue (Op <$> parseQualified parseOperator)  parseHole :: TokenParser Expr parseHole = Hole <$> holeLit -parsePropertyUpdate :: TokenParser (String, Expr)+parsePropertyUpdate :: TokenParser (Text, Expr) parsePropertyUpdate = do   name <- lname <|> stringLiteral   _ <- C.indented *> equals@@ -515,7 +515,7 @@ parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder -parseIdentifierAndBinder :: TokenParser (String, Binder)+parseIdentifierAndBinder :: TokenParser (Text, Binder) parseIdentifierAndBinder =     do name <- lname        b <- P.option (VarBinder (Ident name)) rest

src/Language/PureScript/Parser/Lexer.hs view

@@ -6,7 +6,6 @@   , Token()   , TokenParser()   , lex-  , lex'   , anyToken   , token   , match@@ -63,13 +62,13 @@   )   where -import Prelude hiding (lex)+import Prelude.Compat hiding (lex) -import Control.Applicative+import Control.Applicative ((<|>)) import Control.Monad (void, guard)-+import Control.Monad.Identity (Identity) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)-import Data.Functor.Identity+import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -101,17 +100,17 @@   | Semi   | At   | Underscore-  | LName String-  | UName String-  | Qualifier String-  | Symbol String+  | LName Text+  | UName Text+  | Qualifier Text+  | Symbol Text   | CharLiteral Char-  | StringLiteral String+  | StringLiteral Text   | Number (Either Integer Double)-  | HoleLit String+  | HoleLit Text   deriving (Show, Eq, Ord) -prettyPrintToken :: Token -> String+prettyPrintToken :: Token -> Text prettyPrintToken LParen            = "(" prettyPrintToken RParen            = ")" prettyPrintToken LBrace            = "{"@@ -132,15 +131,15 @@ prettyPrintToken Semi              = ";" prettyPrintToken At                = "@" prettyPrintToken Underscore        = "_"-prettyPrintToken (Indent n)        = "indentation at level " ++ show n-prettyPrintToken (LName s)         = show s-prettyPrintToken (UName s)         = show s+prettyPrintToken (Indent n)        = "indentation at level " <> T.pack (show n)+prettyPrintToken (LName s)         = T.pack (show s)+prettyPrintToken (UName s)         = T.pack (show s) prettyPrintToken (Qualifier _)     = "qualifier" prettyPrintToken (Symbol s)        = s-prettyPrintToken (CharLiteral c)   = show c-prettyPrintToken (StringLiteral s) = show s-prettyPrintToken (Number n)        = either show show n-prettyPrintToken (HoleLit name)    = "?" ++ name+prettyPrintToken (CharLiteral c)   = T.pack (show c)+prettyPrintToken (StringLiteral s) = T.pack (show s)+prettyPrintToken (Number n)        = T.pack (either show show n)+prettyPrintToken (HoleLit name)    = "?" <> name  data PositionedToken = PositionedToken   { -- | Start position of this token@@ -155,15 +154,12 @@  -- Parsec requires this instance for various token-level combinators instance Show PositionedToken where-  show = prettyPrintToken . ptToken+  show = T.unpack . prettyPrintToken . ptToken  type Lexer u a = P.Parsec Text u a -lex :: FilePath -> String -> Either P.ParseError [PositionedToken]-lex fp = lex' fp . T.pack--lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken]-lex' f s = updatePositions <$> P.parse parseTokens f s+lex :: FilePath -> Text -> Either P.ParseError [PositionedToken]+lex f s = updatePositions <$> P.parse parseTokens f s  updatePositions :: [PositionedToken] -> [PositionedToken] updatePositions [] = []@@ -180,11 +176,11 @@ parseComment :: Lexer u Comment parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace   where-  blockComment :: Lexer u String-  blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))+  blockComment :: Lexer u Text+  blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}"))) -  lineComment :: Lexer u String-  lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))+  lineComment :: Lexer u Text+  lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)))  parsePositionedToken :: Lexer u PositionedToken parsePositionedToken = P.try $ do@@ -222,11 +218,11 @@   , P.try $ P.char ';'    *> P.notFollowedBy symbolChar *> pure Semi   , P.try $ P.char '@'    *> P.notFollowedBy symbolChar *> pure At   , P.try $ P.char '_'    *> P.notFollowedBy identLetter *> pure Underscore-  , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter)+  , HoleLit <$> P.try (P.char '?' *> (T.pack <$> P.many1 identLetter))   , LName         <$> parseLName   , parseUName >>= \uName ->-      (guard (validModuleName uName) >> Qualifier uName <$ P.char '.')-        <|> pure (UName uName)+      guard (validModuleName uName) *> (Qualifier uName <$ P.char '.')+      <|> pure (UName uName)   , Symbol        <$> parseSymbol   , CharLiteral   <$> parseCharLiteral   , StringLiteral <$> parseStringLiteral@@ -234,14 +230,14 @@   ]    where-  parseLName :: Lexer u String-  parseLName = (:) <$> identStart <*> P.many identLetter+  parseLName :: Lexer u Text+  parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter) -  parseUName :: Lexer u String-  parseUName = (:) <$> P.upper <*> P.many identLetter+  parseUName :: Lexer u Text+  parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter) -  parseSymbol :: Lexer u String-  parseSymbol = P.many1 symbolChar+  parseSymbol :: Lexer u Text+  parseSymbol = T.pack <$> P.many1 symbolChar    identStart :: Lexer u Char   identStart = P.lower <|> P.oneOf "_"@@ -252,24 +248,41 @@   symbolChar :: Lexer u Char   symbolChar = P.satisfy isSymbolChar +  surrogates :: Char -> (Char, Char)+  surrogates c = (high, low)+    where+      (h, l) = divMod (fromEnum c - 0x10000) 0x400+      high = toEnum (h + 0xD800)+      low = toEnum (l + 0xDC00)++  expandAstralCodePointToUTF16Surrogates :: Char -> [Char]+  expandAstralCodePointToUTF16Surrogates c | fromEnum c > 0xFFFF = [high, low]+    where (high, low) = surrogates c+  expandAstralCodePointToUTF16Surrogates c = [c]+   parseCharLiteral :: Lexer u Char-  parseCharLiteral = PT.charLiteral tokenParser+  parseCharLiteral = P.try $ do {+    c <- PT.charLiteral tokenParser;+    if fromEnum c > 0xFFFF+      then P.unexpected "astral code point in character literal; characters must be valid UTF-16 code units"+      else return c+  } -  parseStringLiteral :: Lexer u String-  parseStringLiteral = blockString <|> PT.stringLiteral tokenParser+  parseStringLiteral :: Lexer u Text+  parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser     where     delimiter   = P.try (P.string "\"\"\"")-    blockString = delimiter >> P.manyTill P.anyChar delimiter+    blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter)    parseNumber :: Lexer u (Either Integer Double)-  parseNumber = (consumeLeadingZero >> P.parserZero) <|>+  parseNumber = (consumeLeadingZero *> P.parserZero) <|>                   (Right <$> P.try (PT.float tokenParser) <|>                   Left <$> P.try (PT.natural tokenParser))                 P.<?> "number"     where     -- lookAhead doesn't consume any input if its parser succeeds     -- if notFollowedBy fails though, the consumed '0' will break the choice chain-    consumeLeadingZero = P.lookAhead (P.char '0' >>+    consumeLeadingZero = P.lookAhead (P.char '0' *>       (P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))  -- |@@ -283,10 +296,10 @@   , PT.commentEnd      = ""   , PT.commentLine     = ""   , PT.nestedComments  = True-  , PT.identStart      = fail "Identifiers not supported"-  , PT.identLetter     = fail "Identifiers not supported"-  , PT.opStart         = fail "Operators not supported"-  , PT.opLetter        = fail "Operators not supported"+  , PT.identStart      = P.parserFail "Identifiers not supported"+  , PT.identLetter     = P.parserFail "Identifiers not supported"+  , PT.opStart         = P.parserFail "Operators not supported"+  , PT.opLetter        = P.parserFail "Operators not supported"   , PT.caseSensitive   = True   } @@ -299,13 +312,13 @@ type TokenParser a = P.Parsec [PositionedToken] ParseState a  anyToken :: TokenParser PositionedToken-anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just+anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just  token :: (Token -> Maybe a) -> TokenParser a-token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)+token f = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos (f . ptToken)  match :: Token -> TokenParser ()-match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok+match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> T.unpack (prettyPrintToken tok)  lparen :: TokenParser () lparen = match LParen@@ -388,7 +401,7 @@ underscore :: TokenParser () underscore = match Underscore -holeLit :: TokenParser String+holeLit :: TokenParser Text holeLit = token go P.<?> "hole literal"   where   go (HoleLit n) = Just n@@ -418,62 +431,62 @@ commaSep1 :: TokenParser a -> TokenParser [a] commaSep1 = flip P.sepBy1 comma -lname :: TokenParser String+lname :: TokenParser Text lname = token go P.<?> "identifier"   where   go (LName s) = Just s   go _ = Nothing -lname' :: String -> TokenParser ()+lname' :: Text -> TokenParser () lname' s = token go P.<?> show s   where   go (LName s') | s == s' = Just ()   go _ = Nothing -qualifier :: TokenParser String+qualifier :: TokenParser Text qualifier = token go P.<?> "qualifier"   where   go (Qualifier s) = Just s   go _ = Nothing -reserved :: String -> TokenParser ()+reserved :: Text -> TokenParser () reserved s = token go P.<?> show s   where   go (LName s') | s == s' = Just ()   go (Symbol s') | s == s' = Just ()   go _ = Nothing -uname :: TokenParser String+uname :: TokenParser Text uname = token go P.<?> "proper name"   where   go (UName s) | validUName s = Just s   go _ = Nothing -uname' :: String -> TokenParser ()+uname' :: Text -> TokenParser () uname' s = token go P.<?> "proper name"   where   go (UName s') | s == s' = Just ()   go _ = Nothing -tyname :: TokenParser String+tyname :: TokenParser Text tyname = token go P.<?> "type name"   where   go (UName s) = Just s   go _ = Nothing -dconsname :: TokenParser String+dconsname :: TokenParser Text dconsname = token go P.<?> "data constructor name"   where   go (UName s) = Just s   go _ = Nothing -mname :: TokenParser String+mname :: TokenParser Text mname = token go P.<?> "module name"   where   go (UName s) | validModuleName s = Just s   go _ = Nothing -symbol :: TokenParser String+symbol :: TokenParser Text symbol = token go P.<?> "symbol"   where   go (Symbol s) = Just s@@ -482,7 +495,7 @@   go At         = Just "@"   go _ = Nothing -symbol' :: String -> TokenParser ()+symbol' :: Text -> TokenParser () symbol' s = token go P.<?> show s   where   go (Symbol s') | s == s'   = Just ()@@ -496,7 +509,7 @@   go (CharLiteral c) = Just c   go _ = Nothing -stringLiteral :: TokenParser String+stringLiteral :: TokenParser Text stringLiteral = token go P.<?> "string literal"   where   go (StringLiteral s) = Just s@@ -514,22 +527,25 @@   go (Number (Left n)) = Just n   go _ = Nothing -identifier :: TokenParser String+identifier :: TokenParser Text identifier = token go P.<?> "identifier"   where   go (LName s) | s `notElem` reservedPsNames = Just s   go _ = Nothing -validModuleName :: String -> Bool-validModuleName s = '_' `notElem` s+validModuleName :: Text -> Bool+validModuleName s = '_' `notElemT` s -validUName :: String -> Bool-validUName s = '\'' `notElem` s+validUName :: Text -> Bool+validUName s = '\'' `notElemT` s +notElemT :: Char -> Text -> Bool+notElemT c = not . T.any (== c)+ -- | -- A list of purescript reserved identifiers ---reservedPsNames :: [String]+reservedPsNames :: [Text] reservedPsNames = [ "data"                   , "newtype"                   , "type"@@ -555,14 +571,14 @@                   , "where"                   ] -reservedTypeNames :: [String]+reservedTypeNames :: [Text] reservedTypeNames = [ "forall", "where" ]  -- | -- The characters allowed for use in operators -- isSymbolChar :: Char -> Bool-isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)+isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c)   -- |@@ -575,12 +591,13 @@ -- The characters allowed in the tail of an unquoted record key -- isUnquotedKeyTailChar :: Char -> Bool-isUnquotedKeyTailChar c = (c `elem` "_'") || isAlphaNum c+isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c  -- | -- Strings allowed to be left unquoted in a record key ---isUnquotedKey :: String -> Bool-isUnquotedKey []        = False-isUnquotedKey (hd : tl) = isUnquotedKeyHeadChar hd &&-                          all isUnquotedKeyTailChar tl+isUnquotedKey :: Text -> Bool+isUnquotedKey t = case T.uncons t of+  Nothing -> False+  Just (hd, tl) -> isUnquotedKeyHeadChar hd &&+                   T.all isUnquotedKeyTailChar tl

src/Language/PureScript/Parser/Types.hs view

@@ -7,8 +7,10 @@  import Prelude.Compat -import Control.Applicative import Control.Monad (when, unless)+import Control.Applicative ((<|>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.SourcePos import Language.PureScript.Environment@@ -21,7 +23,7 @@ import qualified Text.Parsec.Expr as P  parseFunction :: TokenParser Type-parseFunction = parens rarrow >> return tyFunction+parseFunction = parens rarrow *> return tyFunction  parseObject :: TokenParser Type parseObject = braces $ TypeApp tyRecord <$> parseRow@@ -39,7 +41,7 @@ parseTypeVariable :: TokenParser Type parseTypeVariable = do   ident <- identifier-  when (ident `elem` reservedTypeNames) $ P.unexpected ident+  when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident)   return $ TypeVar ident  parseTypeConstructor :: TokenParser Type@@ -87,7 +89,7 @@               , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->                     return (BinaryNoParensType (TypeOp ident))) P.AssocRight                 ]-              , [ P.Infix (rarrow >> return function) P.AssocRight ]+              , [ P.Infix (rarrow *> return function) P.AssocRight ]               ]   postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)                  ]@@ -116,7 +118,7 @@   when (containsWildcards ty) $ P.unexpected "type wildcard"   return ty -parseNameAndType :: TokenParser t -> TokenParser (String, t)+parseNameAndType :: TokenParser t -> TokenParser (Text, t) parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p  parseRowEnding :: TokenParser Type

src/Language/PureScript/Pretty/Common.hs view

@@ -10,20 +10,27 @@ import Control.Monad.State (StateT, modify, get)  import Data.List (elemIndices, intersperse)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) -import Text.PrettyPrint.Boxes+import Text.PrettyPrint.Boxes hiding ((<>))+import qualified Text.PrettyPrint.Boxes as Box  -- | -- Wrap a string in parentheses -- parens :: String -> String-parens s = '(':s ++ ")"+parens s = "(" <> s <> ")" +parensT :: Text -> Text+parensT s = "(" <> s <> ")"+ parensPos :: (Emit gen) => gen -> gen-parensPos s = emit "(" `mappend` s `mappend` emit ")"+parensPos s = emit "(" <> s <> emit ")"  -- | -- Generalize intercalate slightly for monoids@@ -32,15 +39,15 @@ intercalate x xs = mconcat (intersperse x xs)  class (Monoid gen) => Emit gen where-  emit :: String -> gen+  emit :: Text -> gen   addMapping :: SourceSpan -> gen -data SMap = SMap String SourcePos SourcePos+data SMap = SMap Text SourcePos SourcePos  -- | -- String with length and source-map entries ---newtype StrPos = StrPos (SourcePos, String, [SMap])+newtype StrPos = StrPos (SourcePos, Text, [SMap])  -- | -- Make a monoid where append consists of concatenating the string part, adding the lengths@@ -50,10 +57,10 @@ instance Monoid StrPos where   mempty = StrPos (SourcePos 0 0, "", []) -  StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))+  StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c'))    mconcat ms =-    let s' = concatMap (\(StrPos(_, s, _)) -> s) ms+    let s' = foldMap (\(StrPos(_, s, _)) -> s) ms         (p, maps) = foldl plus (SourcePos 0 0, []) ms     in         StrPos (p, s', concat $ reverse maps)@@ -66,22 +73,23 @@   -- Augment a string with its length (rows/column)   --   emit str =-    let newlines = elemIndices '\n' str+    -- TODO(Christoph): get rid of T.unpack+    let newlines = elemIndices '\n' (T.unpack str)         index = if null newlines then 0 else last newlines + 1     in-    StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])+    StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = T.length str - index }, str, [])    -- |   -- Add a new mapping entry for given source position with initially zero generated position   --   addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])     where-      mapping = SMap file startPos zeroPos+      mapping = SMap (T.pack file) startPos zeroPos       zeroPos = SourcePos 0 0 -newtype PlainString = PlainString String deriving Monoid+newtype PlainString = PlainString Text deriving Monoid -runPlainString :: PlainString -> String+runPlainString :: PlainString -> Text runPlainString (PlainString s) = s  instance Emit PlainString where@@ -127,7 +135,7 @@ currentIndent :: (Emit gen) => StateT PrinterState Maybe gen currentIndent = do   current <- get-  return $ emit $ replicate (indent current) ' '+  return $ emit $ T.replicate (indent current) " "  -- | -- Print many lines@@ -141,19 +149,19 @@ -- | -- Prints an object key, escaping reserved names. ---prettyPrintObjectKey :: String -> String-prettyPrintObjectKey s | s `elem` reservedPsNames = show s+prettyPrintObjectKey :: Text -> Text+prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s)                        | isUnquotedKey s = s-                       | otherwise = show s+                       | otherwise = T.pack (show s)  -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box before b1 b2 | rows b1 > 1 = b1 // b2-             | otherwise = b1 <> b2+             | otherwise = b1 Box.<> b2  beforeWithSpace :: Box -> Box -> Box-beforeWithSpace b1 = before (b1 <> text " ")+beforeWithSpace b1 = before (b1 Box.<> text " ")  -- | Place a Box on the bottom right of another endWith :: Box -> Box -> Box-endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r]+endWith l r = l Box.<> vcat top [emptyBox (rows l - 1) (cols r), r]

src/Language/PureScript/Pretty/JS.hs view

@@ -9,12 +9,15 @@ import Prelude.Compat  import Control.Arrow ((<+>))-import Control.Monad.State hiding (sequence)+import Control.Monad (forM, mzero)+import Control.Monad.State (StateT, evalStateT) import Control.PatternArrows import qualified Control.Arrow as A  import Data.Maybe (fromMaybe)-import Data.Monoid+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.AST@@ -25,6 +28,8 @@  import Numeric +-- TODO (Christoph): Get rid of T.unpack / pack+ literals :: (Emit gen) => Pattern PrinterState JS gen literals = mkPattern' match'   where@@ -32,7 +37,7 @@   match' js = (addMapping' (getSourceSpan js) <>) <$> match js    match :: (Emit gen) => JS -> StateT PrinterState Maybe gen-  match (JSNumericLiteral _ n) = return $ emit $ either show show n+  match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n   match (JSStringLiteral _ s) = return $ string s   match (JSBooleanLiteral _ True) = return $ emit "true"   match (JSBooleanLiteral _ False) = return $ emit "false"@@ -53,8 +58,8 @@     , return $ emit "}"     ]     where-    objectPropertyToString :: (Emit gen) => String -> gen-    objectPropertyToString s | identNeedsEscaping s = emit $ show s+    objectPropertyToString :: (Emit gen) => Text -> gen+    objectPropertyToString s | identNeedsEscaping s = string s                              | otherwise = emit s   match (JSBlock _ sts) = mconcat <$> sequence     [ return $ emit "{\n"@@ -65,7 +70,7 @@     ]   match (JSVar _ ident) = return $ emit ident   match (JSVariableIntroduction _ ident value) = mconcat <$> sequence-    [ return $ emit $ "var " ++ ident+    [ return $ emit $ "var " <> ident     , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value     ]   match (JSAssignment _ target value) = mconcat <$> sequence@@ -80,15 +85,15 @@     , prettyPrintJS' sts     ]   match (JSFor _ ident start end sts) = mconcat <$> sequence-    [ return $ emit $ "for (var " ++ ident ++ " = "+    [ return $ emit $ "for (var " <> ident <> " = "     , prettyPrintJS' start-    , return $ emit $ "; " ++ ident ++ " < "+    , return $ emit $ "; " <> ident <> " < "     , prettyPrintJS' end-    , return $ emit $ "; " ++ ident ++ "++) "+    , return $ emit $ "; " <> ident <> "++) "     , prettyPrintJS' sts     ]   match (JSForIn _ ident obj sts) = mconcat <$> sequence-    [ return $ emit $ "for (var " ++ ident ++ " in "+    [ return $ emit $ "for (var " <> ident <> " in "     , prettyPrintJS' obj     , return $ emit ") "     , prettyPrintJS' sts@@ -108,10 +113,10 @@     [ return $ emit "throw "     , prettyPrintJS' value     ]-  match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl-  match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl+  match (JSBreak _ lbl) = return $ emit $ "break " <> lbl+  match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl   match (JSLabel _ lbl js) = mconcat <$> sequence-    [ return $ emit $ lbl ++ ": "+    [ return $ emit $ lbl <> ": "     , prettyPrintJS' js     ]   match (JSComment _ com js) = fmap mconcat $ sequence $@@ -126,27 +131,29 @@     , prettyPrintJS' js     ]     where-    commentLines :: Comment -> [String]+    commentLines :: Comment -> [Text]     commentLines (LineComment s) = [s]-    commentLines (BlockComment s) = lines s+    commentLines (BlockComment s) = T.lines s -    asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen+    asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen     asLine s = do       i <- currentIndent       return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" -    removeComments :: String -> String-    removeComments ('*' : '/' : s) = removeComments s-    removeComments (c : s) = c : removeComments s--    removeComments [] = []+    removeComments :: Text -> Text+    removeComments t =+      case T.stripPrefix "*/" t of+        Just rest -> removeComments rest+        Nothing -> case T.uncons t of+          Just (x, xs) -> x `T.cons` removeComments xs+          Nothing -> ""   match (JSRaw _ js) = return $ emit js   match _ = mzero -string :: (Emit gen) => String -> gen-string s = emit $ '"' : concatMap encodeChar s ++ "\""+string :: (Emit gen) => Text -> gen+string s = emit $ "\"" <> T.concatMap encodeChar s <> "\""   where-  encodeChar :: Char -> String+  encodeChar :: Char -> Text   encodeChar '\b' = "\\b"   encodeChar '\t' = "\\t"   encodeChar '\n' = "\\n"@@ -155,17 +162,17 @@   encodeChar '\r' = "\\r"   encodeChar '"'  = "\\\""   encodeChar '\\' = "\\\\"-  encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "")-    where-    (h, l) = divMod (fromEnum c - 0x10000) 0x400-    highSurrogate = h + 0xD800-    lowSurrogate = l + 0xDC00-  encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""-  encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""-  encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) ""-  encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""-  encodeChar c = [c]+  -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit.+  -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD.+  encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD"+  encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) ""+  encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) ""+  encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) ""+  encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) ""+  encodeChar c = T.singleton c +  showHex' a b = T.pack (showHex a b)+ conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) conditional = mkPattern match   where@@ -185,7 +192,7 @@    match _ = mzero -lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)+lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS) lam = mkPattern match   where   match (JSFunction ss name args ret) = Just ((name, args, ss), ret)@@ -211,7 +218,7 @@   match (JSInstanceOf _ val ty) = Just (val, ty)   match _ = Nothing -unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen+unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen unary' op mkStr = Wrap match (<>)   where   match :: (Emit gen) => Pattern PrinterState JS (gen, JS)@@ -220,7 +227,7 @@     match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)     match' _ = Nothing -unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen unary op str = unary' op (const str)  negateOperator :: (Emit gen) => Operator PrinterState JS gen@@ -229,8 +236,8 @@   isNegate (JSUnary _ Negate _) = True   isNegate _ = False -binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen-binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)   where   match :: Pattern PrinterState JS (JS, JS)   match = mkPattern match'@@ -253,12 +260,12 @@ -- | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level ---prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])+prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap]) prettyPrintJSWithSourceMaps js =   let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js   in (s, mp) -prettyPrintJS :: [JS] -> String+prettyPrintJS :: [JS] -> Text prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression@@ -276,8 +283,8 @@                   , [ unary JSNew "new " ]                   , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>                       emit ("function "-                        ++ fromMaybe "" name-                        ++ "(" ++ intercalate ", " args ++ ") ")+                        <> fromMaybe "" name+                        <> "(" <> intercalate ", " args <> ") ")                         <> ret ]                   , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]                   , [ unary     Not                  "!"

src/Language/PureScript/Pretty/Kinds.hs view

@@ -11,6 +11,8 @@ import Control.PatternArrows as PA  import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Text (Text)  import Language.PureScript.Crash import Language.PureScript.Kinds@@ -38,9 +40,11 @@   match _ = Nothing  -- | Generate a pretty-printed string representing a Kind-prettyPrintKind :: Kind -> String+prettyPrintKind :: Kind -> Text prettyPrintKind-  = fromMaybe (internalError "Incomplete pattern")+  -- TODO(Christoph): get rid of T.pack+  = T.pack+  . fromMaybe (internalError "Incomplete pattern")   . PA.pattern matchKind ()   where   matchKind :: Pattern () Kind String

src/Language/PureScript/Pretty/Types.hs view

@@ -18,6 +18,7 @@ import Control.PatternArrows as PA  import Data.Maybe (fromMaybe)+import qualified Data.Text as T  import Language.PureScript.Crash import Language.PureScript.Environment@@ -29,6 +30,8 @@  import Text.PrettyPrint.Boxes hiding ((<+>)) +-- TODO(Christoph): get rid of T.unpack s+ constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) constraintsAsBox 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 open close = uncurry listToBox . toList []   where   nameAndTypeToPs :: Char -> String -> Type -> Box-  nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty+  nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty    tailToPs :: Type -> Box   tailToPs REmpty = nullBox@@ -57,7 +60,7 @@     [ tailToPs rest, text [close] ]    toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)-  toList tys (RCons name ty row) = toList ((name, ty):tys) row+  toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row   toList tys r = (reverse tys, r)  prettyPrintRow :: Type -> String@@ -112,21 +115,21 @@     typeLiterals :: Pattern () Type Box     typeLiterals = mkPattern match where       match TypeWildcard{} = Just $ text "_"-      match (TypeVar var) = Just $ text var+      match (TypeVar var) = Just $ text $ T.unpack var       match (TypeLevelString s) = Just . text $ show s       match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row-      match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor+      match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor       match (TUnknown u)         | suggesting = Just $ text "_"         | otherwise = Just $ text $ 't' : show u       match (Skolem name s _ _)-        | suggesting =  Just $ text name-        | otherwise = Just $ text $ name ++ show s+        | suggesting =  Just $ text $ T.unpack name+        | otherwise = Just $ text $ T.unpack name ++ show s       match REmpty = Just $ text "()"       match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row       match (BinaryNoParensType op l r) =         Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r-      match (TypeOp op) = Just $ text $ showQualified runOpName op+      match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op       match _ = Nothing  matchType :: Bool -> Pattern () Type Box@@ -137,7 +140,7 @@                   , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]                   , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]                   , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]-                  , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]+                  , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ]                   , [ Wrap explicitParens $ \_ ty -> ty ]                   ] @@ -151,7 +154,7 @@ forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match   where-  match (PrettyPrintForAll idents ty) = Just (idents, ty)+  match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)   match _ = Nothing  typeAtomAsBox :: Type -> Box

src/Language/PureScript/Pretty/Values.hs view

@@ -11,6 +11,11 @@  import Control.Arrow (second) +import qualified Data.Monoid as Monoid ((<>))++import qualified Data.Text as T+import Data.Text (Text)+ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Names@@ -20,6 +25,11 @@  import Text.PrettyPrint.Boxes +-- TODO(Christoph): remove T.unpack s++textT :: Text -> Box+textT = text . T.unpack+ -- | Render an aligned list of items separated with commas list :: Char -> Char -> (a -> Box) -> [a] -> Box list open close _ [] = text [open, close]@@ -30,11 +40,11 @@ ellipsis :: Box ellipsis = text "..." -prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box+prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box prettyPrintObject d = list '{' '}' prettyPrintObjectProperty   where-  prettyPrintObjectProperty :: (String, Maybe Expr) -> Box-  prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value+  prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box+  prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value  -- | Pretty-print an expression prettyPrintValue :: Int -> Expr -> Box@@ -44,13 +54,13 @@   // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th                             , text "else " <> prettyPrintValueAtom (d - 1) el                             ])-prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ prettyPrintObjectKey prop)-prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop)+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg-prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)-prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)+prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)+prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =-  text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps+  text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) =   (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //     moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))@@ -60,14 +70,14 @@     (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) =   text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)-prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys-prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =-    text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"+    text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l-prettyPrintValue _ (Hole name) = text "?" <> text name+prettyPrintValue _ (Hole name) = text "?" <> textT name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr@@ -80,12 +90,12 @@ prettyPrintValueAtom :: Int -> Expr -> Box prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_"-prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)-prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)+prettyPrintValueAtom _ (Constructor name) = text $ T.unpack $ runProperName (disqualify name)+prettyPrintValueAtom _ (Var ident) = text $ T.unpack $ showIdent (disqualify ident) prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =   prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs   where-  printOp (Op (Qualified _ name)) = text (runOpName name)+  printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name   printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val@@ -105,9 +115,9 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration ident ty) =-  text (showIdent ident ++ " :: ") <> typeAsBox ty+  text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =-  text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val+  text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) =   vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)   where@@ -118,7 +128,7 @@ prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box prettyPrintCaseAlternative d _ | d < 0 = ellipsis prettyPrintCaseAlternative d (CaseAlternative binders result) =-  text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result+  text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result   where   prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box   prettyPrintResult (Left gs) =@@ -138,50 +148,50 @@ prettyPrintDoNotationElement d (DoNotationValue val) =   prettyPrintValue d val prettyPrintDoNotationElement d (DoNotationBind binder val) =-  text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val+  textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val prettyPrintDoNotationElement d (DoNotationLet ds) =   text "let" //     moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el -prettyPrintBinderAtom :: Binder -> String+prettyPrintBinderAtom :: Binder -> Text prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l prettyPrintBinderAtom (VarBinder ident) = showIdent ident prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)-prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)-prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder+prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b)+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op) prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =-  prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2-prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)+  prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2+prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) -prettyPrintLiteralBinder :: Literal Binder -> String-prettyPrintLiteralBinder (StringLiteral str) = show str-prettyPrintLiteralBinder (CharLiteral c) = show c-prettyPrintLiteralBinder (NumericLiteral num) = either show show num+prettyPrintLiteralBinder :: Literal Binder -> Text+prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str)+prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)+prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num prettyPrintLiteralBinder (BooleanLiteral True) = "true" prettyPrintLiteralBinder (BooleanLiteral False) = "false" prettyPrintLiteralBinder (ObjectLiteral bs) =   "{ "-  ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)-  ++ " }"+  Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)+  Monoid.<> " }"   where-  prettyPrintObjectPropertyBinder :: (String, Binder) -> String-  prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder+  prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text+  prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder prettyPrintLiteralBinder (ArrayLiteral bs) =   "[ "-  ++ intercalate ", " (map prettyPrintBinder bs)-  ++ " ]"+  Monoid.<> T.intercalate ", " (map prettyPrintBinder bs)+  Monoid.<> " ]"  -- | -- Generate a pretty-printed string representing a Binder ---prettyPrintBinder :: Binder -> String+prettyPrintBinder :: Binder -> Text prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)-prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)+prettyPrintBinder (ConstructorBinder ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b

src/Language/PureScript/Publish.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}  module Language.PureScript.Publish   ( preparePackage

src/Language/PureScript/Publish/ErrorsWarnings.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.PureScript.Publish.ErrorsWarnings   ( PackageError(..)   , PackageWarning(..)

src/Language/PureScript/Renamer.hs view

@@ -10,7 +10,9 @@ import Data.List (find) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M+import Data.Monoid ((<>)) import qualified Data.Set as S+import qualified Data.Text as T  import Language.PureScript.CoreFn import Language.PureScript.Names@@ -80,7 +82,7 @@   getNewName usedNames name =     fromJust $ find       (`S.notMember` usedNames)-      [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]+      [ Ident (runIdent name <> T.pack (show (i :: Int))) | i <- [1..] ]  -- | -- Finds the new name to use for an ident.@@ -91,7 +93,7 @@   name' <- gets $ M.lookup name . rsBoundNames   case name' of     Just name'' -> return name''-    Nothing -> error $ "Rename scope is missing ident '" ++ showIdent name ++ "'"+    Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"  -- | -- Finds idents introduced by declarations.

src/Language/PureScript/Sugar/ObjectWildcards.hs view

@@ -11,6 +11,7 @@  import Data.List (partition) import Data.Maybe (catMaybes)+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Errors@@ -61,7 +62,7 @@     return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])   desugarExpr e = return e -  wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr+  wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr   wrapLambda mkVal ps =     let (args, props) = partition (isAnonymousArgument . snd) ps     in if null args@@ -74,7 +75,7 @@   stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e   stripPositionInfo e = e -  peelAnonAccessorChain :: Expr -> Maybe [String]+  peelAnonAccessorChain :: Expr -> Maybe [Text]   peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e   peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e   peelAnonAccessorChain AnonymousArgument = Just []@@ -85,7 +86,7 @@   isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e   isAnonymousArgument _ = False -  mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))+  mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr))   mkProp (name, e) = do     arg <- freshIfAnon e     return (arg, (name, maybe e argToExpr arg))

src/Language/PureScript/Sugar/Operators/Expr.hs view

@@ -20,7 +20,9 @@   isBinOp _ = False    extractOp :: Expr -> Maybe (Expr, Expr, Expr)-  extractOp (BinaryNoParens op l r) = Just (op, l, r)+  extractOp (BinaryNoParens op l r)+    | PositionedValue _ _ op' <- op = Just (op', l, r)+    | otherwise = Just (op, l, r)   extractOp _ = Nothing    fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName))

src/Language/PureScript/Sugar/TypeClasses.hs view

@@ -27,8 +27,10 @@ import Control.Monad.State import Data.List ((\\), find, sortBy) import Data.Maybe (catMaybes, mapMaybe, isJust)- import qualified Data.Map as M+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData @@ -55,11 +57,7 @@     -> ExternsDeclaration     -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)   fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where-    typeClass = TypeClassData { typeClassArguments    = args-                              , typeClassMembers      = members-                              , typeClassSuperclasses = implies-                              , typeClassDependencies = deps-                              }+    typeClass = makeTypeClassData args members implies deps   fromExternsDecl _ _ = Nothing  desugarModule@@ -180,7 +178,7 @@ desugarDecl mn exps = go   where   go d@(TypeClassDeclaration name args implies deps members) = do-    modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps))+    modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps))     return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)   go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"   go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do@@ -231,7 +229,7 @@  typeClassDictionaryDeclaration   :: ProperName 'ClassName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> [Constraint]   -> [Declaration]   -> Declaration@@ -247,7 +245,7 @@ typeClassMemberToDictionaryAccessor   :: ModuleName   -> ProperName 'ClassName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> Declaration   -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =@@ -323,14 +321,14 @@     return (PositionedValue pos com val)   memberToValue _ _ = internalError "Invalid declaration in type instance definition" -typeClassMemberName :: Declaration -> String+typeClassMemberName :: Declaration -> Text typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" -superClassDictionaryNames :: [Constraint] -> [String]+superClassDictionaryNames :: [Constraint] -> [Text] superClassDictionaryNames supers =-  [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)+  [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer))   | (index, Constraint pn _ _) <- zip [0..] supers   ]

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs view

@@ -1,6 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}- -- | -- This module implements the generic deriving elaboration that takes place during desugaring. --@@ -16,6 +13,7 @@ import Data.List (foldl', find, sortBy, unzip5) import Data.Maybe (fromMaybe) import Data.Ord (comparing)+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -118,7 +116,7 @@     takeReverse :: Int -> [a] -> [a]     takeReverse n = take n . reverse -    stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type+    stripRight :: [(Text, Maybe kind)] -> Type -> Maybe Type     stripRight [] ty = Just ty     stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))       | arg == arg' = stripRight args t@@ -285,14 +283,14 @@               (App e unitVal)       fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) -      mkRecCase :: [(String, Type)] -> CaseAlternative+      mkRecCase :: [(Text, Type)] -> CaseAlternative       mkRecCase rs =         CaseAlternative           [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]           . Right           $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) -      mkRecFun :: [(String, Type)] -> Expr+      mkRecFun :: [(Text, Type)] -> Expr       mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs          where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs     mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d@@ -576,13 +574,13 @@       where       catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ")) -    orderingName :: String -> Qualified (ProperName a)+    orderingName :: Text -> Qualified (ProperName a)     orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName -    orderingCtor :: String -> Expr+    orderingCtor :: Text -> Expr     orderingCtor = Constructor . orderingName -    orderingBinder :: String -> Binder+    orderingBinder :: Text -> Binder     orderingBinder name = ConstructorBinder (orderingName name) []      ordCompare :: Expr -> Expr -> Expr@@ -700,7 +698,7 @@ objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing -decomposeRec :: Type -> [(String, Type)]+decomposeRec :: Type -> [(Text, Type)] decomposeRec = sortBy (comparing fst) . go   where go (RCons str typ typs) = (str, typ) : decomposeRec typs         go _ = []

src/Language/PureScript/TypeChecker.hs view

@@ -16,11 +16,16 @@ import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..))+import Control.Lens ((^..), _1, _2)  import Data.Foldable (for_, traverse_) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M+import qualified Data.Set as S+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -42,7 +47,7 @@   => ModuleName   -> DataDeclType   -> ProperName 'TypeName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> [(ProperName 'ConstructorName, [Type])]   -> Kind   -> m ()@@ -58,7 +63,7 @@   => ModuleName   -> DataDeclType   -> ProperName 'TypeName-  -> [String]+  -> [Text]   -> ProperName 'ConstructorName   -> [Type]   -> m ()@@ -68,14 +73,14 @@   let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)   let dctorTy = foldr function retTy tys   let polyType = mkForAll args dctorTy-  let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]+  let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]]   putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }  addTypeSynonym   :: (MonadState CheckState m, MonadError MultipleErrors m)   => ModuleName   -> ProperName 'TypeName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> Type   -> Kind   -> m ()@@ -111,7 +116,7 @@   :: (MonadState CheckState m)   => ModuleName   -> ProperName 'ClassName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> [Constraint]   -> [FunctionalDependency]   -> [Declaration]@@ -120,12 +125,7 @@     modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }   where     newClass :: TypeClassData-    newClass =-      TypeClassData { typeClassArguments    = args-                    , typeClassMembers      = map toPair ds-                    , typeClassSuperclasses = implies-                    , typeClassDependencies = dependencies-                    }+    newClass = makeTypeClassData args (map toPair ds) implies dependencies      toPair (TypeDeclaration ident ty) = (ident, ty)     toPair (PositionedDeclaration _ _ d) = toPair d@@ -134,7 +134,7 @@ addTypeClassDictionaries   :: (MonadState CheckState m)   => Maybe ModuleName-  -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)+  -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)   -> m () addTypeClassDictionaries mn entries =   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }@@ -142,27 +142,37 @@  checkDuplicateTypeArguments   :: (MonadState CheckState m, MonadError MultipleErrors m)-  => [String]+  => [Text]   -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup ->   throwError . errorMessage $ DuplicateTypeArgument dup   where-  firstDup :: Maybe String+  firstDup :: Maybe Text   firstDup = listToMaybe $ args \\ nub args  checkTypeClassInstance-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)-  => ModuleName+  :: (MonadState CheckState m, MonadError MultipleErrors m)+  => TypeClassData+  -> Int -- ^ index of type class argument   -> Type   -> m ()-checkTypeClassInstance _ (TypeVar _) = return ()-checkTypeClassInstance _ (TypeLevelString _) = return ()-checkTypeClassInstance _ (TypeConstructor ctor) = do-  env <- getEnv-  when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance-  return ()-checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2-checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty+checkTypeClassInstance cls i = check where+  -- If the argument is determined via fundeps then we are less restrictive in+  -- what type is allowed. This is because the type cannot be used to influence+  -- which instance is selected. Currently the only weakened restriction is that+  -- row types are allowed in determined type class arguments.+  isFunDepDetermined = S.member i (typeClassDeterminedArguments cls)+  check = \case+    TypeVar _ -> return ()+    TypeLevelString _ -> return ()+    TypeConstructor ctor -> do+      env <- getEnv+      when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance+      return ()+    TypeApp t1 t2 -> check t1 >> check t2+    REmpty | isFunDepDetermined -> return ()+    RCons _ hd tl | isFunDepDetermined -> check hd >> check tl+    ty -> throwError . errorMessage $ InvalidInstanceHead ty  -- | -- Check that type synonyms are fully-applied in a type@@ -205,9 +215,10 @@       addDataType moduleName dtype name args' dctors ctorKind     return $ DataDeclaration dtype name args dctors   go (d@(DataBindingGroupDeclaration tys)) = do-    warnAndRethrow (addHint ErrorInDataBindingGroup) $ do-      let syns = mapMaybe toTypeSynonym tys-      let dataDecls = mapMaybe toDataDecl tys+    let syns = mapMaybe toTypeSynonym tys+        dataDecls = mapMaybe toDataDecl tys+        bindingGroupNames = nub ((syns^..traverse._1) ++ (dataDecls^..traverse._2))+    warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do       (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)       for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do         when (dtype == Newtype) $ checkNewtype name dctors@@ -278,12 +289,16 @@     addTypeClass moduleName pn args implies deps tys     return d   go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do-    traverse_ (checkTypeClassInstance moduleName) tys-    checkOrphanInstance dictName className tys-    _ <- traverseTypeInstanceBody checkInstanceMembers body-    let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)-    addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict-    return d+    env <- getEnv+    case M.lookup className (typeClasses env) of+      Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"+      Just typeClass -> do+        sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)+        checkOrphanInstance dictName className tys+        _ <- traverseTypeInstanceBody checkInstanceMembers body+        let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)+        addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict+        return d   go (PositionedDeclaration pos com d) =     warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d @@ -323,7 +338,7 @@   -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,   -- extracted from the kind of the type constructor itself.   ---  withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]+  withKinds :: [(Text, Maybe Kind)] -> Kind -> [(Text, Maybe Kind)]   withKinds []                  _               = []   withKinds (s@(_, Just _ ):ss) (FunKind _   k) = s : withKinds ss k   withKinds (  (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

src/Language/PureScript/TypeChecker/Entailment.hs view

@@ -19,12 +19,14 @@ import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer -import Data.Foldable (for_)+import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.List (minimumBy, nub) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -37,17 +39,32 @@ import Language.PureScript.Types import qualified Language.PureScript.Constants as C +-- | Describes what sort of dictionary to generate for type class instances+data Evidence+  = NamedInstance (Qualified Ident)+  -- ^ An existing named instance+  | IsSymbolInstance Text+  -- ^ Computed instance of the IsSymbol type class for a given Symbol literal+  deriving (Eq)++-- | Extract the identifier of a named instance+namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident)+namedInstanceIdentifier (NamedInstance i) = Just i+namedInstanceIdentifier _ = Nothing++-- | Description of a type class dictionary with instance evidence+type TypeClassDict = TypeClassDictionaryInScope Evidence+ -- | The 'InstanceContext' tracks those constraints which can be satisfied. type InstanceContext = M.Map (Maybe ModuleName)                          (M.Map (Qualified (ProperName 'ClassName))-                           (M.Map (Qualified Ident)-                             TypeClassDictionaryInScope))+                           (M.Map (Qualified Ident) NamedDict))  -- | A type substitution which makes an instance head match a list of types. -- -- Note: we store many types per type variable name. For any name, all types -- should unify if we are going to commit to an instance.-type Matching a = M.Map String a+type Matching a = M.Map Text a  combineContexts :: InstanceContext -> InstanceContext -> InstanceContext combineContexts = M.unionWith (M.unionWith M.union)@@ -88,7 +105,7 @@  -- | Three options for how we can handle a constraint, depending on the mode we're in. data EntailsResult a-  = Solved a TypeClassDictionaryInScope+  = Solved a TypeClassDict   -- ^ We solved this constraint   | Unsolved Constraint   -- ^ We couldn't solve this constraint right now, it will be generalized@@ -120,7 +137,8 @@ entails SolverOptions{..} constraint context hints =     solve constraint   where-    forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]+    forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]+    forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]     forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))     forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -130,8 +148,8 @@     ctorModules (TypeApp ty _) = ctorModules ty     ctorModules _ = Nothing -    findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]-    findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx+    findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]+    findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx      valUndefined :: Expr     valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))@@ -181,12 +199,12 @@                 -- Solve any necessary subgoals                 args <- solveSubgoals subst'' (tcdDependencies tcd)                 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)-                                  (mkDictionary (tcdName tcd) args)+                                  (mkDictionary (tcdValue tcd) args)                                   (tcdPath tcd)                 return match               Unsolved unsolved -> do                 -- Generate a fresh name for the unsolved constraint's new dictionary-                ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved)))+                ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved)))                 let qident = Qualified Nothing ident                 -- Store the new dictionary in the InstanceContext so that we can solve this goal in                 -- future.@@ -213,7 +231,7 @@             -- fresh type variables. This function extends a substitution with fresh type variables             -- as necessary, based on the types in the instance head.             withFreshTypes-              :: TypeClassDictionaryInScope+              :: TypeClassDict               -> Matching Type               -> m (Matching Type)             withFreshTypes TypeClassDictionaryInScope{..} subst = do@@ -232,7 +250,7 @@                   t <- freshType                   return (s, t) -            unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)+            unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a)             unique tyArgs []               | solverDeferErrors = return Deferred               -- We need a special case for nullary type classes, since we want@@ -242,7 +260,7 @@             unique _      [(a, dict)] = return $ Solved a dict             unique tyArgs tcds               | pairwiseAny overlapping (map snd tcds) = do-                  tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds)+                  tell . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd))                   return $ uncurry Solved (head tcds)               | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -255,12 +273,12 @@             --             -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have             -- been caught when constructing superclass dictionaries.-            overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool+            overlapping :: TypeClassDict -> TypeClassDict -> Bool             overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False             overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False             overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False             overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False-            overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2+            overlapping tcd1 tcd2 = tcdValue tcd1 /= tcdValue tcd2              -- Create dictionaries for subgoals which still need to be solved by calling go recursively             -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type@@ -271,22 +289,23 @@               Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals              -- Make a dictionary from subgoal dictionaries by applying the correct function-            mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr-            mkDictionary fnName Nothing = Var fnName-            mkDictionary fnName (Just []) = Var fnName-            mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts+            mkDictionary :: Evidence -> Maybe [Expr] -> Expr+            mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)+            mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where+              fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))+                       ]          -- Turn a DictionaryValue into a Expr         subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr         subclassDictionaryValue dict superclassName index =-          App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)+          App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))                         dict)               valUndefined  -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'.-matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type])+matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Maybe (Matching [Type]) matches deps TypeClassDictionaryInScope{..} tys = do     -- First, find those types which match exactly     let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes@@ -345,7 +364,7 @@         sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]         sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] -        go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type])+        go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])         go [] REmpty             [] REmpty             = (True, M.empty)         go [] (TUnknown u1)      [] (TUnknown u2)      | u1 == u2 = (True, M.empty)         go [] (TypeVar v1)       [] (TypeVar v2)       | v1 == v2 = (True, M.empty)@@ -383,7 +402,7 @@               sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]           in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'         where-          go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool+          go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool           go [] (TUnknown u1)     [] (TUnknown u2)     | u1 == u2 = True           go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2           go [] REmpty            [] REmpty            = True@@ -402,7 +421,7 @@   => [(Qualified (ProperName 'ClassName), Integer)]   -> Qualified Ident   -> Constraint-  -> m [TypeClassDictionaryInScope]+  -> m [NamedDict] newDictionaries path name (Constraint className instanceTy _) = do     tcs <- gets (typeClasses . checkEnv)     let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs@@ -413,12 +432,12 @@                                   ) typeClassSuperclasses [0..]     return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)   where-    instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]+    instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type]     instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs -mkContext :: [TypeClassDictionaryInScope] -> InstanceContext+mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where-  fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d))+  fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d))  -- | Check all pairs of values in a list match a predicate pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool

src/Language/PureScript/TypeChecker/Kinds.hs view

@@ -18,6 +18,7 @@ import Control.Monad.State  import qualified Data.Map as M+import Data.Text (Text)  import Language.PureScript.Crash import Language.PureScript.Environment@@ -104,7 +105,7 @@ kindOfWithScopedVars ::   (MonadError MultipleErrors m, MonadState CheckState m) =>   Type ->-  m (Kind, [(String, Kind)])+  m (Kind, [(Text, Kind)]) kindOfWithScopedVars ty =   withErrorMessageHint (ErrorCheckingKind ty) $     fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty@@ -119,7 +120,7 @@   => Bool   -> ModuleName   -> ProperName 'TypeName-  -> [(String, Maybe Kind)]+  -> [(Text, Maybe Kind)]   -> [Type]   -> m Kind kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do@@ -134,7 +135,7 @@  freshKindVar   :: (MonadError MultipleErrors m, MonadState CheckState m)-  => (String, Maybe Kind)+  => (Text, Maybe Kind)   -> Kind   -> m (ProperName 'TypeName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)@@ -146,8 +147,8 @@ kindsOfAll   :: (MonadError MultipleErrors m, MonadState CheckState m)   => ModuleName-  -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]-  -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]+  -> [(ProperName 'TypeName, [(Text, Maybe Kind)], Type)]+  -> [(ProperName 'TypeName, [(Text, Maybe Kind)], [Type])]   -> m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do   synVars <- replicateM (length syns) freshKind@@ -198,14 +199,14 @@ infer   :: (MonadError MultipleErrors m, MonadState CheckState m)   => Type-  -> m (Kind, [(String, Kind)])+  -> m (Kind, [(Text, Kind)]) infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty  infer'   :: forall m    . (MonadError MultipleErrors m, MonadState CheckState m)   => Type-  -> m (Kind, [(String, Kind)])+  -> m (Kind, [(Text, Kind)]) infer' (ForAll ident ty _) = do   k1 <- freshKind   Just moduleName <- checkCurrentModule <$> get

src/Language/PureScript/TypeChecker/Monad.hs view

@@ -15,6 +15,7 @@  import Data.Maybe import qualified Data.Map as M+import Data.Text (Text)  import Language.PureScript.Environment import Language.PureScript.Errors@@ -93,7 +94,7 @@ withScopedTypeVars   :: (MonadState CheckState m, MonadWriter MultipleErrors m)   => ModuleName-  -> [(String, Kind)]+  -> [(Text, Kind)]   -> m a   -> m a withScopedTypeVars mn ks ma = do@@ -133,12 +134,12 @@ -- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries   :: MonadState CheckState m-  => [TypeClassDictionaryInScope]+  => [NamedDict]   -> m a   -> m a withTypeClassDictionaries entries action = do   orig <- get-  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 ]+  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 ]   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }   a <- action   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }@@ -147,14 +148,14 @@ -- | Get the currently available map of type class dictionaries getTypeClassDictionaries   :: (MonadState CheckState m)-  => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))+  => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get  -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries   :: (MonadState CheckState m)   => Maybe ModuleName-  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))+  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get  -- | Temporarily bind a collection of names to local variables

src/Language/PureScript/TypeChecker/Skolems.hs view

@@ -18,6 +18,7 @@ import Data.Functor.Identity (Identity(), runIdentity) import Data.List (nub, (\\)) import Data.Monoid+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -56,7 +57,7 @@ -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants ---skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type+skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)  -- |@@ -64,25 +65,25 @@ -- DeferredDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. ---skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr+skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr skolemizeTypesInValue ident sko scope ss =   let     (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS   in runIdentity . f   where-  onExpr :: [String] -> Expr -> Identity ([String], Expr)+  onExpr :: [Text] -> Expr -> Identity ([Text], Expr)   onExpr sco (DeferredDictionary c ts)     | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))   onExpr sco (TypedValue check val ty)     | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))   onExpr sco other = return (sco, other) -  onBinder :: [String] -> Binder -> Identity ([String], Binder)+  onBinder :: [Text] -> Binder -> Identity ([Text], Binder)   onBinder sco (TypedBinder ty b)     | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)   onBinder sco other = return (sco, other) -  peelTypeVars :: Type -> [String]+  peelTypeVars :: Type -> [Text]   peelTypeVars (ForAll i ty _) = i : peelTypeVars ty   peelTypeVars _ = []

src/Language/PureScript/TypeChecker/Subsumption.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-}

src/Language/PureScript/TypeChecker/TypeSearch.hs view

@@ -1,7 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}- module Language.PureScript.TypeChecker.TypeSearch   ( typeSearch   ) where

src/Language/PureScript/TypeChecker/Types.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-}  -- |@@ -40,8 +38,10 @@ import Data.Functor (($>)) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Set as S+import Data.Text (Text)  import Language.PureScript.AST import Language.PureScript.Crash@@ -442,7 +442,7 @@   unifyTypes val (TypeApp tyRecord row)   return m1   where-  inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type)+  inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)   inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty   inferRowProperties nrow row ((name, binder):binders) = do     propTy <- freshType@@ -559,7 +559,7 @@   return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do   dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) ->-    freshIdent ("dict" ++ className)+    freshIdent ("dict" <> className)   dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints   val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t@@ -681,10 +681,10 @@ checkProperties ::   (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>   Expr ->-  [(String, Expr)] ->+  [(Text, Expr)] ->   Type ->   Bool ->-  m [(String, Expr)]+  m [(Text, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where   go [] [] REmpty = return []   go [] [] u@(TUnknown _)@@ -771,7 +771,7 @@ -- | -- Ensure a set of property names and value does not contain duplicate labels ---ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m ()+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m () ensureNoDuplicateProperties ps =   let ls = map fst ps in   case ls \\ nub ls of

src/Language/PureScript/TypeChecker/Unify.hs view

@@ -24,6 +24,8 @@  import Data.List (nub, sort) import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.Crash import Language.PureScript.Errors@@ -137,7 +139,7 @@     forM_ int (uncurry unifyTypes)     unifyRows' sd1 r1' sd2 r2'   where-  unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m ()+  unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m ()   unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r))   unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r))   unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do@@ -155,7 +157,7 @@ -- | -- Replace a single type variable with a new unification variable ---replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type+replaceVarWithUnknown :: (MonadState CheckState m) => Text -> Type -> m Type replaceVarWithUnknown ident ty = do   tu <- freshType   return $ replaceTypeVars ident tu ty@@ -179,7 +181,7 @@ varIfUnknown :: Type -> Type varIfUnknown ty =   let unks = nub $ unknownsInType ty-      toName = (:) 't' . show+      toName = T.cons 't' . T.pack .  show       ty' = everywhereOnTypes typeToVar ty       typeToVar :: Type -> Type       typeToVar (TUnknown u) = TypeVar (toName u)

src/Language/PureScript/TypeClassDictionaries.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveTraversable #-} module Language.PureScript.TypeClassDictionaries where  import Prelude.Compat@@ -8,10 +10,10 @@ -- | -- Data representing a type class dictionary which is in scope ---data TypeClassDictionaryInScope+data TypeClassDictionaryInScope v   = TypeClassDictionaryInScope {-    -- | The identifier with which the dictionary can be accessed at runtime-      tcdName :: Qualified Ident+    -- | The value with which the dictionary can be accessed at runtime+      tcdValue :: v     -- | How to obtain this instance via superclass relationships     , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]     -- | The name of the type class to which this type class instance applies@@ -21,4 +23,7 @@     -- | Type class dependencies which must be satisfied to construct this dictionary     , tcdDependencies :: Maybe [Constraint]     }-    deriving (Show)+    deriving (Show, Functor, Foldable, Traversable)++type NamedDict = TypeClassDictionaryInScope (Qualified Ident)+

src/Language/PureScript/Types.hs view

@@ -9,11 +9,13 @@ import Prelude.Compat  import Control.Monad ((<=<))--import Data.List (nub)-import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A+import Data.List (nub)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T  import Language.PureScript.AST.SourcePos import Language.PureScript.Kinds@@ -32,9 +34,9 @@   -- | A unification variable of type Type   = TUnknown Int   -- | A named type variable-  | TypeVar String+  | TypeVar Text   -- | A type-level string-  | TypeLevelString String+  | TypeLevelString Text   -- | A type wildcard, as would appear in a partial type synonym   | TypeWildcard SourceSpan   -- | A type constructor@@ -45,15 +47,15 @@   -- | A type application   | TypeApp Type Type   -- | Forall quantifier-  | ForAll String Type (Maybe SkolemScope)+  | ForAll Text Type (Maybe SkolemScope)   -- | A type with a set of type class constraints   | ConstrainedType [Constraint] Type   -- | A skolem constant-  | Skolem String Int SkolemScope (Maybe SourceSpan)+  | Skolem Text Int SkolemScope (Maybe SourceSpan)   -- | An empty row   | REmpty   -- | A non-empty row-  | RCons String Type Type+  | RCons Text Type Type   -- | A type with a kind annotation   | KindedType Type Kind   -- | A placeholder used in pretty printing@@ -61,7 +63,7 @@   -- | A placeholder used in pretty printing   | PrettyPrintObject Type   -- | A placeholder used in pretty printing-  | PrettyPrintForAll [String] Type+  | PrettyPrintForAll [Text] Type   -- | Binary operator application. During the rebracketing phase of desugaring,   -- this data constructor will be removed.   | BinaryNoParensType Type Type Type@@ -75,7 +77,7 @@  -- | Additional data relevant to type class constraints data ConstraintData-  = PartialConstraintData [[String]] Bool+  = PartialConstraintData [[Text]] Bool   -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.   -- It contains (rendered) binder information for those binders which were   -- not matched, and a flag indicating whether the list was truncated or not.@@ -106,7 +108,7 @@ -- | -- Convert a row to a list of pairs of labels and types ---rowToList :: Type -> ([(String, Type)], Type)+rowToList :: Type -> ([(Text, Type)], Type) rowToList (RCons name ty row) = let (tys, rest) = rowToList row                                 in ((name, ty):tys, rest) rowToList r = ([], r)@@ -114,7 +116,7 @@ -- | -- Convert a list of labels and types to a row ---rowFromList :: ([(String, Type)], Type) -> Type+rowFromList :: ([(Text, Type)], Type) -> Type rowFromList ([], r) = r rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) @@ -128,23 +130,23 @@ -- | -- Universally quantify a type ---mkForAll :: [String] -> Type -> Type+mkForAll :: [Text] -> Type -> Type mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args  -- | -- Replace a type variable, taking into account variable shadowing ---replaceTypeVars :: String -> Type -> Type -> Type+replaceTypeVars :: Text -> Type -> Type -> Type replaceTypeVars v r = replaceAllTypeVars [(v, r)]  -- | -- Replace named type variables with types ---replaceAllTypeVars :: [(String, Type)] -> Type -> Type+replaceAllTypeVars :: [(Text, Type)] -> Type -> Type replaceAllTypeVars = go []   where -  go :: [String] -> [(String, Type)] -> Type -> Type+  go :: [Text] -> [(Text, Type)] -> Type -> Type   go _  m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)   go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)   go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f@@ -163,16 +165,16 @@   go bs m (ParensInType t) = ParensInType (go bs m t)   go _  _ ty = ty -  genName orig inUse = try 0+  genName orig inUse = try' 0     where-    try :: Integer -> String-    try n | (orig ++ show n) `elem` inUse = try (n + 1)-          | otherwise = orig ++ show n+    try' :: Integer -> Text+    try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1)+           | otherwise = orig <> T.pack (show n)  -- | -- Collect all type variables appearing in a type ---usedTypeVariables :: Type -> [String]+usedTypeVariables :: Type -> [Text] usedTypeVariables = nub . everythingOnTypes (++) go   where   go (TypeVar v) = [v]@@ -181,10 +183,10 @@ -- | -- Collect all free type variables appearing in a type ---freeTypeVariables :: Type -> [String]+freeTypeVariables :: Type -> [Text] freeTypeVariables = nub . go []   where-  go :: [String] -> Type -> [String]+  go :: [Text] -> Type -> [Text]   go bound (TypeVar v) | v `notElem` bound = [v]   go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2   go bound (ForAll v t _) = go (v : bound) t@@ -292,32 +294,32 @@   go other = f other  everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r-everythingOnTypes (<>) f = go+everythingOnTypes (<+>) f = go   where-  go t@(TypeApp t1 t2) = f t <> go t1 <> go t2-  go t@(ForAll _ ty _) = f t <> go ty-  go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty-  go t@(RCons _ ty rest) = f t <> go ty <> go rest-  go t@(KindedType ty _) = f t <> go ty-  go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2-  go t@(PrettyPrintObject t1) = f t <> go t1-  go t@(PrettyPrintForAll _ t1) = f t <> go t1-  go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3-  go t@(ParensInType t1) = f t <> go t1+  go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2+  go t@(ForAll _ ty _) = f t <+> go ty+  go t@(ConstrainedType cs ty) = foldl (<+>) (f t) (map go $ concatMap constraintArgs cs) <+> go ty+  go t@(RCons _ ty rest) = f t <+> go ty <+> go rest+  go t@(KindedType ty _) = f t <+> go ty+  go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2+  go t@(PrettyPrintObject t1) = f t <+> go t1+  go t@(PrettyPrintForAll _ t1) = f t <+> go t1+  go t@(BinaryNoParensType t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3+  go t@(ParensInType t1) = f t <+> go t1   go other = f other  everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r-everythingWithContextOnTypes s0 r0 (<>) f = go' s0+everythingWithContextOnTypes s0 r0 (<+>) f = go' s0   where-  go' s t = let (s', r) = f s t in r <> go s' t-  go s (TypeApp t1 t2) = go' s t1 <> go' s t2+  go' s t = let (s', r) = f s t in r <+> go s' t+  go s (TypeApp t1 t2) = go' s t1 <+> go' s t2   go s (ForAll _ ty _) = go' s ty-  go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty-  go s (RCons _ ty rest) = go' s ty <> go' s rest+  go s (ConstrainedType cs ty) = foldl (<+>) r0 (map (go' s) $ concatMap constraintArgs cs) <+> go' s ty+  go s (RCons _ ty rest) = go' s ty <+> go' s rest   go s (KindedType ty _) = go' s ty-  go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2+  go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2   go s (PrettyPrintObject t1) = go' s t1   go s (PrettyPrintForAll _ t1) = go' s t1-  go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3+  go s (BinaryNoParensType t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3   go s (ParensInType t1) = go' s t1   go _ _ = r0

stack.yaml view

@@ -1,3 +1,3 @@-resolver: lts-6.10+resolver: lts-6.25 packages: - '.'

tests/Language/PureScript/Ide/ReexportsSpec.hs view

@@ -2,7 +2,6 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where -import qualified Prelude import           Protolude  import qualified Data.Map as Map@@ -11,7 +10,7 @@ import qualified Language.PureScript as P import           Test.Hspec -m :: Prelude.String -> P.ModuleName+m :: Text -> P.ModuleName m = P.moduleNameFromString  d :: IdeDeclaration -> IdeDeclarationAnn

tests/TestCompiler.hs view

@@ -2,6 +2,7 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module TestCompiler where @@ -30,8 +31,8 @@ import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime())-import Data.Tuple (swap) import qualified Data.Text as T+import Data.Tuple (swap)  import qualified Data.Map as M @@ -46,6 +47,7 @@ import System.Process hiding (cwd) import System.FilePath import System.Directory+import System.IO import System.IO.UTF8 import System.IO.Silently import qualified System.FilePath.Glob as Glob@@ -72,7 +74,7 @@     supportPurs <- supportFiles "purs"     supportPursFiles <- readInput supportPurs     supportExterns <- runExceptT $ do-      modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles)+      modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles       foreigns <- inferForeignModules modules       externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)       return (zip (map snd modules) externs)@@ -80,10 +82,15 @@       Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)       Right externs -> return (externs, passingFiles, warningFiles, failingFiles) +  outputFile <- runIO $ do+    tmp <- getTemporaryDirectory+    createDirectoryIfMissing False (tmp </> logpath)+    openFile (tmp </> logpath </> logfile) WriteMode+   context "Passing examples" $     forM_ passingTestCases $ \testPurs ->       it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $-        assertCompiles supportExterns testPurs+        assertCompiles supportExterns testPurs outputFile    context "Warning examples" $     forM_ warningTestCases $ \testPurs -> do@@ -169,20 +176,20 @@   where   getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))   getInputTimestamp mn-    | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)+    | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever)     | otherwise = return (Left P.RebuildAlways)     where     isSupportModule = flip elem supportModules    getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)   getOutputTimestamp mn = do-    let filePath = modulesDir </> P.runModuleName mn+    let filePath = modulesDir </> T.unpack (P.runModuleName mn)     exists <- liftIO $ doesDirectoryExist filePath     return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) -readInput :: [FilePath] -> IO [(FilePath, String)]+readInput :: [FilePath] -> IO [(FilePath, T.Text)] readInput inputFiles = forM inputFiles $ \inputFile -> do-  text <- readUTF8File inputFile+  text <- readUTF8FileT inputFile   return (inputFile, text)  runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors)@@ -195,7 +202,7 @@   -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportExterns inputFiles check = silence $ runTest $ do   fs <- liftIO $ readInput inputFiles-  ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs)+  ms <- P.parseModulesFromFiles id fs   foreigns <- inferForeignModules ms   liftIO (check (map snd ms))   let actions = makeActions foreigns@@ -222,15 +229,16 @@ checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String checkShouldFailWith expected errs =   let actual = map P.errorCode $ P.runMultipleErrors errs-  in if sort expected == sort actual+  in if sort expected == sort (map T.unpack actual)     then Nothing     else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual  assertCompiles   :: [(P.Module, P.ExternsFile)]   -> [FilePath]+  -> Handle   -> Expectation-assertCompiles supportExterns inputFiles =+assertCompiles supportExterns inputFiles outputFile =   assert supportExterns inputFiles checkMain $ \e ->     case e of       Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs@@ -239,10 +247,13 @@         let entryPoint = modulesDir </> "index.js"         writeFile entryPoint "require('Main').main()"         result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process+        hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"         case result of           Just (ExitSuccess, out, err)             | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err-            | not (null out) && trim (last (lines out)) == "Done" -> return Nothing+            | not (null out) && trim (last (lines out)) == "Done" -> do+                hPutStr outputFile out+                return Nothing             | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out           Just (ExitFailure _, _, err) -> return $ Just err           Nothing -> return $ Just "Couldn't find node.js executable"@@ -285,3 +296,9 @@    where   noPreCheck = const (return ())++logpath :: FilePath+logpath = "purescript-output"++logfile :: FilePath+logfile = "psc-tests.out"

tests/TestDocs.hs view

@@ -13,6 +13,7 @@ import Data.Maybe (fromMaybe) import Data.List ((\\)) import Data.Foldable+import qualified Data.Text as T import System.Exit  import qualified Language.PureScript as P@@ -36,8 +37,8 @@   case res of     Left e -> Publish.printErrorToStdout e >> exitFailure     Right Docs.Package{..} ->-      forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->-        let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)+      forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->+        let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))                           (find ((==) mn . Docs.modName) pkgModules)         in forM_ pragmas (`runAssertionIO` mdl) @@ -57,6 +58,9 @@   -- | Assert that a particular declaration has a particular type class   -- constraint.   | ShouldBeConstrained P.ModuleName String String+  -- | Assert that a particular typeclass declaration has a functional+  -- dependency list.+  | ShouldHaveFunDeps P.ModuleName String [([String],[String])]   -- | Assert that a particular value declaration exists, and its type   -- satisfies the given predicate.   | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))@@ -82,6 +86,8 @@   | ChildDocumented P.ModuleName String String   -- | A constraint was missing.   | ConstraintMissing P.ModuleName String String+  -- | A functional dependency was missing.+  | FunDepMissing P.ModuleName String [([String], [String])]   -- | A declaration had the wrong "type" (ie, value, type, type class)   -- Fields: declaration title, expected "type", actual "type".   | WrongDeclarationType P.ModuleName String String String@@ -142,6 +148,20 @@               Fail (WrongDeclarationType mn decl "value"                      (Docs.declInfoToString declInfo)) +    ShouldHaveFunDeps mn decl fds ->+      case find ((==) decl . Docs.declTitle) (declarationsFor mn) of+        Nothing ->+          Fail (NotDocumented mn decl)+        Just Docs.Declaration{..} ->+          case declInfo of+            Docs.TypeClassDeclaration _ _ fundeps ->+              if fundeps == fds+                then Pass+                else Fail (FunDepMissing mn decl fds)+            _ ->+              Fail (WrongDeclarationType mn decl "value"+                     (Docs.declInfoToString declInfo))+     ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->       case find ((==) decl . Docs.declTitle) (declarationsFor mn) of         Nothing ->@@ -197,11 +217,11 @@       False   where   matches className =-    (==) className . P.runProperName . P.disqualify . P.constraintClass+    (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass  runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do-  putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)+  putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion)   case runAssertion assertion mdl of     Pass -> pure ()     Fail reason -> do@@ -270,6 +290,10 @@       , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"       ]) +  , ("TypeClassWithFunDeps",+      [ ShouldHaveFunDeps          (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]+      ])+   , ("NewOperators",       [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []       ])@@ -298,12 +322,12 @@   ]    where-  n = P.moduleNameFromString+  n = P.moduleNameFromString . T.pack    hasTypeVar varName =     getAny . P.everythingOnTypes (<>) (Any . isVar varName) -  isVar varName (P.TypeVar name) | varName == name = True+  isVar varName (P.TypeVar name) | varName == T.unpack name = True   isVar _ _ = False    renderedType expected =

tests/TestPsci.hs view

@@ -10,6 +10,7 @@ import Control.Monad (when)  import Data.List (sort)+import qualified Data.Text as T  import System.Exit (exitFailure) import System.Console.Haskeline@@ -127,11 +128,11 @@     Left err ->       print err >> exitFailure     Right modules ->-      let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]+      let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)]           dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"       in  return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))  controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))   where-  s = P.moduleNameFromString+  s = P.moduleNameFromString . T.pack

tests/TestUtils.hs view

@@ -104,6 +104,7 @@   , "Data.Ring"   , "Data.Semigroup"   , "Data.Semiring"+  , "Data.Symbol"   , "Data.Show"   , "Data.Unit"   , "Data.Void"@@ -112,6 +113,7 @@   , "Prelude"   , "Test.Assert"   , "Test.Main"+  , "Unsafe.Coerce"   ]  pushd :: forall a. FilePath -> IO a -> IO a

tests/support/bower.json view

@@ -9,6 +9,8 @@     "purescript-st": "1.0.0-rc.1",     "purescript-partial": "1.1.2",     "purescript-newtype": "0.1.0",-    "purescript-generics-rep": "2.0.0"+    "purescript-generics-rep": "2.0.0",+    "purescript-symbols": "^1.0.1",+    "purescript-unsafe-coerce": "^1.0.0"   } }