ebb45ef · rowtype-yoga/purescript-native

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

Merge pull request #845 from purescript/object-syntax

More object syntax

commitebb45ef2d589ffb20f5f564d3cf56e8d44622ded authorPhil Freeman <paf31@cantab.net> dateSat 7 Feb 2015, 14:01 (12 years ago) parent36fed27 5cb6528

6 files changed+94−34

compare with golang

unifiedsplit

examples/passing/ObjectGetter.purs+11 examples/passing/ObjectUpdater.purs+23 src/Language/PureScript/AST/Declarations.hs+10 src/Language/PureScript/Parser/Declarations.hs+7−3 src/Language/PureScript/Pretty/Values.hs+33−27 src/Language/PureScript/Sugar/ObjectWildcards.hs+10−4

examples/passing/ObjectGetter.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+getX = (.x)

5+point = { x: 1, y: 0 }

7+main = do

8+ Debug.Trace.print $ getX point

9+ Debug.Trace.trace $ (." 123 string Prop Name ") { " 123 string Prop Name ": "OK" }

10+ Debug.Trace.trace $ ((.x) >>> (.y)) { x: { y: "Nested" } }

11+ Debug.Trace.trace $ (.value) { value: "Done!" }

examples/passing/ObjectUpdater.pursnew file+23

@@ -0,0 +1,23 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+foreign import data Error :: !

8+foreign import error

9+ """

10+ function error() {

11+ throw new Error("Object update failed");

12+ }

13+ """ :: forall e. Eff (error :: Error | e) Unit

14+

15+getValue :: forall e. Eff (| e) Boolean

16+getValue = return true

17+

18+main = do

19+ let record = { value: false }

20+ record2 <- record { value = _ } <$> getValue

21+ if record2.value

22+ then trace "Done"

23+ else error

src/Language/PureScript/AST/Declarations.hs+10

@@ -325,6 +325,11 @@ data Expr

325325 --

326326 | ObjectConstructor [(String, Maybe Expr)]

327327 -- |

328+ -- An object property getter (e.g. `_.x`). This will be removed during

329+ -- desugaring and expanded into a lambda that reads a property from an object.

330+ --

331+ | ObjectGetter String

332+ -- |

328333 -- An record property accessor expression

329334 --

330335 | Accessor String Expr

@@ -333,6 +338,11 @@ data Expr

333338 --

334339 | ObjectUpdate Expr [(String, Expr)]

335340 -- |

341+ -- Partial record updater. This will be removed during desugaring and

342+ -- expanded into a lambda that returns an object update.

343+ --

344+ | ObjectUpdater Expr [(String, Maybe Expr)]

345+ -- |

336346 -- Function introduction

337347 --

338348 | Abs (Either Ident Binder) Expr

src/Language/PureScript/Parser/Declarations.hs+7−3

@@ -345,6 +345,7 @@ parseValueAtom = P.choice

345345 , P.try parseBooleanLiteral

346346 , parseArrayLiteral

347347 , P.try parseObjectLiteral

348+ , P.try parseObjectGetter

348349 , parseAbs

349350 , P.try parseConstructor

350351 , P.try parseVar

@@ -354,11 +355,11 @@ parseValueAtom = P.choice

354355 , parseLet

355356 , Parens <$> parens parseValue ]

356357

357−parsePropertyUpdate :: TokenParser (String, Expr)

358+parsePropertyUpdate :: TokenParser (String, Maybe Expr)

358359parsePropertyUpdate = do

359360 name <- lname <|> stringLiteral

360361 _ <- C.indented *> equals

361− value <- C.indented *> parseValue

362+ value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

362363 return (name, value)

363364

364365parseAccessor :: Expr -> TokenParser Expr

@@ -383,6 +384,9 @@ parseDoNotationElement = P.choice

383384 , parseDoNotationLet

384385 , P.try (DoNotationValue <$> parseValue) ]

385386

387+parseObjectGetter :: TokenParser Expr

388+parseObjectGetter = ObjectGetter <$> parens (dot *> C.indented *> (lname <|> stringLiteral))

389+

386390-- |

387391-- Parse a value

388392--

@@ -394,7 +398,7 @@ parseValue = withSourceSpan PositionedValue

394398 where

395399 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

396400 postfixTable1 = [ parseAccessor

397− , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

401+ , \v -> P.try $ flip ObjectUpdater <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

398402 postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

399403 , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v

400404 ]

src/Language/PureScript/Pretty/Values.hs+33−27

@@ -21,7 +21,7 @@ module Language.PureScript.Pretty.Values (

2121import Data.Maybe (fromMaybe)

2222import Data.List (intercalate)

2323

24−import Control.Arrow ((<+>), runKleisli)

24+import Control.Arrow ((<+>), runKleisli, second)

2525import Control.PatternArrows

2626import Control.Monad.State

2727import Control.Applicative

@@ -38,33 +38,28 @@ literals = mkPattern' match

3838 match (StringLiteral s) = return $ show s

3939 match (BooleanLiteral True) = return "true"

4040 match (BooleanLiteral False) = return "false"

41− match (ArrayLiteral xs) = fmap concat $ sequence

41+ match (ArrayLiteral xs) = concat <$> sequence

4242 [ return "[ "

4343 , withIndent $ prettyPrintMany prettyPrintValue' xs

4444 , return " ]"

4545 ]

46− match (ObjectLiteral []) = return "{}"

47− match (ObjectLiteral ps) = fmap concat $ sequence

48− [ return "{\n"

49− , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

50− , return "\n"

51− , currentIndent

52− , return "}"

53− ]

54− match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence

55− [ return ((show className) ++ "(\n")

46+ match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps

47+ match (ObjectConstructor ps) = prettyPrintObject' ps

48+ match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"

49+ match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence

50+ [ return (show className ++ "(\n")

5651 , match ps

5752 , return ")"

5853 ]

5954 match (Constructor name) = return $ show name

60− match (Case values binders) = fmap concat $ sequence

55+ match (Case values binders) = concat <$> sequence

6156 [ return "case "

6257 , unwords <$> forM values prettyPrintValue'

6358 , return " of\n"

6459 , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

6560 , currentIndent

6661 ]

67− match (Let ds val) = fmap concat $ sequence

62+ match (Let ds val) = concat <$> sequence

6863 [ return "let\n"

6964 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

7065 , return "\n"

@@ -73,7 +68,7 @@ literals = mkPattern' match

7368 , prettyPrintValue' val

7469 ]

7570 match (Var ident) = return $ show ident

76− match (Do els) = fmap concat $ sequence

71+ match (Do els) = concat <$> sequence

7772 [ return "do "

7873 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

7974 , currentIndent

@@ -86,7 +81,7 @@ literals = mkPattern' match

8681

8782prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

8883prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

89−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence

84+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence

9085 [ return $ show ident ++ " = "

9186 , prettyPrintValue' val

9287 ]

@@ -95,7 +90,7 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

9590

9691prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

9792prettyPrintCaseAlternative (CaseAlternative binders result) =

98− fmap concat $ sequence

93+ concat <$> sequence

9994 [ intercalate ", " <$> forM binders prettyPrintBinder'

10095 , prettyPrintResult result

10196 ]

@@ -104,7 +99,7 @@ prettyPrintCaseAlternative (CaseAlternative binders result) =

10499 prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

105100

106101 prettyPrintGuardedValue (grd, val) =

107− fmap concat $ sequence

102+ concat <$> sequence

108103 [ return "| "

109104 , prettyPrintValue' grd

110105 , return " -> "

@@ -116,18 +111,28 @@ prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe S

116111prettyPrintDoNotationElement (DoNotationValue val) =

117112 prettyPrintValue' val

118113prettyPrintDoNotationElement (DoNotationBind binder val) =

119− fmap concat $ sequence

114+ concat <$> sequence

120115 [ prettyPrintBinder' binder

121116 , return " <- "

122117 , prettyPrintValue' val

123118 ]

124119prettyPrintDoNotationElement (DoNotationLet ds) =

125− fmap concat $ sequence

120+ concat <$> sequence

126121 [ return "let "

127122 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

128123 ]

129124prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

130125

126+prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String

127+prettyPrintObject' [] = return "{}"

128+prettyPrintObject' ps = concat <$> sequence

129+ [ return "{\n"

130+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

131+ , return "\n"

132+ , currentIndent

133+ , return "}"

134+ ]

135+

131136ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

132137ifThenElse = mkPattern match

133138 where

@@ -144,6 +149,7 @@ objectUpdate :: Pattern PrinterState Expr ([String], Expr)

144149objectUpdate = mkPattern match

145150 where

146151 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

152+ match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, o)

147153 match _ = Nothing

148154

149155app :: Pattern PrinterState Expr (String, Expr)

@@ -188,17 +194,17 @@ prettyPrintBinderAtom = mkPattern' match

188194 match (BooleanBinder True) = return "true"

189195 match (BooleanBinder False) = return "false"

190196 match (VarBinder ident) = return $ show ident

191− match (ConstructorBinder ctor args) = fmap concat $ sequence

197+ match (ConstructorBinder ctor args) = concat <$> sequence

192198 [ return $ show ctor ++ " "

193199 , unwords <$> forM args match

194200 ]

195− match (ObjectBinder bs) = fmap concat $ sequence

201+ match (ObjectBinder bs) = concat <$> sequence

196202 [ return "{\n"

197203 , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs

198204 , currentIndent

199205 , return "}"

200206 ]

201− match (ArrayBinder bs) = fmap concat $ sequence

207+ match (ArrayBinder bs) = concat <$> sequence

202208 [ return "["

203209 , unwords <$> mapM prettyPrintBinder' bs

204210 , return "]"

@@ -229,13 +235,13 @@ matchConsBinder = mkPattern match'

229235 match' _ = Nothing

230236

231237prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String

232−prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence

238+prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence

233239 [ return $ prettyPrintObjectKey key ++ ": "

234240 , prettyPrintBinder' binder

235241 ]

236242

237−prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String

238−prettyPrintObjectProperty (key, value) = fmap concat $ sequence

243+prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String

244+prettyPrintObjectProperty (key, value) = concat <$> sequence

239245 [ return $ prettyPrintObjectKey key ++ ": "

240− , prettyPrintValue' value

246+ , maybe (pure "_") prettyPrintValue' value

241247 ]

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

@@ -32,12 +32,18 @@ desugarObjectConstructors (Module mn ds exts) = Module mn (map desugarDecl ds) e

3232 (desugarDecl, _, _) = everywhereOnValues id desugarExpr id

3333

3434 desugarExpr :: Expr -> Expr

35− desugarExpr (ObjectConstructor ps) =

35+ desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

36+ desugarExpr (ObjectUpdater obj ps) = wrapLambda (ObjectUpdate obj) ps

37+ desugarExpr (ObjectGetter prop) =

38+ Abs (Left (Ident "obj")) (Accessor prop (Var (Qualified Nothing (Ident "obj"))))

39+ desugarExpr e = e

40+

41+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> Expr

42+ wrapLambda mkVal ps =

3643 let (props, args) = partition (isJust . snd) ps

3744 in if null args

38− then ObjectLiteral $ second fromJust `map` props

39− else foldr (Abs . Left . Ident . fst) (ObjectLiteral (mkProp `map` ps)) args

40− desugarExpr e = e

45+ then mkVal $ second fromJust `map` props

46+ else foldr (Abs . Left . Ident . fst) (mkVal (mkProp `map` ps)) args

4147

4248 mkProp :: (String, Maybe Expr) -> (String, Expr)

4349 mkProp (name, Just e) = (name, e)