purescript 0.10.4 → 0.10.5

raw patch · 49 files changed

+817/−333 lines, 49 filesdep +scientificdep ~bower-jsonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: scientific

Dependency ranges changed: bower-json

API changes (from Hackage documentation)

Files

• examples/failing/2534.purs +8/−0
• examples/failing/DeclConflictDuplicateCtor.purs +5/−0
• examples/passing/StringEdgeCases.purs +9/−0
• examples/passing/StringEdgeCases/Records.purs +66/−0
• examples/passing/StringEdgeCases/Symbols.purs +30/−0
• examples/passing/StringEscapes.purs +1/−1
• purescript.cabal +6/−2
• src/Language/PureScript/AST/Declarations.hs +8/−6
• src/Language/PureScript/AST/Literals.hs +3/−3
• src/Language/PureScript/CodeGen/JS.hs +20/−14
• src/Language/PureScript/CodeGen/JS/AST.hs +5/−3
• src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +2/−1
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +1/−1
• src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +2/−1
• src/Language/PureScript/CoreFn/Desugar.hs +3/−2
• src/Language/PureScript/CoreFn/Expr.hs +3/−3
• src/Language/PureScript/CoreFn/ToJSON.hs +13/−2
• src/Language/PureScript/Docs/RenderedCode/Render.hs +7/−5
• src/Language/PureScript/Docs/Types.hs +6/−7
• src/Language/PureScript/Errors.hs +12/−10
• src/Language/PureScript/Kinds.hs +66/−4
• src/Language/PureScript/Label.hs +16/−0
• src/Language/PureScript/PSString.hs +187/−0
• src/Language/PureScript/Parser/Common.hs +7/−0
• src/Language/PureScript/Parser/Declarations.hs +9/−8
• src/Language/PureScript/Parser/Lexer.hs +7/−17
• src/Language/PureScript/Parser/Types.hs +3/−3
• src/Language/PureScript/Pretty.hs +1/−0
• src/Language/PureScript/Pretty/Common.hs +4/−8
• src/Language/PureScript/Pretty/JS.hs +10/−30
• src/Language/PureScript/Pretty/Kinds.hs +14/−11
• src/Language/PureScript/Pretty/Types.hs +22/−6
• src/Language/PureScript/Pretty/Values.hs +8/−7
• src/Language/PureScript/Publish.hs +6/−7
• src/Language/PureScript/Publish/BoxesHelpers.hs +5/−0
• src/Language/PureScript/Publish/ErrorsWarnings.hs +7/−7
• src/Language/PureScript/Sugar/Names/Env.hs +6/−1
• src/Language/PureScript/Sugar/ObjectWildcards.hs +4/−4
• src/Language/PureScript/Sugar/TypeClasses.hs +4/−2
• src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +39/−24
• src/Language/PureScript/TypeChecker/Entailment.hs +6/−4
• src/Language/PureScript/TypeChecker/Kinds.hs +1/−0
• src/Language/PureScript/TypeChecker/Types.hs +144/−122
• src/Language/PureScript/TypeChecker/Unify.hs +2/−1
• src/Language/PureScript/Types.hs +6/−4
• stack.yaml +2/−0
• tests/TestPsci.hs +1/−1
• tests/TestUtils.hs +19/−1
• tests/support/bower.json +1/−0

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

@@ -0,0 +1,5 @@+-- @shouldFailWith DeclConflict+module Main where++data T = Fail | Fail+

@@ -0,0 +1,9 @@+module Main where++import Prelude+import Records as Records+import Symbols as Symbols++main = do+  Records.main+  Symbols.main

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

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

@@ -22,5 +22,5 @@   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"

@@ -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 @@                   , 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 @@                    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 @@                    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 @@                      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 @@                      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

@@ -18,6 +18,8 @@ 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 @@   | 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 @@   | 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 @@   | 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 @@   -- 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   --

@@ -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 @@   -- |   -- A string literal   ---  | StringLiteral Text+  | StringLiteral PSString   -- |   -- A character literal   --@@ -34,5 +34,5 @@   -- |   -- An object literal   ---  | ObjectLiteral [(Text, a)]+  | ObjectLiteral [(PSString, a)]   deriving (Eq, Ord, Show, Functor)

@@ -20,6 +20,7 @@ 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 @@                                    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 @@     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 @@   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 @@   -- 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 @@     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 @@   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 @@   -- |   -- 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 @@   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 @@       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 @@   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 @@     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

@@ -11,6 +11,7 @@  import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments+import Language.PureScript.PSString (PSString) import Language.PureScript.Traversals  -- |@@ -132,7 +133,7 @@   -- |   -- A string literal   ---  | JSStringLiteral (Maybe SourceSpan) Text+  | JSStringLiteral (Maybe SourceSpan) PSString   -- |   -- A boolean literal   --@@ -156,7 +157,7 @@   -- |   -- An object literal   ---  | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)]+  | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]   -- |   -- An object property accessor expression   --@@ -240,7 +241,8 @@   -- |   -- 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

@@ -11,6 +11,7 @@  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 (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

@@ -239,7 +239,7 @@   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)

@@ -12,6 +12,7 @@ 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 @@   -- 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 =

@@ -24,6 +24,7 @@ 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 @@     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 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)

@@ -6,11 +6,11 @@ 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 @@   -- |   -- 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   --

@@ -9,6 +9,7 @@  import Prelude.Compat +import Data.Maybe (fromMaybe) import Data.Aeson import Data.Version (Version, showVersion) import Data.Text (Text)@@ -17,6 +18,7 @@ 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 (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"

@@ -26,7 +26,9 @@ 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 @@   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 @@   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

@@ -10,6 +10,7 @@ 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 @@     "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 @@  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 @@   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 @@  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 @@       , "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

@@ -32,10 +32,10 @@ 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 @@   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 @@       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 @@             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 @@     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 @@             , 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 @@   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)

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

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

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

@@ -16,6 +16,7 @@ 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 @@ -71,6 +72,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.

@@ -33,6 +33,7 @@ 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 @@ 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 @@ 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 @@ 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

@@ -70,11 +70,13 @@ 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 @@   | Qualifier Text   | Symbol Text   | CharLiteral Char-  | StringLiteral Text+  | StringLiteral PSString   | Number (Either Integer Double)   | HoleLit Text   deriving (Show, Eq, Ord)@@ -249,18 +251,6 @@   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 @@       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 @@   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

@@ -9,7 +9,6 @@  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.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 @@   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

@@ -15,3 +15,4 @@ 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)

@@ -15,7 +15,7 @@ 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 @@   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

@@ -25,8 +25,7 @@ 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 @@    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 @@     , 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 @@   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 @@ 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 = mkPattern' match   where   match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val-   match _ = mzero  lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)

@@ -10,6 +10,7 @@ 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.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 @@ -- | 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 ] ]

@@ -10,6 +10,8 @@   , prettyPrintTypeAtom   , prettyPrintRowWith   , prettyPrintRow+  , prettyPrintLabel+  , prettyPrintObjectKey   ) where  import Prelude.Compat@@ -18,6 +20,7 @@ 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.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 @@ 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 @@     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 @@ -- | 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

@@ -20,8 +20,9 @@ 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 @@ 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 @@                             , 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 @@  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 (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 @@   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) =   "[ "

@@ -209,7 +209,7 @@       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 @@     [] ->       userError NoLicenseSpecified     ls ->-      unless (any isValidSPDX ls)+      unless (any (isValidSPDX . T.unpack) ls)         (userError InvalidLicense)  -- |@@ -320,8 +320,7 @@   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 =   fmap (map fst) $     key "dependencies" $-      eachInObjectWithKey (parsePackageName . T.unpack) (return ())+      eachInObjectWithKey parsePackageName (return ())  asDependencyStatus :: Parse e DependencyStatus asDependencyStatus = do@@ -371,7 +370,7 @@       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 @@   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

@@ -6,6 +6,8 @@  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@@ -36,6 +38,9 @@  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

@@ -65,7 +65,7 @@  data RepositoryFieldError   = RepositoryFieldMissing-  | BadRepositoryType String+  | BadRepositoryType Text   | NotOnGithub   deriving (Show) @@ -213,7 +213,7 @@         , "installed:"         ])       ] ++-        bulletedList runPackageName (NonEmpty.toList pkgs)+        bulletedListT runPackageName (NonEmpty.toList pkgs)         ++       [ spacer       , para (concat@@ -263,7 +263,7 @@   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 @@       ["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 @@       [ "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 @@       , "not be parsed:"       ])     ] ++-      bulletedList showTuple (NonEmpty.toList pkgs)+      bulletedListT showTuple (NonEmpty.toList pkgs)       ++     [ spacer     , para (concat@@ -414,7 +414,7 @@       ])     ]   where-  showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag+  showTuple (pkgName, tag) = runPackageName pkgName <> "#" <> tag  warnDirtyWorkingTree :: Box warnDirtyWorkingTree =

@@ -242,7 +242,12 @@   -> 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) $

@@ -11,11 +11,11 @@  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 @@     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 @@   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 @@   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))

@@ -19,6 +19,8 @@ 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 @@         ]       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 @@             , 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

@@ -11,9 +11,11 @@ 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.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 @@         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 @@       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 @@         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 @@       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 @@                 [ ("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 @@         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 @@               (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 @@         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 @@     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 @@     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 @@     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 @@ 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 @@           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

@@ -37,13 +37,15 @@ 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 @@         -- 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 @@         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 @@               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

@@ -229,6 +229,7 @@     unifyKinds k k'     return k'   go TypeWildcard{} = freshKind+  go TUnknown{} = freshKind   go (TypeLevelString _) = return kindSymbol   go (TypeVar v) = do     Just moduleName <- checkCurrentModule <$> get

@@ -34,14 +34,14 @@ 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.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 @@   -> 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 @@     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 @@ -- -- 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 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 (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 @@   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 @@   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 _ _ _ _ = 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 @@   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 _ = 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 @@ -- | -- 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 @@ -- | -- 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 @@   -- 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 @@ -- -- 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 @@   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 @@ -- | -- 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 ()

@@ -31,6 +31,7 @@ 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 @@     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

@@ -20,6 +20,8 @@ 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 @@   -- | 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 @@   -- | 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 @@ -- | -- 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 @@ -- | -- 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)) 

@@ -1,3 +1,5 @@ resolver: lts-6.25 packages: - '.'+extra-deps:+- bower-json-1.0.0.1

@@ -120,7 +120,7 @@ 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

@@ -69,11 +69,15 @@   , "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 @@   , "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 @@   , "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 @@   , "Data.Generic.Rep.Semigroup"   , "Data.Generic.Rep.Show"   , "Data.HeytingAlgebra"+  , "Data.Identity"   , "Data.Maybe"   , "Data.Maybe.First"   , "Data.Maybe.Last"@@ -115,6 +124,7 @@   , "Data.Monoid.Multiplicative"   , "Data.NaturalTransformation"   , "Data.Newtype"+  , "Data.NonEmpty"   , "Data.Ord"   , "Data.Ord.Unsafe"   , "Data.Ordering"@@ -122,15 +132,23 @@   , "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"

@@ -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",