086bbe6 · rowtype-yoga/purescript-native

examples/passing/StringEdgeCases.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+module Main where

2+

3+import Prelude

4+import Records as Records

5+import Symbols as Symbols

6+

7+main = do

8+ Records.main

9+ Symbols.main

examples/passing/StringEdgeCases/Records.pursnew file+66

@@ -0,0 +1,66 @@

1+module Records where

2+

3+import Prelude

4+import Data.Generic (class Generic, toSpine, GenericSpine(..))

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+spineOf :: forall a. Generic a => a -> Unit -> GenericSpine

15+spineOf x _ = toSpine x

16+

17+testLoneSurrogateKeys =

18+ let

19+ expected = 5

20+ actual = (_."\xd801" <<< helper) { "\xd800": 5 }

21+ in

22+ assert' ("lone surrogate keys: " <> show actual) (expected == actual)

23+

24+ where

25+ helper :: { "\xd800" :: Int } -> { "\xd801" :: Int }

26+ helper o =

27+ case o."\xd800" of

28+ x -> { "\xd801": x }

29+

30+testAstralKeys =

31+ let

32+ expected = 5

33+ actual = (_."💢" <<< helper) { "💡": 5 }

34+ in

35+ assert' ("astral keys: " <> show actual) (expected == actual)

36+

37+ where

38+ helper :: { "💡" :: Int } -> { "💢" :: Int }

39+ helper o =

40+ case o."💡" of

41+ x -> { "💢": x }

42+

43+testGenericLoneSurrogateKeys = do

44+ let expected = SProd "Records.LoneSurrogateKeys"

45+ [ \_ -> SRecord [ {recLabel: "\xd834", recValue: spineOf 1}

46+ , {recLabel: "\xdf06", recValue: spineOf 0}

47+ ]

48+ ]

49+ actual = toSpine (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 })

50+ assert' ("generic lone surrogate keys: " <> show actual) (expected == actual)

51+

52+testGenericAstralKeys = do

53+ let expected = SProd "Records.AstralKeys"

54+ [ \_ -> SRecord [ {recLabel: "💡", recValue: spineOf 0}

55+ , {recLabel: "💢", recValue: spineOf 1}

56+ ]

57+ ]

58+ actual = toSpine (AstralKeys { "💡": 0, "💢": 1 })

59+ assert' ("generic astral keys: " <> show actual) (expected == actual)

60+

61+main = do

62+ testLoneSurrogateKeys

63+ testAstralKeys

64+ testGenericLoneSurrogateKeys

65+ testGenericAstralKeys

66+ log "Done"

examples/passing/StringEdgeCases/Symbols.pursnew file+30

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

1+-- This is similar to StringEscapes except we are performing the same tests

2+-- with Symbols (at the type level).

3+

4+module Symbols where

5+

6+import Prelude

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

8+import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol)

9+import Test.Assert (assert')

10+

11+highS :: SProxy "\xd834"

12+highS = SProxy

13+

14+lowS :: SProxy "\xdf06"

15+lowS = SProxy

16+

17+loneSurrogates :: Boolean

18+loneSurrogates = reflectSymbol (appendSymbol highS lowS) == "\x1d306"

19+

20+outOfOrderSurrogates :: Boolean

21+outOfOrderSurrogates = reflectSymbol (appendSymbol lowS highS) == "\xdf06\xd834"

22+

23+notReplacing :: Boolean

24+notReplacing = reflectSymbol lowS /= "\xfffd"

25+

26+main = do

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

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

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

30+ 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+4

@@ -54,6 +54,7 @@ extra-source-files: examples/passing/*.purs

54 , examples/passing/ResolvableScopeConflict3/*.purs

55 , examples/passing/ShadowedModuleName/*.purs

56 , examples/passing/SolvingIsSymbol/*.purs

57+ , examples/passing/StringEdgeCases/*.purs

57 , examples/passing/TransitiveImport/*.purs

58 , examples/passing/TransitiveImport/*.purs

58 , examples/passing/TypeOperators/*.purs

59 , examples/passing/TypeOperators/*.purs

59 , examples/passing/TypeWithoutParens/*.purs

60 , examples/passing/TypeWithoutParens/*.purs

@@ -146,6 +147,7 @@ library

146 protolude >= 0.1.6,

147 protolude >= 0.1.6,

147 regex-tdfa -any,

148 regex-tdfa -any,

148 safe >= 0.3.9 && < 0.4,

149 safe >= 0.3.9 && < 0.4,

150+ scientific >= 0.3.4.9 && < 0.4,

149 semigroups >= 0.16.2 && < 0.19,

151 semigroups >= 0.16.2 && < 0.19,

150 sourcemap >= 0.1.6,

152 sourcemap >= 0.1.6,

151 spdx == 0.2.*,

153 spdx == 0.2.*,

@@ -199,6 +201,7 @@ library

199 Language.PureScript.Errors

201 Language.PureScript.Errors

200 Language.PureScript.Errors.JSON

202 Language.PureScript.Errors.JSON

201 Language.PureScript.Kinds

203 Language.PureScript.Kinds

204+ Language.PureScript.Label

202 Language.PureScript.Linter

205 Language.PureScript.Linter

203 Language.PureScript.Linter.Exhaustive

206 Language.PureScript.Linter.Exhaustive

204 Language.PureScript.Linter.Imports

207 Language.PureScript.Linter.Imports

@@ -219,6 +222,7 @@ library

219 Language.PureScript.Pretty.Kinds

222 Language.PureScript.Pretty.Kinds

220 Language.PureScript.Pretty.Types

223 Language.PureScript.Pretty.Types

221 Language.PureScript.Pretty.Values

224 Language.PureScript.Pretty.Values

225+ Language.PureScript.PSString

222 Language.PureScript.Renamer

226 Language.PureScript.Renamer

223 Language.PureScript.Sugar

227 Language.PureScript.Sugar

224 Language.PureScript.Sugar.BindingGroups

228 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+20−14

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

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

186+ case decodeString prop of

187+ Just s | not (identNeedsEscaping s) ->

188+ JSAccessor Nothing s

189+ _ ->

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

190+ JSIndexer Nothing (JSStringLiteral Nothing prop)

184− | otherwise = JSAccessor Nothing prop

185

191

186 -- |

192 -- |

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

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

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

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

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

213 unAbs _ = []

219 unAbs _ = []

214 assign :: Ident -> JS

220 assign :: Ident -> JS

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

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

216 (var name)

222 (var name)

217 valueToJs' (Abs _ arg val) = do

223 valueToJs' (Abs _ arg val) = do

218 ret <- valueToJs val

224 ret <- valueToJs val

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

280 -- |

286 -- |

281 -- Shallow copy an object.

287 -- Shallow copy an object.

282 --

288 --

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

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

284 extendObj obj sts = do

290 extendObj obj sts = do

285 newObj <- freshName

291 newObj <- freshName

286 key <- freshName

292 key <- freshName

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

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

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

318

324

319 foreignIdent :: Ident -> JS

325 foreignIdent :: Ident -> JS

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

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

321

327

322 -- |

328 -- |

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

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

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

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

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

342

348

343 failedPatternError :: [Text] -> JS

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

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

345

351

346 failedPatternMessage :: Text

352 failedPatternMessage :: Text

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

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

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

402 literalToBinderJS varName done (NumericLiteral num) =

408 literalToBinderJS varName done (NumericLiteral num) =

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

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

404 literalToBinderJS varName done (CharLiteral c) =

410 literalToBinderJS varName done (CharLiteral c) =

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

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

406 literalToBinderJS varName done (StringLiteral str) =

412 literalToBinderJS varName done (StringLiteral str) =

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

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

408 literalToBinderJS varName done (BooleanLiteral True) =

414 literalToBinderJS varName done (BooleanLiteral True) =

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

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

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

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

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

413 where

419 where

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

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

415 go done' [] = return done'

421 go done' [] = return done'

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

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

417 propVar <- freshName

423 propVar <- freshName

src/Language/PureScript/CodeGen/JS/AST.hs+5−3

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

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

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

@@ -73,7 +74,7 @@ isFn :: (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 == 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

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

@@ -239,7 +239,7 @@ inlineCommonOperators = applyAll $

239 isModFn _ _ = False

240

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

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

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

243 isModFnWithDict _ _ = False

244

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

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+2−1

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

@@ -104,7 +105,7 @@ 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 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 =

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)

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 = toJSON . map (\(key, a) -> (toJSON 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+7−5

@@ -26,7 +26,9 @@ import Language.PureScript.Environment

26import Language.PureScript.Kinds

27import Language.PureScript.Names

28import Language.PureScript.Pretty.Kinds

29+import Language.PureScript.Pretty.Types

29import Language.PureScript.Types

30import Language.PureScript.Types

31+import Language.PureScript.Label (Label)

30

32

31typeLiterals :: Pattern () Type RenderedCode

33typeLiterals :: Pattern () Type RenderedCode

32typeLiterals = mkPattern match

34typeLiterals = mkPattern match

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

79 where

81 where

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

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

81

83

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

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

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

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

84

86

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

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

86renderLabel (label, ty) =

88renderLabel (label, ty) =

87 mintersperse sp

89 mintersperse sp

88− [ ident label

90+ [ syntax $ prettyPrintLabel label

89 , syntax "::"

91 , syntax "::"

90 , renderType ty

92 , renderType ty

91 ]

93 ]

@@ -125,9 +127,9 @@ explicitParens = mkPattern match

125 match _ = Nothing

127 match _ = Nothing

126

128

127matchTypeAtom :: Pattern () Type RenderedCode

129matchTypeAtom :: Pattern () Type RenderedCode

128−matchTypeAtom = typeLiterals <+> fmap parens matchType

130+matchTypeAtom = typeLiterals <+> fmap parens_ matchType

129 where

131 where

130− parens x = syntax "(" <> x <> syntax ")"

132+ parens_ x = syntax "(" <> x <> syntax ")"

131

133

132matchType :: Pattern () Type RenderedCode

134matchType :: Pattern () Type RenderedCode

133matchType = buildPrettyPrinter operators matchTypeAtom

135matchType = buildPrettyPrinter operators matchTypeAtom

src/Language/PureScript/Errors.hs+10−10

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

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

36import qualified Language.PureScript.Bundle as Bundle

37import qualified Language.PureScript.Bundle as Bundle

37import qualified Language.PureScript.Constants as C

38import qualified Language.PureScript.Constants as C

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

39

40import qualified System.Console.ANSI as ANSI

41

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

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

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

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

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

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

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

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

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

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

565 sortRows t1 t2 = (t1, t2)

566

567 -- Put the common labels last

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

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

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

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

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

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

572

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

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

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

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

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

@@ -673,7 +673,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

673 renderSimpleErrorMessage (CannotFindDerivingType nm) =

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

675 renderSimpleErrorMessage (DuplicateLabel l expr) =

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

676+ paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ]

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

678 , markCodeBox $ indent $ prettyPrintValue valueDepth expr'

679 ]) expr

@@ -706,9 +706,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

706 , markCodeBox $ indent $ typeAsBox ty

707 ]

708 renderSimpleErrorMessage (PropertyIsMissing prop) =

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

709+ line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "."

710 renderSimpleErrorMessage (AdditionalProperty prop) =

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

711+ line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "."

712 renderSimpleErrorMessage TypeSynonymInstance =

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

714 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

@@ -1265,7 +1265,7 @@ renderBox = unlines

1265 whiteSpace = all isSpace

1266

1267toTypelevelString :: Type -> Maybe Box.Box

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

1268+toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s

1269toTypelevelString (TypeApp (TypeConstructor f) x)

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

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

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

@@ -0,0 +1,16 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

3+

4+import Prelude.Compat hiding (lex)

5+import Data.Monoid ()

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

7+import qualified Data.Aeson as A

8+

9+import Language.PureScript.PSString (PSString)

10+

11+-- |

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

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

14+--

15+newtype Label = Label { runLabel :: PSString }

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

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

@@ -0,0 +1,173 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Language.PureScript.PSString

4+ ( PSString

5+ , toUTF16CodeUnits

6+ , decodeString

7+ , decodeStringEither

8+ , prettyPrintString

9+ , prettyPrintStringJS

10+ , mkString

11+ ) where

12+

13+import Prelude.Compat

14+import Control.Exception (try, evaluate)

15+import Data.Char (chr)

16+import Data.Bits (shiftR)

17+import Data.List (unfoldr)

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

19+import Data.Scientific (toBoundedInteger)

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

21+import Data.ByteString (ByteString)

22+import qualified Data.ByteString as BS

23+import Data.Text (Text)

24+import qualified Data.Text as T

25+import Data.Text.Encoding (decodeUtf16BE)

26+import Data.Text.Encoding.Error (UnicodeException)

27+import qualified Data.Vector as V

28+import Data.Word (Word16, Word8)

29+import Numeric (showHex)

30+import System.IO.Unsafe (unsafePerformIO)

31+import qualified Data.Aeson as A

32+import qualified Data.Aeson.Types as A

33+

34+-- |

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

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

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

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

39+--

40+-- The Show instance for PSString produces a string literal which would

41+-- represent the same data were it inserted into a PureScript source file.

42+--

43+newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }

44+ deriving (Eq, Ord, Monoid)

45+

46+instance Show PSString where

47+ show = show . codePoints

48+

49+-- Decode a PSString to a String, representing any lone surrogates as the

50+-- reserved code point with that index. Warning: if there are any lone

51+-- surrogates, converting the result to Text via Data.Text.pack will result in

52+-- loss of information as those lone surrogates will be replaced with U+FFFD

53+-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,

54+-- we do not export it.

55+codePoints :: PSString -> String

56+codePoints = map (either (chr . fromIntegral) id) . decodeStringEither

57+

58+-- |

59+-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in

60+-- the output with the Left constructor; characters which were successfully

61+-- decoded are represented with the Right constructor.

62+--

63+decodeStringEither :: PSString -> [Either Word16 Char]

64+decodeStringEither = unfoldr decode . toUTF16CodeUnits

65+ where

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

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

68+ decode (c:rest) | isSurrogate c = Just (Left c, rest)

69+ decode (c:rest) = Just (Right (toChar c), rest)

70+ decode [] = Nothing

71+

72+ unsurrogate :: Word16 -> Word16 -> Char

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

74+

75+-- |

76+-- Pretty print a PSString, using Haskell/PureScript escape sequences.

77+-- This is identical to the Show instance except that we get a Text out instead

78+-- of a String.

79+--

80+prettyPrintString :: PSString -> Text

81+prettyPrintString = T.pack . show

82+

83+-- |

84+-- Attempt to decode a PSString as UTF-16 text. This will fail (returning

85+-- Nothing) if the argument contains lone surrogates.

86+--

87+decodeString :: PSString -> Maybe Text

88+decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits

89+ where

90+ unpair w = [highByte w, lowByte w]

91+

92+ lowByte :: Word16 -> Word8

93+ lowByte = fromIntegral

94+

95+ highByte :: Word16 -> Word8

96+ highByte = fromIntegral . (`shiftR` 8)

97+

98+ -- Based on a similar function from Data.Text.Encoding for utf8. This is a

99+ -- safe usage of unsafePerformIO because there are no side effects after

100+ -- handling any thrown UnicodeExceptions.

101+ decodeEither :: ByteString -> Either UnicodeException Text

102+ decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE

103+

104+ hush = either (const Nothing) Just

105+

106+instance IsString PSString where

107+ fromString a = PSString $ concatMap encodeUTF16 a

108+ where

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

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

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

112+

113+ encodeUTF16 :: Char -> [Word16]

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

115+ where (high, low) = surrogates c

116+ encodeUTF16 c = [toWord $ fromEnum c]

117+

118+instance A.ToJSON PSString where

119+ toJSON = A.toJSON . toUTF16CodeUnits

120+

121+instance A.FromJSON PSString where

122+ parseJSON a = PSString <$> parseArrayOfCodeUnits a

123+ where

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

125+ parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList)

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

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

128+

129+-- |

130+-- Pretty print a PSString, using JavaScript escape sequences. Intended for

131+-- use in compiled JS output.

132+--

133+prettyPrintStringJS :: PSString -> Text

134+prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""

135+ where

136+ encodeChar :: Word16 -> Text

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

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

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

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

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

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

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

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

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

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

147+ encodeChar c = T.singleton $ toChar c

148+

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

150+ hex width c =

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

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

153+

154+isLead :: Word16 -> Bool

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

156+

157+isTrail :: Word16 -> Bool

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

159+

160+isSurrogate :: Word16 -> Bool

161+isSurrogate c = isLead c || isTrail c

162+

163+toChar :: Word16 -> Char

164+toChar = toEnum . fromIntegral

165+

166+toWord :: Int -> Word16

167+toWord = fromIntegral

168+

169+toInt :: Word16 -> Int

170+toInt = fromIntegral

171+

172+mkString :: Text -> PSString

173+mkString = fromString . T.unpack

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.hs+1

@@ -15,3 +15,4 @@ import Language.PureScript.Pretty.JS as P

15import Language.PureScript.Pretty.Kinds as P

16import Language.PureScript.Pretty.Types as P

17import Language.PureScript.Pretty.Values as P

18+import Language.PureScript.PSString as P (prettyPrintString)

src/Language/PureScript/Pretty/Common.hs+4−8

@@ -15,7 +15,7 @@ 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.Parser.Lexer (isUnquotedKey, reservedPsNames)

19

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

21import qualified Text.PrettyPrint.Boxes as Box

@@ -146,13 +146,9 @@ prettyPrintMany f xs = do

146 indentString <- currentIndent

147 return $ intercalate (emit "\n") $ map (mappend indentString) ss

148

149−-- |

149+objectKeyRequiresQuoting :: Text -> Bool

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

150+objectKeyRequiresQuoting s =

151−--

152−prettyPrintObjectKey :: Text -> Text

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

154− | isUnquotedKey s = s

151+ s `elem` reservedPsNames || isUnquotedKey s

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

156

152

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

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

158before :: Box -> Box -> Box

154before :: Box -> Box -> Box

src/Language/PureScript/Pretty/JS.hs+10−30

@@ -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, decodeString, prettyPrintStringJS)

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 $ prettyPrintStringJS 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,13 @@ 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+ emit $ case decodeString s of

63+ Just s' | not (identNeedsEscaping s') ->

64+ s'

65+ _ ->

66+ prettyPrintStringJS s

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

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

65 [ return $ emit "{\n"

68 [ return $ emit "{\n"

66 , withIndent $ prettyStatements sts

69 , withIndent $ prettyStatements sts

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

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

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

151 match _ = mzero

154 match _ = mzero

152

155

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)

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

177conditional = mkPattern match

157conditional = mkPattern match

178 where

158 where

@@ -182,6 +162,7 @@ conditional = mkPattern match

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

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

183accessor = mkPattern match

163accessor = mkPattern match

184 where

164 where

165+ -- 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)

166 match (JSAccessor _ prop val) = Just (emit prop, val)

186 match _ = Nothing

167 match _ = Nothing

187

168

@@ -189,7 +170,6 @@ indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

189indexer = mkPattern' match

170indexer = mkPattern' match

190 where

171 where

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

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

192−

193 match _ = mzero

173 match _ = mzero

194

174

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

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

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

@@ -10,6 +10,8 @@ module Language.PureScript.Pretty.Types

10 , prettyPrintTypeAtom

11 , prettyPrintRowWith

12 , prettyPrintRow

13+ , prettyPrintLabel

14+ , prettyPrintObjectKey

13 ) where

15 ) where

14

16

15import Prelude.Compat

17import Prelude.Compat

@@ -18,6 +20,7 @@ import Control.Arrow ((<+>))

18import Control.PatternArrows as PA

20import Control.PatternArrows as PA

19

21

20import Data.Maybe (fromMaybe)

22import Data.Maybe (fromMaybe)

23+import Data.Text (Text)

21import qualified Data.Text as T

24import qualified Data.Text as T

22

25

23import Language.PureScript.Crash

26import Language.PureScript.Crash

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

27import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

28import Language.PureScript.Pretty.Kinds

31import Language.PureScript.Pretty.Kinds

29import Language.PureScript.Types

32import Language.PureScript.Types

33+import Language.PureScript.PSString (PSString, prettyPrintString, decodeString)

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

30

35

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

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

32

37

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

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

50prettyPrintRowWith :: Char -> Char -> Type -> Box

46prettyPrintRowWith open close = uncurry listToBox . toList []

51prettyPrintRowWith open close = uncurry listToBox . toList []

47 where

52 where

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

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

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

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

50

55

51 tailToPs :: Type -> Box

56 tailToPs :: Type -> Box

52 tailToPs REmpty = nullBox

57 tailToPs REmpty = nullBox

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

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

54

59

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

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

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

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

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

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

58 listToBox ts rest = vcat left $

63 listToBox ts rest = vcat left $

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

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

60 [ tailToPs rest, text [close] ]

65 [ tailToPs rest, text [close] ]

61

66

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

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

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

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

64 toList tys r = (reverse tys, r)

69 toList tys r = (reverse tys, r)

65

70

66prettyPrintRow :: Type -> String

71prettyPrintRow :: Type -> String

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

116 typeLiterals = mkPattern match where

121 typeLiterals = mkPattern match where

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

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

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

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

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

124+ match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s

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

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

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

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

122 match (TUnknown u)

127 match (TUnknown u)

@@ -186,3 +191,14 @@ prettyPrintType = render . typeAsBoxImpl False

186-- | Generate a pretty-printed string representing a suggested 'Type'

191-- | Generate a pretty-printed string representing a suggested 'Type'

187prettyPrintSuggestedType :: Type -> String

192prettyPrintSuggestedType :: Type -> String

188prettyPrintSuggestedType = render . typeAsBoxImpl True

193prettyPrintSuggestedType = render . typeAsBoxImpl True

194+

195+prettyPrintLabel :: Label -> Text

196+prettyPrintLabel (Label s) =

197+ case decodeString s of

198+ Just s' | not (objectKeyRequiresQuoting s') ->

199+ s'

200+ _ ->

201+ prettyPrintString s

202+

203+prettyPrintObjectKey :: PSString -> Text

204+prettyPrintObjectKey = prettyPrintLabel . Label

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

@@ -20,8 +20,9 @@ import Language.PureScript.AST

20import Language.PureScript.Crash

21import Language.PureScript.Names

22import Language.PureScript.Pretty.Common

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

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

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

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

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 $ prettyPrintString 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) = prettyPrintString 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+39−24

@@ -11,9 +11,11 @@ import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Supply.Class (MonadSupply)

12import Data.List (foldl', find, sortBy, unzip5)

13import qualified Data.Map as M

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

14import Data.Maybe (fromMaybe, mapMaybe)

15import Data.Maybe (fromMaybe, mapMaybe)

15import Data.Ord (comparing)

16import Data.Ord (comparing)

16import Data.Text (Text)

17import Data.Text (Text)

18+import qualified Data.Text as T

17import Language.PureScript.AST

19import Language.PureScript.AST

18import qualified Language.PureScript.Constants as C

20import qualified Language.PureScript.Constants as C

19import Language.PureScript.Crash

21import Language.PureScript.Crash

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

22import Language.PureScript.Externs

24import Language.PureScript.Externs

23import Language.PureScript.Kinds

25import Language.PureScript.Kinds

24import Language.PureScript.Names

26import Language.PureScript.Names

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

28+import Language.PureScript.PSString (mkString, decodeStringEither)

25import Language.PureScript.Types

29import Language.PureScript.Types

26import Language.PureScript.TypeChecker (checkNewtype)

30import Language.PureScript.TypeChecker (checkNewtype)

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

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

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

207 idents <- replicateM (length tys) freshIdent'

211 idents <- replicateM (length tys) freshIdent'

208 tys' <- mapM (replaceAllTypeSynonymsM syns) tys

212 tys' <- mapM (replaceAllTypeSynonymsM syns) tys

209 let caseResult =

213 let caseResult =

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

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

211 . Literal . ArrayLiteral

215 . Literal . ArrayLiteral

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

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

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

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

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

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

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

217 lamNull . recordConstructor . Literal . ArrayLiteral

221 lamNull . recordConstructor . Literal . ArrayLiteral

218 . map

222 . map

219− (\(str,typ) ->

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

220 Literal $ ObjectLiteral

224 Literal $ ObjectLiteral

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

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

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

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

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

235 App

239 App

236 (App

240 (App

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

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

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

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

239 )

243 )

240 . Literal

244 . Literal

241 . ArrayLiteral

245 . ArrayLiteral

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

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

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

250 mkProdClause (ctorName, tys) =

254 mkProdClause (ctorName, tys) =

251 Literal $ ObjectLiteral

255 Literal $ ObjectLiteral

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

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

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

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

254 ]

258 ]

255

259

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

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

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

261 , ("recValue", mkProductSignature typ)

265 , ("recValue", mkProductSignature typ)

262 ]

266 ]

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

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

264 ]

268 ]

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

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

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

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

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

291 return $

295 return $

292 CaseAlternative

296 CaseAlternative

293 [ prodBinder

297 [ prodBinder

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

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

295 , LiteralBinder (ArrayLiteral (map VarBinder idents))

299 , LiteralBinder (ArrayLiteral (map VarBinder idents))

296 ]

300 ]

297 ]

301 ]

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

314 (App e unitVal)

318 (App e unitVal)

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

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

316

320

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

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

318 mkRecCase rs =

322 mkRecCase rs =

319 CaseAlternative

323 CaseAlternative

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

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

321 . Right

325 . Right

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

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

323

327

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

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

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

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

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

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

327 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

331 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

328 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

332 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

329

333

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

405 args' <- mapM (replaceAllTypeSynonymsM syns) args

409 args' <- mapM (replaceAllTypeSynonymsM syns) args

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

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

407 return ( TypeApp (TypeApp (TypeConstructor constructor)

411 return ( TypeApp (TypeApp (TypeConstructor constructor)

408− (TypeLevelString (runProperName ctorName)))

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

409 ctorTy

413 ctorTy

410 , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

414 , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]

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

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

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

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

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

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

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

432 let fields = decomposeRec rec

436 let fields = decomposeRec rec

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

437+ fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields)

434 pure ( TypeApp (TypeConstructor record)

438 pure ( TypeApp (TypeConstructor record)

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

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

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

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

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

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

438 , ConstructorBinder record

442 , ConstructorBinder record

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

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

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

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

441 ]

445 ]

442 , Literal . ObjectLiteral $

446 , Literal . ObjectLiteral $

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

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

444 , LiteralBinder . ObjectLiteral $

448 , LiteralBinder . ObjectLiteral $

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

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

446 , record' $

450 , record' $

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

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

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

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

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

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

578 toEqTest :: Expr -> Expr -> Type -> Expr

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

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

576 conjAll

580 conjAll

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

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

578 $ decomposeRec rec

582 $ decomposeRec rec

579 toEqTest l r _ = preludeEq l r

583 toEqTest l r _ = preludeEq l r

580

584

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

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

665 toOrdering :: Expr -> Expr -> Type -> Expr

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

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

663 appendAll

667 appendAll

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

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

665 $ decomposeRec rec

669 $ decomposeRec rec

666 toOrdering l r _ = ordCompare l r

670 toOrdering l r _ = ordCompare l r

667

671

@@ -733,11 +737,22 @@ mkVarMn mn = Var . Qualified mn

733mkVar :: Ident -> Expr

737mkVar :: Ident -> Expr

734mkVar = mkVarMn Nothing

738mkVar = mkVarMn Nothing

735

739

740+-- This function may seem a little obtuse, but it's only this way to ensure

741+-- that it is injective. Injectivity is important here; without it, we can end

742+-- up with accidental variable shadowing in the generated code.

743+labelToIdent :: Label -> Ident

744+labelToIdent =

745+ Ident . foldMap (either loneSurrogate char) . decodeStringEither . runLabel

746+ where

747+ char '_' = "__"

748+ char c = T.singleton c

749+ loneSurrogate x = "_" <> T.pack (show x) <> "_"

750+

736objectType :: Type -> Maybe Type

751objectType :: Type -> Maybe Type

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

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

738objectType _ = Nothing

753objectType _ = Nothing

739

754

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

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

741decomposeRec = sortBy (comparing fst) . go

756decomposeRec = sortBy (comparing fst) . go

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

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

743 go _ = []

758 go _ = []

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

790 goType recTy | Just row <- objectType recTy =

805 goType recTy | Just row <- objectType recTy =

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

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

792 where

807 where

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

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

794 justUpdates = foldMap (fmap return)

809 justUpdates = foldMap (fmap return)

795

810

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

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

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

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

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

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

799

814

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

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

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

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

802 let argVar = mkVar arg

817 let argVar = mkVar arg

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

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

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

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

805

820

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

821 -- 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+6−4

@@ -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/TestPsci.hs+1−1

@@ -120,7 +120,7 @@ getPSCiState :: IO PSCiState

120getPSCiState = do

121 cwd <- getCurrentDirectory

122 let supportDir = cwd </> "tests" </> "support" </> "bower_components"

123− let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir

123+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir

124 pursFiles <- supportFiles "purs"

125

126 modulesOrFirstError <- loadAllModules pursFiles

tests/TestUtils.hs+19−1

@@ -69,11 +69,15 @@ supportModules =

69 , "Control.Monad.Eff.Class"

70 , "Control.Monad.Eff.Console"

71 , "Control.Monad.Eff.Unsafe"

72+ , "Control.Monad.Rec.Class"

72 , "Control.Monad.ST"

73 , "Control.Monad.ST"

73 , "Control.MonadPlus"

74 , "Control.MonadPlus"

74 , "Control.MonadZero"

75 , "Control.MonadZero"

75 , "Control.Plus"

76 , "Control.Plus"

76 , "Control.Semigroupoid"

77 , "Control.Semigroupoid"

78+ , "Data.Array"

79+ , "Data.Array.Partial"

80+ , "Data.Array.ST"

77 , "Data.Bifoldable"

81 , "Data.Bifoldable"

78 , "Data.Bifunctor"

82 , "Data.Bifunctor"

79 , "Data.Bifunctor.Clown"

83 , "Data.Bifunctor.Clown"

@@ -86,7 +90,10 @@ supportModules =

86 , "Data.Boolean"

90 , "Data.Boolean"

87 , "Data.BooleanAlgebra"

91 , "Data.BooleanAlgebra"

88 , "Data.Bounded"

92 , "Data.Bounded"

93+ , "Data.Char"

89 , "Data.CommutativeRing"

94 , "Data.CommutativeRing"

95+ , "Data.Either"

96+ , "Data.Either.Nested"

90 , "Data.Eq"

97 , "Data.Eq"

91 , "Data.EuclideanRing"

98 , "Data.EuclideanRing"

92 , "Data.Field"

99 , "Data.Field"

@@ -95,6 +102,7 @@ supportModules =

95 , "Data.Function.Uncurried"

102 , "Data.Function.Uncurried"

96 , "Data.Functor"

103 , "Data.Functor"

97 , "Data.Functor.Invariant"

104 , "Data.Functor.Invariant"

105+ , "Data.Generic"

98 , "Data.Generic.Rep"

106 , "Data.Generic.Rep"

99 , "Data.Generic.Rep.Eq"

107 , "Data.Generic.Rep.Eq"

100 , "Data.Generic.Rep.Monoid"

108 , "Data.Generic.Rep.Monoid"

@@ -102,6 +110,7 @@ supportModules =

102 , "Data.Generic.Rep.Semigroup"

110 , "Data.Generic.Rep.Semigroup"

103 , "Data.Generic.Rep.Show"

111 , "Data.Generic.Rep.Show"

104 , "Data.HeytingAlgebra"

112 , "Data.HeytingAlgebra"

113+ , "Data.Identity"

105 , "Data.Maybe"

114 , "Data.Maybe"

106 , "Data.Maybe.First"

115 , "Data.Maybe.First"

107 , "Data.Maybe.Last"

116 , "Data.Maybe.Last"

@@ -115,6 +124,7 @@ supportModules =

115 , "Data.Monoid.Multiplicative"

124 , "Data.Monoid.Multiplicative"

116 , "Data.NaturalTransformation"

125 , "Data.NaturalTransformation"

117 , "Data.Newtype"

126 , "Data.Newtype"

127+ , "Data.NonEmpty"

118 , "Data.Ord"

128 , "Data.Ord"

119 , "Data.Ord.Unsafe"

129 , "Data.Ord.Unsafe"

120 , "Data.Ordering"

130 , "Data.Ordering"

@@ -122,15 +132,23 @@ supportModules =

122 , "Data.Semigroup"

132 , "Data.Semigroup"

123 , "Data.Semiring"

133 , "Data.Semiring"

124 , "Data.Show"

134 , "Data.Show"

135+ , "Data.String"

136+ , "Data.String.CaseInsensitive"

137+ , "Data.String.Regex"

138+ , "Data.String.Regex.Flags"

139+ , "Data.String.Regex.Unsafe"

140+ , "Data.String.Unsafe"

125 , "Data.Symbol"

141 , "Data.Symbol"

126 , "Data.Traversable"

142 , "Data.Traversable"

143+ , "Data.Tuple"

144+ , "Data.Tuple.Nested"

145+ , "Data.Unfoldable"

127 , "Data.Unit"

146 , "Data.Unit"

128 , "Data.Void"

147 , "Data.Void"

129 , "Partial"

148 , "Partial"

130 , "Partial.Unsafe"

149 , "Partial.Unsafe"

131 , "Prelude"

150 , "Prelude"

132 , "Test.Assert"

151 , "Test.Assert"

133− , "Test.Main"

134 , "Type.Data.Ordering"

152 , "Type.Data.Ordering"

135 , "Type.Data.Symbol"

153 , "Type.Data.Symbol"

136 , "Type.Equality"

154 , "Type.Equality"

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