773d778 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

fixes #2438: represent PureScript strings as sequence of Word16

commit773d778a3df014d64a509abe043969d919ec9ae6 authorMichael Ficarra <git@michael.ficarra.me> dateSun 11 Dec 2016, 18:20 (10 years ago) parent7876083

34 files changed+388−198

compare with golang

unifiedsplit

examples/passing/RecordLabels.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+import RecordLabels as RecordLabels

5+main = RecordLabels.main

examples/passing/RecordLabels/RecordLabels.pursnew file+25

@@ -0,0 +1,25 @@

1+module RecordLabels where

3+import Prelude

4+import Data.Generic (class Generic, gShow)

5+import Control.Monad.Eff.Console (log)

6+import Test.Assert (assert')

8+newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int }

9+newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int }

10+

11+derive instance genericAstralKeys :: Generic AstralKeys

12+derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys

13+

14+loneSurrogateKeys =

15+ gShow (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }) ==

16+ """LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }"""

17+

18+astralKeys =

19+ gShow (AstralKeys { "💡": 0, "💢": 1 }) ==

20+ """AstralKeys { "💡": 0, "💢": 1 }"""

21+

22+main = do

23+ assert' "lone surrogate keys" loneSurrogateKeys

24+ assert' "astral keys" astralKeys

25+ log "Done"

examples/passing/StringEscapes.purs+1−1

@@ -22,5 +22,5 @@ main = do

2222 assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair

2323 assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates

2424 assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates

25− -- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing

25+ assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing

2626 log "Done"

purescript.cabal+3

@@ -141,6 +141,7 @@ library

141141 protolude >= 0.1.6,

142142 regex-tdfa -any,

143143 safe >= 0.3.9 && < 0.4,

144+ scientific >= 0.3.4.9 && < 0.4,

144145 semigroups >= 0.16.2 && < 0.19,

145146 sourcemap >= 0.1.6,

146147 spdx == 0.2.*,

@@ -194,6 +195,7 @@ library

194195 Language.PureScript.Errors

195196 Language.PureScript.Errors.JSON

196197 Language.PureScript.Kinds

198+ Language.PureScript.Label

197199 Language.PureScript.Linter

198200 Language.PureScript.Linter.Exhaustive

199201 Language.PureScript.Linter.Imports

@@ -214,6 +216,7 @@ library

214216 Language.PureScript.Pretty.Kinds

215217 Language.PureScript.Pretty.Types

216218 Language.PureScript.Pretty.Values

219+ Language.PureScript.PSString

217220 Language.PureScript.Renamer

218221 Language.PureScript.Sugar

219222 Language.PureScript.Sugar.BindingGroups

src/Language/PureScript/AST/Declarations.hs+8−6

@@ -18,6 +18,8 @@ import Language.PureScript.AST.Literals

1818import Language.PureScript.AST.Operators

1919import Language.PureScript.AST.SourcePos

2020import Language.PureScript.Types

21+import Language.PureScript.PSString (PSString)

22+import Language.PureScript.Label (Label)

2123import Language.PureScript.Names

2224import Language.PureScript.Kinds

2325import Language.PureScript.TypeClassDictionaries

@@ -90,7 +92,7 @@ data SimpleErrorMessage

9092 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

9193 | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

9294 | CannotFindDerivingType (ProperName 'TypeName)

93− | DuplicateLabel Text (Maybe Expr)

95+ | DuplicateLabel Label (Maybe Expr)

9496 | DuplicateValueDeclaration Ident

9597 | ArgListLengthsDiffer Ident

9698 | OverlappingArgNames (Maybe Ident)

@@ -99,8 +101,8 @@ data SimpleErrorMessage

99101 | ExpectedType Type Kind

100102 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

101103 | ExprDoesNotHaveType Expr Type

102− | PropertyIsMissing Text

103− | AdditionalProperty Text

104+ | PropertyIsMissing Label

105+ | AdditionalProperty Label

104106 | TypeSynonymInstance

105107 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

106108 | InvalidNewtype (ProperName 'TypeName)

@@ -145,7 +147,7 @@ data ErrorMessageHint

145147 | ErrorInModule ModuleName

146148 | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

147149 | ErrorInSubsumption Type Type

148− | ErrorCheckingAccessor Expr Text

150+ | ErrorCheckingAccessor Expr PSString

149151 | ErrorCheckingType Expr Type

150152 | ErrorCheckingKind Type

151153 | ErrorCheckingGuard

@@ -573,11 +575,11 @@ data Expr

573575 -- Anonymous arguments will be removed during desugaring and expanded

574576 -- into a lambda that reads a property from a record.

575577 --

576− | Accessor Text Expr

578+ | Accessor PSString Expr

577579 -- |

578580 -- Partial record update

579581 --

580− | ObjectUpdate Expr [(Text, Expr)]

582+ | ObjectUpdate Expr [(PSString, Expr)]

581583 -- |

582584 -- Function introduction

583585 --

src/Language/PureScript/AST/Literals.hs+3−3

@@ -4,7 +4,7 @@

44module Language.PureScript.AST.Literals where

66import Prelude.Compat

7−import Data.Text (Text)

7+import Language.PureScript.PSString (PSString)

99-- |

1010-- Data type for literal values. Parameterised so it can be used for Exprs and

@@ -18,7 +18,7 @@ data Literal a

1818 -- |

1919 -- A string literal

2020 --

21− | StringLiteral Text

21+ | StringLiteral PSString

2222 -- |

2323 -- A character literal

2424 --

@@ -34,5 +34,5 @@ data Literal a

3434 -- |

3535 -- An object literal

3636 --

37− | ObjectLiteral [(Text, a)]

37+ | ObjectLiteral [(PSString, a)]

3838 deriving (Eq, Ord, Show, Functor)

src/Language/PureScript/CodeGen/JS.hs+19−16

@@ -20,6 +20,7 @@ import qualified Data.Foldable as F

2020import qualified Data.Map as M

2121import Data.Maybe (fromMaybe, isNothing)

2222import Data.Monoid ((<>))

23+import Data.String (fromString)

2324import Data.Text (Text)

2425import qualified Data.Text as T

2526

@@ -34,6 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),

3435 errorMessage, rethrowWithPosition, addHint)

3536import Language.PureScript.Names

3637import Language.PureScript.Options

38+import Language.PureScript.PSString (PSString, mkString, codePoints)

3739import Language.PureScript.Traversals (sndM)

3840import qualified Language.PureScript.Constants as C

3941

@@ -65,8 +67,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

6567 let moduleBody = header : foreign' ++ jsImports ++ concat optimized

6668 let foreignExps = exps `intersect` (fst `map` foreigns)

6769 let standardExps = exps \\ foreignExps

68− let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps

69− ++ map (runIdent &&& foreignIdent) foreignExps

70+ let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps

71+ ++ map (mkString . runIdent &&& foreignIdent) foreignExps

7072 return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']

7173

7274 where

@@ -108,7 +110,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

108110 importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS

109111 importToJs mnLookup mn' = do

110112 let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

111− let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (T.pack (".." </> T.unpack (runModuleName mn')))]

113+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn')))]

112114 withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

113115

114116 -- |

@@ -176,12 +178,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

176178 -- indexer is returned.

177179 --

178180 accessor :: Ident -> JS -> JS

179− accessor (Ident prop) = accessorString prop

181+ accessor (Ident prop) = accessorString $ mkString prop

180182 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

181183

182− accessorString :: Text -> JS -> JS

183− accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

184− | otherwise = JSAccessor Nothing prop

184+ accessorString :: PSString -> JS -> JS

185+ accessorString prop =

186+ let quoted = JSIndexer Nothing (JSStringLiteral Nothing prop) in

187+ either (const quoted) (\t -> if identNeedsEscaping t then quoted else JSAccessor Nothing prop) $ codePoints prop

185188

186189 -- |

187190 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

@@ -212,7 +215,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

212215 unAbs (Abs _ arg val) = arg : unAbs val

213216 unAbs _ = []

214217 assign :: Ident -> JS

215− assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))

218+ assign name = JSAssignment Nothing (accessorString (mkString $ runIdent name) (JSVar Nothing "this"))

216219 (var name)

217220 valueToJs' (Abs _ arg val) = do

218221 ret <- valueToJs val

@@ -256,7 +259,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

256259 (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]

257260 valueToJs' (Constructor _ _ (ProperName ctor) fields) =

258261 let constructor =

259− let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

262+ let body = [ JSAssignment Nothing (JSAccessor Nothing (mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

260263 in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)

261264 createFn =

262265 let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)

@@ -272,7 +275,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

272275 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)

273276 literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)

274277 literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s

275− literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (T.singleton c)

278+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (fromString [c])

276279 literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b

277280 literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs

278281 literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps

@@ -280,7 +283,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

280283 -- |

281284 -- Shallow copy an object.

282285 --

283− extendObj :: JS -> [(Text, JS)] -> m JS

286+ extendObj :: JS -> [(PSString, JS)] -> m JS

284287 extendObj obj sts = do

285288 newObj <- freshName

286289 key <- freshName

@@ -317,7 +320,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

317320 qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)

318321

319322 foreignIdent :: Ident -> JS

320− foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")

323+ foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign")

321324

322325 -- |

323326 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

@@ -341,7 +344,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

341344 go _ _ _ = internalError "Invalid arguments to bindersToJs"

342345

343346 failedPatternError :: [Text] -> JS

344− failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]

347+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing $ mkString failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]

345348

346349 failedPatternMessage :: Text

347350 failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": "

@@ -391,7 +394,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

391394 argVar <- freshName

392395 done'' <- go remain done'

393396 js <- binderToJs argVar done'' binder

394− return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)

397+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (mkString $ identToJs field) (JSVar Nothing varName))) : js)

395398 binderToJs' _ _ ConstructorBinder{} =

396399 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

397400 binderToJs' varName done (NamedBinder _ ident binder) = do

@@ -402,7 +405,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

402405 literalToBinderJS varName done (NumericLiteral num) =

403406 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]

404407 literalToBinderJS varName done (CharLiteral c) =

405− return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (T.singleton c))) (JSBlock Nothing done) Nothing]

408+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (fromString [c]))) (JSBlock Nothing done) Nothing]

406409 literalToBinderJS varName done (StringLiteral str) =

407410 return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]

408411 literalToBinderJS varName done (BooleanLiteral True) =

@@ -411,7 +414,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

411414 return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]

412415 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

413416 where

414− go :: [JS] -> [(Text, Binder Ann)] -> m [JS]

417+ go :: [JS] -> [(PSString, Binder Ann)] -> m [JS]

415418 go done' [] = return done'

416419 go done' ((prop, binder):bs') = do

417420 propVar <- freshName

src/Language/PureScript/CodeGen/JS/AST.hs+6−4

@@ -11,6 +11,7 @@ import Data.Text (Text)

1111

1212import Language.PureScript.AST (SourceSpan(..))

1313import Language.PureScript.Comments

14+import Language.PureScript.PSString (PSString)

1415import Language.PureScript.Traversals

1516

1617-- |

@@ -132,7 +133,7 @@ data JS

132133 -- |

133134 -- A string literal

134135 --

135− | JSStringLiteral (Maybe SourceSpan) Text

136+ | JSStringLiteral (Maybe SourceSpan) PSString

136137 -- |

137138 -- A boolean literal

138139 --

@@ -156,11 +157,11 @@ data JS

156157 -- |

157158 -- An object literal

158159 --

159− | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)]

160+ | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]

160161 -- |

161162 -- An object property accessor expression

162163 --

163− | JSAccessor (Maybe SourceSpan) Text JS

164+ | JSAccessor (Maybe SourceSpan) PSString JS

164165 -- |

165166 -- A function introduction (optional name, arguments, body)

166167 --

@@ -240,7 +241,8 @@ data JS

240241 -- |

241242 -- Commented Javascript

242243 --

243− | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq)

244+ | JSComment (Maybe SourceSpan) [Comment] JS

245+ deriving (Show, Eq)

244246

245247withSourceSpan :: SourceSpan -> JS -> JS

246248withSourceSpan withSpan = go

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+4−3

@@ -11,6 +11,7 @@ import Data.Maybe (fromMaybe)

1111

1212import Language.PureScript.Crash

1313import Language.PureScript.CodeGen.JS.AST

14+import Language.PureScript.PSString (mkString)

1415

1516applyAll :: [a -> a] -> a -> a

1617applyAll = foldl' (.) id

@@ -71,13 +72,13 @@ removeFromBlock _ js = js

7172

7273isFn :: (Text, Text) -> JS -> Bool

7374isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =

74− x == fnName && y == moduleName

75+ x == mkString fnName && y == moduleName

7576isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =

76− x == fnName && y == moduleName

77+ x == mkString fnName && y == moduleName

7778isFn _ _ = False

7879

7980isDict :: (Text, Text) -> JS -> Bool

80−isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName

81+isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == mkString dictName && y == moduleName

8182isDict _ _ = False

8283

8384isDict' :: [(Text, Text)] -> JS -> Bool

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+4−3

@@ -23,6 +23,7 @@ import qualified Data.Text as T

2323import Language.PureScript.CodeGen.JS.AST

2424import Language.PureScript.CodeGen.JS.Optimizer.Common

2525import qualified Language.PureScript.Constants as C

26+import Language.PureScript.PSString (mkString)

2627

2728-- TODO: Potential bug:

2829-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }

@@ -213,7 +214,7 @@ inlineCommonOperators = applyAll $

213214

214215 isNFn :: Text -> Int -> JS -> Bool

215216 isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))

216− isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))

217+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == mkString (prefix <> T.pack (show n))

217218 isNFn _ _ _ = False

218219

219220 runFn :: Int -> JS -> JS

@@ -235,11 +236,11 @@ inlineCommonOperators = applyAll $

235236 convert other = other

236237

237238 isModFn :: (Text, Text) -> JS -> Bool

238− isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'

239+ isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && mkString op == op'

239240 isModFn _ _ = False

240241

241242 isModFnWithDict :: (Text, Text) -> JS -> Bool

242− isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op'

243+ isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && mkString op == op'

243244 isModFnWithDict _ _ = False

244245

245246-- (f <<< g $ x) = f (g x)

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+7−6

@@ -12,6 +12,7 @@ import Data.Maybe (fromJust, isJust)

1212import Language.PureScript.CodeGen.JS.AST

1313import Language.PureScript.CodeGen.JS.Optimizer.Common

1414import Language.PureScript.Options

15+import Language.PureScript.PSString (mkString)

1516import qualified Language.PureScript.Constants as C

1617

1718magicDo :: Options -> JS -> JS

@@ -67,7 +68,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

6768 -- Check if an expression represents the polymorphic pure or return function

6869 isPurePoly = isFn (C.controlApplicative, C.pure')

6970 -- Check if an expression represents a function in the Eff module

70− isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'

71+ isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && mkString name == name'

7172 isEffFunc _ _ = False

7273

7374 -- Remove __do function applications which remain after desugaring

@@ -104,16 +105,16 @@ inlineST = everywhereOnJS convertBlock

104105 -- or in a more aggressive way, turning wrappers into local variables depending on the

105106 -- agg(ressive) parameter.

106107 convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =

107− JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])

108+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])

108109 convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =

109− if agg then ref else JSAccessor s1 C.stRefValue ref

110+ if agg then ref else JSAccessor s1 (mkString C.stRefValue) ref

110111 convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

111− if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg

112+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) arg

112113 convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

113− if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])

114+ if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) (JSApp s1 func [JSAccessor s1 (mkString C.stRefValue) ref])

114115 convert _ other = other

115116 -- Check if an expression represents a function in the ST module

116− isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'

117+ isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && mkString name == name'

117118 isSTFunc _ _ = False

118119 -- Find all ST Refs initialized in this block

119120 findSTRefsIn = everythingOnJS (++) isSTRef

src/Language/PureScript/CoreFn/Desugar.hs+3−2

@@ -24,6 +24,7 @@ import Language.PureScript.Environment

2424import Language.PureScript.Names

2525import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)

2626import Language.PureScript.Types

27+import Language.PureScript.PSString (mkString)

2728import qualified Language.PureScript.AST as A

2829

2930-- |

@@ -119,7 +120,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

119120 in foldl (App (ss, com, Nothing, Nothing)) ctor args

120121 exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =

121122 Abs (ss, com, ty, Nothing) (Ident "dict")

122− (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))

123+ (Accessor nullAnn (mkString $ runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))

123124 exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =

124125 exprToCoreFn (Just ss) (com ++ com1) ty v

125126 exprToCoreFn _ _ _ e =

@@ -265,7 +266,7 @@ mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.De

265266mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])

266267mkTypeClassConstructor ss com supers members =

267268 let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers

268− props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]

269+ props = [ (mkString arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]

269270 dict = Literal nullAnn (ObjectLiteral props)

270271 in Abs (ss, com, Nothing, Just IsTypeClassConstructor)

271272 (Ident a)

src/Language/PureScript/CoreFn/Expr.hs+3−3

@@ -6,11 +6,11 @@ module Language.PureScript.CoreFn.Expr where

66import Prelude.Compat

88import Control.Arrow ((***))

9−import Data.Text (Text)

109

1110import Language.PureScript.AST.Literals

1211import Language.PureScript.CoreFn.Binders

1312import Language.PureScript.Names

13+import Language.PureScript.PSString (PSString)

1414

1515-- |

1616-- Data type for expressions and terms

@@ -27,11 +27,11 @@ data Expr a

2727 -- |

2828 -- A record property accessor

2929 --

30− | Accessor a Text (Expr a)

30+ | Accessor a PSString (Expr a)

3131 -- |

3232 -- Partial record update

3333 --

34− | ObjectUpdate a (Expr a) [(Text, Expr a)]

34+ | ObjectUpdate a (Expr a) [(PSString, Expr a)]

3535 -- |

3636 -- Function introduction

3737 --

src/Language/PureScript/CoreFn/ToJSON.hs+3−2

@@ -17,6 +17,7 @@ import qualified Data.Text as T

1717import Language.PureScript.AST.Literals

1818import Language.PureScript.CoreFn

1919import Language.PureScript.Names

20+import Language.PureScript.PSString (PSString, codePoints)

2021

2122literalToJSON :: (a -> Value) -> Literal a -> Value

2223literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)

@@ -51,8 +52,8 @@ bindToJSON :: Bind a -> Value

5152bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ]

5253bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs

5354

54−recordToJSON :: (a -> Value) -> [(Text, a)] -> Value

55−recordToJSON f = object . map (\(label, a) -> label .= f a)

55+recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value

56+recordToJSON f = object . map (\(key, a) -> either T.pack id (codePoints key) .= f a)

5657

5758exprToJSON :: Expr a -> Value

5859exprToJSON (Var _ i) = toJSON ( "Var"

src/Language/PureScript/Docs/RenderedCode/Render.hs+4−3

@@ -27,6 +27,7 @@ import Language.PureScript.Kinds

2727import Language.PureScript.Names

2828import Language.PureScript.Pretty.Kinds

2929import Language.PureScript.Types

30+import Language.PureScript.Label (Label(..), renderPSLabel)

3031

3132typeLiterals :: Pattern () Type RenderedCode

3233typeLiterals = mkPattern match

@@ -79,13 +80,13 @@ renderRow = uncurry renderRow' . rowToList

7980 where

8081 renderRow' h t = renderHead h <> renderTail t

8182

82−renderHead :: [(Text, Type)] -> RenderedCode

83+renderHead :: [(Label, Type)] -> RenderedCode

8384renderHead = mintersperse (syntax "," <> sp) . map renderLabel

8485

85−renderLabel :: (Text, Type) -> RenderedCode

86+renderLabel :: (Label, Type) -> RenderedCode

8687renderLabel (label, ty) =

8788 mintersperse sp

88− [ ident label

89+ [ syntax $ renderPSLabel label

8990 , syntax "::"

9091 , renderType ty

9192 ]

src/Language/PureScript/Errors.hs+14−13

@@ -32,10 +32,11 @@ import Language.PureScript.Names

3232import Language.PureScript.Pretty

3333import Language.PureScript.Traversals

3434import Language.PureScript.Types

35−import Language.PureScript.Pretty.Common (endWith)

35+import Language.PureScript.PSString (renderPSString)

36+import Language.PureScript.Label (Label(..))

37+import Language.PureScript.Pretty.Common (before, endWith)

3638import qualified Language.PureScript.Bundle as Bundle

3739import qualified Language.PureScript.Constants as C

38−import Language.PureScript.Pretty.Common (before)

3940

4041import qualified System.Console.ANSI as ANSI

4142

@@ -264,7 +265,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

264265 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

265266 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

266267 gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con

267− gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con

268+ gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> f t <*> pure con

268269 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

269270 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

270271 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

@@ -563,12 +564,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

563564 sortRows t1 t2 = (t1, t2)

564565

565566 -- Put the common labels last

566− sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type)

567+ sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type)

567568 sortRows' (s1, r1) (s2, r2) =

568− let common :: [(Text, (Type, Type))]

569+ let common :: [(Label, (Type, Type))]

569570 common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

570571

571− sd1, sd2 :: [(Text, Type)]

572+ sd1, sd2 :: [(Label, Type)]

572573 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

573574 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

574575 in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)

@@ -670,8 +671,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

670671 ]

671672 renderSimpleErrorMessage (CannotFindDerivingType nm) =

672673 line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found."

673− renderSimpleErrorMessage (DuplicateLabel l expr) =

674− paras $ [ line $ "Label " <> markCode l <> " appears more than once in a row type." ]

674+ renderSimpleErrorMessage (DuplicateLabel (Label l) expr) =

675+ paras $ [ line $ "Label " <> T.pack (show l) <> " appears more than once in a row type." ]

675676 <> foldMap (\expr' -> [ line "Relevant expression: "

676677 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

677678 ]) expr

@@ -703,10 +704,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

703704 , line "does not have type"

704705 , markCodeBox $ indent $ typeAsBox ty

705706 ]

706− renderSimpleErrorMessage (PropertyIsMissing prop) =

707− line $ "Type of expression lacks required label " <> markCode prop <> "."

708− renderSimpleErrorMessage (AdditionalProperty prop) =

709− line $ "Type of expression contains additional label " <> markCode prop <> "."

707+ renderSimpleErrorMessage (PropertyIsMissing (Label prop)) =

708+ line $ "Type of expression lacks required label " <> T.pack (show prop) <> "."

709+ renderSimpleErrorMessage (AdditionalProperty (Label prop)) =

710+ line $ "Type of expression contains additional label " <> T.pack (show prop) <> "."

710711 renderSimpleErrorMessage TypeSynonymInstance =

711712 line "Type class instances for type synonyms are disallowed."

712713 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

@@ -1263,7 +1264,7 @@ renderBox = unlines

12631264 whiteSpace = all isSpace

12641265

12651266toTypelevelString :: Type -> Maybe Box.Box

1266−toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s)

1267+toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ renderPSString s

12671268toTypelevelString (TypeApp (TypeConstructor f) x)

12681269 | f == primName "TypeString" = Just $ typeAsBox x

12691270toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)

src/Language/PureScript/Label.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+module Language.PureScript.Label (Label(..), renderPSLabel) where

4+import Prelude.Compat hiding (lex)

5+import Data.Monoid ()

6+import Data.String (IsString(..))

7+import Data.Text (Text)

8+import Text.Parsec.Combinator (eof)

9+import qualified Data.Aeson as A

10+

11+import Language.PureScript.Parser.Common (runTokenParser)

12+import Language.PureScript.Parser.Lexer (TokenParser, lname, lex)

13+import Language.PureScript.PSString (PSString, codePoints, renderPSString)

14+

15+-- |

16+-- Labels are used as record keys and row entry names. Labels newtype PSString

17+-- because records are indexable by PureScript strings at runtime.

18+--

19+newtype Label = Label PSString

20+ deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON)

21+

22+renderPSLabel :: Label -> Text

23+renderPSLabel (Label s) =

24+ let quoted = const $ renderPSString s in

25+ either quoted (\t -> either quoted (const t) $ runParser lname t) $ codePoints s

26+

27+runParser :: TokenParser a -> Text -> Either String a

28+runParser p s = either (Left . show) Right $ do

29+ ts <- lex "" s

30+ runTokenParser "" (p <* eof) ts

src/Language/PureScript/PSString.hsnew file+118

@@ -0,0 +1,118 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Language.PureScript.PSString (PSString, mkString, renderPSString, renderJSON, toUTF16CodeUnits, codePoints, containsLoneSurrogates) where

5+import Prelude.Compat

6+import Numeric (showHex)

7+import Data.List (unfoldr)

8+import Data.Monoid ((<>))

9+import Data.Scientific (toBoundedInteger)

10+import Data.String (IsString(..))

11+import Data.Text (Text)

12+import Data.Word (Word16)

13+import qualified Data.Aeson as A

14+import qualified Data.Aeson.Types as A

15+import qualified Data.Vector as V

16+import qualified Data.Text as T

17+

18+-- |

19+-- Strings in PureScript are sequences of UTF-16 code units, which do not

20+-- necessarily represent UTF-16 encoded text. For example, it is permissible

21+-- for a string to contain *lone surrogates,* i.e. characters in the range

22+-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair.

23+--

24+--

25+newtype PSString = PSString [Word16]

26+ deriving (Eq, Ord, Monoid)

27+

28+instance Show PSString where

29+ show = either show show . codePoints

30+

31+renderPSString :: PSString -> Text

32+renderPSString = T.pack . either show show . codePoints

33+

34+-- NOTE: lone surrogates in the given PSString are represented in the resulting

35+-- String as the reserved code point with that index

36+codePoints :: PSString -> Either String Text

37+codePoints s = (if containsLoneSurrogates s then Left . unfoldr decode else Right . T.unfoldr decode) $ toUTF16CodeUnits s

38+ where

39+ decode :: [Word16] -> Maybe (Char, [Word16])

40+ decode (h:l:rest) | isLead h && isTrail l = Just (unsurrogate h l, rest)

41+ decode (c:rest) = Just (toChar c, rest)

42+ decode [] = Nothing

43+

44+ unsurrogate :: Word16 -> Word16 -> Char

45+ unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)

46+

47+containsLoneSurrogates :: PSString -> Bool

48+containsLoneSurrogates = or . unfoldr headIsLoneSurrogate . toUTF16CodeUnits

49+ where

50+ headIsLoneSurrogate :: [Word16] -> Maybe (Bool, [Word16])

51+ headIsLoneSurrogate (h:l:rest) | isLead h && isTrail l = Just (False, rest)

52+ headIsLoneSurrogate (c:rest) = Just (isLead c || isTrail c, rest)

53+ headIsLoneSurrogate [] = Nothing

54+

55+instance IsString PSString where

56+ fromString a = PSString $ concatMap encodeUTF16 a

57+ where

58+ surrogates :: Char -> (Word16, Word16)

59+ surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00))

60+ where (h, l) = divMod (fromEnum c - 0x10000) 0x400

61+

62+ encodeUTF16 :: Char -> [Word16]

63+ encodeUTF16 c | fromEnum c > 0xFFFF = [high, low]

64+ where (high, low) = surrogates c

65+ encodeUTF16 c = [toWord $ fromEnum c]

66+

67+instance A.ToJSON PSString where

68+ toJSON = A.toJSON . toUTF16CodeUnits

69+

70+instance A.FromJSON PSString where

71+ parseJSON a = PSString <$> parseArrayOfCodeUnits a

72+ where

73+ parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16]

74+ parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" $ \b -> sequence (parseCodeUnit <$> V.toList b)

75+ parseCodeUnit :: A.Value -> A.Parser Word16

76+ parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b

77+

78+renderJSON :: PSString -> Text

79+renderJSON s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""

80+ where

81+ encodeChar :: Word16 -> Text

82+ encodeChar c | c > 0xFF = "\\u" <> hex 4 c

83+ encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c

84+ encodeChar c | toChar c == '\b' = "\\b"

85+ encodeChar c | toChar c == '\t' = "\\t"

86+ encodeChar c | toChar c == '\n' = "\\n"

87+ encodeChar c | toChar c == '\v' = "\\v"

88+ encodeChar c | toChar c == '\f' = "\\f"

89+ encodeChar c | toChar c == '\r' = "\\r"

90+ encodeChar c | toChar c == '"' = "\\\""

91+ encodeChar c | toChar c == '\\' = "\\\\"

92+ encodeChar c = T.singleton $ toChar c

93+

94+ hex :: (Enum a) => Int -> a -> Text

95+ hex width c =

96+ let hs = showHex (fromEnum c) "" in

97+ T.pack (replicate (width - length hs) '0' <> hs)

98+

99+isLead :: Word16 -> Bool

100+isLead h = h >= 0xD800 && h <= 0xDBFF

101+

102+isTrail :: Word16 -> Bool

103+isTrail l = l >= 0xDC00 && l <= 0xDFFF

104+

105+toChar :: Word16 -> Char

106+toChar = toEnum . fromIntegral

107+

108+toWord :: Int -> Word16

109+toWord = fromIntegral

110+

111+toInt :: Word16 -> Int

112+toInt = fromIntegral

113+

114+mkString :: Text -> PSString

115+mkString = fromString . T.unpack

116+

117+toUTF16CodeUnits :: PSString -> [Word16]

118+toUTF16CodeUnits (PSString s) = s

src/Language/PureScript/Parser/Common.hs+7

@@ -16,6 +16,7 @@ import Language.PureScript.Comments

1616import Language.PureScript.Names

1717import Language.PureScript.Parser.Lexer

1818import Language.PureScript.Parser.State

19+import Language.PureScript.PSString (PSString, mkString)

1920

2021import qualified Text.Parsec as P

2122

@@ -72,6 +73,12 @@ parseQualified parser = part []

7273parseIdent :: TokenParser Ident

7374parseIdent = Ident <$> identifier

7475

76+-- |

77+-- Parse a label, which may look like an identifier or a string

78+--

79+parseLabel :: TokenParser PSString

80+parseLabel = (mkString <$> lname) <|> stringLiteral

81+

7582-- |

7683-- Parse an operator.

7784--

src/Language/PureScript/Parser/Declarations.hs+9−8

@@ -33,6 +33,7 @@ import Language.PureScript.Errors

3333import Language.PureScript.Kinds

3434import Language.PureScript.Names

3535import Language.PureScript.Types

36+import Language.PureScript.PSString (PSString, mkString)

3637import Language.PureScript.Parser.Common

3738import Language.PureScript.Parser.Kinds

3839import Language.PureScript.Parser.Lexer

@@ -338,15 +339,15 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

338339parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

339340parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

340341

341−parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a)

342+parseObjectLiteral :: TokenParser (PSString, a) -> TokenParser (Literal a)

342343parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

343344

344−parseIdentifierAndValue :: TokenParser (Text, Expr)

345+parseIdentifierAndValue :: TokenParser (PSString, Expr)

345346parseIdentifierAndValue =

346347 do

347348 name <- C.indented *> lname

348349 b <- P.option (Var $ Qualified Nothing (Ident name)) rest

349− return (name, b)

350+ return (mkString name, b)

350351 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

351352 where

352353 rest = C.indented *> colon *> C.indented *> parseValue

@@ -428,16 +429,16 @@ parseInfixExpr

428429parseHole :: TokenParser Expr

429430parseHole = Hole <$> holeLit

430431

431−parsePropertyUpdate :: TokenParser (Text, Expr)

432+parsePropertyUpdate :: TokenParser (PSString, Expr)

432433parsePropertyUpdate = do

433− name <- lname <|> stringLiteral

434+ name <- parseLabel

434435 _ <- C.indented *> equals

435436 value <- C.indented *> parseValue

436437 return (name, value)

437438

438439parseAccessor :: Expr -> TokenParser Expr

439440parseAccessor (Constructor _) = P.unexpected "constructor"

440−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj

441+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj

441442

442443parseDo :: TokenParser Expr

443444parseDo = do

@@ -520,11 +521,11 @@ parseVarOrNamedBinder = do

520521parseNullBinder :: TokenParser Binder

521522parseNullBinder = underscore *> return NullBinder

522523

523−parseIdentifierAndBinder :: TokenParser (Text, Binder)

524+parseIdentifierAndBinder :: TokenParser (PSString, Binder)

524525parseIdentifierAndBinder =

525526 do name <- lname

526527 b <- P.option (VarBinder (Ident name)) rest

527− return (name, b)

528+ return (mkString name, b)

528529 <|> (,) <$> stringLiteral <*> rest

529530 where

530531 rest = C.indented *> colon *> C.indented *> parseBinder

src/Language/PureScript/Parser/Lexer.hs+7−17

@@ -70,11 +70,13 @@ import Control.Monad (void, guard)

7070import Control.Monad.Identity (Identity)

7171import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum)

7272import Data.Monoid ((<>))

73+import Data.String (fromString)

7374import Data.Text (Text)

7475import qualified Data.Text as T

7576

7677import Language.PureScript.Comments

7778import Language.PureScript.Parser.State

79+import Language.PureScript.PSString (PSString)

7880

7981import qualified Text.Parsec as P

8082import qualified Text.Parsec.Token as PT

@@ -106,7 +108,7 @@ data Token

106108 | Qualifier Text

107109 | Symbol Text

108110 | CharLiteral Char

109− | StringLiteral Text

111+ | StringLiteral PSString

110112 | Number (Either Integer Double)

111113 | HoleLit Text

112114 deriving (Show, Eq, Ord)

@@ -249,18 +251,6 @@ parseToken = P.choice

249251 symbolChar :: Lexer u Char

250252 symbolChar = P.satisfy isSymbolChar

251253

252− surrogates :: Char -> (Char, Char)

253− surrogates c = (high, low)

254− where

255− (h, l) = divMod (fromEnum c - 0x10000) 0x400

256− high = toEnum (h + 0xD800)

257− low = toEnum (l + 0xDC00)

258−

259− expandAstralCodePointToUTF16Surrogates :: Char -> [Char]

260− expandAstralCodePointToUTF16Surrogates c | fromEnum c > 0xFFFF = [high, low]

261− where (high, low) = surrogates c

262− expandAstralCodePointToUTF16Surrogates c = [c]

263−

264254 parseCharLiteral :: Lexer u Char

265255 parseCharLiteral = P.try $ do {

266256 c <- PT.charLiteral tokenParser;

@@ -269,11 +259,11 @@ parseToken = P.choice

269259 else return c

270260 }

271261

272− parseStringLiteral :: Lexer u Text

273− parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser

262+ parseStringLiteral :: Lexer u PSString

263+ parseStringLiteral = fromString <$> (blockString <|> PT.stringLiteral tokenParser)

274264 where

275265 delimiter = P.try (P.string "\"\"\"")

276− blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter)

266+ blockString = delimiter *> P.manyTill P.anyChar delimiter

277267

278268 parseNumber :: Lexer u (Either Integer Double)

279269 parseNumber = (consumeLeadingZero *> P.parserZero) <|>

@@ -516,7 +506,7 @@ charLiteral = token go P.<?> "char literal"

516506 go (CharLiteral c) = Just c

517507 go _ = Nothing

518508

519−stringLiteral :: TokenParser Text

509+stringLiteral :: TokenParser PSString

520510stringLiteral = token go P.<?> "string literal"

521511 where

522512 go (StringLiteral s) = Just s

src/Language/PureScript/Parser/Types.hs+3−3

@@ -9,7 +9,6 @@ import Prelude.Compat

1010import Control.Monad (when, unless)

1111import Control.Applicative ((<|>))

12−import Data.Text (Text)

1312import qualified Data.Text as T

1413

1514import Language.PureScript.AST.SourcePos

@@ -18,6 +17,7 @@ import Language.PureScript.Parser.Common

1817import Language.PureScript.Parser.Kinds

1918import Language.PureScript.Parser.Lexer

2019import Language.PureScript.Types

20+import Language.PureScript.Label (Label(..))

2121

2222import qualified Text.Parsec as P

2323import qualified Text.Parsec.Expr as P

@@ -118,8 +118,8 @@ noWildcards p = do

118118 when (containsWildcards ty) $ P.unexpected "type wildcard"

119119 return ty

120120

121−parseNameAndType :: TokenParser t -> TokenParser (Text, t)

122−parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p

121+parseNameAndType :: TokenParser t -> TokenParser (Label, t)

122+parseNameAndType p = (,) <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p

123123

124124parseRowEnding :: TokenParser Type

125125parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType

src/Language/PureScript/Pretty/Common.hs+7−5

@@ -15,7 +15,8 @@ import Data.Text (Text)

1515import qualified Data.Text as T

1616

1717import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

18−import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey)

18+import Language.PureScript.PSString (PSString)

19+import Language.PureScript.Label (Label(..), renderPSLabel)

1920

2021import Text.PrettyPrint.Boxes hiding ((<>))

2122import qualified Text.PrettyPrint.Boxes as Box

@@ -149,10 +150,11 @@ prettyPrintMany f xs = do

149150-- |

150151-- Prints an object key, escaping reserved names.

151152--

152−prettyPrintObjectKey :: Text -> Text

153−prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s)

154− | isUnquotedKey s = s

155− | otherwise = T.pack (show s)

153+prettyPrintObjectKey :: PSString -> Text

154+prettyPrintObjectKey = prettyPrintLabel . Label

155+

156+prettyPrintLabel :: Label -> Text

157+prettyPrintLabel = renderPSLabel

156158

157159-- | Place a box before another, vertically when the first box takes up multiple lines.

158160before :: Box -> Box -> Box

src/Language/PureScript/Pretty/JS.hs+8−31

@@ -25,8 +25,7 @@ import Language.PureScript.CodeGen.JS.Common

2525import Language.PureScript.Comments

2626import Language.PureScript.Crash

2727import Language.PureScript.Pretty.Common

28−

29−import Numeric

28+import Language.PureScript.PSString (PSString, codePoints, renderJSON)

3029

3130-- TODO (Christoph): Get rid of T.unpack / pack

3231

@@ -38,7 +37,7 @@ literals = mkPattern' match'

3837

3938 match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

4039 match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n

41− match (JSStringLiteral _ s) = return $ string s

40+ match (JSStringLiteral _ s) = return $ emit $ renderJSON s

4241 match (JSBooleanLiteral _ True) = return $ emit "true"

4342 match (JSBooleanLiteral _ False) = return $ emit "false"

4443 match (JSArrayLiteral _ xs) = mconcat <$> sequence

@@ -58,9 +57,10 @@ literals = mkPattern' match'

5857 , return $ emit "}"

5958 ]

6059 where

61− objectPropertyToString :: (Emit gen) => Text -> gen

62− objectPropertyToString s | identNeedsEscaping s = string s

63− | otherwise = emit s

60+ objectPropertyToString :: (Emit gen) => PSString -> gen

61+ objectPropertyToString s =

62+ let quoted = renderJSON s in

63+ emit $ either (const quoted) (\t -> if identNeedsEscaping t then quoted else t) $ codePoints s

6464 match (JSBlock _ sts) = mconcat <$> sequence

6565 [ return $ emit "{\n"

6666 , withIndent $ prettyStatements sts

@@ -150,29 +150,6 @@ literals = mkPattern' match'

150150 match (JSRaw _ js) = return $ emit js

151151 match _ = mzero

152152

153−string :: (Emit gen) => Text -> gen

154−string s = emit $ "\"" <> T.concatMap encodeChar s <> "\""

155− where

156− encodeChar :: Char -> Text

157− encodeChar '\b' = "\\b"

158− encodeChar '\t' = "\\t"

159− encodeChar '\n' = "\\n"

160− encodeChar '\v' = "\\v"

161− encodeChar '\f' = "\\f"

162− encodeChar '\r' = "\\r"

163− encodeChar '"' = "\\\""

164− encodeChar '\\' = "\\\\"

165− -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit.

166− -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD.

167− encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD"

168− encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) ""

169− encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) ""

170− encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) ""

171− encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) ""

172− encodeChar c = T.singleton c

173−

174− showHex' a b = T.pack (showHex a b)

175−

176153conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

177154conditional = mkPattern match

178155 where

@@ -182,14 +159,14 @@ conditional = mkPattern match

182159accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

183160accessor = mkPattern match

184161 where

185− match (JSAccessor _ prop val) = Just (emit prop, val)

162+ -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513

163+ match (JSAccessor _ prop val) = either (const Nothing) (\t -> Just (emit t, val)) $ codePoints prop

186164 match _ = Nothing

187165

188166indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

189167indexer = mkPattern' match

190168 where

191169 match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val

192−

193170 match _ = mzero

194171

195172lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)

src/Language/PureScript/Pretty/Types.hs+8−6

@@ -27,6 +27,8 @@ import Language.PureScript.Names

2727import Language.PureScript.Pretty.Common

2828import Language.PureScript.Pretty.Kinds

2929import Language.PureScript.Types

30+import Language.PureScript.PSString (renderPSString)

31+import Language.PureScript.Label (Label)

3032

3133import Text.PrettyPrint.Boxes hiding ((<+>))

3234

@@ -45,22 +47,22 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo

4547prettyPrintRowWith :: Char -> Char -> Type -> Box

4648prettyPrintRowWith open close = uncurry listToBox . toList []

4749 where

48− nameAndTypeToPs :: Char -> String -> Type -> Box

49− nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty

50+ nameAndTypeToPs :: Char -> Label -> Type -> Box

51+ nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty

5052

5153 tailToPs :: Type -> Box

5254 tailToPs REmpty = nullBox

5355 tailToPs other = text "| " <> typeAsBox other

5456

55− listToBox :: [(String, Type)] -> Type -> Box

57+ listToBox :: [(Label, Type)] -> Type -> Box

5658 listToBox [] REmpty = text [open, close]

5759 listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]

5860 listToBox ts rest = vcat left $

5961 zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++

6062 [ tailToPs rest, text [close] ]

6163

62− toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

63− toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row

64+ toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)

65+ toList tys (RCons name ty row) = toList ((name, ty):tys) row

6466 toList tys r = (reverse tys, r)

6567

6668prettyPrintRow :: Type -> String

@@ -116,7 +118,7 @@ matchTypeAtom suggesting =

116118 typeLiterals = mkPattern match where

117119 match TypeWildcard{} = Just $ text "_"

118120 match (TypeVar var) = Just $ text $ T.unpack var

119− match (TypeLevelString s) = Just . text $ show s

121+ match (TypeLevelString s) = Just . text $ T.unpack $ renderPSString s

120122 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row

121123 match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor

122124 match (TUnknown u)

src/Language/PureScript/Pretty/Values.hs+7−6

@@ -22,6 +22,7 @@ import Language.PureScript.Names

2222import Language.PureScript.Pretty.Common

2323import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)

2424import Language.PureScript.Types (Constraint(..))

25+import Language.PureScript.PSString (PSString, renderPSString)

2526

2627import Text.PrettyPrint.Boxes

2728

@@ -40,10 +41,10 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl

4041ellipsis :: Box

4142ellipsis = text "..."

4243

43−prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box

44+prettyPrintObject :: Int -> [(PSString, Maybe Expr)] -> Box

4445prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

4546 where

46− prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box

47+ prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box

4748 prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

4849

4950-- | Pretty-print an expression

@@ -55,7 +56,7 @@ prettyPrintValue d (IfThenElse cond th el) =

5556 , text "else " <> prettyPrintValueAtom (d - 1) el

5657 ])

5758prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)

58−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps

59+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (prettyPrintObjectKey key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps

5960prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

6061prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

6162prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

@@ -105,7 +106,7 @@ prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` tex

105106

106107prettyPrintLiteralValue :: Int -> Literal Expr -> Box

107108prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n

108−prettyPrintLiteralValue _ (StringLiteral s) = text $ show s

109+prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ renderPSString s

109110prettyPrintLiteralValue _ (CharLiteral c) = text $ show c

110111prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"

111112prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"

@@ -169,7 +170,7 @@ prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

169170prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b)

170171

171172prettyPrintLiteralBinder :: Literal Binder -> Text

172−prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str)

173+prettyPrintLiteralBinder (StringLiteral str) = renderPSString str

173174prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)

174175prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num

175176prettyPrintLiteralBinder (BooleanLiteral True) = "true"

@@ -179,7 +180,7 @@ prettyPrintLiteralBinder (ObjectLiteral bs) =

179180 Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)

180181 Monoid.<> " }"

181182 where

182− prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text

183+ prettyPrintObjectPropertyBinder :: (PSString, Binder) -> Text

183184 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder

184185prettyPrintLiteralBinder (ArrayLiteral bs) =

185186 "[ "

src/Language/PureScript/Sugar/ObjectWildcards.hs+4−4

@@ -11,11 +11,11 @@ import Control.Monad.Supply.Class

1111

1212import Data.List (partition)

1313import Data.Maybe (catMaybes)

14−import Data.Text (Text)

1514

1615import Language.PureScript.AST

1716import Language.PureScript.Errors

1817import Language.PureScript.Names

18+import Language.PureScript.PSString (PSString)

1919

2020desugarObjectConstructors

2121 :: forall m

@@ -62,7 +62,7 @@ desugarDecl other = fn other

6262 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

6363 desugarExpr e = return e

6464

65− wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr

65+ wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr

6666 wrapLambda mkVal ps =

6767 let (args, props) = partition (isAnonymousArgument . snd) ps

6868 in if null args

@@ -75,7 +75,7 @@ desugarDecl other = fn other

7575 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

7676 stripPositionInfo e = e

7777

78− peelAnonAccessorChain :: Expr -> Maybe [Text]

78+ peelAnonAccessorChain :: Expr -> Maybe [PSString]

7979 peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e

8080 peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e

8181 peelAnonAccessorChain AnonymousArgument = Just []

@@ -86,7 +86,7 @@ desugarDecl other = fn other

8686 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

8787 isAnonymousArgument _ = False

8888

89− mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr))

89+ mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))

9090 mkProp (name, e) = do

9191 arg <- freshIfAnon e

9292 return (arg, (name, maybe e argToExpr arg))

src/Language/PureScript/Sugar/TypeClasses.hs+4−2

@@ -19,6 +19,8 @@ import Language.PureScript.Externs

1919import Language.PureScript.Sugar.CaseDeclarations

2020import Control.Monad.Supply.Class

2121import Language.PureScript.Types

22+import Language.PureScript.Label (Label(..))

23+import Language.PureScript.PSString (mkString)

2224

2325import qualified Language.PureScript.Constants as C

2426

@@ -240,7 +242,7 @@ typeClassDictionaryDeclaration name args implies members =

240242 ]

241243 members' = map (first runIdent . memberToNameAndType) members

242244 mtys = members' ++ superclassTypes

243− in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (mtys, REmpty))

245+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty))

244246

245247typeClassMemberToDictionaryAccessor

246248 :: ModuleName

@@ -297,7 +299,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

297299 , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs

298300 ]

299301

300− let props = Literal $ ObjectLiteral (members ++ superclasses)

302+ let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses)

301303 dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

302304 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

303305 dict = TypeClassDictionaryConstructorApp className props

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+30−24

@@ -14,6 +14,7 @@ import qualified Data.Map as M

1414import Data.Maybe (fromMaybe, mapMaybe)

1515import Data.Ord (comparing)

1616import Data.Text (Text)

17+import qualified Data.Text as T

1718import Language.PureScript.AST

1819import qualified Language.PureScript.Constants as C

1920import Language.PureScript.Crash

@@ -22,6 +23,8 @@ import Language.PureScript.Errors

2223import Language.PureScript.Externs

2324import Language.PureScript.Kinds

2425import Language.PureScript.Names

26+import Language.PureScript.Label (Label(..))

27+import Language.PureScript.PSString (mkString, codePoints)

2528import Language.PureScript.Types

2629import Language.PureScript.TypeChecker (checkNewtype)

2730import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM)

@@ -207,7 +210,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

207210 idents <- replicateM (length tys) freshIdent'

208211 tys' <- mapM (replaceAllTypeSynonymsM syns) tys

209212 let caseResult =

210− App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

213+ App (prodConstructor (Literal . StringLiteral . mkString . showQualified runProperName $ Qualified (Just mn) ctorName))

211214 . Literal . ArrayLiteral

212215 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys'

213216 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult)

@@ -216,7 +219,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

216219 toSpineFun i r | Just rec <- objectType r =

217220 lamNull . recordConstructor . Literal . ArrayLiteral

218221 . map

219− (\(str,typ) ->

222+ (\((Label str),typ) ->

220223 Literal $ ObjectLiteral

221224 [ ("recLabel", Literal (StringLiteral str))

222225 , ("recValue", toSpineFun (Accessor str i) typ)

@@ -235,7 +238,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

235238 App

236239 (App

237240 (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

238− (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))

241+ (Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) name))))

239242 )

240243 . Literal

241244 . ArrayLiteral

@@ -249,7 +252,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

249252 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

250253 mkProdClause (ctorName, tys) =

251254 Literal $ ObjectLiteral

252− [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))

255+ [ ("sigConstructor", Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName))))

253256 , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

254257 ]

255258

@@ -260,7 +263,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

260263 [ ("recLabel", Literal (StringLiteral str))

261264 , ("recValue", mkProductSignature typ)

262265 ]

263− | (str, typ) <- decomposeRec rec

266+ | ((Label str), typ) <- decomposeRec rec

264267 ]

265268 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

266269 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

@@ -291,7 +294,7 @@ deriveGeneric mn syns ds tyConNm dargs = do

291294 return $

292295 CaseAlternative

293296 [ prodBinder

294− [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

297+ [ LiteralBinder (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName)))

295298 , LiteralBinder (ArrayLiteral (map VarBinder idents))

296299 ]

297300 ]

@@ -314,16 +317,16 @@ deriveGeneric mn syns ds tyConNm dargs = do

314317 (App e unitVal)

315318 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal)

316319

317− mkRecCase :: [(Text, Type)] -> CaseAlternative

320+ mkRecCase :: [(Label, Type)] -> CaseAlternative

318321 mkRecCase rs =

319322 CaseAlternative

320− [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

323+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . labelToIdent . fst) rs)) ] ]

321324 . Right

322− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

325+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar $ labelToIdent x)) y) rs)

323326

324− mkRecFun :: [(Text, Type)] -> Expr

325− mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs

326− where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

327+ mkRecFun :: [(Label, Type)] -> Expr

328+ mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs

329+ where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs

327330 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

328331 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

329332

@@ -405,7 +408,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do

405408 args' <- mapM (replaceAllTypeSynonymsM syns) args

406409 (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'

407410 return ( TypeApp (TypeApp (TypeConstructor constructor)

408− (TypeLevelString (runProperName ctorName)))

411+ (TypeLevelString $ mkString (runProperName ctorName)))

409412 ctorTy

410413 , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

411414 (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))

@@ -430,19 +433,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do

430433 makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)

431434 makeArg arg | Just rec <- objectType arg = do

432435 let fields = decomposeRec rec

433− fieldNames <- traverse freshIdent (map fst fields)

436+ fieldNames <- traverse freshIdent (map ((\(Label s) -> either T.pack id $ codePoints s) . fst) fields)

434437 pure ( TypeApp (TypeConstructor record)

435438 (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))

436− (map (\(name, ty) ->

439+ (map (\((Label name), ty) ->

437440 TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))

438441 , ConstructorBinder record

439442 [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])

440443 (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)

441444 ]

442445 , Literal . ObjectLiteral $

443− zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames

446+ zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames

444447 , LiteralBinder . ObjectLiteral $

445− zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames

448+ zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames

446449 , record' $

447450 foldr1 (\e1 -> App (App (Constructor productName) e1))

448451 (map (field' . Var . Qualified Nothing) fieldNames)

@@ -574,7 +577,7 @@ deriveEq mn syns ds tyConNm = do

574577 toEqTest :: Expr -> Expr -> Type -> Expr

575578 toEqTest l r ty | Just rec <- objectType ty =

576579 conjAll

577− . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)

580+ . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)

578581 $ decomposeRec rec

579582 toEqTest l r _ = preludeEq l r

580583

@@ -661,7 +664,7 @@ deriveOrd mn syns ds tyConNm = do

661664 toOrdering :: Expr -> Expr -> Type -> Expr

662665 toOrdering l r ty | Just rec <- objectType ty =

663666 appendAll

664− . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)

667+ . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)

665668 $ decomposeRec rec

666669 toOrdering l r _ = ordCompare l r

667670

@@ -733,11 +736,14 @@ mkVarMn mn = Var . Qualified mn

733736mkVar :: Ident -> Expr

734737mkVar = mkVarMn Nothing

735738

739+labelToIdent :: Label -> Ident

740+labelToIdent (Label l) = Ident $ either T.pack id $ codePoints l

741+

736742objectType :: Type -> Maybe Type

737743objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec

738744objectType _ = Nothing

739745

740−decomposeRec :: Type -> [(Text, Type)]

746+decomposeRec :: Type -> [(Label, Type)]

741747decomposeRec = sortBy (comparing fst) . go

742748 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

743749 go _ = []

@@ -790,17 +796,17 @@ deriveFunctor mn syns ds tyConNm = do

790796 goType recTy | Just row <- objectType recTy =

791797 traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates)

792798 where

793− justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)]

799+ justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)]

794800 justUpdates = foldMap (fmap return)

795801

796− buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr))

802+ buildUpdate :: (Label, Type) -> m (Maybe (Label, Expr))

797803 buildUpdate (lbl, ty) = do upd <- goType ty

798804 return ((lbl,) <$> upd)

799805

800− buildRecord :: [(Text, Expr)] -> m Expr

806+ buildRecord :: [(Label, Expr)] -> m Expr

801807 buildRecord updates = do arg <- freshIdent "o"

802808 let argVar = mkVar arg

803− mkAssignment (l, x) = (l, App x (Accessor l argVar))

809+ mkAssignment ((Label l), x) = (l, App x (Accessor l argVar))

804810 return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates)))

805811

806812 -- under a `* -> *`, just assume functor for now

src/Language/PureScript/TypeChecker/Entailment.hs+6−4

@@ -37,13 +37,15 @@ import Language.PureScript.TypeChecker.Monad

3737import Language.PureScript.TypeChecker.Unify

3838import Language.PureScript.TypeClassDictionaries

3939import Language.PureScript.Types

40+import Language.PureScript.Label (Label(..))

41+import Language.PureScript.PSString (PSString, mkString)

4042import qualified Language.PureScript.Constants as C

4143

4244-- | Describes what sort of dictionary to generate for type class instances

4345data Evidence

4446 = NamedInstance (Qualified Ident)

4547 -- ^ An existing named instance

46− | IsSymbolInstance Text

48+ | IsSymbolInstance PSString

4749 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

4850 | CompareSymbolInstance

4951 -- ^ Computed instance of CompareSymbol

@@ -319,7 +321,7 @@ entails SolverOptions{..} constraint context hints =

319321 -- Turn a DictionaryValue into a Expr

320322 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr

321323 subclassDictionaryValue dict superclassName index =

322− App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))

324+ App (Accessor (mkString (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index)))

323325 dict)

324326 valUndefined

325327

@@ -387,7 +389,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

387389 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

388390 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

389391

390− go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])

392+ go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> (Bool, Matching [Type])

391393 go l (KindedType t1 _) r t2 = go l t1 r t2

392394 go l t1 r (KindedType t2 _) = go l t1 r t2

393395 go [] REmpty [] REmpty = (True, M.empty)

@@ -429,7 +431,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do

429431 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

430432 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

431433 where

432− go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool

434+ go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> Bool

433435 go l (KindedType t1 _) r t2 = go l t1 r t2

434436 go l t1 r (KindedType t2 _) = go l t1 r t2

435437 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

src/Language/PureScript/TypeChecker/Types.hs+18−17

@@ -41,7 +41,6 @@ import Data.Maybe (fromMaybe)

4141import Data.Monoid ((<>))

4242import qualified Data.Map as M

4343import qualified Data.Set as S

44−import Data.Text (Text)

4544

4645import Language.PureScript.AST

4746import Language.PureScript.Crash

@@ -60,6 +59,8 @@ import Language.PureScript.TypeChecker.Synonyms

6059import Language.PureScript.TypeChecker.TypeSearch

6160import Language.PureScript.TypeChecker.Unify

6261import Language.PureScript.Types

62+import Language.PureScript.Label (Label(..))

63+import Language.PureScript.PSString (PSString)

6364

6465

6566data BindingGroupType

@@ -289,22 +290,22 @@ infer' (Literal (ArrayLiteral vals)) = do

289290infer' (Literal (ObjectLiteral ps)) = do

290291 ensureNoDuplicateProperties ps

291292 ts <- traverse (infer . snd) ps

292− let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

293+ let fields = zipWith (\name (TypedValue _ _ t) -> (Label name, t)) (map fst ps) ts

293294 ty = TypeApp tyRecord $ rowFromList (fields, REmpty)

294295 return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty

295296infer' (ObjectUpdate o ps) = do

296297 ensureNoDuplicateProperties ps

297298 row <- freshType

298299 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps

299− let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals

300− oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType

300+ let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals

301+ oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType

301302 let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)

302303 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

303304 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)

304305infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do

305306 field <- freshType

306307 rest <- freshType

307− typed <- check val (TypeApp tyRecord (RCons prop field rest))

308+ typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest))

308309 return $ TypedValue True (Accessor prop typed) field

309310infer' (Abs (Left arg) ret) = do

310311 ty <- freshType

@@ -442,12 +443,12 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do

442443 unifyTypes val (TypeApp tyRecord row)

443444 return m1

444445 where

445− inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type)

446+ inferRowProperties :: Type -> Type -> [(PSString, Binder)] -> m (M.Map Ident Type)

446447 inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty

447448 inferRowProperties nrow row ((name, binder):binders) = do

448449 propTy <- freshType

449450 m1 <- inferBinder propTy binder

450− m2 <- inferRowProperties nrow (RCons name propTy row) binders

451+ m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders

451452 return $ m1 `M.union` m2

452453inferBinder val (LiteralBinder (ArrayLiteral binders)) = do

453454 el <- freshType

@@ -641,14 +642,14 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do

641642 -- We need to be careful to avoid duplicate labels here.

642643 -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.

643644 let (propsToCheck, rest) = rowToList row

644− (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck

645+ (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map (Label . fst) ps) propsToCheck

645646 us <- zip (map fst removedProps) <$> replicateM (length ps) freshType

646647 obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))

647648 ps' <- checkProperties e ps row True

648649 return $ TypedValue True (ObjectUpdate obj' ps') t

649650check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do

650651 rest <- freshType

651− val' <- check val (TypeApp tyRecord (RCons prop ty rest))

652+ val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest))

652653 return $ TypedValue True (Accessor prop val') ty

653654check' v@(Constructor c) ty = do

654655 env <- getEnv

@@ -681,10 +682,10 @@ check' val ty = do

681682checkProperties ::

682683 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

683684 Expr ->

684− [(Text, Expr)] ->

685+ [(PSString, Expr)] ->

685686 Type ->

686687 Bool ->

687− m [(Text, Expr)]

688+ m [(PSString, Expr)]

688689checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where

689690 go [] [] REmpty = return []

690691 go [] [] u@(TUnknown _)

@@ -694,18 +695,18 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh

694695 go [] [] Skolem{} | lax = return []

695696 go [] ((p, _): _) _ | lax = return []

696697 | otherwise = throwError . errorMessage $ PropertyIsMissing p

697− go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p

698+ go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty $ Label p

698699 go ((p,v):ps') ts r =

699− case lookup p ts of

700+ case lookup (Label p) ts of

700701 Nothing -> do

701702 v'@(TypedValue _ _ ty) <- infer v

702703 rest <- freshType

703− unifyTypes r (RCons p ty rest)

704+ unifyTypes r (RCons (Label p) ty rest)

704705 ps'' <- go ps' ts rest

705706 return $ (p, v') : ps''

706707 Just ty -> do

707708 v' <- check v ty

708− ps'' <- go ps' (delete (p, ty) ts) r

709+ ps'' <- go ps' (delete (Label p, ty) ts) r

709710 return $ (p, v') : ps''

710711 go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)

711712

@@ -771,9 +772,9 @@ checkFunctionApplication' fn u arg = do

771772-- |

772773-- Ensure a set of property names and value does not contain duplicate labels

773774--

774−ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m ()

775+ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m ()

775776ensureNoDuplicateProperties ps =

776777 let ls = map fst ps in

777778 case ls \\ nub ls of

778− l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing

779+ l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing

779780 _ -> return ()

src/Language/PureScript/TypeChecker/Unify.hs+2−1

@@ -31,6 +31,7 @@ import Language.PureScript.Crash

3131import Language.PureScript.Errors

3232import Language.PureScript.TypeChecker.Monad

3333import Language.PureScript.TypeChecker.Skolems

34+import Language.PureScript.Label (Label(..))

3435import Language.PureScript.Types

3536

3637-- | Generate a fresh type variable

@@ -139,7 +140,7 @@ unifyRows r1 r2 =

139140 forM_ int (uncurry unifyTypes)

140141 unifyRows' sd1 r1' sd2 r2'

141142 where

142− unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m ()

143+ unifyRows' :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> m ()

143144 unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r))

144145 unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r))

145146 unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do

src/Language/PureScript/Types.hs+7−5

@@ -2,7 +2,7 @@

22{-# LANGUAGE TemplateHaskell #-}

44-- |

5−-- Data types for types

5+-- Data types for PureScript types and compile-time representation of PureScript terms

66--

77module Language.PureScript.Types where

@@ -20,6 +20,8 @@ import qualified Data.Text as T

2020import Language.PureScript.AST.SourcePos

2121import Language.PureScript.Kinds

2222import Language.PureScript.Names

23+import Language.PureScript.Label (Label)

24+import Language.PureScript.PSString (PSString)

2325

2426-- |

2527-- An identifier for the scope of a skolem variable

@@ -36,7 +38,7 @@ data Type

3638 -- | A named type variable

3739 | TypeVar Text

3840 -- | A type-level string

39− | TypeLevelString Text

41+ | TypeLevelString PSString

4042 -- | A type wildcard, as would appear in a partial type synonym

4143 | TypeWildcard SourceSpan

4244 -- | A type constructor

@@ -55,7 +57,7 @@ data Type

5557 -- | An empty row

5658 | REmpty

5759 -- | A non-empty row

58− | RCons Text Type Type

60+ | RCons Label Type Type

5961 -- | A type with a kind annotation

6062 | KindedType Type Kind

6163 -- | A placeholder used in pretty printing

@@ -108,7 +110,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData)

108110-- |

109111-- Convert a row to a list of pairs of labels and types

110112--

111−rowToList :: Type -> ([(Text, Type)], Type)

113+rowToList :: Type -> ([(Label, Type)], Type)

112114rowToList (RCons name ty row) = let (tys, rest) = rowToList row

113115 in ((name, ty):tys, rest)

114116rowToList r = ([], r)

@@ -116,7 +118,7 @@ rowToList r = ([], r)

116118-- |

117119-- Convert a list of labels and types to a row

118120--

119−rowFromList :: ([(Text, Type)], Type) -> Type

121+rowFromList :: ([(Label, Type)], Type) -> Type

120122rowFromList ([], r) = r

121123rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

122124

tests/support/bower.json+1

@@ -9,6 +9,7 @@

99 "purescript-st": "2.0.0",

1010 "purescript-partial": "1.1.2",

1111 "purescript-newtype": "1.1.0",

12+ "purescript-generics": "3.3.0",

1213 "purescript-generics-rep": "4.0.0",

1314 "purescript-symbols": "^2.0.0",

1415 "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac",