summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-12-11 02:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-12-11 02:42:00 (GMT)
commit79948f219fa19b886408053ae2e9ec97d28ccf45 (patch)
tree1f1314c04d2f2d1cec8060add8cb13e2847cf2f8
parentab4b395c66e5fb609628ec32fc9142fafc083207 (diff)
version 0.10.30.10.3
-rw-r--r--CONTRIBUTING.md2
-rw-r--r--CONTRIBUTORS.md2
-rw-r--r--README.md2
-rw-r--r--examples/docs/src/TypeClassWithFunDeps.purs5
-rw-r--r--examples/failing/2434.purs5
-rw-r--r--examples/failing/RowInInstanceNotDetermined0.purs9
-rw-r--r--examples/failing/RowInInstanceNotDetermined1.purs9
-rw-r--r--examples/failing/RowInInstanceNotDetermined2.purs9
-rw-r--r--examples/passing/2438.purs8
-rw-r--r--examples/passing/RowInInstanceHeadDetermined.purs40
-rw-r--r--examples/passing/SolvingIsSymbol.purs13
-rw-r--r--examples/passing/SolvingIsSymbol/Lib.purs10
-rw-r--r--examples/passing/StringEscapes.purs21
-rw-r--r--examples/warning/2140.purs5
-rw-r--r--hierarchy/Main.hs3
-rw-r--r--psc-bundle/Main.hs4
-rw-r--r--psc-docs/Main.hs9
-rw-r--r--psc-docs/Tags.hs4
-rw-r--r--psc-ide-client/Main.hs1
-rw-r--r--psc-ide-server/Main.hs42
-rw-r--r--psc-package/Main.hs25
-rw-r--r--purescript.cabal7
-rw-r--r--src/Control/Monad/Supply/Class.hs10
-rw-r--r--src/Language/PureScript/AST/Declarations.hs38
-rw-r--r--src/Language/PureScript/AST/Literals.hs5
-rw-r--r--src/Language/PureScript/AST/Operators.hs2
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs19
-rw-r--r--src/Language/PureScript/Bundle.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs48
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs28
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs90
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs22
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs99
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs23
-rw-r--r--src/Language/PureScript/Comments.hs5
-rw-r--r--src/Language/PureScript/Constants.hs251
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs10
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs5
-rw-r--r--src/Language/PureScript/CoreFn/ToJSON.hs24
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs5
-rw-r--r--src/Language/PureScript/Docs/Convert.hs5
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs31
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs57
-rw-r--r--src/Language/PureScript/Docs/Render.hs34
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs18
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs4
-rw-r--r--src/Language/PureScript/Docs/Types.hs22
-rw-r--r--src/Language/PureScript/Environment.hs73
-rw-r--r--src/Language/PureScript/Errors.hs295
-rw-r--r--src/Language/PureScript/Errors/JSON.hs13
-rw-r--r--src/Language/PureScript/Externs.hs20
-rw-r--r--src/Language/PureScript/Ide.hs19
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs10
-rw-r--r--src/Language/PureScript/Ide/Command.hs18
-rw-r--r--src/Language/PureScript/Ide/Completion.hs1
-rw-r--r--src/Language/PureScript/Ide/Conversions.hs20
-rw-r--r--src/Language/PureScript/Ide/Error.hs1
-rw-r--r--src/Language/PureScript/Ide/Externs.hs38
-rw-r--r--src/Language/PureScript/Ide/Filter.hs1
-rw-r--r--src/Language/PureScript/Ide/Imports.hs12
-rw-r--r--src/Language/PureScript/Ide/Logging.hs37
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs1
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs4
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs6
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs5
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs24
-rw-r--r--src/Language/PureScript/Ide/State.hs21
-rw-r--r--src/Language/PureScript/Ide/Types.hs17
-rw-r--r--src/Language/PureScript/Ide/Util.hs29
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs20
-rw-r--r--src/Language/PureScript/Interactive.hs39
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs12
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs3
-rw-r--r--src/Language/PureScript/Interactive/Printer.hs28
-rw-r--r--src/Language/PureScript/Linter.hs26
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs11
-rw-r--r--src/Language/PureScript/Linter/Imports.hs5
-rw-r--r--src/Language/PureScript/Make.hs53
-rw-r--r--src/Language/PureScript/Names.hs40
-rw-r--r--src/Language/PureScript/Parser/Common.hs21
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs16
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs171
-rw-r--r--src/Language/PureScript/Parser/Types.hs12
-rw-r--r--src/Language/PureScript/Pretty/Common.hs48
-rw-r--r--src/Language/PureScript/Pretty/JS.hs93
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs8
-rw-r--r--src/Language/PureScript/Pretty/Types.hs21
-rw-r--r--src/Language/PureScript/Pretty/Values.hs82
-rw-r--r--src/Language/PureScript/Publish.hs1
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs2
-rw-r--r--src/Language/PureScript/Renamer.hs6
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs7
-rw-r--r--src/Language/PureScript/Sugar/Operators/Expr.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs22
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs18
-rw-r--r--src/Language/PureScript/TypeChecker.hs83
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs73
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs1
-rw-r--r--src/Language/PureScript/TypeChecker/TypeSearch.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs14
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs8
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs13
-rw-r--r--src/Language/PureScript/Types.hs84
-rw-r--r--stack.yaml2
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs3
-rw-r--r--tests/TestCompiler.hs39
-rw-r--r--tests/TestDocs.hs36
-rw-r--r--tests/TestPsci.hs5
-rw-r--r--tests/TestUtils.hs2
-rw-r--r--tests/support/bower.json4
113 files changed, 1714 insertions, 1220 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 888a087..65443cc 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -12,7 +12,7 @@ Please follow the following guidelines:
- 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
index ae69642..d4e6edf 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -78,12 +78,14 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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
index cc391f7..f7e5a86 100644
--- a/README.md
+++ b/README.md
@@ -17,7 +17,7 @@ A small strongly typed programming language with expressive types that compiles
## 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
index 0000000..3fd918a
--- /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
index 0000000..87c41ff
--- /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
index 0000000..6e2a9d8
--- /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
index 0000000..39083a9
--- /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
index 0000000..141e9c5
--- /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
index 0000000..75bd83c
--- /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
index 0000000..73a89ba
--- /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
index 0000000..e14866a
--- /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
index 0000000..18ea3b2
--- /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
index 5867819..55487d1 100644
--- 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
index 0000000..3369cba
--- /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
index 291d4a3..8700870 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -25,6 +25,7 @@ import Data.List (intercalate,nub,sort)
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 @@ instance Ord SuperMap where
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
index 7caeac3..ab4a09a 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -20,7 +20,7 @@ import System.FilePath (takeDirectory)
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 @@ main = do
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
index 2f5abb4..ff557bc 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -8,6 +8,7 @@ import Control.Arrow (first, second)
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 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
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 :: String -> DocgenOutputItem
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
index eb17442..df5d2be 100644
--- 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
index 85d56a6..932a4b2 100644
--- 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
index 675966a..7bdb9b6 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -30,6 +30,7 @@ import qualified Data.Text.IO as T
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 Network.Socket hiding (PortNumber, Type,
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 @@ data Options = Options
, 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 @@ main = do
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 @@ main = do
<*> (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 @@ startServer port env = withSocketsDo $ do
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
@@ -132,7 +153,6 @@ startServer port env = withSocketsDo $ do
hFlush stdout
liftIO (hClose h)
-
acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
=> Socket -> m (Text, Handle)
acceptCommand sock = do
diff --git a/psc-package/Main.hs b/psc-package/Main.hs
index ef90ee1..b6b7943 100644
--- a/psc-package/Main.hs
+++ b/psc-package/Main.hs
@@ -119,7 +119,7 @@ readPackageSet PackageConfig{ set } = do
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 @@ install pkgName = do
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 @@ listDependencies = do
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 @@ main = do
, 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 @@ main = do
, 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
index 0c3540a..d39f3fe 100644
--- 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 @@ extra-source-files: examples/passing/*.purs
, 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 @@ library
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 @@ library
PatternSynonyms
RankNTypes
RecordWildCards
+ OverloadedStrings
ScopedTypeVariables
TupleSections
ViewPatterns
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 00d70cf..64038a6 100644
--- 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 Prelude.Compat
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 Monad m => MonadSupply (SupplyT m) where
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
index fde3ff5..9029b1a 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -11,6 +11,7 @@ import Control.Monad.Identity
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 @@ data SimpleErrorMessage
| 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 @@ data SimpleErrorMessage
| DeclConflict Name Name
| ExportConflict (Qualified Name) (Qualified Name)
| DuplicateModule ModuleName [SourceSpan]
- | DuplicateTypeArgument String
+ | DuplicateTypeArgument Text
| InvalidDoBind
| InvalidDoLet
| CycleInDeclaration Ident
@@ -89,7 +90,7 @@ data SimpleErrorMessage
| 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 @@ data SimpleErrorMessage
| 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 @@ data SimpleErrorMessage
| 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 @@ data SimpleErrorMessage
| 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 @@ data ErrorMessageHint
| 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 @@ data ErrorMessageHint
| 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 @@ data Declaration
-- |
-- 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 @@ data Declaration
-- |
-- 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 @@ data Declaration
-- |
-- 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 @@ data Expr
-- 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 @@ data Expr
-- 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 @@ data Expr
-- |
-- 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
index 01da91d..3a45623 100644
--- 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 @@ data Literal a
-- |
-- A string literal
--
- | StringLiteral String
+ | StringLiteral Text
-- |
-- A character literal
--
@@ -33,5 +34,5 @@ data Literal a
-- |
-- 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
index 0b8e536..c562e7d 100644
--- 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
index 266a94e..5dfb98b 100644
--- 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 Prelude.Compat
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 @@ data SourcePos = SourcePos
, 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 @@ data SourceSpan = SourceSpan
, 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
index 1ef4953..2a36afe 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -534,6 +534,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
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 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
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
index 94b5c5e..2625a6a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -10,16 +10,18 @@ module Language.PureScript.CodeGen.JS
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
, 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- |
-- 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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
index b6e1b8a..5f124dd 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -5,7 +5,9 @@ module Language.PureScript.CodeGen.JS.AST where
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 @@ data JS
-- |
-- A string literal
--
- | JSStringLiteral (Maybe SourceSpan) String
+ | JSStringLiteral (Maybe SourceSpan) Text
-- |
-- A boolean literal
--
@@ -154,15 +156,15 @@ data JS
-- |
-- 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 @@ data JS
-- |
-- Variable
--
- | JSVar (Maybe SourceSpan) String
+ | JSVar (Maybe SourceSpan) Text
-- |
-- Conditional expression
--
@@ -182,7 +184,7 @@ data JS
-- |
-- 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 @@ data JS
-- |
-- 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 @@ data JS
-- |
-- 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
index 758e235..e07b5ab 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -6,15 +6,17 @@ module Language.PureScript.CodeGen.JS.Common where
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 @@ moduleNameToJs (ModuleName pns) =
--
-- * 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 @@ nameIsJsBuiltIn name =
, "WeakSet"
]
-jsAnyReserved :: [String]
+jsAnyReserved :: [Text]
jsAnyReserved =
concat
[ jsKeywords
@@ -149,7 +151,7 @@ jsAnyReserved =
, jsLiterals
]
-jsKeywords :: [String]
+jsKeywords :: [Text]
jsKeywords =
[ "break"
, "case"
@@ -185,7 +187,7 @@ jsKeywords =
, "with"
]
-jsSometimesReserved :: [String]
+jsSometimesReserved :: [Text]
jsSometimesReserved =
[ "await"
, "let"
@@ -193,11 +195,11 @@ jsSometimesReserved =
, "yield"
]
-jsFutureReserved :: [String]
+jsFutureReserved :: [Text]
jsFutureReserved =
[ "enum" ]
-jsFutureReservedStrict :: [String]
+jsFutureReservedStrict :: [Text]
jsFutureReservedStrict =
[ "implements"
, "interface"
@@ -207,7 +209,7 @@ jsFutureReservedStrict =
, "public"
]
-jsOldReserved :: [String]
+jsOldReserved :: [Text]
jsOldReserved =
[ "abstract"
, "boolean"
@@ -227,7 +229,7 @@ jsOldReserved =
, "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
index a7ed7fb..01a41ca 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -5,27 +5,29 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where
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 @@ isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (
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 @@ isUsed var1 = everythingOnJS (||) check
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 :: ([JS] -> [JS]) -> JS -> JS
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
index ff8c7c3..fdc482a 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -16,6 +16,9 @@ import Prelude.Compat
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 @@ inlineCommonOperators = applyAll $
] ++
[ 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 @@ inlineCommonOperators = applyAll $
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 @@ inlineCommonOperators = applyAll $
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 @@ inlineFnComposition = everywhereOnJSTopDownM convert
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
index c1b261e..0a3850d 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -5,7 +5,8 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
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 opts | optionsNoTco opts = id
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 @@ tco' = everywhereOnJS convert
| 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 @@ tco' = everywhereOnJS convert
(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 @@ tco' = everywhereOnJS convert
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 @@ tco' = everywhereOnJS convert
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
index 15356eb..fd8f678 100644
--- 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
index 8f607b9..a472387 100644
--- 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 @@ pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fa
-- 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
index af03744..99a5fa7 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals
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 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
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 @@ findQualModules decls =
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
index 43479a7..0d01b9e 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -6,6 +6,7 @@ module Language.PureScript.CoreFn.Expr where
import Prelude.Compat
import Control.Arrow ((***))
+import Data.Text (Text)
import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn.Binders
@@ -26,11 +27,11 @@ data Expr a
-- |
-- 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
index 69ef3eb..8ad7242 100644
--- 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 Prelude.Compat
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 @@ identToJSON = toJSON . runIdent
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
index 1022e4c..a336030 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -14,6 +14,7 @@ import Control.Monad.Writer (Writer, tell, execWriter)
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 @@ modulesAsMarkdown = mapM_ moduleAsMarkdown
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
index 9eee086..5473cff 100644
--- 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.Error.Class (MonadError)
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 @@ insertValueTypes env m =
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
index f4bce8c..f4fcec2 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports
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.Map (Map)
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 @@ updateReExports env order = execState action
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 ::
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 @@ lookupValueDeclaration importedFrom ident = do
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 @@ lookupValueDeclaration importedFrom ident = do
(declChildren d))
matchesIdent cdecl =
- cdeclTitle cdecl == P.showIdent ident
+ cdeclTitle cdecl == T.unpack (P.showIdent ident)
matchesAndIsTypeClassMember =
uncurry (&&) . (matchesIdent &&& isTypeClassMember)
@@ -238,7 +239,7 @@ lookupValueOpDeclaration
-> 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 ::
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
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
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 @@ lookupModuleDeclarations definedIn moduleName = do
Nothing ->
internalErrorInModule
(definedIn ++ ": module missing: "
- ++ P.runModuleName moduleName)
+ ++ T.unpack (P.runModuleName moduleName))
Just mdl ->
pure (allDeclarations mdl)
@@ -447,7 +448,7 @@ filterDataConstructors
-> 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 @@ filterTypeClassMembers
-> 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
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 @@ internalErrorInModule msg = do
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
index d34df2e..0743560 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -5,16 +5,24 @@ module Language.PureScript.Docs.Convert.Single
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 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
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.ExternDataDeclaration name _) = Just (P.runProperName nam
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.ExternDeclaration _ ty) title =
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 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
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 @@ convertComments cs = do
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 (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
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
index e13e03a..352bff9 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -13,12 +13,16 @@ import Prelude.Compat
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 @@ renderDeclarationWithOptions opts Declaration{..} =
, 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 @@ renderDeclarationWithOptions opts Declaration{..} =
, 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 @@ renderDeclarationWithOptions opts Declaration{..} =
<> 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 @@ renderDeclarationWithOptions opts Declaration{..} =
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 @@ renderConstraintsWithOptions opts constraints
(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 @@ typeApp title typeArgs =
(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
index 332530b..bae5544 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -14,8 +14,10 @@ import Prelude.Compat
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 @@ typeLiterals = mkPattern match
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 @@ typeLiterals = mkPattern match
, 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 @@ typeLiterals = mkPattern match
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 @@ renderConstraints deps ty =
-- 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 @@ matchType = buildPrettyPrinter operators matchTypeAtom
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 @@ preprocessType opts = dePrim . insertPlaceholders opts
-- 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
index 63f837e..05bd8a1 100644
--- 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 Control.Monad.Error.Class (MonadError(..))
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 @@ instance A.ToJSON ContainingModule where
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
index c5e15b2..506d24c 100644
--- 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 @@ data DeclarationInfo
| 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 (ValueDeclaration _) = "value"
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 @@ parseVersion' str =
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 @@ asDeclarationInfo = do
"typeClass" ->
TypeClassDeclaration <$> key "arguments" asTypeArguments
<*> key "superclasses" (eachInArray asConstraint)
+ <*> keyOrDefault "fundeps" [] asFunDeps
"alias" ->
AliasDeclaration <$> key "fixity" asFixity
<*> key "alias" asFixityAlias
@@ -430,6 +429,11 @@ asKind = fromAesonParser
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 @@ asBookmarks = eachInArray asBookmark
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 @@ instance A.ToJSON DeclarationInfo where
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
index 49043e2..01adeed 100644
--- 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 @@ module Language.PureScript.Environment where
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 @@ data Environment = Environment
, 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 @@ data Environment = Environment
-- | 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 @@ data TypeClassData = TypeClassData
-- 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
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 TypeKind
-- |
-- Data type
--
- = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
+ = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
-- |
-- Type synonym
--
@@ -138,7 +189,7 @@ data DataDeclType
| Newtype
deriving (Show, Eq, Ord)
-showDataDeclType :: DataDeclType -> String
+showDataDeclType :: DataDeclType -> Text
showDataDeclType Data = "data"
showDataDeclType Newtype = "newtype"
@@ -155,13 +206,13 @@ instance A.FromJSON DataDeclType where
-- |
-- 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 @@ primTypes =
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
index 60bba56..40ee521 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -18,10 +18,12 @@ import Data.Char (isSpace)
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 Text.PrettyPrint.Boxes as Box
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 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt
-- |
-- 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 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
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 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
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 @@ errorSuggestion err =
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 @@ suggestionSpan e =
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 :: String
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
] ++
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
]
_ -> []
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, 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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
]
]
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
]
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
]
]
renderHint (PositionedError srcSpan) detail =
- paras [ line $ "at " ++ displaySourceSpan srcSpan
+ paras [ line $ "at " <> displaySourceSpan srcSpan
, detail
]
@@ -1006,17 +1012,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
valueDepth | full = 1000
| otherwise = 3
- levelText :: String
+ levelText :: Text
levelText = case level of
Error -> "error"
Warning -> "warning"
@@ -1108,40 +1114,40 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
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,8 +1240,11 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
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
@@ -1249,7 +1258,7 @@ renderBox = unlines
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
index c693640..8b0eadc 100644
--- a/src/Language/PureScript/Errors/JSON.hs
+++ b/src/Language/PureScript/Errors/JSON.hs
@@ -5,6 +5,9 @@ module Language.PureScript.Errors.JSON where
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 @@ data ErrorPosition = ErrorPosition
} 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 @@ toJSONError verbose level e =
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
index 16a70ad..12f04ad 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -17,9 +17,11 @@ module Language.PureScript.Externs
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 @@ import Paths_purescript as Paths
data ExternsFile = ExternsFile
{
-- | The externs version
- efVersion :: String
+ efVersion :: Text
-- | Module name
, efModuleName :: ModuleName
-- | List of module exports
@@ -100,7 +102,7 @@ data ExternsDeclaration =
-- | A type synonym
| EDTypeSynonym
{ edTypeSynonymName :: ProperName 'TypeName
- , edTypeSynonymArguments :: [(String, Maybe Kind)]
+ , edTypeSynonymArguments :: [(Text, Maybe Kind)]
, edTypeSynonymType :: Type
}
-- | A data construtor
@@ -119,7 +121,7 @@ data ExternsDeclaration =
-- | 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 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
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 -> Environment -> ExternsFile
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 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
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
index 0c466ca..77af155 100644
--- 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 @@ findPursuitPackages (PursuitQuery q) =
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 @@ findAvailableExterns = do
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 @@ loadModules moduleNames = do
-- 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
index 00940e4..c54380b 100644
--- 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 @@ splitTypeConstructor = go []
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 :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Tex
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
index 6540db9..c51015f 100644
--- 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
@@ -61,6 +58,21 @@ data Command
| 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
| AddImportForIdentifier Text
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index acb6675..181dbe0 100644
--- 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
index bb5ec88..1420c9d 100644
--- 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
index 5b56717..44ee78e 100644
--- 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
index 1e92bd9..d02f6bf 100644
--- 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 @@ module Language.PureScript.Ide.Externs
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 @@ convertExterns ef =
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 @@ annotateModule (defs, types) (moduleName, decls) =
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
index 6c52549..5648028 100644
--- 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
index b45e367..b8ad743 100644
--- 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 @@ step (Res start end) _ = Res start end
moduleParse :: [Text] -> Either Text P.Module
moduleParse t = first show $ do
- tokens <- (P.lex "" . T.unpack . T.unlines) t
+ tokens <- P.lex "" (T.unlines t)
P.runTokenParser "<psc-ide>" P.parseModule tokens
-- | Adds an implicit import like @import Prelude@ to a Sourcefile.
@@ -210,7 +208,7 @@ addExplicitImport' decl moduleName imports =
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 @@ addImportForIdentifier fp ident filters = do
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 @@ answerRequest outfp rs =
-- | Test and ghci helper
parseImport :: Text -> Maybe Import
parseImport t =
- case P.lex "<psc-ide>" (T.unpack t)
+ case P.lex "<psc-ide>" t
>>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of
Right (mn, P.Explicit refs, mmn) ->
Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)
diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs
new file mode 100644
index 0000000..84f45d2
--- /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
index 7a495d2..531a29e 100644
--- 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
index 90957fa..1143a24 100644
--- 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 @@ import qualified Pipes.Prelude as P
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
index a50646c..b1647ee 100644
--- 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.Errors.JSON
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 @@ rebuildModuleOpen makeEnv externs m = do
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
index f0ac391..47f1927 100644
--- 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 @@ prettyPrintReexportResult f ReexportResult{..}
| 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
index 141e011..c0b9695 100644
--- 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 @@ getImportsForFile fp = do
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 @@ extractSpans ss d = case d of
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
index 3a6ddfc..f24ad0c 100644
--- 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 @@ module Language.PureScript.Ide.State
, resolveOperatorsForModule
) where
-import qualified Prelude
import Protolude
import Control.Concurrent.STM
@@ -46,7 +44,6 @@ import Language.PureScript.Ide.Reexports
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 @@ cachedRebuild = s3CachedRebuild <$> getStage3
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 @@ populateStage2STM ref = do
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
index a9f98aa..3408e34 100644
--- 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 Data.Aeson
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 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation
-- 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 @@ instance ToJSON ModuleImport where
] ++ 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
index 63d208e..0a61278 100644
--- 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 @@ module Language.PureScript.Ide.Util
, 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 @@ identifierFromIdeDeclaration d = case d of
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 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
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 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
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
index 8ae6213..97b45b5 100644
--- a/src/Language/PureScript/Ide/Watcher.hs
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -22,6 +22,7 @@ import Control.Concurrent.STM
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 :: TVar IdeState -> Event -> IO ()
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 @@ reloadFile ref ev = do
-- | 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
index e9534e3..b926383 100644
--- 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 @@ module Language.PureScript.Interactive
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 @@ handleShowLoadedModules = do
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 @@ handleShowImportedModules = do
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 @@ handleKindOf typ = do
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 @@ handleBrowse moduleName = do
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
index 5a875c7..7ab532a 100644
--- 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 Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
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 @@ getLoadedModules = asks (map fst . psciLoadedExterns)
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 @@ getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls
-- | 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 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
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
index c4397f3..e310543 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -9,6 +9,7 @@ import Prelude.Compat hiding (lex)
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 @@ parseCommand cmdString =
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
index 14889e8..38022a7 100644
--- 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 Prelude.Compat
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 @@ printModuleSignatures moduleName P.Environment{..} =
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 @@ printModuleSignatures moduleName P.Environment{..} =
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 @@ printModuleSignatures moduleName P.Environment{..} =
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 @@ printModuleSignatures moduleName P.Environment{..} =
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 @@ printModuleSignatures moduleName P.Environment{..} =
_ -> "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 @@ printModuleSignatures moduleName P.Environment{..} =
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
index 14c8a20..4918c11 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -11,6 +11,7 @@ import Data.List (nub, (\\))
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,9 +45,14 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
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)
@@ -70,16 +76,16 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
| 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 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
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
index 768bd0c..25c5bec 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -19,7 +19,10 @@ import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)
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 @@ getConstructors env defmn n = extractConstructors lnte
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 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (
-- 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 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (
(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
index 7db7706..1dfcede 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -15,6 +15,7 @@ import Data.List (find, intersect, nub, groupBy, sortBy, (\\))
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 @@ findUsedRefs env mni qn names =
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
index 668231b..9f60e06 100644
--- 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 Control.Monad.Writer.Class (MonadWriter(..))
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.Lazy as B
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 SourceMap.Types
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 @@ data ProgressMessage
-- | 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 @@ data MakeActions m = MakeActions
-- |
-- Generated code for an externs file.
--
-type Externs = String
+type Externs = B.ByteString
-- |
-- Determines when to rebuild a module
@@ -155,7 +154,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
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 @@ make ma@MakeActions{..} ms = do
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 @@ makeIO f io = do
-- | 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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
}) 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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
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 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
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 @@ checkForeignDecls m path = do
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 @@ checkForeignDecls m path = do
-- 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
index 6df8185..508a256 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -11,7 +11,9 @@ import Control.Monad.Supply.Class
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 @@ data Ident
-- |
-- 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 @@ freshIdent' = GenIdent Nothing <$> fresh
-- |
-- 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 ToJSON (OpName a) where
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 @@ data OpNameType = ValueOpName | TypeOpName
-- |
-- 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 @@ coerceProperName = ProperName . runProperName
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 @@ moduleNameFromString = ModuleName . splitProperNames
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
index e786a50..67b4205 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -5,8 +5,11 @@ module Language.PureScript.Parser.Common where
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 @@ augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
-- 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 @@ fold first more combine = do
-- 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 @@ mark p = do
-- 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
index 4b505b3..eea6165 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -61,7 +61,7 @@ withSourceSpan f p = do
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 @@ parseModuleFromFile
-> 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 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
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 @@ parseLet = do
return $ Let ds result
parseValueAtom :: TokenParser Expr
-parseValueAtom = P.choice
+parseValueAtom = withSourceSpan PositionedValue $ P.choice
[ parseAnonymousArgument
, Literal <$> parseNumericLiteral
, Literal <$> parseCharLiteral
@@ -418,12 +418,12 @@ parseValueAtom = P.choice
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 @@ parseVarOrNamedBinder = do
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
index 286bb73..cbe90f5 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -6,7 +6,6 @@ module Language.PureScript.Parser.Lexer
, Token()
, TokenParser()
, lex
- , lex'
, anyToken
, token
, match
@@ -63,13 +62,13 @@ module Language.PureScript.Parser.Lexer
)
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 @@ data Token
| 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 Comma = ","
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 @@ data PositionedToken = PositionedToken
-- 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 @@ whitespace = P.skipMany (P.satisfy isSpace)
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 @@ parseToken = P.choice
, 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 @@ parseToken = P.choice
]
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 @@ parseToken = P.choice
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 @@ langDef = PT.LanguageDef
, 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 @@ tokenParser = PT.makeTokenParser langDef
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 @@ at = match At
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 @@ commaSep = flip P.sepBy comma
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 @@ symbol = token go P.<?> "symbol"
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 @@ charLiteral = token go P.<?> "char literal"
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 @@ natural = token go P.<?> "natural"
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 :: Text -> Bool
+validUName s = '\'' `notElemT` s
-validUName :: String -> Bool
-validUName s = '\'' `notElem` 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 @@ reservedPsNames = [ "data"
, "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 @@ isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c
-- 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
index 6bb1e14..d218e6a 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -7,8 +7,10 @@ module Language.PureScript.Parser.Types
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 as P
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 @@ parseTypeWildcard = do
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 @@ parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTabl
, [ 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 @@ noWildcards p = do
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
index 2436a16..f5f0e2f 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -10,20 +10,27 @@ import Prelude.Compat
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 :: Monoid m => m -> [m] -> m
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 @@ newtype StrPos = StrPos (SourcePos, String, [SMap])
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 @@ instance Emit StrPos where
-- 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 @@ withIndent action = do
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 @@ prettyPrintMany f xs = do
-- |
-- 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
index 2b089ea..d142873 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -9,12 +9,15 @@ module Language.PureScript.Pretty.JS
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 Language.PureScript.Pretty.Common
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 @@ literals = mkPattern' match'
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 @@ literals = mkPattern' match'
, 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 @@ literals = mkPattern' match'
]
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 @@ literals = mkPattern' match'
, 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 @@ literals = mkPattern' match'
[ 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 @@ literals = mkPattern' match'
, 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,16 +162,16 @@ string s = emit $ '"' : concatMap encodeChar s ++ "\""
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
@@ -185,7 +192,7 @@ indexer = mkPattern' match
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 @@ instanceOf = mkPattern match
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 @@ unary' op mkStr = Wrap match (<>)
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 @@ negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
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 @@ prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalState
-- |
-- 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 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ 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
index fdcbb38..364ace9 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -11,6 +11,8 @@ import Control.Arrow (ArrowPlus(..))
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 @@ funKind = mkPattern match
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
index 1233dc2..3486077 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -18,6 +18,7 @@ import Control.Arrow ((<+>))
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 Language.PureScript.Types
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 :: Char -> Char -> Type -> Box
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 @@ prettyPrintRowWith open close = uncurry listToBox . toList []
[ 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 @@ matchTypeAtom suggesting =
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 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where
, [ 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 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where
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
index bd36555..72b1734 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -11,6 +11,11 @@ import Prelude.Compat
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 Language.PureScript.Types (Constraint(..))
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 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl
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 @@ prettyPrintValue d (IfThenElse cond th el) =
// 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 @@ prettyPrintValue d (Let ds val) =
(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 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr
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 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon
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 @@ prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDecla
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 _ | d < 0 = ellipsis
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
index d1ce4b5..83589ba 100644
--- 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
index e1c8ed7..db7d7de 100644
--- 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
index 7dfc873..cb28d1e 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -10,7 +10,9 @@ import Control.Monad.State
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 @@ updateScope ident =
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 @@ lookupIdent name = do
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
index d6d3600..b92782a 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -11,6 +11,7 @@ import Control.Monad.Supply.Class
import Data.List (partition)
import Data.Maybe (catMaybes)
+import Data.Text (Text)
import Language.PureScript.AST
import Language.PureScript.Errors
@@ -61,7 +62,7 @@ desugarDecl other = fn other
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 @@ desugarDecl other = fn other
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 @@ desugarDecl other = fn other
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
index 0c9c2b3..84a1691 100644
--- a/src/Language/PureScript/Sugar/Operators/Expr.hs
+++ b/src/Language/PureScript/Sugar/Operators/Expr.hs
@@ -20,7 +20,9 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable
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
index 4d91324..4b1007f 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -27,8 +27,10 @@ import Control.Monad.Error.Class (MonadError(..))
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 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu
-> 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
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 @@ memberToNameAndType _ = internalError "Invalid declaration in type class definit
typeClassDictionaryDeclaration
:: ProperName 'ClassName
- -> [(String, Maybe Kind)]
+ -> [(Text, Maybe Kind)]
-> [Constraint]
-> [Declaration]
-> Declaration
@@ -247,7 +245,7 @@ typeClassDictionaryDeclaration name args implies members =
typeClassMemberToDictionaryAccessor
:: ModuleName
-> ProperName 'ClassName
- -> [(String, Maybe Kind)]
+ -> [(Text, Maybe Kind)]
-> Declaration
-> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
@@ -323,14 +321,14 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
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
index 95dab22..fbf0be8 100755
--- 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 Control.Monad.Supply.Class (MonadSupply)
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 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
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 @@ deriveGeneric mn ds tyConNm dargs = do
(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 @@ deriveOrd mn ds tyConNm = do
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 :: Type -> Maybe Type
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
index 6ffca1f..9b6e1bb 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -16,11 +16,16 @@ import Control.Monad.Error.Class (MonadError(..))
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 @@ addDataType
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
- -> [(String, Maybe Kind)]
+ -> [(Text, Maybe Kind)]
-> [(ProperName 'ConstructorName, [Type])]
-> Kind
-> m ()
@@ -58,7 +63,7 @@ addDataConstructor
=> ModuleName
-> DataDeclType
-> ProperName 'TypeName
- -> [String]
+ -> [Text]
-> ProperName 'ConstructorName
-> [Type]
-> m ()
@@ -68,14 +73,14 @@ addDataConstructor moduleName dtype name args dctor tys = do
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 @@ addTypeClass
:: (MonadState CheckState m)
=> ModuleName
-> ProperName 'ClassName
- -> [(String, Maybe Kind)]
+ -> [(Text, Maybe Kind)]
-> [Constraint]
-> [FunctionalDependency]
-> [Declaration]
@@ -120,12 +125,7 @@ addTypeClass moduleName pn args implies dependencies ds =
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 @@ addTypeClass moduleName pn args implies dependencies ds =
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 @@ addTypeClassDictionaries mn entries =
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 @@ typeCheckAll moduleName _ = traverse go
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 @@ typeCheckAll moduleName _ = traverse go
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 @@ typeCheckAll moduleName _ = traverse go
-- 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
index 01f9fab..a857cdf 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -19,12 +19,14 @@ import Control.Monad.State
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.TypeClassDictionaries
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 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d
-- | 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
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 @@ entails SolverOptions{..} constraint context hints =
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 @@ entails SolverOptions{..} constraint context hints =
-- 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 @@ entails SolverOptions{..} constraint context hints =
-- 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 @@ entails SolverOptions{..} constraint context hints =
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 @@ entails SolverOptions{..} constraint context hints =
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 @@ entails SolverOptions{..} constraint context hints =
--
-- 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 @@ entails SolverOptions{..} constraint context hints =
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 @@ matches deps TypeClassDictionaryInScope{..} tys = do
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 @@ matches deps TypeClassDictionaryInScope{..} tys = do
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 @@ newDictionaries
=> [(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 @@ newDictionaries path name (Constraint className instanceTy _) = do
) 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
index 8138837..fedd623 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -18,6 +18,7 @@ import Control.Monad.Error.Class (MonadError(..))
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 @@ kindOf ty = fst <$> kindOfWithScopedVars ty
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 @@ kindsOf
=> 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 @@ kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . c
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 @@ freshKindVar (arg, Just kind') kind = do
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 @@ starIfUnknown k = k
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
index 79e71fb..909af18 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -15,6 +15,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor)
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 @@ bindTypes newNames action = do
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 @@ warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition
-- | 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 @@ withTypeClassDictionaries entries action = do
-- | 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
index b0ca42f..7b0ee12 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -18,6 +18,7 @@ import Control.Monad.State.Class (MonadState(..), gets, modify)
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 @@ newSkolemScope = do
-- |
-- 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 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
-- 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
index 2838da1..82c685e 100644
--- 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
index c84c360..b78ca07 100644
--- 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
index 5989c26..e417a4a 100644
--- 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.Either (lefts, rights)
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 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do
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 @@ check' val (ForAll ident ty _) = do
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 @@ check' val ty = do
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 @@ checkFunctionApplication' fn u arg = do
-- |
-- 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
index 5d0584b..9625c33 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -24,6 +24,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))
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 @@ unifyRows r1 r2 =
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 @@ unifyRows r1 r2 =
-- |
-- 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 @@ replaceTypeWildcards = everywhereOnTypesM replace
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
index 59becfd..13281c1 100644
--- 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 @@ import Language.PureScript.Types
-- |
-- 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 @@ data TypeClassDictionaryInScope
-- | 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
index a38300c..1477015 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -9,11 +9,13 @@ module Language.PureScript.Types where
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 @@ data Type
-- | 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 @@ data Type
-- | 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 @@ data Type
-- | 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 @@ data Type
-- | 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 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData)
-- |
-- 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 @@ rowToList r = ([], r)
-- |
-- 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 @@ isMonoType _ = True
-- |
-- 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 @@ replaceAllTypeVars = go []
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 @@ usedTypeVariables = nub . everythingOnTypes (++) go
-- |
-- 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 @@ everywhereOnTypesTopDownM f = go <=< f
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
index f800d9d..3fbbbeb 100644
--- 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
index f273938..d5d394c 100644
--- 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 Language.PureScript.Ide.Types
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
index a11babe..4fc8552 100644
--- 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.Function (on)
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.Exit
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 @@ spec = do
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 @@ spec = do
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 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi
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 @@ compile
-> 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 @@ checkMain ms =
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 @@ assertCompiles supportExterns inputFiles =
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 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith =
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
index 1d56293..c689437 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -13,6 +13,7 @@ import Data.Monoid
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 @@ main = pushd "examples/docs" $ do
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 @@ data Assertion
-- | 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 @@ data AssertionFailure
| 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 @@ runAssertion assertion Docs.Module{..} =
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 @@ checkConstrained ty tyClass =
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 @@ testCases =
, ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
])
+ , ("TypeClassWithFunDeps",
+ [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
+ ])
+
, ("NewOperators",
[ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
])
@@ -298,12 +322,12 @@ testCases =
]
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
index 19eb961..f758acb 100644
--- a/tests/TestPsci.hs
+++ b/tests/TestPsci.hs
@@ -10,6 +10,7 @@ import Control.Monad.Trans.State.Strict (evalStateT)
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 @@ getPSCiState = do
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
index 6c8e099..cf67a38 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -104,6 +104,7 @@ supportModules =
, "Data.Ring"
, "Data.Semigroup"
, "Data.Semiring"
+ , "Data.Symbol"
, "Data.Show"
, "Data.Unit"
, "Data.Void"
@@ -112,6 +113,7 @@ supportModules =
, "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
index d2f01dd..2de10e8 100644
--- 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"
}
}