summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-01-06 03:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-01-06 03:44:00 (GMT)
commit393ecc8ee0178ccac2b9ae81e74708f0d17b2ca5 (patch)
treee9ef260318e657e04a175ac647cc2d0cfe24d56b
parentdfc92b2cabaa9529df644929982e90166ffdea4d (diff)
version 0.10.50.10.5
-rw-r--r--examples/failing/2534.purs8
-rw-r--r--examples/failing/DeclConflictDuplicateCtor.purs5
-rw-r--r--examples/passing/StringEdgeCases.purs9
-rw-r--r--examples/passing/StringEdgeCases/Records.purs66
-rw-r--r--examples/passing/StringEdgeCases/Symbols.purs30
-rw-r--r--examples/passing/StringEscapes.purs2
-rw-r--r--purescript.cabal8
-rw-r--r--src/Language/PureScript/AST/Declarations.hs14
-rw-r--r--src/Language/PureScript/AST/Literals.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs34
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs3
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs3
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs5
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs6
-rw-r--r--src/Language/PureScript/CoreFn/ToJSON.hs15
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs12
-rw-r--r--src/Language/PureScript/Docs/Types.hs13
-rw-r--r--src/Language/PureScript/Errors.hs22
-rw-r--r--src/Language/PureScript/Kinds.hs70
-rw-r--r--src/Language/PureScript/Label.hs16
-rw-r--r--src/Language/PureScript/PSString.hs187
-rw-r--r--src/Language/PureScript/Parser/Common.hs7
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs17
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs24
-rw-r--r--src/Language/PureScript/Parser/Types.hs6
-rw-r--r--src/Language/PureScript/Pretty.hs1
-rw-r--r--src/Language/PureScript/Pretty/Common.hs12
-rw-r--r--src/Language/PureScript/Pretty/JS.hs40
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs25
-rw-r--r--src/Language/PureScript/Pretty/Types.hs28
-rw-r--r--src/Language/PureScript/Pretty/Values.hs15
-rw-r--r--src/Language/PureScript/Publish.hs13
-rw-r--r--src/Language/PureScript/Publish/BoxesHelpers.hs5
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs14
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs7
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs8
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs6
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs63
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs1
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs270
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs3
-rw-r--r--src/Language/PureScript/Types.hs10
-rw-r--r--stack.yaml2
-rw-r--r--tests/TestPsci.hs2
-rw-r--r--tests/TestUtils.hs20
-rw-r--r--tests/support/bower.json1
49 files changed, 819 insertions, 335 deletions
diff --git a/examples/failing/2534.purs b/examples/failing/2534.purs
new file mode 100644
index 0000000..a4a4f27
--- /dev/null
+++ b/examples/failing/2534.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InfiniteType
+module Main where
+
+foo :: Array Int -> Int
+foo xs = go xs where
+ go :: Array _ -> Int
+ go [] = 0
+ go xs = go [xs]
diff --git a/examples/failing/DeclConflictDuplicateCtor.purs b/examples/failing/DeclConflictDuplicateCtor.purs
new file mode 100644
index 0000000..cc2a28e
--- /dev/null
+++ b/examples/failing/DeclConflictDuplicateCtor.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith DeclConflict
+module Main where
+
+data T = Fail | Fail
+
diff --git a/examples/passing/StringEdgeCases.purs b/examples/passing/StringEdgeCases.purs
new file mode 100644
index 0000000..b361eb1
--- /dev/null
+++ b/examples/passing/StringEdgeCases.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Prelude
+import Records as Records
+import Symbols as Symbols
+
+main = do
+ Records.main
+ Symbols.main
diff --git a/examples/passing/StringEdgeCases/Records.purs b/examples/passing/StringEdgeCases/Records.purs
new file mode 100644
index 0000000..faa58c6
--- /dev/null
+++ b/examples/passing/StringEdgeCases/Records.purs
@@ -0,0 +1,66 @@
+module Records where
+
+import Prelude
+import Data.Generic (class Generic, toSpine, GenericSpine(..))
+import Control.Monad.Eff.Console (log)
+import Test.Assert (assert')
+
+newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int }
+newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int }
+
+derive instance genericAstralKeys :: Generic AstralKeys
+derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys
+
+spineOf :: forall a. Generic a => a -> Unit -> GenericSpine
+spineOf x _ = toSpine x
+
+testLoneSurrogateKeys =
+ let
+ expected = 5
+ actual = (_."\xd801" <<< helper) { "\xd800": 5 }
+ in
+ assert' ("lone surrogate keys: " <> show actual) (expected == actual)
+
+ where
+ helper :: { "\xd800" :: Int } -> { "\xd801" :: Int }
+ helper o =
+ case o."\xd800" of
+ x -> { "\xd801": x }
+
+testAstralKeys =
+ let
+ expected = 5
+ actual = (_."💢" <<< helper) { "💡": 5 }
+ in
+ assert' ("astral keys: " <> show actual) (expected == actual)
+
+ where
+ helper :: { "💡" :: Int } -> { "💢" :: Int }
+ helper o =
+ case o."💡" of
+ x -> { "💢": x }
+
+testGenericLoneSurrogateKeys = do
+ let expected = SProd "Records.LoneSurrogateKeys"
+ [ \_ -> SRecord [ {recLabel: "\xd834", recValue: spineOf 1}
+ , {recLabel: "\xdf06", recValue: spineOf 0}
+ ]
+ ]
+ actual = toSpine (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 })
+ assert' ("generic lone surrogate keys: " <> show actual) (expected == actual)
+
+testGenericAstralKeys = do
+ let expected = SProd "Records.AstralKeys"
+ [ \_ -> SRecord [ {recLabel: "💡", recValue: spineOf 0}
+ , {recLabel: "💢", recValue: spineOf 1}
+ ]
+ ]
+ actual = toSpine (AstralKeys { "💡": 0, "💢": 1 })
+ assert' ("generic astral keys: " <> show actual) (expected == actual)
+
+main = do
+ testLoneSurrogateKeys
+ testAstralKeys
+ testGenericLoneSurrogateKeys
+ testGenericAstralKeys
+ log "Done"
diff --git a/examples/passing/StringEdgeCases/Symbols.purs b/examples/passing/StringEdgeCases/Symbols.purs
new file mode 100644
index 0000000..991563a
--- /dev/null
+++ b/examples/passing/StringEdgeCases/Symbols.purs
@@ -0,0 +1,30 @@
+-- This is similar to StringEscapes except we are performing the same tests
+-- with Symbols (at the type level).
+
+module Symbols where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol)
+import Test.Assert (assert')
+
+highS :: SProxy "\xd834"
+highS = SProxy
+
+lowS :: SProxy "\xdf06"
+lowS = SProxy
+
+loneSurrogates :: Boolean
+loneSurrogates = reflectSymbol (appendSymbol highS lowS) == "\x1d306"
+
+outOfOrderSurrogates :: Boolean
+outOfOrderSurrogates = reflectSymbol (appendSymbol lowS highS) == "\xdf06\xd834"
+
+notReplacing :: Boolean
+notReplacing = reflectSymbol lowS /= "\xfffd"
+
+main = do
+ 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/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs
index 55487d1..9fbcab2 100644
--- a/examples/passing/StringEscapes.purs
+++ b/examples/passing/StringEscapes.purs
@@ -22,5 +22,5 @@ main = do
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
+ assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing
log "Done"
diff --git a/purescript.cabal b/purescript.cabal
index bf50897..1ba5bb2 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.10.4
+version: 0.10.5
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -54,6 +54,7 @@ extra-source-files: examples/passing/*.purs
, examples/passing/ResolvableScopeConflict3/*.purs
, examples/passing/ShadowedModuleName/*.purs
, examples/passing/SolvingIsSymbol/*.purs
+ , examples/passing/StringEdgeCases/*.purs
, examples/passing/TransitiveImport/*.purs
, examples/passing/TypeOperators/*.purs
, examples/passing/TypeWithoutParens/*.purs
@@ -116,7 +117,7 @@ library
aeson-better-errors >= 0.8,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
- bower-json >= 0.8,
+ bower-json >= 1.0.0.1 && < 1.1,
boxes >= 0.1.4 && < 0.2.0,
bytestring -any,
containers -any,
@@ -146,6 +147,7 @@ library
protolude >= 0.1.6,
regex-tdfa -any,
safe >= 0.3.9 && < 0.4,
+ scientific >= 0.3.4.9 && < 0.4,
semigroups >= 0.16.2 && < 0.19,
sourcemap >= 0.1.6,
spdx == 0.2.*,
@@ -199,6 +201,7 @@ library
Language.PureScript.Errors
Language.PureScript.Errors.JSON
Language.PureScript.Kinds
+ Language.PureScript.Label
Language.PureScript.Linter
Language.PureScript.Linter.Exhaustive
Language.PureScript.Linter.Imports
@@ -219,6 +222,7 @@ library
Language.PureScript.Pretty.Kinds
Language.PureScript.Pretty.Types
Language.PureScript.Pretty.Values
+ Language.PureScript.PSString
Language.PureScript.Renamer
Language.PureScript.Sugar
Language.PureScript.Sugar.BindingGroups
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 781ec09..8be4193 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -18,6 +18,8 @@ import Language.PureScript.AST.Literals
import Language.PureScript.AST.Operators
import Language.PureScript.AST.SourcePos
import Language.PureScript.Types
+import Language.PureScript.PSString (PSString)
+import Language.PureScript.Label (Label)
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.TypeClassDictionaries
@@ -90,7 +92,7 @@ data SimpleErrorMessage
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotFindDerivingType (ProperName 'TypeName)
- | DuplicateLabel Text (Maybe Expr)
+ | DuplicateLabel Label (Maybe Expr)
| DuplicateValueDeclaration Ident
| ArgListLengthsDiffer Ident
| OverlappingArgNames (Maybe Ident)
@@ -99,8 +101,8 @@ data SimpleErrorMessage
| ExpectedType Type Kind
| IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
| ExprDoesNotHaveType Expr Type
- | PropertyIsMissing Text
- | AdditionalProperty Text
+ | PropertyIsMissing Label
+ | AdditionalProperty Label
| TypeSynonymInstance
| OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtype (ProperName 'TypeName)
@@ -145,7 +147,7 @@ data ErrorMessageHint
| ErrorInModule ModuleName
| ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
| ErrorInSubsumption Type Type
- | ErrorCheckingAccessor Expr Text
+ | ErrorCheckingAccessor Expr PSString
| ErrorCheckingType Expr Type
| ErrorCheckingKind Type
| ErrorCheckingGuard
@@ -573,11 +575,11 @@ data Expr
-- Anonymous arguments will be removed during desugaring and expanded
-- into a lambda that reads a property from a record.
--
- | Accessor Text Expr
+ | Accessor PSString Expr
-- |
-- Partial record update
--
- | ObjectUpdate Expr [(Text, Expr)]
+ | ObjectUpdate Expr [(PSString, Expr)]
-- |
-- Function introduction
--
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index 3a45623..a161fd8 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -4,7 +4,7 @@
module Language.PureScript.AST.Literals where
import Prelude.Compat
-import Data.Text (Text)
+import Language.PureScript.PSString (PSString)
-- |
-- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -18,7 +18,7 @@ data Literal a
-- |
-- A string literal
--
- | StringLiteral Text
+ | StringLiteral PSString
-- |
-- A character literal
--
@@ -34,5 +34,5 @@ data Literal a
-- |
-- An object literal
--
- | ObjectLiteral [(Text, a)]
+ | ObjectLiteral [(PSString, a)]
deriving (Eq, Ord, Show, Functor)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index c92de6b..0abc9de 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -20,6 +20,7 @@ import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid ((<>))
+import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
@@ -34,6 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
errorMessage, rethrowWithPosition, addHint)
import Language.PureScript.Names
import Language.PureScript.Options
+import Language.PureScript.PSString (PSString, mkString, decodeString)
import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
@@ -65,8 +67,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` (fst `map` foreigns)
let standardExps = exps \\ foreignExps
- let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps
- ++ map (runIdent &&& foreignIdent) foreignExps
+ let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps
+ ++ map (mkString . runIdent &&& foreignIdent) foreignExps
return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
where
@@ -108,7 +110,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 (T.pack (".." </> T.unpack (runModuleName mn')))]
+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn')))]
withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
-- |
@@ -176,12 +178,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- indexer is returned.
--
accessor :: Ident -> JS -> JS
- accessor (Ident prop) = accessorString prop
+ accessor (Ident prop) = accessorString $ mkString prop
accessor (GenIdent _ _) = internalError "GenIdent in accessor"
- accessorString :: Text -> JS -> JS
- accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
- | otherwise = JSAccessor Nothing prop
+ accessorString :: PSString -> JS -> JS
+ accessorString prop =
+ case decodeString prop of
+ Just s | not (identNeedsEscaping s) ->
+ JSAccessor Nothing s
+ _ ->
+ JSIndexer Nothing (JSStringLiteral Nothing prop)
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
@@ -212,7 +218,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
unAbs (Abs _ arg val) = arg : unAbs val
unAbs _ = []
assign :: Ident -> JS
- assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))
+ assign name = JSAssignment Nothing (accessorString (mkString $ runIdent name) (JSVar Nothing "this"))
(var name)
valueToJs' (Abs _ arg val) = do
ret <- valueToJs val
@@ -272,7 +278,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 (T.singleton c)
+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (fromString [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
@@ -280,7 +286,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- |
-- Shallow copy an object.
--
- extendObj :: JS -> [(Text, JS)] -> m JS
+ extendObj :: JS -> [(PSString, JS)] -> m JS
extendObj obj sts = do
newObj <- freshName
key <- freshName
@@ -317,7 +323,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)
foreignIdent :: Ident -> JS
- foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")
+ foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign")
-- |
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
@@ -341,7 +347,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
go _ _ _ = internalError "Invalid arguments to bindersToJs"
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)]
+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing $ mkString failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]
failedPatternMessage :: Text
failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": "
@@ -402,7 +408,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 (T.singleton c))) (JSBlock Nothing done) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (fromString [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) =
@@ -411,7 +417,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] -> [(Text, Binder Ann)] -> m [JS]
+ go :: [JS] -> [(PSString, 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 5f124dd..8f3583c 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -11,6 +11,7 @@ import Data.Text (Text)
import Language.PureScript.AST (SourceSpan(..))
import Language.PureScript.Comments
+import Language.PureScript.PSString (PSString)
import Language.PureScript.Traversals
-- |
@@ -132,7 +133,7 @@ data JS
-- |
-- A string literal
--
- | JSStringLiteral (Maybe SourceSpan) Text
+ | JSStringLiteral (Maybe SourceSpan) PSString
-- |
-- A boolean literal
--
@@ -156,7 +157,7 @@ data JS
-- |
-- An object literal
--
- | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)]
+ | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]
-- |
-- An object property accessor expression
--
@@ -240,7 +241,8 @@ data JS
-- |
-- Commented Javascript
--
- | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq)
+ | JSComment (Maybe SourceSpan) [Comment] JS
+ deriving (Show, Eq)
withSourceSpan :: SourceSpan -> JS -> JS
withSourceSpan withSpan = go
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
index 01a41ca..3fc9ca3 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -11,6 +11,7 @@ import Data.Maybe (fromMaybe)
import Language.PureScript.Crash
import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.PSString (mkString)
applyAll :: [a -> a] -> a -> a
applyAll = foldl' (.) id
@@ -73,7 +74,7 @@ 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
+ x == mkString fnName && y == moduleName
isFn _ _ = False
isDict :: (Text, Text) -> JS -> Bool
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index fdc482a..753b63d 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -239,7 +239,7 @@ inlineCommonOperators = applyAll $
isModFn _ _ = False
isModFnWithDict :: (Text, Text) -> JS -> Bool
- isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'
+ isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op'
isModFnWithDict _ _ = False
-- (f <<< g $ x) = f (g x)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
index 8fb82ab..bb37d2c 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
@@ -12,6 +12,7 @@ import Data.Maybe (fromJust, isJust)
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.JS.Optimizer.Common
import Language.PureScript.Options
+import Language.PureScript.PSString (mkString)
import qualified Language.PureScript.Constants as C
magicDo :: Options -> JS -> JS
@@ -104,7 +105,7 @@ inlineST = everywhereOnJS convertBlock
-- or in a more aggressive way, turning wrappers into local variables depending on the
-- agg(ressive) parameter.
convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
- JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])
+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])
convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
if agg then ref else JSAccessor s1 C.stRefValue ref
convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 99a5fa7..d02657c 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -24,6 +24,7 @@ import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)
import Language.PureScript.Types
+import Language.PureScript.PSString (mkString)
import qualified Language.PureScript.AST as A
-- |
@@ -119,7 +120,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
in foldl (App (ss, com, Nothing, Nothing)) ctor args
exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =
Abs (ss, com, ty, Nothing) (Ident "dict")
- (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
+ (Accessor nullAnn (mkString $ runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
exprToCoreFn (Just ss) (com ++ com1) ty v
exprToCoreFn _ _ _ e =
@@ -265,7 +266,7 @@ mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.De
mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
mkTypeClassConstructor ss com supers members =
let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
- props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
+ props = [ (mkString arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
dict = Literal nullAnn (ObjectLiteral props)
in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
(Ident a)
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 0d01b9e..981bf37 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -6,11 +6,11 @@ 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
import Language.PureScript.Names
+import Language.PureScript.PSString (PSString)
-- |
-- Data type for expressions and terms
@@ -27,11 +27,11 @@ data Expr a
-- |
-- A record property accessor
--
- | Accessor a Text (Expr a)
+ | Accessor a PSString (Expr a)
-- |
-- Partial record update
--
- | ObjectUpdate a (Expr a) [(Text, Expr a)]
+ | ObjectUpdate a (Expr a) [(PSString, Expr a)]
-- |
-- Function introduction
--
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index 8ad7242..fa84d1b 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -9,6 +9,7 @@ module Language.PureScript.CoreFn.ToJSON
import Prelude.Compat
+import Data.Maybe (fromMaybe)
import Data.Aeson
import Data.Version (Version, showVersion)
import Data.Text (Text)
@@ -17,6 +18,7 @@ import qualified Data.Text as T
import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn
import Language.PureScript.Names
+import Language.PureScript.PSString (PSString, decodeString)
literalToJSON :: (a -> Value) -> Literal a -> Value
literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
@@ -51,8 +53,17 @@ bindToJSON :: Bind a -> Value
bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]
bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs
-recordToJSON :: (a -> Value) -> [(Text, a)] -> Value
-recordToJSON f = object . map (\(label, a) -> label .= f a)
+-- If all of the labels in the record can safely be converted to JSON strings,
+-- we generate a JSON object. Otherwise the labels must be represented as
+-- arrays of integers in the JSON, and in this case we generate the record as
+-- an array of pairs.
+recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value
+recordToJSON f rec = fromMaybe (asArrayOfPairs rec) (asObject rec)
+ where
+ asObject = fmap object . traverse (uncurry maybePair)
+ maybePair label a = fmap (\l -> l .= f a) (decodeString label)
+
+ asArrayOfPairs = toJSON . map (\(label, a) -> (toJSON label, f a))
exprToJSON :: Expr a -> Value
exprToJSON (Var _ i) = toJSON ( "Var"
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index 281cd6b..b8d1008 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -26,7 +26,9 @@ import Language.PureScript.Environment
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
+import Language.PureScript.Pretty.Types
import Language.PureScript.Types
+import Language.PureScript.Label (Label)
typeLiterals :: Pattern () Type RenderedCode
typeLiterals = mkPattern match
@@ -79,13 +81,13 @@ renderRow = uncurry renderRow' . rowToList
where
renderRow' h t = renderHead h <> renderTail t
-renderHead :: [(Text, Type)] -> RenderedCode
+renderHead :: [(Label, Type)] -> RenderedCode
renderHead = mintersperse (syntax "," <> sp) . map renderLabel
-renderLabel :: (Text, Type) -> RenderedCode
+renderLabel :: (Label, Type) -> RenderedCode
renderLabel (label, ty) =
mintersperse sp
- [ ident label
+ [ syntax $ prettyPrintLabel label
, syntax "::"
, renderType ty
]
@@ -125,9 +127,9 @@ explicitParens = mkPattern match
match _ = Nothing
matchTypeAtom :: Pattern () Type RenderedCode
-matchTypeAtom = typeLiterals <+> fmap parens matchType
+matchTypeAtom = typeLiterals <+> fmap parens_ matchType
where
- parens x = syntax "(" <> x <> syntax ")"
+ parens_ x = syntax "(" <> x <> syntax ")"
matchType :: Pattern () Type RenderedCode
matchType = buildPrettyPrinter operators matchTypeAtom
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 69edffa..3616635 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -10,6 +10,7 @@ import Control.Arrow (first, (***))
import Control.Monad (when)
import Control.Monad.Error.Class (catchError)
+import Data.Monoid ((<>))
import Data.Aeson ((.=))
import Data.Aeson.BetterErrors
import Data.ByteString.Lazy (ByteString)
@@ -358,8 +359,6 @@ displayPackageError e = case e of
"Invalid kind: \"" <> str <> "\""
InvalidDataDeclType str ->
"Invalid data declaration type: \"" <> str <> "\""
- where
- (<>) = T.append
instance A.FromJSON a => A.FromJSON (Package a) where
parseJSON = toAesonParser displayPackageError
@@ -413,7 +412,7 @@ asReExport =
asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
asInPackage inner =
- build <$> key "package" (perhaps (withString parsePackageName))
+ build <$> key "package" (perhaps (withText parsePackageName))
<*> key "item" inner
where
build Nothing = Local
@@ -468,8 +467,8 @@ asTypeArguments = eachInArray asTypeArgument
where
asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind)
-asKind :: Parse e P.Kind
-asKind = fromAesonParser
+asKind :: Parse PackageError P.Kind
+asKind = P.kindFromJSON .! InvalidKind
asType :: Parse e P.Type
asType = fromAesonParser
@@ -532,7 +531,7 @@ asBookmark =
asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
asResolvedDependencies =
- eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName . T.unpack) asVersion
+ eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion
where
mapLeft f (Left x) = Left (f x)
mapLeft _ (Right x) = Right x
@@ -557,7 +556,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where
, "versionTag" .= pkgVersionTag
, "modules" .= pkgModules
, "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks
- , "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName)
+ , "resolvedDependencies" .= assocListToJSON runPackageName
(T.pack . showVersion)
pkgResolvedDependencies
, "github" .= pkgGithub
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 74831b4..50b8521 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -32,10 +32,10 @@ import Language.PureScript.Names
import Language.PureScript.Pretty
import Language.PureScript.Traversals
import Language.PureScript.Types
-import Language.PureScript.Pretty.Common (endWith)
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.Pretty.Common (before, endWith)
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.Constants as C
-import Language.PureScript.Pretty.Common (before)
import qualified System.Console.ANSI as ANSI
@@ -264,7 +264,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
- gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con
+ gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> f t <*> pure con
gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
@@ -498,6 +498,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
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"
+ renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident "bind")))) =
+ line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " function. Please import " <> markCode "bind" <> " from module " <> markCode "Prelude"
renderSimpleErrorMessage (UnknownName name) =
line $ "Unknown " <> printName name
renderSimpleErrorMessage (UnknownImport mn name) =
@@ -563,12 +565,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
sortRows t1 t2 = (t1, t2)
-- Put the common labels last
- sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type)
+ sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type)
sortRows' (s1, r1) (s2, r2) =
- let common :: [(Text, (Type, Type))]
+ let common :: [(Label, (Type, Type))]
common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
- sd1, sd2 :: [(Text, Type)]
+ sd1, sd2 :: [(Label, 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)
@@ -671,7 +673,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
renderSimpleErrorMessage (CannotFindDerivingType nm) =
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 (prettyPrintLabel l) <> " appears more than once in a row type." ]
<> foldMap (\expr' -> [ line "Relevant expression: "
, markCodeBox $ indent $ prettyPrintValue valueDepth expr'
]) expr
@@ -704,9 +706,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) 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 (prettyPrintLabel prop) <> "."
renderSimpleErrorMessage (AdditionalProperty prop) =
- line $ "Type of expression contains additional label " <> markCode prop <> "."
+ line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "."
renderSimpleErrorMessage TypeSynonymInstance =
line "Type class instances for type synonyms are disallowed."
renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
@@ -1263,7 +1265,7 @@ renderBox = unlines
whiteSpace = all isSpace
toTypelevelString :: Type -> Maybe Box.Box
-toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s)
+toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString 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/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 78d126b..93cabc9 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -1,12 +1,15 @@
-{-# LANGUAGE TemplateHaskell #-}
-
module Language.PureScript.Kinds where
import Prelude.Compat
-import qualified Data.Aeson.TH as A
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as A
import Language.PureScript.Names
+import qualified Language.PureScript.Constants as C
-- | The data type of kinds
data Kind
@@ -20,7 +23,66 @@ data Kind
| NamedKind (Qualified (ProperName 'KindName))
deriving (Show, Eq, Ord)
-$(A.deriveJSON A.defaultOptions ''Kind)
+-- This is equivalent to the derived Aeson ToJSON instance, except that we
+-- write it out manually so that we can define a parser which is
+-- backwards-compatible.
+instance A.ToJSON Kind where
+ toJSON kind = case kind of
+ KUnknown i ->
+ obj "KUnknown" i
+ Row k ->
+ obj "Row" k
+ FunKind k1 k2 ->
+ obj "FunKind" [k1, k2]
+ NamedKind n ->
+ obj "NamedKind" n
+ where
+ obj :: A.ToJSON a => Text -> a -> A.Value
+ obj tag contents =
+ A.object [ "tag" .= tag, "contents" .= contents ]
+
+-- This is equivalent to the derived Aeson FromJSON instance, except that it
+-- also handles JSON generated by compilers up to 0.10.3 and maps them to the
+-- new representations (i.e. NamedKinds which are defined in the Prim module).
+kindFromJSON :: Parse Text Kind
+kindFromJSON = do
+ t <- key "tag" asText
+ case t of
+ "KUnknown" ->
+ KUnknown <$> key "contents" (nth 0 asIntegral)
+ "Star" ->
+ pure kindType
+ "Bang" ->
+ pure kindEffect
+ "Row" ->
+ Row <$> key "contents" kindFromJSON
+ "FunKind" ->
+ let
+ kindAt n = key "contents" (nth n kindFromJSON)
+ in
+ FunKind <$> kindAt 0 <*> kindAt 1
+ "Symbol" ->
+ pure kindSymbol
+ "NamedKind" ->
+ NamedKind <$> key "contents" fromAesonParser
+ other ->
+ throwCustomError (T.append "Unrecognised tag: " other)
+
+ where
+ -- The following are copied from Environment and reimplemented to avoid
+ -- circular dependencies.
+ primName :: Text -> Qualified (ProperName a)
+ primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
+
+ primKind :: Text -> Kind
+ primKind = NamedKind . primName
+
+ kindType = primKind "Type"
+ kindEffect = primKind "Effect"
+ kindSymbol = primKind "Symbol"
+
+instance A.FromJSON Kind where
+ parseJSON = toAesonParser id kindFromJSON
everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
everywhereOnKinds f = go
diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs
new file mode 100644
index 0000000..3c8123d
--- /dev/null
+++ b/src/Language/PureScript/Label.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Language.PureScript.Label (Label(..)) where
+
+import Prelude.Compat hiding (lex)
+import Data.Monoid ()
+import Data.String (IsString(..))
+import qualified Data.Aeson as A
+
+import Language.PureScript.PSString (PSString)
+
+-- |
+-- Labels are used as record keys and row entry names. Labels newtype PSString
+-- because records are indexable by PureScript strings at runtime.
+--
+newtype Label = Label { runLabel :: PSString }
+ deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON)
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
new file mode 100644
index 0000000..a841e43
--- /dev/null
+++ b/src/Language/PureScript/PSString.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.PSString
+ ( PSString
+ , toUTF16CodeUnits
+ , decodeString
+ , decodeStringEither
+ , prettyPrintString
+ , prettyPrintStringJS
+ , mkString
+ ) where
+
+import Prelude.Compat
+import Control.Exception (try, evaluate)
+import Control.Applicative ((<|>))
+import Data.Char (chr)
+import Data.Bits (shiftR)
+import Data.List (unfoldr)
+import Data.Monoid ((<>))
+import Data.Scientific (toBoundedInteger)
+import Data.String (IsString(..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf16BE)
+import Data.Text.Encoding.Error (UnicodeException)
+import qualified Data.Vector as V
+import Data.Word (Word16, Word8)
+import Numeric (showHex)
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Types as A
+
+-- |
+-- Strings in PureScript are sequences of UTF-16 code units, which do not
+-- necessarily represent UTF-16 encoded text. For example, it is permissible
+-- for a string to contain *lone surrogates,* i.e. characters in the range
+-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.
+--
+-- The Show instance for PSString produces a string literal which would
+-- represent the same data were it inserted into a PureScript source file.
+--
+-- Because JSON parsers vary wildly in terms of how they deal with lone
+-- surrogates in JSON strings, the ToJSON instance for PSString produces JSON
+-- strings where that would be safe (i.e. when there are no lone surrogates),
+-- and arrays of UTF-16 code units (integers) otherwise.
+--
+newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
+ deriving (Eq, Ord, Monoid)
+
+instance Show PSString where
+ show = show . codePoints
+
+-- Decode a PSString to a String, representing any lone surrogates as the
+-- reserved code point with that index. Warning: if there are any lone
+-- surrogates, converting the result to Text via Data.Text.pack will result in
+-- loss of information as those lone surrogates will be replaced with U+FFFD
+-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
+-- we do not export it.
+codePoints :: PSString -> String
+codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
+
+-- |
+-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
+-- the output with the Left constructor; characters which were successfully
+-- decoded are represented with the Right constructor.
+--
+decodeStringEither :: PSString -> [Either Word16 Char]
+decodeStringEither = unfoldr decode . toUTF16CodeUnits
+ where
+ decode :: [Word16] -> Maybe (Either Word16 Char, [Word16])
+ decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest)
+ decode (c:rest) | isSurrogate c = Just (Left c, rest)
+ decode (c:rest) = Just (Right (toChar c), rest)
+ decode [] = Nothing
+
+ unsurrogate :: Word16 -> Word16 -> Char
+ unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
+
+-- |
+-- Pretty print a PSString, using Haskell/PureScript escape sequences.
+-- This is identical to the Show instance except that we get a Text out instead
+-- of a String.
+--
+prettyPrintString :: PSString -> Text
+prettyPrintString = T.pack . show
+
+-- |
+-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
+-- Nothing) if the argument contains lone surrogates.
+--
+decodeString :: PSString -> Maybe Text
+decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits
+ where
+ unpair w = [highByte w, lowByte w]
+
+ lowByte :: Word16 -> Word8
+ lowByte = fromIntegral
+
+ highByte :: Word16 -> Word8
+ highByte = fromIntegral . (`shiftR` 8)
+
+ -- Based on a similar function from Data.Text.Encoding for utf8. This is a
+ -- safe usage of unsafePerformIO because there are no side effects after
+ -- handling any thrown UnicodeExceptions.
+ decodeEither :: ByteString -> Either UnicodeException Text
+ decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE
+
+ hush = either (const Nothing) Just
+
+instance IsString PSString where
+ fromString a = PSString $ concatMap encodeUTF16 a
+ where
+ surrogates :: Char -> (Word16, Word16)
+ surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))
+ where (h, l) = divMod (fromEnum c - 0x10000) 0x400
+
+ encodeUTF16 :: Char -> [Word16]
+ encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]
+ where (high, low) = surrogates c
+ encodeUTF16 c = [toWord $ fromEnum c]
+
+instance A.ToJSON PSString where
+ toJSON str =
+ case decodeString str of
+ Just t -> A.toJSON t
+ Nothing -> A.toJSON (toUTF16CodeUnits str)
+
+instance A.FromJSON PSString where
+ parseJSON a = jsonString <|> arrayOfCodeUnits
+ where
+ jsonString = fromString <$> A.parseJSON a
+
+ arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a
+
+ parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]
+ parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)
+
+ parseCodeUnit :: A.Value -> A.Parser Word16
+ parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
+
+-- |
+-- Pretty print a PSString, using JavaScript escape sequences. Intended for
+-- use in compiled JS output.
+--
+prettyPrintStringJS :: PSString -> Text
+prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
+ where
+ encodeChar :: Word16 -> Text
+ encodeChar c | c > 0xFF = "\\u" <> hex 4 c
+ encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
+ encodeChar c | toChar c == '\b' = "\\b"
+ encodeChar c | toChar c == '\t' = "\\t"
+ encodeChar c | toChar c == '\n' = "\\n"
+ encodeChar c | toChar c == '\v' = "\\v"
+ encodeChar c | toChar c == '\f' = "\\f"
+ encodeChar c | toChar c == '\r' = "\\r"
+ encodeChar c | toChar c == '"' = "\\\""
+ encodeChar c | toChar c == '\\' = "\\\\"
+ encodeChar c = T.singleton $ toChar c
+
+ hex :: (Enum a) => Int -> a -> Text
+ hex width c =
+ let hs = showHex (fromEnum c) "" in
+ T.pack (replicate (width - length hs) '0' <> hs)
+
+isLead :: Word16 -> Bool
+isLead h = h >= 0xD800 && h <= 0xDBFF
+
+isTrail :: Word16 -> Bool
+isTrail l = l >= 0xDC00 && l <= 0xDFFF
+
+isSurrogate :: Word16 -> Bool
+isSurrogate c = isLead c || isTrail c
+
+toChar :: Word16 -> Char
+toChar = toEnum . fromIntegral
+
+toWord :: Int -> Word16
+toWord = fromIntegral
+
+toInt :: Word16 -> Int
+toInt = fromIntegral
+
+mkString :: Text -> PSString
+mkString = fromString . T.unpack
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index d60a394..0048cd9 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -16,6 +16,7 @@ import Language.PureScript.Comments
import Language.PureScript.Names
import Language.PureScript.Parser.Lexer
import Language.PureScript.Parser.State
+import Language.PureScript.PSString (PSString, mkString)
import qualified Text.Parsec as P
@@ -73,6 +74,12 @@ parseIdent :: TokenParser Ident
parseIdent = Ident <$> identifier
-- |
+-- Parse a label, which may look like an identifier or a string
+--
+parseLabel :: TokenParser PSString
+parseLabel = (mkString <$> lname) <|> stringLiteral
+
+-- |
-- Parse an operator.
--
parseOperator :: TokenParser (OpName a)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 161a9b2..cd8d582 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -33,6 +33,7 @@ import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Types
+import Language.PureScript.PSString (PSString, mkString)
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Lexer
@@ -338,15 +339,15 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)
parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)
-parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a)
+parseObjectLiteral :: TokenParser (PSString, a) -> TokenParser (Literal a)
parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)
-parseIdentifierAndValue :: TokenParser (Text, Expr)
+parseIdentifierAndValue :: TokenParser (PSString, Expr)
parseIdentifierAndValue =
do
name <- C.indented *> lname
b <- P.option (Var $ Qualified Nothing (Ident name)) rest
- return (name, b)
+ return (mkString name, b)
<|> (,) <$> (C.indented *> stringLiteral) <*> rest
where
rest = C.indented *> colon *> C.indented *> parseValue
@@ -428,16 +429,16 @@ parseInfixExpr
parseHole :: TokenParser Expr
parseHole = Hole <$> holeLit
-parsePropertyUpdate :: TokenParser (Text, Expr)
+parsePropertyUpdate :: TokenParser (PSString, Expr)
parsePropertyUpdate = do
- name <- lname <|> stringLiteral
+ name <- parseLabel
_ <- C.indented *> equals
value <- C.indented *> parseValue
return (name, value)
parseAccessor :: Expr -> TokenParser Expr
parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj
parseDo :: TokenParser Expr
parseDo = do
@@ -520,11 +521,11 @@ parseVarOrNamedBinder = do
parseNullBinder :: TokenParser Binder
parseNullBinder = underscore *> return NullBinder
-parseIdentifierAndBinder :: TokenParser (Text, Binder)
+parseIdentifierAndBinder :: TokenParser (PSString, Binder)
parseIdentifierAndBinder =
do name <- lname
b <- P.option (VarBinder (Ident name)) rest
- return (name, b)
+ return (mkString name, b)
<|> (,) <$> stringLiteral <*> rest
where
rest = C.indented *> colon *> C.indented *> parseBinder
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 59eff68..744519c 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -70,11 +70,13 @@ import Control.Monad (void, guard)
import Control.Monad.Identity (Identity)
import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)
import Data.Monoid ((<>))
+import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Comments
import Language.PureScript.Parser.State
+import Language.PureScript.PSString (PSString)
import qualified Text.Parsec as P
import qualified Text.Parsec.Token as PT
@@ -106,7 +108,7 @@ data Token
| Qualifier Text
| Symbol Text
| CharLiteral Char
- | StringLiteral Text
+ | StringLiteral PSString
| Number (Either Integer Double)
| HoleLit Text
deriving (Show, Eq, Ord)
@@ -249,18 +251,6 @@ 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 = P.try $ do {
c <- PT.charLiteral tokenParser;
@@ -269,11 +259,11 @@ parseToken = P.choice
else return c
}
- parseStringLiteral :: Lexer u Text
- parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser
+ parseStringLiteral :: Lexer u PSString
+ parseStringLiteral = fromString <$> (blockString <|> PT.stringLiteral tokenParser)
where
delimiter = P.try (P.string "\"\"\"")
- blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter)
+ blockString = delimiter *> P.manyTill P.anyChar delimiter
parseNumber :: Lexer u (Either Integer Double)
parseNumber = (consumeLeadingZero *> P.parserZero) <|>
@@ -516,7 +506,7 @@ charLiteral = token go P.<?> "char literal"
go (CharLiteral c) = Just c
go _ = Nothing
-stringLiteral :: TokenParser Text
+stringLiteral :: TokenParser PSString
stringLiteral = token go P.<?> "string literal"
where
go (StringLiteral s) = Just s
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index d218e6a..403f8ff 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -9,7 +9,6 @@ import Prelude.Compat
import Control.Monad (when, unless)
import Control.Applicative ((<|>))
-import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST.SourcePos
@@ -18,6 +17,7 @@ import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Lexer
import Language.PureScript.Types
+import Language.PureScript.Label (Label(..))
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
@@ -118,8 +118,8 @@ noWildcards p = do
when (containsWildcards ty) $ P.unexpected "type wildcard"
return ty
-parseNameAndType :: TokenParser t -> TokenParser (Text, t)
-parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
+parseNameAndType :: TokenParser t -> TokenParser (Label, t)
+parseNameAndType p = (,) <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p
parseRowEnding :: TokenParser Type
parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType
diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs
index b242a05..e9affc1 100644
--- a/src/Language/PureScript/Pretty.hs
+++ b/src/Language/PureScript/Pretty.hs
@@ -15,3 +15,4 @@ import Language.PureScript.Pretty.JS as P
import Language.PureScript.Pretty.Kinds as P
import Language.PureScript.Pretty.Types as P
import Language.PureScript.Pretty.Values as P
+import Language.PureScript.PSString as P (prettyPrintString)
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index f5f0e2f..9b7b6a1 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -15,7 +15,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
-import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey)
+import Language.PureScript.Parser.Lexer (isUnquotedKey, reservedPsNames)
import Text.PrettyPrint.Boxes hiding ((<>))
import qualified Text.PrettyPrint.Boxes as Box
@@ -146,13 +146,9 @@ prettyPrintMany f xs = do
indentString <- currentIndent
return $ intercalate (emit "\n") $ map (mappend indentString) ss
--- |
--- Prints an object key, escaping reserved names.
---
-prettyPrintObjectKey :: Text -> Text
-prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s)
- | isUnquotedKey s = s
- | otherwise = T.pack (show s)
+objectKeyRequiresQuoting :: Text -> Bool
+objectKeyRequiresQuoting s =
+ s `elem` reservedPsNames || isUnquotedKey s
-- | Place a box before another, vertically when the first box takes up multiple lines.
before :: Box -> Box -> Box
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index d142873..0015933 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -25,8 +25,7 @@ import Language.PureScript.CodeGen.JS.Common
import Language.PureScript.Comments
import Language.PureScript.Crash
import Language.PureScript.Pretty.Common
-
-import Numeric
+import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS)
-- TODO (Christoph): Get rid of T.unpack / pack
@@ -38,7 +37,7 @@ literals = mkPattern' match'
match :: (Emit gen) => JS -> StateT PrinterState Maybe gen
match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n
- match (JSStringLiteral _ s) = return $ string s
+ match (JSStringLiteral _ s) = return $ emit $ prettyPrintStringJS s
match (JSBooleanLiteral _ True) = return $ emit "true"
match (JSBooleanLiteral _ False) = return $ emit "false"
match (JSArrayLiteral _ xs) = mconcat <$> sequence
@@ -58,9 +57,13 @@ literals = mkPattern' match'
, return $ emit "}"
]
where
- objectPropertyToString :: (Emit gen) => Text -> gen
- objectPropertyToString s | identNeedsEscaping s = string s
- | otherwise = emit s
+ objectPropertyToString :: (Emit gen) => PSString -> gen
+ objectPropertyToString s =
+ emit $ case decodeString s of
+ Just s' | not (identNeedsEscaping s') ->
+ s'
+ _ ->
+ prettyPrintStringJS s
match (JSBlock _ sts) = mconcat <$> sequence
[ return $ emit "{\n"
, withIndent $ prettyStatements sts
@@ -150,29 +153,6 @@ literals = mkPattern' match'
match (JSRaw _ js) = return $ emit js
match _ = mzero
-string :: (Emit gen) => Text -> gen
-string s = emit $ "\"" <> T.concatMap encodeChar s <> "\""
- where
- encodeChar :: Char -> Text
- encodeChar '\b' = "\\b"
- encodeChar '\t' = "\\t"
- encodeChar '\n' = "\\n"
- encodeChar '\v' = "\\v"
- encodeChar '\f' = "\\f"
- encodeChar '\r' = "\\r"
- encodeChar '"' = "\\\""
- encodeChar '\\' = "\\\\"
- -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit.
- -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD.
- encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD"
- encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) ""
- encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) ""
- encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) ""
- encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) ""
- encodeChar c = T.singleton c
-
- showHex' a b = T.pack (showHex a b)
-
conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)
conditional = mkPattern match
where
@@ -182,6 +162,7 @@ conditional = mkPattern match
accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)
accessor = mkPattern match
where
+ -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513
match (JSAccessor _ prop val) = Just (emit prop, val)
match _ = Nothing
@@ -189,7 +170,6 @@ indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)
indexer = mkPattern' match
where
match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
-
match _ = mzero
lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 0ec29ba..24d4451 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -10,6 +10,7 @@ import Prelude.Compat
import Control.Arrow (ArrowPlus(..))
import Control.PatternArrows as PA
+import Data.Monoid ((<>))
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text)
@@ -19,11 +20,15 @@ import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
-typeLiterals :: Pattern () Kind String
+typeLiterals :: Pattern () Kind Text
typeLiterals = mkPattern match
where
- match (KUnknown u) = Just $ 'u' : show u
- match (NamedKind name) = Just $ T.unpack (showQualified runProperName name)
+ match (KUnknown u) =
+ Just $ T.cons 'k' (T.pack (show u))
+ match (NamedKind name) =
+ Just $ if isQualifiedWith (moduleNameFromString "Prim") name
+ then runProperName (disqualify name)
+ else showQualified runProperName name
match _ = Nothing
matchRow :: Pattern () Kind ((), Kind)
@@ -41,15 +46,13 @@ funKind = mkPattern match
-- | Generate a pretty-printed string representing a Kind
prettyPrintKind :: Kind -> Text
prettyPrintKind
- -- TODO(Christoph): get rid of T.pack
- = T.pack
- . fromMaybe (internalError "Incomplete pattern")
+ = fromMaybe (internalError "Incomplete pattern")
. PA.pattern matchKind ()
where
- matchKind :: Pattern () Kind String
- matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
+ matchKind :: Pattern () Kind Text
+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parensT matchKind)
- operators :: OperatorTable () Kind String
+ operators :: OperatorTable () Kind Text
operators =
- OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
- , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " <> k]
+ , [ AssocR funKind $ \arg ret -> arg <> " -> " <> ret ] ]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 3486077..db92df6 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -10,6 +10,8 @@ module Language.PureScript.Pretty.Types
, prettyPrintTypeAtom
, prettyPrintRowWith
, prettyPrintRow
+ , prettyPrintLabel
+ , prettyPrintObjectKey
) where
import Prelude.Compat
@@ -18,6 +20,7 @@ import Control.Arrow ((<+>))
import Control.PatternArrows as PA
import Data.Maybe (fromMaybe)
+import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Crash
@@ -27,6 +30,8 @@ import Language.PureScript.Names
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Types
+import Language.PureScript.PSString (PSString, prettyPrintString, decodeString)
+import Language.PureScript.Label (Label(..))
import Text.PrettyPrint.Boxes hiding ((<+>))
@@ -45,22 +50,22 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo
prettyPrintRowWith :: Char -> Char -> Type -> Box
prettyPrintRowWith open close = uncurry listToBox . toList []
where
- nameAndTypeToPs :: Char -> String -> Type -> Box
- nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty
+ nameAndTypeToPs :: Char -> Label -> Type -> Box
+ nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty
tailToPs :: Type -> Box
tailToPs REmpty = nullBox
tailToPs other = text "| " <> typeAsBox other
- listToBox :: [(String, Type)] -> Type -> Box
+ listToBox :: [(Label, Type)] -> Type -> Box
listToBox [] REmpty = text [open, close]
listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]
listToBox ts rest = vcat left $
zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
[ tailToPs rest, text [close] ]
- toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
- toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row
+ toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)
+ toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (reverse tys, r)
prettyPrintRow :: Type -> String
@@ -116,7 +121,7 @@ matchTypeAtom suggesting =
typeLiterals = mkPattern match where
match TypeWildcard{} = Just $ text "_"
match (TypeVar var) = Just $ text $ T.unpack var
- match (TypeLevelString s) = Just . text $ show s
+ match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
match (TUnknown u)
@@ -186,3 +191,14 @@ prettyPrintType = render . typeAsBoxImpl False
-- | Generate a pretty-printed string representing a suggested 'Type'
prettyPrintSuggestedType :: Type -> String
prettyPrintSuggestedType = render . typeAsBoxImpl True
+
+prettyPrintLabel :: Label -> Text
+prettyPrintLabel (Label s) =
+ case decodeString s of
+ Just s' | not (objectKeyRequiresQuoting s') ->
+ s'
+ _ ->
+ prettyPrintString s
+
+prettyPrintObjectKey :: PSString -> Text
+prettyPrintObjectKey = prettyPrintLabel . Label
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 14838c5..4b1c38e 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -20,8 +20,9 @@ import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
-import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)
+import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey)
import Language.PureScript.Types (Constraint(..))
+import Language.PureScript.PSString (PSString, prettyPrintString)
import Text.PrettyPrint.Boxes
@@ -40,10 +41,10 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl
ellipsis :: Box
ellipsis = text "..."
-prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box
+prettyPrintObject :: Int -> [(PSString, Maybe Expr)] -> Box
prettyPrintObject d = list '{' '}' prettyPrintObjectProperty
where
- prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box
+ prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box
prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value
-- | Pretty-print an expression
@@ -55,7 +56,7 @@ prettyPrintValue d (IfThenElse cond th el) =
, text "else " <> prettyPrintValueAtom (d - 1) el
])
prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)
-prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps
+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (prettyPrintObjectKey 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 ('\\' : 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)
@@ -105,7 +106,7 @@ prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` tex
prettyPrintLiteralValue :: Int -> Literal Expr -> Box
prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n
-prettyPrintLiteralValue _ (StringLiteral s) = text $ show s
+prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s
prettyPrintLiteralValue _ (CharLiteral c) = text $ show c
prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"
prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"
@@ -169,7 +170,7 @@ prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =
prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b)
prettyPrintLiteralBinder :: Literal Binder -> Text
-prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str)
+prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str
prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)
prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num
prettyPrintLiteralBinder (BooleanLiteral True) = "true"
@@ -179,7 +180,7 @@ prettyPrintLiteralBinder (ObjectLiteral bs) =
Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)
Monoid.<> " }"
where
- prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text
+ prettyPrintObjectPropertyBinder :: (PSString, Binder) -> Text
prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder
prettyPrintLiteralBinder (ArrayLiteral bs) =
"[ "
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 136991a..8a862df 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -209,7 +209,7 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt
Just Repository{..} -> do
unless (repositoryType == "git")
(Left (BadRepositoryType repositoryType))
- maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl))
+ maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
checkLicense :: PackageMeta -> PrepareM ()
checkLicense pkgMeta =
@@ -217,7 +217,7 @@ checkLicense pkgMeta =
[] ->
userError NoLicenseSpecified
ls ->
- unless (any isValidSPDX ls)
+ unless (any (isValidSPDX . T.unpack) ls)
(userError InvalidLicense)
-- |
@@ -320,8 +320,7 @@ asResolvedDependencies = nubBy ((==) `on` fst) <$> go
go =
fmap (fromMaybe []) $
keyMay "dependencies" $
- (++) <$> eachInObjectWithKey (parsePackageName . T.unpack)
- asDependencyStatus
+ (++) <$> eachInObjectWithKey parsePackageName asDependencyStatus
<*> (concatMap snd <$> eachInObject asResolvedDependencies)
-- | Extracts only the top level dependency names from the output of
@@ -330,7 +329,7 @@ asToplevelDependencies :: Parse BowerError [PackageName]
asToplevelDependencies =
fmap (map fst) $
key "dependencies" $
- eachInObjectWithKey (parsePackageName . T.unpack) (return ())
+ eachInObjectWithKey parsePackageName (return ())
asDependencyStatus :: Parse e DependencyStatus
asDependencyStatus = do
@@ -371,7 +370,7 @@ handleDeps deps = do
ResolvedOther _ -> (ms, pkgName : os, is)
ResolvedVersion v -> (ms, os, (pkgName, v) : is)
- bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
+ bowerDir pkgName = T.unpack $ "bower_components/" <> runPackageName pkgName
-- Try to extract a version, and warn if unsuccessful.
tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
@@ -406,6 +405,6 @@ getPackageName fp = do
let xs = splitOn [pathSeparator] fp
ys <- stripPrefix ["bower_components"] xs
y <- headMay ys
- case Bower.mkPackageName y of
+ case Bower.mkPackageName (T.pack y) of
Right name -> Just name
Left _ -> Nothing
diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs
index 9a108b6..0fe2b0f 100644
--- a/src/Language/PureScript/Publish/BoxesHelpers.hs
+++ b/src/Language/PureScript/Publish/BoxesHelpers.hs
@@ -6,6 +6,8 @@ module Language.PureScript.Publish.BoxesHelpers
import Prelude.Compat
+import Data.Text (Text)
+import qualified Data.Text as T
import System.IO (hPutStr, stderr)
import qualified Text.PrettyPrint.Boxes as Boxes
@@ -37,6 +39,9 @@ spacer = Boxes.emptyBox 1 1
bulletedList :: (a -> String) -> [a] -> [Boxes.Box]
bulletedList f = map (indented . para . ("* " ++) . f)
+bulletedListT :: (a -> Text) -> [a] -> [Boxes.Box]
+bulletedListT f = bulletedList (T.unpack . f)
+
printToStderr :: Boxes.Box -> IO ()
printToStderr = hPutStr stderr . Boxes.render
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index 597b2a4..01935a1 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -65,7 +65,7 @@ data UserError
data RepositoryFieldError
= RepositoryFieldMissing
- | BadRepositoryType String
+ | BadRepositoryType Text
| NotOnGithub
deriving (Show)
@@ -213,7 +213,7 @@ displayUserError e = case e of
, "installed:"
])
] ++
- bulletedList runPackageName (NonEmpty.toList pkgs)
+ bulletedListT runPackageName (NonEmpty.toList pkgs)
++
[ spacer
, para (concat
@@ -263,7 +263,7 @@ displayRepositoryError err = case err of
BadRepositoryType ty ->
para (concat
[ "In your bower.json file, the repository type is currently listed as "
- , "\"" ++ ty ++ "\". Currently, only git repositories are supported. "
+ , "\"" ++ T.unpack ty ++ "\". Currently, only git repositories are supported. "
, "Please publish your code in a git repository, and then update the "
, "repository type in your bower.json file to \"git\"."
])
@@ -361,7 +361,7 @@ warnNoResolvedVersions pkgNames =
["The following ", packages, " did not appear to have a resolved "
, "version:"])
] ++
- bulletedList runPackageName (NonEmpty.toList pkgNames)
+ bulletedListT runPackageName (NonEmpty.toList pkgNames)
++
[ spacer
, para (concat
@@ -385,7 +385,7 @@ warnUndeclaredDependencies pkgNames =
[ "The following Bower ", packages, " ", are, " installed, but not "
, "declared as ", dependencies, " in your bower.json file:"
])
- : bulletedList runPackageName (NonEmpty.toList pkgNames)
+ : bulletedListT runPackageName (NonEmpty.toList pkgNames)
warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box
warnUnacceptableVersions pkgs =
@@ -403,7 +403,7 @@ warnUnacceptableVersions pkgs =
, "not be parsed:"
])
] ++
- bulletedList showTuple (NonEmpty.toList pkgs)
+ bulletedListT showTuple (NonEmpty.toList pkgs)
++
[ spacer
, para (concat
@@ -414,7 +414,7 @@ warnUnacceptableVersions pkgs =
])
]
where
- showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag
+ showTuple (pkgName, tag) = runPackageName pkgName <> "#" <> tag
warnDirtyWorkingTree :: Box
warnDirtyWorkingTree =
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 7b527e4..0ebbcac 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -242,7 +242,12 @@ exportType
-> m Exports
exportType exportMode exps name dctors mn = do
let exTypes = exportedTypes exps
- let exClasses = exportedTypeClasses exps
+ exClasses = exportedTypeClasses exps
+ dctorNameCounts :: [(ProperName 'ConstructorName, Int)]
+ dctorNameCounts = M.toList $ M.fromListWith (+) (map (,1) dctors)
+ forM_ dctorNameCounts $ \(dctorName, count) ->
+ when (count > 1) $
+ throwDeclConflict (DctorName dctorName) (DctorName dctorName)
case exportMode of
Internal -> do
when (name `M.member` exTypes) $
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index b92782a..3e306d0 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -11,11 +11,11 @@ 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
import Language.PureScript.Names
+import Language.PureScript.PSString (PSString)
desugarObjectConstructors
:: forall m
@@ -62,7 +62,7 @@ desugarDecl other = fn other
return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
desugarExpr e = return e
- wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr
+ wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
wrapLambda mkVal ps =
let (args, props) = partition (isAnonymousArgument . snd) ps
in if null args
@@ -75,7 +75,7 @@ desugarDecl other = fn other
stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
stripPositionInfo e = e
- peelAnonAccessorChain :: Expr -> Maybe [Text]
+ peelAnonAccessorChain :: Expr -> Maybe [PSString]
peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e
peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e
peelAnonAccessorChain AnonymousArgument = Just []
@@ -86,7 +86,7 @@ desugarDecl other = fn other
isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
isAnonymousArgument _ = False
- mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr))
+ mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))
mkProp (name, e) = do
arg <- freshIfAnon e
return (arg, (name, maybe e argToExpr arg))
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 4b1007f..b20a066 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -19,6 +19,8 @@ import Language.PureScript.Externs
import Language.PureScript.Sugar.CaseDeclarations
import Control.Monad.Supply.Class
import Language.PureScript.Types
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.PSString (mkString)
import qualified Language.PureScript.Constants as C
@@ -240,7 +242,7 @@ typeClassDictionaryDeclaration name args implies members =
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
- in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (mtys, REmpty))
+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty))
typeClassMemberToDictionaryAccessor
:: ModuleName
@@ -297,7 +299,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
, let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
]
- let props = Literal $ ObjectLiteral (members ++ superclasses)
+ let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className props
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 8b5ad3c..8dbb8ee 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -11,9 +11,11 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class (MonadSupply)
import Data.List (foldl', find, sortBy, unzip5)
import qualified Data.Map as M
+import Data.Monoid ((<>))
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
+import qualified Data.Text as T
import Language.PureScript.AST
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
@@ -22,6 +24,8 @@ import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.PSString (mkString, decodeStringEither)
import Language.PureScript.Types
import Language.PureScript.TypeChecker (checkNewtype)
import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM)
@@ -207,7 +211,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
idents <- replicateM (length tys) freshIdent'
tys' <- mapM (replaceAllTypeSynonymsM syns) tys
let caseResult =
- App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
+ App (prodConstructor (Literal . StringLiteral . mkString . showQualified runProperName $ Qualified (Just mn) ctorName))
. Literal . ArrayLiteral
$ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys'
return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult)
@@ -216,7 +220,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
toSpineFun i r | Just rec <- objectType r =
lamNull . recordConstructor . Literal . ArrayLiteral
. map
- (\(str,typ) ->
+ (\((Label str),typ) ->
Literal $ ObjectLiteral
[ ("recLabel", Literal (StringLiteral str))
, ("recValue", toSpineFun (Accessor str i) typ)
@@ -235,7 +239,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
App
(App
(Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
- (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))
+ (Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) name))))
)
. Literal
. ArrayLiteral
@@ -249,7 +253,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
mkProdClause (ctorName, tys) =
Literal $ ObjectLiteral
- [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))
+ [ ("sigConstructor", Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName))))
, ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
]
@@ -260,7 +264,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
[ ("recLabel", Literal (StringLiteral str))
, ("recValue", mkProductSignature typ)
]
- | (str, typ) <- decomposeRec rec
+ | ((Label str), typ) <- decomposeRec rec
]
mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
(TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
@@ -291,7 +295,7 @@ deriveGeneric mn syns ds tyConNm dargs = do
return $
CaseAlternative
[ prodBinder
- [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
+ [ LiteralBinder (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName)))
, LiteralBinder (ArrayLiteral (map VarBinder idents))
]
]
@@ -314,16 +318,16 @@ deriveGeneric mn syns ds tyConNm dargs = do
(App e unitVal)
fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal)
- mkRecCase :: [(Text, Type)] -> CaseAlternative
+ mkRecCase :: [(Label, Type)] -> CaseAlternative
mkRecCase rs =
CaseAlternative
- [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]
+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . labelToIdent . fst) rs)) ] ]
. Right
- $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar $ labelToIdent x)) y) rs)
- mkRecFun :: [(Text, Type)] -> Expr
- mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs
- where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
+ mkRecFun :: [(Label, Type)] -> Expr
+ mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs
+ where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs
mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
@@ -405,7 +409,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
args' <- mapM (replaceAllTypeSynonymsM syns) args
(ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'
return ( TypeApp (TypeApp (TypeConstructor constructor)
- (TypeLevelString (runProperName ctorName)))
+ (TypeLevelString $ mkString (runProperName ctorName)))
ctorTy
, CaseAlternative [ ConstructorBinder constructor [matchProduct] ]
(Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))
@@ -430,19 +434,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)
makeArg arg | Just rec <- objectType arg = do
let fields = decomposeRec rec
- fieldNames <- traverse freshIdent (map fst fields)
+ fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields)
pure ( TypeApp (TypeConstructor record)
(foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))
- (map (\(name, ty) ->
+ (map (\((Label name), ty) ->
TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))
, ConstructorBinder record
[ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])
(map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)
]
, Literal . ObjectLiteral $
- zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames
+ zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames
, LiteralBinder . ObjectLiteral $
- zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames
+ zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames
, record' $
foldr1 (\e1 -> App (App (Constructor productName) e1))
(map (field' . Var . Qualified Nothing) fieldNames)
@@ -574,7 +578,7 @@ deriveEq mn syns ds tyConNm = do
toEqTest :: Expr -> Expr -> Type -> Expr
toEqTest l r ty | Just rec <- objectType ty =
conjAll
- . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
+ . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
$ decomposeRec rec
toEqTest l r _ = preludeEq l r
@@ -661,7 +665,7 @@ deriveOrd mn syns ds tyConNm = do
toOrdering :: Expr -> Expr -> Type -> Expr
toOrdering l r ty | Just rec <- objectType ty =
appendAll
- . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
+ . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
$ decomposeRec rec
toOrdering l r _ = ordCompare l r
@@ -733,11 +737,22 @@ mkVarMn mn = Var . Qualified mn
mkVar :: Ident -> Expr
mkVar = mkVarMn Nothing
+-- This function may seem a little obtuse, but it's only this way to ensure
+-- that it is injective. Injectivity is important here; without it, we can end
+-- up with accidental variable shadowing in the generated code.
+labelToIdent :: Label -> Ident
+labelToIdent =
+ Ident . foldMap (either loneSurrogate char) . decodeStringEither . runLabel
+ where
+ char '_' = "__"
+ char c = T.singleton c
+ loneSurrogate x = "_" <> T.pack (show x) <> "_"
+
objectType :: Type -> Maybe Type
objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec
objectType _ = Nothing
-decomposeRec :: Type -> [(Text, Type)]
+decomposeRec :: Type -> [(Label, Type)]
decomposeRec = sortBy (comparing fst) . go
where go (RCons str typ typs) = (str, typ) : decomposeRec typs
go _ = []
@@ -790,17 +805,17 @@ deriveFunctor mn syns ds tyConNm = do
goType recTy | Just row <- objectType recTy =
traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates)
where
- justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)]
+ justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)]
justUpdates = foldMap (fmap return)
- buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr))
+ buildUpdate :: (Label, Type) -> m (Maybe (Label, Expr))
buildUpdate (lbl, ty) = do upd <- goType ty
return ((lbl,) <$> upd)
- buildRecord :: [(Text, Expr)] -> m Expr
+ buildRecord :: [(Label, Expr)] -> m Expr
buildRecord updates = do arg <- freshIdent "o"
let argVar = mkVar arg
- mkAssignment (l, x) = (l, App x (Accessor l argVar))
+ mkAssignment ((Label l), x) = (l, App x (Accessor l argVar))
return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates)))
-- under a `* -> *`, just assume functor for now
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index ae5374f..e5e33cb 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -37,13 +37,15 @@ import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.PSString (PSString, mkString)
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
+ | IsSymbolInstance PSString
-- ^ Computed instance of the IsSymbol type class for a given Symbol literal
| CompareSymbolInstance
-- ^ Computed instance of CompareSymbol
@@ -319,7 +321,7 @@ entails SolverOptions{..} constraint context hints =
-- Turn a DictionaryValue into a Expr
subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
subclassDictionaryValue dict superclassName index =
- App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))
+ App (Accessor (mkString (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index)))
dict)
valUndefined
@@ -387,7 +389,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 :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])
+ go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> (Bool, Matching [Type])
go l (KindedType t1 _) r t2 = go l t1 r t2
go l t1 r (KindedType t2 _) = go l t1 r t2
go [] REmpty [] REmpty = (True, M.empty)
@@ -429,7 +431,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 :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool
+ go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> Bool
go l (KindedType t1 _) r t2 = go l t1 r t2
go l t1 r (KindedType t2 _) = go l t1 r t2
go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 05e7a1e..b951431 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -229,6 +229,7 @@ infer' other = (, []) <$> go other
unifyKinds k k'
return k'
go TypeWildcard{} = freshKind
+ go TUnknown{} = freshKind
go (TypeLevelString _) = return kindSymbol
go (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 665f569..b9c382d 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -34,14 +34,14 @@ import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Bifunctor (bimap)
-import Data.Either (lefts, rights)
+import Data.Either (partitionEithers)
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 Data.Traversable (for)
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -60,7 +60,8 @@ import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.TypeSearch
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.Types
-
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.PSString (PSString)
data BindingGroupType
= RecursiveBindingGroup
@@ -77,9 +78,9 @@ typesOf
-> m [(Ident, (Expr, Type))]
typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
tys <- capturingSubstitution tidyUp $ do
- (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
+ SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals
ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
- ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict
+ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict
return (map (False, ) ds1 ++ map (True, ) ds2)
inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
@@ -165,81 +166,101 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
isHoleError (ErrorMessage _ HoleInferredType{}) = True
isHoleError _ = False
-type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
-
-type UntypedData = [(Ident, Type)]
-
+-- | A binding group contains multiple value definitions, some of which are typed
+-- and some which are not.
+--
+-- This structure breaks down a binding group into typed and untyped parts.
+data SplitBindingGroup = SplitBindingGroup
+ { _splitBindingGroupUntyped :: [(Ident, (Expr, Type))]
+ -- ^ The untyped expressions
+ , _splitBindingGroupTyped :: [(Ident, (Expr, Type, Bool))]
+ -- ^ The typed expressions, along with their type annotations
+ , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
+ -- ^ A map containing all expressions and their assigned types (which might be
+ -- fresh unification variables). These will be added to the 'Environment' after
+ -- the binding group is checked, so the value type of the 'Map' is chosen to be
+ -- compatible with the type of 'bindNames'.
+ }
+
+-- | This function breaks a binding group down into two sets of declarations:
+-- those which contain type annotations, and those which don't.
+-- This function also generates fresh unification variables for the types of
+-- declarations without type annotations, returned in the 'UntypedData' structure.
typeDictionaryForBindingGroup
- :: (MonadState CheckState m)
+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Maybe ModuleName
-> [(Ident, Expr)]
- -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
+ -> m SplitBindingGroup
typeDictionaryForBindingGroup moduleName vals = do
- let
- -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
- es = map isTyped vals
- -- Filter the typed and untyped declarations
- untyped = lefts es
- typed = rights es
- -- Make a map of names to typed declarations
- typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
-
- -- Create fresh unification variables for the types of untyped declarations
- untypedNames <- replicateM (length untyped) freshType
-
- let
- -- Make a map of names to the unification variables of untyped declarations
- untypedDict = zip (map fst untyped) untypedNames
- -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
- dict = M.fromList (map (\(ident, ty) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict)
- return (untyped, typed, dict, untypedDict)
-
+ -- Filter the typed and untyped declarations and make a map of names to typed declarations.
+ -- Replace type wildcards here so that the resulting dictionary of types contains the
+ -- fully expanded types.
+ let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)
+ (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do
+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
+ return ((ident, ty'), (ident, (expr, ty', checkType)))
+ -- Create fresh unification variables for the types of untyped declarations
+ (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do
+ ty <- freshType
+ return ((ident, ty), (ident, (expr, ty)))
+ -- Create the dictionary of all name/type pairs, which will be added to the
+ -- environment during type checking
+ let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined))
+ | (ident, ty) <- typedDict <> untypedDict
+ ]
+ return (SplitBindingGroup untyped' typed' dict)
+ where
+ -- | Check if a value contains a type annotation, and if so, separate it
+ -- from the value itself.
+ splitTypeAnnotation :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
+ splitTypeAnnotation (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
+ splitTypeAnnotation (name, PositionedValue pos c value) =
+ bimap (second (PositionedValue pos c))
+ (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))
+ (splitTypeAnnotation (name, value))
+ splitTypeAnnotation (name, value) = Left (name, value)
+
+-- | Check the type annotation of a typed value in a binding group.
checkTypedBindingGroupElement
:: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> ModuleName
-> (Ident, (Expr, Type, Bool))
- -> TypeData
+ -- ^ The identifier we are trying to define, along with the expression and its type annotation
+ -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
+ -- ^ Names brought into scope in this binding group
-> m (Ident, (Expr, Type))
-checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
- -- Replace type wildcards
- ty' <- replaceTypeWildcards ty
+checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
-- Kind check
(kind, args) <- kindOfWithScopedVars ty
checkTypeKind ty kind
-- Check the type with the new names in scope
- ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
- val'' <- if checkType
- then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''
- else return (TypedValue False val' ty'')
- return (ident, (val'', ty''))
+ val' <- if checkType
+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty
+ else return (TypedValue False val ty)
+ return (ident, (val', ty))
+-- | Infer a type for a value in a binding group which lacks an annotation.
typeForBindingGroupElement
:: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => (Ident, Expr)
- -> TypeData
- -> UntypedData
+ => (Ident, (Expr, Type))
+ -- ^ The identifier we are trying to define, along with the expression and its assigned type
+ -- (at this point, this should be a unification variable)
+ -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
+ -- ^ Names brought into scope in this binding group
-> m (Ident, (Expr, Type))
-typeForBindingGroupElement (ident, val) dict untypedDict = do
+typeForBindingGroupElement (ident, (val, ty)) dict = do
-- Infer the type with the new names in scope
- TypedValue _ val' ty <- bindNames dict $ infer val
- unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)
- return (ident, (TypedValue True val' ty, ty))
-
--- | Check if a value contains a type annotation
-isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
-isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
-isTyped (name, PositionedValue pos c value) =
- bimap (second (PositionedValue pos c))
- (second (\(e, t, b) -> (PositionedValue pos c e, t, b)))
- (isTyped (name, value))
-isTyped (name, value) = Left (name, value)
+ TypedValue _ val' ty' <- bindNames dict $ infer val
+ -- Unify the type with the unification variable we chose for this definition
+ unifyTypes ty ty'
+ return (ident, (TypedValue True val' ty', ty'))
-- | Check the kind of a type, failing if it is not of kind *.
-checkTypeKind ::
- (MonadError MultipleErrors m) =>
- Type ->
- Kind ->
- m ()
+checkTypeKind
+ :: MonadError MultipleErrors m
+ => Type
+ -> Kind
+ -> m ()
checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType
-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -247,11 +268,11 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =
--
-- This is necessary during type checking to avoid unifying a polymorphic type with a
-- unification variable.
-instantiatePolyTypeWithUnknowns ::
- (MonadState CheckState m, MonadError MultipleErrors m) =>
- Expr ->
- Type ->
- m (Expr, Type)
+instantiatePolyTypeWithUnknowns
+ :: (MonadState CheckState m, MonadError MultipleErrors m)
+ => Expr
+ -> Type
+ -> m (Expr, Type)
instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
ty' <- replaceVarWithUnknown ident ty
instantiatePolyTypeWithUnknowns val ty'
@@ -262,17 +283,17 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- | Infer a type for a value, rethrowing any error to provide a more useful error message
-infer ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- m Expr
+infer
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> m Expr
infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
-- | Infer a type for a value
-infer' ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- m Expr
+infer'
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> m Expr
infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString
@@ -289,22 +310,22 @@ infer' (Literal (ArrayLiteral vals)) = do
infer' (Literal (ObjectLiteral ps)) = do
ensureNoDuplicateProperties ps
ts <- traverse (infer . snd) ps
- let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
+ let fields = zipWith (\name (TypedValue _ _ t) -> (Label name, t)) (map fst ps) ts
ty = TypeApp tyRecord $ rowFromList (fields, REmpty)
return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty
infer' (ObjectUpdate o ps) = do
ensureNoDuplicateProperties ps
row <- freshType
newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps
- let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
- oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType
+ let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals
+ oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType
let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)
o' <- TypedValue True <$> check o oldTy <*> pure oldTy
return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)
infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
field <- freshType
rest <- freshType
- typed <- check val (TypeApp tyRecord (RCons prop field rest))
+ typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest))
return $ TypedValue True (Accessor prop typed) field
infer' (Abs (Left arg) ret) = do
ty <- freshType
@@ -369,13 +390,13 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
return $ TypedValue t (PositionedValue pos c v) ty
infer' v = internalError $ "Invalid argument to infer: " ++ show v
-inferLetBinding ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- [Declaration] ->
- [Declaration] ->
- Expr ->
- (Expr -> m Expr) ->
- m ([Declaration], Expr)
+inferLetBinding
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [Declaration]
+ -> [Declaration]
+ -> Expr
+ -> (Expr -> m Expr)
+ -> m ([Declaration], Expr)
inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
@@ -393,9 +414,9 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret
bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
- (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
+ SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
- ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict
let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
bindNames dict $ do
makeBindingGroupVisible
@@ -406,11 +427,12 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr
inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
-- | Infer the types of variables brought into scope by a binder
-inferBinder :: forall m.
- (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Type ->
- Binder ->
- m (M.Map Ident Type)
+inferBinder
+ :: forall m
+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Type
+ -> Binder
+ -> m (M.Map Ident Type)
inferBinder _ NullBinder = return M.empty
inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty
inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
@@ -442,12 +464,12 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do
unifyTypes val (TypeApp tyRecord row)
return m1
where
- inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)
+ inferRowProperties :: Type -> Type -> [(PSString, Binder)] -> m (M.Map Ident Type)
inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty
inferRowProperties nrow row ((name, binder):binders) = do
propTy <- freshType
m1 <- inferBinder propTy binder
- m2 <- inferRowProperties nrow (RCons name propTy row) binders
+ m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders
return $ m1 `M.union` m2
inferBinder val (LiteralBinder (ArrayLiteral binders)) = do
el <- freshType
@@ -485,11 +507,11 @@ binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
binderRequiresMonotype _ = True
-- | Instantiate polytypes only when necessitated by a binder.
-instantiateForBinders ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- [Expr] ->
- [CaseAlternative] ->
- m ([Expr], [Type])
+instantiateForBinders
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [Expr]
+ -> [CaseAlternative]
+ -> m ([Expr], [Type])
instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
TypedValue _ val' ty <- infer val
if inst
@@ -502,12 +524,12 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
-- |
-- Check the types of the return values in a set of binders in a case statement
--
-checkBinders ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- [Type] ->
- Type ->
- [CaseAlternative] ->
- m [CaseAlternative]
+checkBinders
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [Type]
+ -> Type
+ -> [CaseAlternative]
+ -> m [CaseAlternative]
checkBinders _ _ [] = return []
checkBinders nvals ret (CaseAlternative binders result : bs) = do
guardWith (errorMessage $ OverlappingArgNames Nothing) $
@@ -531,11 +553,11 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- |
-- Check the type of a value, rethrowing errors to provide a better error message
--
-check ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- Type ->
- m Expr
+check
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> Type
+ -> m Expr
check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
-- |
@@ -641,14 +663,14 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do
-- We need to be careful to avoid duplicate labels here.
-- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.
let (propsToCheck, rest) = rowToList row
- (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
+ (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map (Label . fst) ps) propsToCheck
us <- zip (map fst removedProps) <$> replicateM (length ps) freshType
obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
ps' <- checkProperties e ps row True
return $ TypedValue True (ObjectUpdate obj' ps') t
check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
rest <- freshType
- val' <- check val (TypeApp tyRecord (RCons prop ty rest))
+ val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest))
return $ TypedValue True (Accessor prop val') ty
check' v@(Constructor c) ty = do
env <- getEnv
@@ -678,13 +700,13 @@ check' val ty = do
--
-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
--
-checkProperties ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- [(Text, Expr)] ->
- Type ->
- Bool ->
- m [(Text, Expr)]
+checkProperties
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> [(PSString, Expr)]
+ -> Type
+ -> Bool
+ -> m [(PSString, Expr)]
checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where
go [] [] REmpty = return []
go [] [] u@(TUnknown _)
@@ -694,18 +716,18 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
go [] [] Skolem{} | lax = return []
go [] ((p, _): _) _ | lax = return []
| otherwise = throwError . errorMessage $ PropertyIsMissing p
- go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p
+ go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty $ Label p
go ((p,v):ps') ts r =
- case lookup p ts of
+ case lookup (Label p) ts of
Nothing -> do
v'@(TypedValue _ _ ty) <- infer v
rest <- freshType
- unifyTypes r (RCons p ty rest)
+ unifyTypes r (RCons (Label p) ty rest)
ps'' <- go ps' ts rest
return $ (p, v') : ps''
Just ty -> do
v' <- check v ty
- ps'' <- go ps' (delete (p, ty) ts) r
+ ps'' <- go ps' (delete (Label p, ty) ts) r
return $ (p, v') : ps''
go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
@@ -771,9 +793,9 @@ checkFunctionApplication' fn u arg = do
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
-ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m ()
+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m ()
ensureNoDuplicateProperties ps =
let ls = map fst ps in
case ls \\ nub ls of
- l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing
+ l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing
_ -> return ()
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 9625c33..a920e88 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -31,6 +31,7 @@ import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Skolems
+import Language.PureScript.Label (Label(..))
import Language.PureScript.Types
-- | Generate a fresh type variable
@@ -139,7 +140,7 @@ unifyRows r1 r2 =
forM_ int (uncurry unifyTypes)
unifyRows' sd1 r1' sd2 r2'
where
- unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m ()
+ unifyRows' :: [(Label, Type)] -> Type -> [(Label, 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
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 1477015..e345ad9 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -20,6 +20,8 @@ import qualified Data.Text as T
import Language.PureScript.AST.SourcePos
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Label (Label)
+import Language.PureScript.PSString (PSString)
-- |
-- An identifier for the scope of a skolem variable
@@ -36,7 +38,7 @@ data Type
-- | A named type variable
| TypeVar Text
-- | A type-level string
- | TypeLevelString Text
+ | TypeLevelString PSString
-- | A type wildcard, as would appear in a partial type synonym
| TypeWildcard SourceSpan
-- | A type constructor
@@ -55,7 +57,7 @@ data Type
-- | An empty row
| REmpty
-- | A non-empty row
- | RCons Text Type Type
+ | RCons Label Type Type
-- | A type with a kind annotation
| KindedType Type Kind
-- | A placeholder used in pretty printing
@@ -108,7 +110,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData)
-- |
-- Convert a row to a list of pairs of labels and types
--
-rowToList :: Type -> ([(Text, Type)], Type)
+rowToList :: Type -> ([(Label, Type)], Type)
rowToList (RCons name ty row) = let (tys, rest) = rowToList row
in ((name, ty):tys, rest)
rowToList r = ([], r)
@@ -116,7 +118,7 @@ rowToList r = ([], r)
-- |
-- Convert a list of labels and types to a row
--
-rowFromList :: ([(Text, Type)], Type) -> Type
+rowFromList :: ([(Label, Type)], Type) -> Type
rowFromList ([], r) = r
rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
diff --git a/stack.yaml b/stack.yaml
index 3fbbbeb..6d5f737 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,3 +1,5 @@
resolver: lts-6.25
packages:
- '.'
+extra-deps:
+- bower-json-1.0.0.1
diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs
index f758acb..65c7173 100644
--- a/tests/TestPsci.hs
+++ b/tests/TestPsci.hs
@@ -120,7 +120,7 @@ getPSCiState :: IO PSCiState
getPSCiState = do
cwd <- getCurrentDirectory
let supportDir = cwd </> "tests" </> "support" </> "bower_components"
- let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
pursFiles <- supportFiles "purs"
modulesOrFirstError <- loadAllModules pursFiles
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 67e3fbf..783f0c7 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -69,11 +69,15 @@ supportModules =
, "Control.Monad.Eff.Class"
, "Control.Monad.Eff.Console"
, "Control.Monad.Eff.Unsafe"
+ , "Control.Monad.Rec.Class"
, "Control.Monad.ST"
, "Control.MonadPlus"
, "Control.MonadZero"
, "Control.Plus"
, "Control.Semigroupoid"
+ , "Data.Array"
+ , "Data.Array.Partial"
+ , "Data.Array.ST"
, "Data.Bifoldable"
, "Data.Bifunctor"
, "Data.Bifunctor.Clown"
@@ -86,7 +90,10 @@ supportModules =
, "Data.Boolean"
, "Data.BooleanAlgebra"
, "Data.Bounded"
+ , "Data.Char"
, "Data.CommutativeRing"
+ , "Data.Either"
+ , "Data.Either.Nested"
, "Data.Eq"
, "Data.EuclideanRing"
, "Data.Field"
@@ -95,6 +102,7 @@ supportModules =
, "Data.Function.Uncurried"
, "Data.Functor"
, "Data.Functor.Invariant"
+ , "Data.Generic"
, "Data.Generic.Rep"
, "Data.Generic.Rep.Eq"
, "Data.Generic.Rep.Monoid"
@@ -102,6 +110,7 @@ supportModules =
, "Data.Generic.Rep.Semigroup"
, "Data.Generic.Rep.Show"
, "Data.HeytingAlgebra"
+ , "Data.Identity"
, "Data.Maybe"
, "Data.Maybe.First"
, "Data.Maybe.Last"
@@ -115,6 +124,7 @@ supportModules =
, "Data.Monoid.Multiplicative"
, "Data.NaturalTransformation"
, "Data.Newtype"
+ , "Data.NonEmpty"
, "Data.Ord"
, "Data.Ord.Unsafe"
, "Data.Ordering"
@@ -122,15 +132,23 @@ supportModules =
, "Data.Semigroup"
, "Data.Semiring"
, "Data.Show"
+ , "Data.String"
+ , "Data.String.CaseInsensitive"
+ , "Data.String.Regex"
+ , "Data.String.Regex.Flags"
+ , "Data.String.Regex.Unsafe"
+ , "Data.String.Unsafe"
, "Data.Symbol"
, "Data.Traversable"
+ , "Data.Tuple"
+ , "Data.Tuple.Nested"
+ , "Data.Unfoldable"
, "Data.Unit"
, "Data.Void"
, "Partial"
, "Partial.Unsafe"
, "Prelude"
, "Test.Assert"
- , "Test.Main"
, "Type.Data.Ordering"
, "Type.Data.Symbol"
, "Type.Equality"
diff --git a/tests/support/bower.json b/tests/support/bower.json
index c6a7173..aef7751 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -9,6 +9,7 @@
"purescript-st": "2.0.0",
"purescript-partial": "1.1.2",
"purescript-newtype": "1.1.0",
+ "purescript-generics": "3.3.0",
"purescript-generics-rep": "4.0.0",
"purescript-symbols": "^2.0.0",
"purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac",