51d4cb5 · rowtype-yoga/purescript-native

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

Merge pull request #844 from purescript/extended-object-literals

Extended object literals

commit51d4cb59bb52353bb89d64113314e87b3371bb3b authorPhil Freeman <paf31@cantab.net> dateFri 6 Feb 2015, 13:15 (12 years ago) parent01b1c54 180d491

9 files changed+95−15

compare with golang

unifiedsplit

examples/passing/ObjectWildcards.purs+14 purescript.cabal+1 src/Language/PureScript/AST/Declarations.hs+5 src/Language/PureScript/AST/Traversals.hs+2−1 src/Language/PureScript/Parser/Declarations.hs+6−4 src/Language/PureScript/Parser/Lexer.hs+7 src/Language/PureScript/Parser/Types.hs+1−1 src/Language/PureScript/Sugar.hs+15−9 src/Language/PureScript/Sugar/ObjectWildcards.hs+44

examples/passing/ObjectWildcards.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+mkRecord = { foo: _, bar: _, baz: "baz" }

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

9+getValue = return true

10+

11+main = do

12+ obj <- { value: _ } <$> getValue

13+ print obj.value

14+ trace (mkRecord 1 "Done!").bar

purescript.cabal+1

@@ -93,6 +93,7 @@ library

9393 Language.PureScript.Sugar.CaseDeclarations

9494 Language.PureScript.Sugar.DoNotation

9595 Language.PureScript.Sugar.Names

96+ Language.PureScript.Sugar.ObjectWildcards

9697 Language.PureScript.Sugar.Operators

9798 Language.PureScript.Sugar.TypeClasses

9899 Language.PureScript.Sugar.TypeDeclarations

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

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

320320 --

321321 | ObjectLiteral [(String, Expr)]

322322 -- |

323+ -- An object constructor (object literal with underscores). This will be removed during

324+ -- desugaring and expanded into a lambda that returns an object literal.

325+ --

326+ | ObjectConstructor [(String, Maybe Expr)]

327+ -- |

323328 -- An record property accessor expression

324329 --

325330 | Accessor String Expr

src/Language/PureScript/AST/Traversals.hs+2−1

@@ -18,7 +18,7 @@ import Data.Monoid (Monoid(..), mconcat)

1818

1919import Control.Applicative

2020import Control.Monad

21−import Control.Arrow ((***), (+++))

21+import Control.Arrow ((***), (+++), second)

2222

2323import Language.PureScript.AST.Binders

2424import Language.PureScript.AST.Declarations

@@ -46,6 +46,7 @@ everywhereOnValues f g h = (f', g', h')

4646 g' (Parens v) = g (Parens (g' v))

4747 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

4848 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

49+ g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

4950 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

5051 g' (Accessor prop v) = g (Accessor prop (g' v))

5152 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

src/Language/PureScript/Parser/Declarations.hs+6−4

@@ -285,11 +285,13 @@ parseArrayLiteral :: TokenParser Expr

285285parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

286286

287287parseObjectLiteral :: TokenParser Expr

288−parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

288+parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

289289

290−parseIdentifierAndValue :: TokenParser (String, Expr)

290+parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

291291parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)

292− <*> (C.indented *> parseValue)

292+ <*> (C.indented *> val)

293+ where

294+ val = (Just <$> parseValue) <|> (underscore *> pure Nothing)

293295

294296parseAbs :: TokenParser Expr

295297parseAbs = do

@@ -437,7 +439,7 @@ parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)

437439 <*> (C.indented *> parseBinder)

438440

439441parseNullBinder :: TokenParser Binder

440−parseNullBinder = reserved "_" *> return NullBinder

442+parseNullBinder = underscore *> return NullBinder

441443

442444parseIdentifierAndBinder :: TokenParser (String, Binder)

443445parseIdentifierAndBinder = do

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

@@ -47,6 +47,7 @@ module Language.PureScript.Parser.Lexer

4747 , comma

4848 , semi

4949 , at

50+ , underscore

5051 , semiSep

5152 , semiSep1

5253 , commaSep

@@ -105,6 +106,7 @@ data Token

105106 | Comma

106107 | Semi

107108 | At

109+ | Underscore

108110 | LName String

109111 | UName String

110112 | Qualifier String

@@ -133,6 +135,7 @@ prettyPrintToken Dot = "."

133135prettyPrintToken Comma = ","

134136prettyPrintToken Semi = ";"

135137prettyPrintToken At = "@"

138+prettyPrintToken Underscore = "_"

136139prettyPrintToken (Indent n) = "indentation at level " ++ show n

137140prettyPrintToken (LName s) = show s

138141prettyPrintToken (UName s) = show s

@@ -196,6 +199,7 @@ parseToken = P.choice

196199 , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot

197200 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

198201 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

202+ , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

199203 , LName <$> parseLName

200204 , do uName <- parseUName

201205 (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)

@@ -349,6 +353,9 @@ semi = match Semi

349353at :: TokenParser ()

350354at = match At

351355

356+underscore :: TokenParser ()

357+underscore = match Underscore

358+

352359-- |

353360-- Parse zero or more values separated by semicolons

354361--

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

@@ -45,7 +45,7 @@ parseObject :: TokenParser Type

4545parseObject = braces $ TypeApp tyObject <$> parseRow

4646

4747parseTypeWildcard :: TokenParser Type

48−parseTypeWildcard = reserved "_" >> return TypeWildcard

48+parseTypeWildcard = underscore >> return TypeWildcard

4949

5050parseTypeVariable :: TokenParser Type

5151parseTypeVariable = do

src/Language/PureScript/Sugar.hs+15−9

@@ -23,20 +23,21 @@ import Language.PureScript.AST

2323import Language.PureScript.Errors

2424import Language.PureScript.Supply

2525

26−import Language.PureScript.Sugar.Operators as S

27−import Language.PureScript.Sugar.DoNotation as S

28−import Language.PureScript.Sugar.CaseDeclarations as S

29−import Language.PureScript.Sugar.TypeDeclarations as S

3026import Language.PureScript.Sugar.BindingGroups as S

31−import Language.PureScript.Sugar.TypeClasses as S

27+import Language.PureScript.Sugar.CaseDeclarations as S

28+import Language.PureScript.Sugar.DoNotation as S

3229import Language.PureScript.Sugar.Names as S

30+import Language.PureScript.Sugar.ObjectWildcards as S

31+import Language.PureScript.Sugar.Operators as S

32+import Language.PureScript.Sugar.TypeClasses as S

33+import Language.PureScript.Sugar.TypeDeclarations as S

3334

3435-- |

3536-- The desugaring pipeline proceeds as follows:

3637--

37−-- * Introduce type synonyms for type class dictionaries

38+-- * Remove signed literals in favour of `negate` applications

3839--

39−-- * Rebracket user-defined binary operators

40+-- * Desguar object literals with wildcards into lambdas

4041--

4142-- * Desugar do-notation using the @Prelude.Monad@ type class

4243--

@@ -44,12 +45,17 @@ import Language.PureScript.Sugar.Names as S

4445--

4546-- * Desugar type declarations into value declarations with explicit type annotations

4647--

47−-- * Group mutually recursive value and data declarations into binding groups.

48−--

4948-- * Qualify any unqualified names and types

5049--

50+-- * Rebracket user-defined binary operators

51+--

52+-- * Introduce type synonyms for type class dictionaries

53+--

54+-- * Group mutually recursive value and data declarations into binding groups.

55+--

5156desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

5257desugar = map removeSignedLiterals

58+ >>> map desugarObjectConstructors

5359 >>> mapM desugarDoModule

5460 >=> desugarCasesModule

5561 >=> lift . (desugarTypeDeclarationsModule

src/Language/PureScript/Sugar/ObjectWildcards.hsnew file+44

@@ -0,0 +1,44 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.ObjectWildcards

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Sugar.ObjectWildcards (

16+ desugarObjectConstructors

17+) where

18+

19+import Control.Arrow (second)

20+

21+import Data.List (partition)

22+import Data.Maybe (isJust, fromJust)

23+

24+import Language.PureScript.AST

25+import Language.PureScript.Names

26+

27+desugarObjectConstructors :: Module -> Module

28+desugarObjectConstructors (Module mn ds exts) = Module mn (map desugarDecl ds) exts

29+ where

30+

31+ desugarDecl :: Declaration -> Declaration

32+ (desugarDecl, _, _) = everywhereOnValues id desugarExpr id

33+

34+ desugarExpr :: Expr -> Expr

35+ desugarExpr (ObjectConstructor ps) =

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

37+ 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

41+

42+ mkProp :: (String, Maybe Expr) -> (String, Expr)

43+ mkProp (name, Just e) = (name, e)

44+ mkProp (name, Nothing) = (name, Var (Qualified Nothing (Ident name)))