Skip to content

Commit 773d778

Browse files
michaelficarramichaelficarra
committed
fixes purescript#2438: represent PureScript strings as sequence of Word16
1 parent 7876083 commit 773d778

File tree

34 files changed

+388
-198
lines changed

34 files changed

+388
-198
lines changed

‎examples/passing/RecordLabels.purs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module Main where
2+
3+
import RecordLabels as RecordLabels
4+
5+
main = RecordLabels.main

‎examples/passing/RecordLabels/RecordLabels.purs‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
module RecordLabels where
2+
3+
import Prelude
4+
import Data.Generic (class Generic, gShow)
5+
import Control.Monad.Eff.Console (log)
6+
import Test.Assert (assert')
7+
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‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@ import Language.PureScript.AST.Literals
1818
import Language.PureScript.AST.Operators
1919
import Language.PureScript.AST.SourcePos
2020
import Language.PureScript.Types
21+
import Language.PureScript.PSString (PSString)
22+
import Language.PureScript.Label (Label)
2123
import Language.PureScript.Names
2224
import Language.PureScript.Kinds
2325
import 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‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
module Language.PureScript.AST.Literals where
55

66
import Prelude.Compat
7-
import Data.Text (Text)
7+
import Language.PureScript.PSString (PSString)
88

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‎

Lines changed: 19 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import qualified Data.Foldable as F
2020
import qualified Data.Map as M
2121
import Data.Maybe (fromMaybe, isNothing)
2222
import Data.Monoid ((<>))
23+
import Data.String (fromString)
2324
import Data.Text (Text)
2425
import qualified Data.Text as T
2526

@@ -34,6 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
3435
errorMessage, rethrowWithPosition, addHint)
3536
import Language.PureScript.Names
3637
import Language.PureScript.Options
38+
import Language.PureScript.PSString (PSString, mkString, codePoints)
3739
import Language.PureScript.Traversals (sndM)
3840
import 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,15 +275,15 @@ 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
279282

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‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Data.Text (Text)
1111

1212
import Language.PureScript.AST (SourceSpan(..))
1313
import Language.PureScript.Comments
14+
import Language.PureScript.PSString (PSString)
1415
import 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

245247
withSourceSpan :: SourceSpan -> JS -> JS
246248
withSourceSpan withSpan = go

‎src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Data.Maybe (fromMaybe)
1111

1212
import Language.PureScript.Crash
1313
import Language.PureScript.CodeGen.JS.AST
14+
import Language.PureScript.PSString (mkString)
1415

1516
applyAll :: [a -> a] -> a -> a
1617
applyAll = foldl' (.) id
@@ -71,13 +72,13 @@ removeFromBlock _ js = js
7172

7273
isFn :: (Text, Text) -> JS -> Bool
7374
isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =
74-
x == fnName && y == moduleName
75+
x == mkString fnName && y == moduleName
7576
isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =
76-
x == fnName && y == moduleName
77+
x == mkString fnName && y == moduleName
7778
isFn _ _ = False
7879

7980
isDict :: (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
8182
isDict _ _ = False
8283

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

‎src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import qualified Data.Text as T
2323
import Language.PureScript.CodeGen.JS.AST
2424
import Language.PureScript.CodeGen.JS.Optimizer.Common
2525
import 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)

0 commit comments

Comments
 (0)