diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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 diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/) diff --git a/examples/docs/src/TypeClassWithFunDeps.purs b/examples/docs/src/TypeClassWithFunDeps.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/TypeClassWithFunDeps.purs @@ -0,0 +1,5 @@ + +module TypeClassWithFunDeps where + +class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where + aMember :: a diff --git a/examples/failing/2434.purs b/examples/failing/2434.purs new file mode 100644 --- /dev/null +++ b/examples/failing/2434.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +x :: Char +x = '\x10000' diff --git a/examples/failing/RowInInstanceNotDetermined0.purs b/examples/failing/RowInInstanceNotDetermined0.purs new file mode 100644 --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined0.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude + +-- no fundeps +class C a b +instance c :: C Unit {} + diff --git a/examples/failing/RowInInstanceNotDetermined1.purs b/examples/failing/RowInInstanceNotDetermined1.purs new file mode 100644 --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined1.purs @@ -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 {} + diff --git a/examples/failing/RowInInstanceNotDetermined2.purs b/examples/failing/RowInInstanceNotDetermined2.purs new file mode 100644 --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined2.purs @@ -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 {} + diff --git a/examples/passing/2438.purs b/examples/passing/2438.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2438.purs @@ -0,0 +1,8 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +done :: String +done = {"𝌆": "Done"}."𝌆" + +main = log done diff --git a/examples/passing/RowInInstanceHeadDetermined.purs b/examples/passing/RowInInstanceHeadDetermined.purs new file mode 100644 --- /dev/null +++ b/examples/passing/RowInInstanceHeadDetermined.purs @@ -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" + diff --git a/examples/passing/SolvingIsSymbol.purs b/examples/passing/SolvingIsSymbol.purs new file mode 100644 --- /dev/null +++ b/examples/passing/SolvingIsSymbol.purs @@ -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") diff --git a/examples/passing/SolvingIsSymbol/Lib.purs b/examples/passing/SolvingIsSymbol/Lib.purs new file mode 100644 --- /dev/null +++ b/examples/passing/SolvingIsSymbol/Lib.purs @@ -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 + diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -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" diff --git a/examples/warning/2140.purs b/examples/warning/2140.purs new file mode 100644 --- /dev/null +++ b/examples/warning/2140.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +class Test a where + f :: (forall a. a -> a) -> a -> a diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -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 diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -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 diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -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 # diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -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 diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where import Prelude () diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -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) diff --git a/psc-package/Main.hs b/psc-package/Main.hs --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -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 $ diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -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 diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -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 diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -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 -- diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -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) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- Operators fixity and associativity -- diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -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 diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -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 = diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -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 diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -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 -- diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -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" diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -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 diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -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) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -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 diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -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) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -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" diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -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] diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -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 -- diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -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" diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -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 diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -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 -- | diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -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 diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -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)) diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -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 diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -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 diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -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 diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -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 diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -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)] [] [] [])) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -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) diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -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" diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -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) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -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.")) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -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) => diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -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 diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Completion ( getCompletions , getExactMatches diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs --- a/src/Language/PureScript/Ide/Conversions.hs +++ b/src/Language/PureScript/Ide/Conversions.hs @@ -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 diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -12,7 +12,6 @@ -- Error types for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error ( PscIdeError(..) ) where diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -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}) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Filter ( Filter diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -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 "" 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 "" (T.unpack t) + case P.lex "" t >>= P.runTokenParser "" P.parseImportDeclaration' of Right (mn, P.Explicit refs, mmn) -> Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Logging.hs @@ -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" diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,7 +14,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Matcher ( Matcher diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -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")] diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -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@ diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -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 diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -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)] _ -> [] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -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] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -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 = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -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 diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -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) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -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) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -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) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -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 diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -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 diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -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 _ = [] diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -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 diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -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)) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -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 diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -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 diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -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 diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -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 diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -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 diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -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] diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -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 "!" diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -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 diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Publish ( preparePackage diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) , PackageWarning(..) diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -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. diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -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)) diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -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)) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -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 ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -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 _ = [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -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 _ = [] diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.TypeChecker.TypeSearch ( typeSearch ) where diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -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) diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -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) + diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-6.10 +resolver: lts-6.25 packages: - '.' diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -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 diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -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" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -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 = diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -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 diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -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 diff --git a/tests/support/bower.json b/tests/support/bower.json --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -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" } }