773d778 · rowtype-yoga/purescript-native

examples/passing/RecordLabels.pursnew file+5

compare with golang

unifiedsplit

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

1+module Main where

2+

3+import RecordLabels as RecordLabels

4+

5+main = RecordLabels.main

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

@@ -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+1−1

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

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

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

24 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

26 log "Done"

purescript.cabal+3

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

141 protolude >= 0.1.6,

142 regex-tdfa -any,

143 safe >= 0.3.9 && < 0.4,

144+ scientific >= 0.3.4.9 && < 0.4,

144 semigroups >= 0.16.2 && < 0.19,

145 semigroups >= 0.16.2 && < 0.19,

145 sourcemap >= 0.1.6,

146 sourcemap >= 0.1.6,

146 spdx == 0.2.*,

147 spdx == 0.2.*,

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

194 Language.PureScript.Errors

195 Language.PureScript.Errors

195 Language.PureScript.Errors.JSON

196 Language.PureScript.Errors.JSON

196 Language.PureScript.Kinds

197 Language.PureScript.Kinds

198+ Language.PureScript.Label

197 Language.PureScript.Linter

199 Language.PureScript.Linter

198 Language.PureScript.Linter.Exhaustive

200 Language.PureScript.Linter.Exhaustive

199 Language.PureScript.Linter.Imports

201 Language.PureScript.Linter.Imports

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

214 Language.PureScript.Pretty.Kinds

216 Language.PureScript.Pretty.Kinds

215 Language.PureScript.Pretty.Types

217 Language.PureScript.Pretty.Types

216 Language.PureScript.Pretty.Values

218 Language.PureScript.Pretty.Values

219+ Language.PureScript.PSString

217 Language.PureScript.Renamer

220 Language.PureScript.Renamer

218 Language.PureScript.Sugar

221 Language.PureScript.Sugar

219 Language.PureScript.Sugar.BindingGroups

222 Language.PureScript.Sugar.BindingGroups

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

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

18import Language.PureScript.AST.Operators

19import Language.PureScript.AST.SourcePos

20import Language.PureScript.Types

21+import Language.PureScript.PSString (PSString)

22+import Language.PureScript.Label (Label)

21import Language.PureScript.Names

23import Language.PureScript.Names

22import Language.PureScript.Kinds

24import Language.PureScript.Kinds

23import Language.PureScript.TypeClassDictionaries

25import Language.PureScript.TypeClassDictionaries

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

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

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

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

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

92 | CannotFindDerivingType (ProperName 'TypeName)

94 | CannotFindDerivingType (ProperName 'TypeName)

93− | DuplicateLabel Text (Maybe Expr)

95+ | DuplicateLabel Label (Maybe Expr)

94 | DuplicateValueDeclaration Ident

96 | DuplicateValueDeclaration Ident

95 | ArgListLengthsDiffer Ident

97 | ArgListLengthsDiffer Ident

96 | OverlappingArgNames (Maybe Ident)

98 | OverlappingArgNames (Maybe Ident)

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

99 | ExpectedType Type Kind

101 | ExpectedType Type Kind

100 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

102 | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

101 | ExprDoesNotHaveType Expr Type

103 | ExprDoesNotHaveType Expr Type

102− | PropertyIsMissing Text

104+ | PropertyIsMissing Label

103− | AdditionalProperty Text

105+ | AdditionalProperty Label

104 | TypeSynonymInstance

106 | TypeSynonymInstance

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

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

106 | InvalidNewtype (ProperName 'TypeName)

108 | InvalidNewtype (ProperName 'TypeName)

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

145 | ErrorInModule ModuleName

147 | ErrorInModule ModuleName

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

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

147 | ErrorInSubsumption Type Type

149 | ErrorInSubsumption Type Type

148− | ErrorCheckingAccessor Expr Text

150+ | ErrorCheckingAccessor Expr PSString

149 | ErrorCheckingType Expr Type

151 | ErrorCheckingType Expr Type

150 | ErrorCheckingKind Type

152 | ErrorCheckingKind Type

151 | ErrorCheckingGuard

153 | ErrorCheckingGuard

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

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

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

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

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

575 --

577 --

576− | Accessor Text Expr

578+ | Accessor PSString Expr

577 -- |

579 -- |

578 -- Partial record update

580 -- Partial record update

579 --

581 --

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

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

581 -- |

583 -- |

582 -- Function introduction

584 -- Function introduction

583 --

585 --

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

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

4module Language.PureScript.AST.Literals where

5

6import Prelude.Compat

7−import Data.Text (Text)

7+import Language.PureScript.PSString (PSString)

8

9-- |

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

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

18 -- |

19 -- A string literal

20 --

21− | StringLiteral Text

21+ | StringLiteral PSString

22 -- |

23 -- A character literal

24 --

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

34 -- |

35 -- An object literal

36 --

37− | ObjectLiteral [(Text, a)]

37+ | ObjectLiteral [(PSString, a)]

38 deriving (Eq, Ord, Show, Functor)

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

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

20import qualified Data.Map as M

21import Data.Maybe (fromMaybe, isNothing)

22import Data.Monoid ((<>))

23+import Data.String (fromString)

23import Data.Text (Text)

24import Data.Text (Text)

24import qualified Data.Text as T

25import qualified Data.Text as T

25

26

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

34 errorMessage, rethrowWithPosition, addHint)

35 errorMessage, rethrowWithPosition, addHint)

35import Language.PureScript.Names

36import Language.PureScript.Names

36import Language.PureScript.Options

37import Language.PureScript.Options

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

37import Language.PureScript.Traversals (sndM)

39import Language.PureScript.Traversals (sndM)

38import qualified Language.PureScript.Constants as C

40import qualified Language.PureScript.Constants as C

39

41

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

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

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

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

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

67 let standardExps = exps \\ foreignExps

69 let standardExps = exps \\ foreignExps

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

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

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

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

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

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

71

73

72 where

74 where

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

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

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

109 importToJs mnLookup mn' = do

111 importToJs mnLookup mn' = do

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

112 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')))]

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

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

113

115

114 -- |

116 -- |

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

176 -- indexer is returned.

178 -- indexer is returned.

177 --

179 --

178 accessor :: Ident -> JS -> JS

180 accessor :: Ident -> JS -> JS

179− accessor (Ident prop) = accessorString prop

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

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

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

181

183

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

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

185+ accessorString prop =

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

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

184− | otherwise = JSAccessor Nothing prop

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

185

188

186 -- |

189 -- |

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

190 -- 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_ =

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

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

213 unAbs _ = []

216 unAbs _ = []

214 assign :: Ident -> JS

217 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"))

216 (var name)

219 (var name)

217 valueToJs' (Abs _ arg val) = do

220 valueToJs' (Abs _ arg val) = do

218 ret <- valueToJs val

221 ret <- valueToJs val

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

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

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

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

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

258 let constructor =

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

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

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

261 createFn =

264 createFn =

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

265 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_ =

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

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

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

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

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

277 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])

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

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

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

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

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

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

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

280 -- |

283 -- |

281 -- Shallow copy an object.

284 -- Shallow copy an object.

282 --

285 --

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

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

284 extendObj obj sts = do

287 extendObj obj sts = do

285 newObj <- freshName

288 newObj <- freshName

286 key <- freshName

289 key <- freshName

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

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

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

318

321

319 foreignIdent :: Ident -> JS

322 foreignIdent :: Ident -> JS

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

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

321

324

322 -- |

325 -- |

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

326 -- 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_ =

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

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

342

345

343 failedPatternError :: [Text] -> JS

346 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)]

345

348

346 failedPatternMessage :: Text

349 failedPatternMessage :: Text

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

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

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

391 argVar <- freshName

394 argVar <- freshName

392 done'' <- go remain done'

395 done'' <- go remain done'

393 js <- binderToJs argVar done'' binder

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

395 binderToJs' _ _ ConstructorBinder{} =

398 binderToJs' _ _ ConstructorBinder{} =

396 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

399 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

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

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

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

402 literalToBinderJS varName done (NumericLiteral num) =

405 literalToBinderJS varName done (NumericLiteral num) =

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

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

404 literalToBinderJS varName done (CharLiteral c) =

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

406 literalToBinderJS varName done (StringLiteral str) =

409 literalToBinderJS varName done (StringLiteral str) =

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

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

408 literalToBinderJS varName done (BooleanLiteral True) =

411 literalToBinderJS varName done (BooleanLiteral True) =

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

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

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

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

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

413 where

416 where

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

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

415 go done' [] = return done'

418 go done' [] = return done'

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

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

417 propVar <- freshName

420 propVar <- freshName

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

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

11

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

13import Language.PureScript.Comments

14+import Language.PureScript.PSString (PSString)

14import Language.PureScript.Traversals

15import Language.PureScript.Traversals

15

16

16-- |

17-- |

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

132 -- |

133 -- |

133 -- A string literal

134 -- A string literal

134 --

135 --

135− | JSStringLiteral (Maybe SourceSpan) Text

136+ | JSStringLiteral (Maybe SourceSpan) PSString

136 -- |

137 -- |

137 -- A boolean literal

138 -- A boolean literal

138 --

139 --

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

156 -- |

157 -- |

157 -- An object literal

158 -- An object literal

158 --

159 --

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

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

160 -- |

161 -- |

161 -- An object property accessor expression

162 -- An object property accessor expression

162 --

163 --

163− | JSAccessor (Maybe SourceSpan) Text JS

164+ | JSAccessor (Maybe SourceSpan) PSString JS

164 -- |

165 -- |

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

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

166 --

167 --

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

240 -- |

241 -- |

241 -- Commented Javascript

242 -- Commented Javascript

242 --

243 --

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

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

245+ deriving (Show, Eq)

244

246

245withSourceSpan :: SourceSpan -> JS -> JS

247withSourceSpan :: SourceSpan -> JS -> JS

246withSourceSpan withSpan = go

248withSourceSpan withSpan = go

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

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

11

12import Language.PureScript.Crash

13import Language.PureScript.CodeGen.JS.AST

14+import Language.PureScript.PSString (mkString)

14

15

15applyAll :: [a -> a] -> a -> a

16applyAll :: [a -> a] -> a -> a

16applyAll = foldl' (.) id

17applyAll = foldl' (.) id

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

71

72

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

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

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

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

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

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

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

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

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

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

77isFn _ _ = False

78isFn _ _ = False

78

79

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

80isDict :: (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

81isDict _ _ = False

82isDict _ _ = False

82

83

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

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

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

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

23import Language.PureScript.CodeGen.JS.AST

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

25import qualified Language.PureScript.Constants as C

26+import Language.PureScript.PSString (mkString)

26

27

27-- TODO: Potential bug:

28-- TODO: Potential bug:

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

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

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

213

214

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

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

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

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

217 isNFn _ _ _ = False

218 isNFn _ _ _ = False

218

219

219 runFn :: Int -> JS -> JS

220 runFn :: Int -> JS -> JS

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

235 convert other = other

236 convert other = other

236

237

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

238 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'

239 isModFn _ _ = False

240 isModFn _ _ = False

240

241

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

242 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'

243 isModFnWithDict _ _ = False

244 isModFnWithDict _ _ = False

244

245

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

246-- (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)

12import Language.PureScript.CodeGen.JS.AST

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

14import Language.PureScript.Options

15+import Language.PureScript.PSString (mkString)

15import qualified Language.PureScript.Constants as C

16import qualified Language.PureScript.Constants as C

16

17

17magicDo :: Options -> JS -> JS

18magicDo :: Options -> JS -> JS

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

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

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

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

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

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

70 -- 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'

71 isEffFunc _ _ = False

72 isEffFunc _ _ = False

72

73

73 -- Remove __do function applications which remain after desugaring

74 -- Remove __do function applications which remain after desugaring

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

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

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

105 -- agg(ressive) parameter.

106 -- agg(ressive) parameter.

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

107 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)]])

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

109 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

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

111 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

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

113 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])

114 convert _ other = other

115 convert _ other = other

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

116 -- 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'

117 isSTFunc _ _ = False

118 isSTFunc _ _ = False

118 -- Find all ST Refs initialized in this block

119 -- Find all ST Refs initialized in this block

119 findSTRefsIn = everythingOnJS (++) isSTRef

120 findSTRefsIn = everythingOnJS (++) isSTRef

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

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

24import Language.PureScript.Names

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

26import Language.PureScript.Types

27+import Language.PureScript.PSString (mkString)

27import qualified Language.PureScript.AST as A

28import qualified Language.PureScript.AST as A

28

29

29-- |

30-- |

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

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

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

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

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

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

122 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")))

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

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

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

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

125 exprToCoreFn _ _ _ e =

126 exprToCoreFn _ _ _ e =

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

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

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

266mkTypeClassConstructor ss com supers members =

267mkTypeClassConstructor ss com supers members =

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

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

269 dict = Literal nullAnn (ObjectLiteral props)

270 dict = Literal nullAnn (ObjectLiteral props)

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

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

271 (Ident a)

272 (Ident a)

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

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

6import Prelude.Compat

7

8import Control.Arrow ((***))

9−import Data.Text (Text)

10

9

11import Language.PureScript.AST.Literals

10import Language.PureScript.AST.Literals

12import Language.PureScript.CoreFn.Binders

11import Language.PureScript.CoreFn.Binders

13import Language.PureScript.Names

12import Language.PureScript.Names

13+import Language.PureScript.PSString (PSString)

14

15-- |

16-- Data type for expressions and terms

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

27 -- |

28 -- A record property accessor

29 --

30− | Accessor a Text (Expr a)

30+ | Accessor a PSString (Expr a)

31 -- |

32 -- Partial record update

33 --

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

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

35 -- |

36 -- Function introduction

37 --

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

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

17import Language.PureScript.AST.Literals

18import Language.PureScript.CoreFn

19import Language.PureScript.Names

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

20

21

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

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

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

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

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

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

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

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

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

53

54

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

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

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

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

56

57

57exprToJSON :: Expr a -> Value

58exprToJSON :: Expr a -> Value

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

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

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

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

27import Language.PureScript.Names

28import Language.PureScript.Pretty.Kinds

29import Language.PureScript.Types

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

30

31

31typeLiterals :: Pattern () Type RenderedCode

32typeLiterals :: Pattern () Type RenderedCode

32typeLiterals = mkPattern match

33typeLiterals = mkPattern match

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

79 where

80 where

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

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

81

82

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

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

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

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

84

85

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

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

86renderLabel (label, ty) =

87renderLabel (label, ty) =

87 mintersperse sp

88 mintersperse sp

88− [ ident label

89+ [ syntax $ renderPSLabel label

89 , syntax "::"

90 , syntax "::"

90 , renderType ty

91 , renderType ty

91 ]

92 ]

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

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

32import Language.PureScript.Pretty

33import Language.PureScript.Traversals

34import 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)

36import qualified Language.PureScript.Bundle as Bundle

38import qualified Language.PureScript.Bundle as Bundle

37import qualified Language.PureScript.Constants as C

39import qualified Language.PureScript.Constants as C

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

39

40

40import qualified System.Console.ANSI as ANSI

41import qualified System.Console.ANSI as ANSI

41

42

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

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

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

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

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

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

267 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

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

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

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

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

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

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

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

563 sortRows t1 t2 = (t1, t2)

564 sortRows t1 t2 = (t1, t2)

564

565

565 -- Put the common labels last

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

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

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

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

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

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

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

570

571

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

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

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

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

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

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

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

575 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

670 ]

671 ]

671 renderSimpleErrorMessage (CannotFindDerivingType nm) =

672 renderSimpleErrorMessage (CannotFindDerivingType nm) =

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

673 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+ renderSimpleErrorMessage (DuplicateLabel (Label l) expr) =

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

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

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

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

676 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

677 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

677 ]) expr

678 ]) expr

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

703 , line "does not have type"

704 , line "does not have type"

704 , markCodeBox $ indent $ typeAsBox ty

705 , markCodeBox $ indent $ typeAsBox ty

705 ]

706 ]

706− renderSimpleErrorMessage (PropertyIsMissing prop) =

707+ renderSimpleErrorMessage (PropertyIsMissing (Label prop)) =

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

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

708− renderSimpleErrorMessage (AdditionalProperty prop) =

709+ renderSimpleErrorMessage (AdditionalProperty (Label prop)) =

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

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

710 renderSimpleErrorMessage TypeSynonymInstance =

711 renderSimpleErrorMessage TypeSynonymInstance =

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

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

712 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

713 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

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

1263 whiteSpace = all isSpace

1264 whiteSpace = all isSpace

1264

1265

1265toTypelevelString :: Type -> Maybe Box.Box

1266toTypelevelString :: 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

1267toTypelevelString (TypeApp (TypeConstructor f) x)

1268toTypelevelString (TypeApp (TypeConstructor f) x)

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

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

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

1270toTypelevelString (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

3+

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

4+

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

16import Language.PureScript.Names

17import Language.PureScript.Parser.Lexer

18import Language.PureScript.Parser.State

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

19

20

20import qualified Text.Parsec as P

21import qualified Text.Parsec as P

21

22

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

72parseIdent :: TokenParser Ident

73parseIdent :: TokenParser Ident

73parseIdent = Ident <$> identifier

74parseIdent = Ident <$> identifier

74

75

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+

75-- |

82-- |

76-- Parse an operator.

83-- Parse an operator.

77--

84--

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

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

33import Language.PureScript.Kinds

34import Language.PureScript.Names

35import Language.PureScript.Types

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

36import Language.PureScript.Parser.Common

37import Language.PureScript.Parser.Common

37import Language.PureScript.Parser.Kinds

38import Language.PureScript.Parser.Kinds

38import Language.PureScript.Parser.Lexer

39import Language.PureScript.Parser.Lexer

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

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

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

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

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

340

341

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

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

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

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

343

344

344−parseIdentifierAndValue :: TokenParser (Text, Expr)

345+parseIdentifierAndValue :: TokenParser (PSString, Expr)

345parseIdentifierAndValue =

346parseIdentifierAndValue =

346 do

347 do

347 name <- C.indented *> lname

348 name <- C.indented *> lname

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

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

349− return (name, b)

350+ return (mkString name, b)

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

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

351 where

352 where

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

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

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

428parseHole :: TokenParser Expr

429parseHole :: TokenParser Expr

429parseHole = Hole <$> holeLit

430parseHole = Hole <$> holeLit

430

431

431−parsePropertyUpdate :: TokenParser (Text, Expr)

432+parsePropertyUpdate :: TokenParser (PSString, Expr)

432parsePropertyUpdate = do

433parsePropertyUpdate = do

433− name <- lname <|> stringLiteral

434+ name <- parseLabel

434 _ <- C.indented *> equals

435 _ <- C.indented *> equals

435 value <- C.indented *> parseValue

436 value <- C.indented *> parseValue

436 return (name, value)

437 return (name, value)

437

438

438parseAccessor :: Expr -> TokenParser Expr

439parseAccessor :: Expr -> TokenParser Expr

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

440parseAccessor (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

441

442

442parseDo :: TokenParser Expr

443parseDo :: TokenParser Expr

443parseDo = do

444parseDo = do

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

520parseNullBinder :: TokenParser Binder

521parseNullBinder :: TokenParser Binder

521parseNullBinder = underscore *> return NullBinder

522parseNullBinder = underscore *> return NullBinder

522

523

523−parseIdentifierAndBinder :: TokenParser (Text, Binder)

524+parseIdentifierAndBinder :: TokenParser (PSString, Binder)

524parseIdentifierAndBinder =

525parseIdentifierAndBinder =

525 do name <- lname

526 do name <- lname

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

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

527− return (name, b)

528+ return (mkString name, b)

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

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

529 where

530 where

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

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

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

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

70import Control.Monad.Identity (Identity)

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

72import Data.Monoid ((<>))

73+import Data.String (fromString)

73import Data.Text (Text)

74import Data.Text (Text)

74import qualified Data.Text as T

75import qualified Data.Text as T

75

76

76import Language.PureScript.Comments

77import Language.PureScript.Comments

77import Language.PureScript.Parser.State

78import Language.PureScript.Parser.State

79+import Language.PureScript.PSString (PSString)

78

80

79import qualified Text.Parsec as P

81import qualified Text.Parsec as P

80import qualified Text.Parsec.Token as PT

82import qualified Text.Parsec.Token as PT

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

106 | Qualifier Text

108 | Qualifier Text

107 | Symbol Text

109 | Symbol Text

108 | CharLiteral Char

110 | CharLiteral Char

109− | StringLiteral Text

111+ | StringLiteral PSString

110 | Number (Either Integer Double)

112 | Number (Either Integer Double)

111 | HoleLit Text

113 | HoleLit Text

112 deriving (Show, Eq, Ord)

114 deriving (Show, Eq, Ord)

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

249 symbolChar :: Lexer u Char

251 symbolChar :: Lexer u Char

250 symbolChar = P.satisfy isSymbolChar

252 symbolChar = P.satisfy isSymbolChar

251

253

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−

264 parseCharLiteral :: Lexer u Char

254 parseCharLiteral :: Lexer u Char

265 parseCharLiteral = P.try $ do {

255 parseCharLiteral = P.try $ do {

266 c <- PT.charLiteral tokenParser;

256 c <- PT.charLiteral tokenParser;

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

269 else return c

259 else return c

270 }

260 }

271

261

272− parseStringLiteral :: Lexer u Text

262+ parseStringLiteral :: Lexer u PSString

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

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

274 where

264 where

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

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

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

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

277

267

278 parseNumber :: Lexer u (Either Integer Double)

268 parseNumber :: Lexer u (Either Integer Double)

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

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

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

516 go (CharLiteral c) = Just c

506 go (CharLiteral c) = Just c

517 go _ = Nothing

507 go _ = Nothing

518

508

519−stringLiteral :: TokenParser Text

509+stringLiteral :: TokenParser PSString

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

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

521 where

511 where

522 go (StringLiteral s) = Just s

512 go (StringLiteral s) = Just s

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

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

9

10import Control.Monad (when, unless)

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

12−import Data.Text (Text)

13import qualified Data.Text as T

12import qualified Data.Text as T

14

13

15import Language.PureScript.AST.SourcePos

14import Language.PureScript.AST.SourcePos

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

18import Language.PureScript.Parser.Kinds

17import Language.PureScript.Parser.Kinds

19import Language.PureScript.Parser.Lexer

18import Language.PureScript.Parser.Lexer

20import Language.PureScript.Types

19import Language.PureScript.Types

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

21

22import qualified Text.Parsec as P

23import qualified Text.Parsec.Expr as P

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

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

119 return ty

120

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

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

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

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

123

124parseRowEnding :: TokenParser Type

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

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

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

15import qualified Data.Text as T

16

17import 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)

19

20

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

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

21import qualified Text.PrettyPrint.Boxes as Box

22import qualified Text.PrettyPrint.Boxes as Box

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

149-- |

150-- |

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

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

151--

152--

152−prettyPrintObjectKey :: Text -> Text

153+prettyPrintObjectKey :: PSString -> Text

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

154+prettyPrintObjectKey = prettyPrintLabel . Label

154− | isUnquotedKey s = s

155+

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

156+prettyPrintLabel :: Label -> Text

157+prettyPrintLabel = renderPSLabel

156

158

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

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

158before :: Box -> Box -> Box

160before :: Box -> Box -> Box

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

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

25import Language.PureScript.Comments

26import Language.PureScript.Crash

27import Language.PureScript.Pretty.Common

28−

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

29−import Numeric

30

29

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

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

32

31

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

38

37

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

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

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

39 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

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

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

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

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

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

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

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

58 , return $ emit "}"

57 , return $ emit "}"

59 ]

58 ]

60 where

59 where

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

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

62− objectPropertyToString s | identNeedsEscaping s = string s

61+ objectPropertyToString s =

63− | otherwise = emit s

62+ let quoted = renderJSON s in

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

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

65 [ return $ emit "{\n"

66 , withIndent $ prettyStatements sts

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

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

151 match _ = mzero

152

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−

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

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

177conditional = mkPattern match

154conditional = mkPattern match

178 where

155 where

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

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

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

183accessor = mkPattern match

160accessor = mkPattern match

184 where

161 where

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

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

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

186 match _ = Nothing

164 match _ = Nothing

187

165

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

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

189indexer = mkPattern' match

167indexer = mkPattern' match

190 where

168 where

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

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

192−

193 match _ = mzero

170 match _ = mzero

194

171

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

172lam :: 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

27import Language.PureScript.Pretty.Common

28import Language.PureScript.Pretty.Kinds

29import Language.PureScript.Types

30+import Language.PureScript.PSString (renderPSString)

31+import Language.PureScript.Label (Label)

30

32

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

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

32

34

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

45prettyPrintRowWith :: Char -> Char -> Type -> Box

47prettyPrintRowWith :: Char -> Char -> Type -> Box

46prettyPrintRowWith open close = uncurry listToBox . toList []

48prettyPrintRowWith open close = uncurry listToBox . toList []

47 where

49 where

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

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

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

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

50

52

51 tailToPs :: Type -> Box

53 tailToPs :: Type -> Box

52 tailToPs REmpty = nullBox

54 tailToPs REmpty = nullBox

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

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

54

56

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

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

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

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

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

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

58 listToBox ts rest = vcat left $

60 listToBox ts rest = vcat left $

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

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

60 [ tailToPs rest, text [close] ]

62 [ tailToPs rest, text [close] ]

61

63

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

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

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

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

64 toList tys r = (reverse tys, r)

66 toList tys r = (reverse tys, r)

65

67

66prettyPrintRow :: Type -> String

68prettyPrintRow :: Type -> String

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

116 typeLiterals = mkPattern match where

118 typeLiterals = mkPattern match where

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

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

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

120 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

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

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

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

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

122 match (TUnknown u)

124 match (TUnknown u)

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

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

22import Language.PureScript.Pretty.Common

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

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

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

25

26

26import Text.PrettyPrint.Boxes

27import Text.PrettyPrint.Boxes

27

28

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

40ellipsis :: Box

41ellipsis :: Box

41ellipsis = text "..."

42ellipsis = text "..."

42

43

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

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

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

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

45 where

46 where

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

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

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

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

48

49

49-- | Pretty-print an expression

50-- | Pretty-print an expression

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

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

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

56 ])

57 ])

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

58prettyPrintValue 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

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

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

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

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

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

62prettyPrintValue 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

105

106

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

170

171

171prettyPrintLiteralBinder :: Literal Binder -> Text

172prettyPrintLiteralBinder :: Literal Binder -> Text

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

173+prettyPrintLiteralBinder (StringLiteral str) = renderPSString str

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

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

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

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

175prettyPrintLiteralBinder (BooleanLiteral True) = "true"

176prettyPrintLiteralBinder (BooleanLiteral True) = "true"

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

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

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

180 Monoid.<> " }"

181 Monoid.<> " }"

181 where

182 where

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

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

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

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

184prettyPrintLiteralBinder (ArrayLiteral bs) =

185prettyPrintLiteralBinder (ArrayLiteral bs) =

185 "[ "

186 "[ "

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

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

11

12import Data.List (partition)

13import Data.Maybe (catMaybes)

14−import Data.Text (Text)

15

14

16import Language.PureScript.AST

15import Language.PureScript.AST

17import Language.PureScript.Errors

16import Language.PureScript.Errors

18import Language.PureScript.Names

17import Language.PureScript.Names

18+import Language.PureScript.PSString (PSString)

19

20desugarObjectConstructors

21 :: forall m

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

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

63 desugarExpr e = return e

64

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

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

66 wrapLambda mkVal ps =

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

68 in if null args

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

75 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

76 stripPositionInfo e = e

77

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

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

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

80 peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e

81 peelAnonAccessorChain AnonymousArgument = Just []

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

86 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

87 isAnonymousArgument _ = False

88

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

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

90 mkProp (name, e) = do

91 arg <- freshIfAnon e

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

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

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

19import Language.PureScript.Sugar.CaseDeclarations

20import Control.Monad.Supply.Class

21import Language.PureScript.Types

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

23+import Language.PureScript.PSString (mkString)

22

24

23import qualified Language.PureScript.Constants as C

25import qualified Language.PureScript.Constants as C

24

26

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

240 ]

242 ]

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

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

242 mtys = members' ++ superclassTypes

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

244

246

245typeClassMemberToDictionaryAccessor

247typeClassMemberToDictionaryAccessor

246 :: ModuleName

248 :: ModuleName

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

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

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

298 ]

300 ]

299

301

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

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

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

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

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

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

303 dict = TypeClassDictionaryConstructorApp className props

305 dict = TypeClassDictionaryConstructorApp className props

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

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

14import Data.Maybe (fromMaybe, mapMaybe)

15import Data.Ord (comparing)

16import Data.Text (Text)

17+import qualified Data.Text as T

17import Language.PureScript.AST

18import Language.PureScript.AST

18import qualified Language.PureScript.Constants as C

19import qualified Language.PureScript.Constants as C

19import Language.PureScript.Crash

20import Language.PureScript.Crash

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

22import Language.PureScript.Externs

23import Language.PureScript.Externs

23import Language.PureScript.Kinds

24import Language.PureScript.Kinds

24import Language.PureScript.Names

25import Language.PureScript.Names

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

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

25import Language.PureScript.Types

28import Language.PureScript.Types

26import Language.PureScript.TypeChecker (checkNewtype)

29import Language.PureScript.TypeChecker (checkNewtype)

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

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

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

207 idents <- replicateM (length tys) freshIdent'

210 idents <- replicateM (length tys) freshIdent'

208 tys' <- mapM (replaceAllTypeSynonymsM syns) tys

211 tys' <- mapM (replaceAllTypeSynonymsM syns) tys

209 let caseResult =

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

211 . Literal . ArrayLiteral

214 . Literal . ArrayLiteral

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

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

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

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

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

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

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

217 lamNull . recordConstructor . Literal . ArrayLiteral

220 lamNull . recordConstructor . Literal . ArrayLiteral

218 . map

221 . map

219− (\(str,typ) ->

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

220 Literal $ ObjectLiteral

223 Literal $ ObjectLiteral

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

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

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

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

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

235 App

238 App

236 (App

239 (App

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

240 (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))))

239 )

242 )

240 . Literal

243 . Literal

241 . ArrayLiteral

244 . ArrayLiteral

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

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

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

250 mkProdClause (ctorName, tys) =

253 mkProdClause (ctorName, tys) =

251 Literal $ ObjectLiteral

254 Literal $ ObjectLiteral

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

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

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

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

254 ]

257 ]

255

258

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

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

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

261 , ("recValue", mkProductSignature typ)

264 , ("recValue", mkProductSignature typ)

262 ]

265 ]

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

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

264 ]

267 ]

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

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

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

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

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

291 return $

294 return $

292 CaseAlternative

295 CaseAlternative

293 [ prodBinder

296 [ prodBinder

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

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

295 , LiteralBinder (ArrayLiteral (map VarBinder idents))

298 , LiteralBinder (ArrayLiteral (map VarBinder idents))

296 ]

299 ]

297 ]

300 ]

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

314 (App e unitVal)

317 (App e unitVal)

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

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

316

319

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

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

318 mkRecCase rs =

321 mkRecCase rs =

319 CaseAlternative

322 CaseAlternative

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

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

321 . Right

324 . 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)

323

326

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

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

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

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

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

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

327 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

330 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

328 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

331 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

329

332

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

405 args' <- mapM (replaceAllTypeSynonymsM syns) args

408 args' <- mapM (replaceAllTypeSynonymsM syns) args

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

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

407 return ( TypeApp (TypeApp (TypeConstructor constructor)

410 return ( TypeApp (TypeApp (TypeConstructor constructor)

408− (TypeLevelString (runProperName ctorName)))

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

409 ctorTy

412 ctorTy

410 , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

413 , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

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

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

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

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

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

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

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

432 let fields = decomposeRec rec

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

434 pure ( TypeApp (TypeConstructor record)

437 pure ( TypeApp (TypeConstructor record)

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

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

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

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

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

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

438 , ConstructorBinder record

441 , ConstructorBinder record

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

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

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

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

441 ]

444 ]

442 , Literal . ObjectLiteral $

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

444 , LiteralBinder . ObjectLiteral $

447 , LiteralBinder . ObjectLiteral $

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

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

446 , record' $

449 , record' $

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

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

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

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

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

574 toEqTest :: Expr -> Expr -> Type -> Expr

577 toEqTest :: Expr -> Expr -> Type -> Expr

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

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

576 conjAll

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

578 $ decomposeRec rec

581 $ decomposeRec rec

579 toEqTest l r _ = preludeEq l r

582 toEqTest l r _ = preludeEq l r

580

583

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

661 toOrdering :: Expr -> Expr -> Type -> Expr

664 toOrdering :: Expr -> Expr -> Type -> Expr

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

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

663 appendAll

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

665 $ decomposeRec rec

668 $ decomposeRec rec

666 toOrdering l r _ = ordCompare l r

669 toOrdering l r _ = ordCompare l r

667

670

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

733mkVar :: Ident -> Expr

736mkVar :: Ident -> Expr

734mkVar = mkVarMn Nothing

737mkVar = mkVarMn Nothing

735

738

739+labelToIdent :: Label -> Ident

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

741+

736objectType :: Type -> Maybe Type

742objectType :: Type -> Maybe Type

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

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

738objectType _ = Nothing

744objectType _ = Nothing

739

745

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

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

741decomposeRec = sortBy (comparing fst) . go

747decomposeRec = sortBy (comparing fst) . go

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

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

743 go _ = []

749 go _ = []

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

790 goType recTy | Just row <- objectType recTy =

796 goType recTy | Just row <- objectType recTy =

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

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

792 where

798 where

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

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

794 justUpdates = foldMap (fmap return)

800 justUpdates = foldMap (fmap return)

795

801

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

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

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

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

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

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

799

805

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

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

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

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

802 let argVar = mkVar arg

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

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

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

805

811

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

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

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

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

37import Language.PureScript.TypeChecker.Unify

38import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Types

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

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

40import qualified Language.PureScript.Constants as C

42import qualified Language.PureScript.Constants as C

41

43

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

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

43data Evidence

45data Evidence

44 = NamedInstance (Qualified Ident)

46 = NamedInstance (Qualified Ident)

45 -- ^ An existing named instance

47 -- ^ An existing named instance

46− | IsSymbolInstance Text

48+ | IsSymbolInstance PSString

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

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

48 | CompareSymbolInstance

50 | CompareSymbolInstance

49 -- ^ Computed instance of CompareSymbol

51 -- ^ Computed instance of CompareSymbol

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

319 -- Turn a DictionaryValue into a Expr

321 -- Turn a DictionaryValue into a Expr

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

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

321 subclassDictionaryValue dict superclassName index =

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

323 dict)

325 dict)

324 valUndefined

326 valUndefined

325

327

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

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

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

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

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

389

391

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

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

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

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

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

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

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

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

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

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

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

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

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

431 where

433 where

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

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

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

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

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

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

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

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

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

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

41import Data.Monoid ((<>))

42import qualified Data.Map as M

43import qualified Data.Set as S

44−import Data.Text (Text)

45

44

46import Language.PureScript.AST

45import Language.PureScript.AST

47import Language.PureScript.Crash

46import Language.PureScript.Crash

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

60import Language.PureScript.TypeChecker.TypeSearch

59import Language.PureScript.TypeChecker.TypeSearch

61import Language.PureScript.TypeChecker.Unify

60import Language.PureScript.TypeChecker.Unify

62import Language.PureScript.Types

61import Language.PureScript.Types

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

63+import Language.PureScript.PSString (PSString)

63

64

65

65data BindingGroupType

66data BindingGroupType

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

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

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

290 ensureNoDuplicateProperties ps

291 ensureNoDuplicateProperties ps

291 ts <- traverse (infer . snd) ps

292 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

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

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

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

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

295infer' (ObjectUpdate o ps) = do

296infer' (ObjectUpdate o ps) = do

296 ensureNoDuplicateProperties ps

297 ensureNoDuplicateProperties ps

297 row <- freshType

298 row <- freshType

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

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

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

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

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

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

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

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

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

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

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

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

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

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

305 field <- freshType

306 field <- freshType

306 rest <- freshType

307 rest <- freshType

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

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

308 return $ TypedValue True (Accessor prop typed) field

309 return $ TypedValue True (Accessor prop typed) field

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

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

310 ty <- freshType

311 ty <- freshType

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

442 unifyTypes val (TypeApp tyRecord row)

443 unifyTypes val (TypeApp tyRecord row)

443 return m1

444 return m1

444 where

445 where

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

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

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

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

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

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

448 propTy <- freshType

449 propTy <- freshType

449 m1 <- inferBinder propTy binder

450 m1 <- inferBinder propTy binder

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

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

451 return $ m1 `M.union` m2

452 return $ m1 `M.union` m2

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

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

453 el <- freshType

454 el <- freshType

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

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

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

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

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

643 let (propsToCheck, rest) = rowToList row

644 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

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

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

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

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

647 ps' <- checkProperties e ps row True

648 ps' <- checkProperties e ps row True

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

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

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

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

650 rest <- freshType

651 rest <- freshType

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

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

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

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

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

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

654 env <- getEnv

655 env <- getEnv

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

681checkProperties ::

682checkProperties ::

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

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

683 Expr ->

684 Expr ->

684− [(Text, Expr)] ->

685+ [(PSString, Expr)] ->

685 Type ->

686 Type ->

686 Bool ->

687 Bool ->

687− m [(Text, Expr)]

688+ m [(PSString, Expr)]

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

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

689 go [] [] REmpty = return []

690 go [] [] REmpty = return []

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

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

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

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

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

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

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

696 | otherwise = throwError . errorMessage $ PropertyIsMissing p

697 | otherwise = throwError . errorMessage $ PropertyIsMissing p

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

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

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

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

699− case lookup p ts of

700+ case lookup (Label p) ts of

700 Nothing -> do

701 Nothing -> do

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

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

702 rest <- freshType

703 rest <- freshType

703− unifyTypes r (RCons p ty rest)

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

704 ps'' <- go ps' ts rest

705 ps'' <- go ps' ts rest

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

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

706 Just ty -> do

707 Just ty -> do

707 v' <- check v ty

708 v' <- check v ty

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

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

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

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

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

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

711

712

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

771-- |

772-- |

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

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

773--

774--

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

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

775ensureNoDuplicateProperties ps =

776ensureNoDuplicateProperties ps =

776 let ls = map fst ps in

777 let ls = map fst ps in

777 case ls \\ nub ls of

778 case ls \\ nub ls of

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

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

779 _ -> return ()

780 _ -> return ()

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

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

31import Language.PureScript.Errors

32import Language.PureScript.TypeChecker.Monad

33import Language.PureScript.TypeChecker.Skolems

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

34import Language.PureScript.Types

35import Language.PureScript.Types

35

36

36-- | Generate a fresh type variable

37-- | Generate a fresh type variable

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

139 forM_ int (uncurry unifyTypes)

140 forM_ int (uncurry unifyTypes)

140 unifyRows' sd1 r1' sd2 r2'

141 unifyRows' sd1 r1' sd2 r2'

141 where

142 where

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

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

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

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

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

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

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

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

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

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

2{-# LANGUAGE TemplateHaskell #-}

3

4-- |

5−-- Data types for types

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

6--

7module Language.PureScript.Types where

8

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

20import Language.PureScript.AST.SourcePos

21import Language.PureScript.Kinds

22import Language.PureScript.Names

23+import Language.PureScript.Label (Label)

24+import Language.PureScript.PSString (PSString)

23

25

24-- |

26-- |

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

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

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

36 -- | A named type variable

38 -- | A named type variable

37 | TypeVar Text

39 | TypeVar Text

38 -- | A type-level string

40 -- | A type-level string

39− | TypeLevelString Text

41+ | TypeLevelString PSString

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

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

41 | TypeWildcard SourceSpan

43 | TypeWildcard SourceSpan

42 -- | A type constructor

44 -- | A type constructor

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

55 -- | An empty row

57 -- | An empty row

56 | REmpty

58 | REmpty

57 -- | A non-empty row

59 -- | A non-empty row

58− | RCons Text Type Type

60+ | RCons Label Type Type

59 -- | A type with a kind annotation

61 -- | A type with a kind annotation

60 | KindedType Type Kind

62 | KindedType Type Kind

61 -- | A placeholder used in pretty printing

63 -- | A placeholder used in pretty printing

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

108-- |

110-- |

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

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

110--

112--

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

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

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

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

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

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

114rowToList r = ([], r)

116rowToList r = ([], r)

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

116-- |

118-- |

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

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

118--

120--

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

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

120rowFromList ([], r) = r

122rowFromList ([], r) = r

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

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

122

124

tests/support/bower.json+1

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

9 "purescript-st": "2.0.0",

10 "purescript-partial": "1.1.2",

11 "purescript-newtype": "1.1.0",

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

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

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

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

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

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

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