51d4cb5 · rowtype-yoga/purescript-native

examples/passing/ObjectWildcards.pursnew file+14

compare with golang

unifiedsplit

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

1+module Main where

2+

3+import Control.Monad.Eff

4+import Debug.Trace

5+

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

7+

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

93 Language.PureScript.Sugar.CaseDeclarations

94 Language.PureScript.Sugar.DoNotation

95 Language.PureScript.Sugar.Names

96+ Language.PureScript.Sugar.ObjectWildcards

96 Language.PureScript.Sugar.Operators

97 Language.PureScript.Sugar.Operators

97 Language.PureScript.Sugar.TypeClasses

98 Language.PureScript.Sugar.TypeClasses

98 Language.PureScript.Sugar.TypeDeclarations

99 Language.PureScript.Sugar.TypeDeclarations

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

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

320 --

321 | ObjectLiteral [(String, Expr)]

322 -- |

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

323 -- An record property accessor expression

328 -- An record property accessor expression

324 --

329 --

325 | Accessor String Expr

330 | Accessor String Expr

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

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

18

19import Control.Applicative

20import Control.Monad

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

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

22

23import Language.PureScript.AST.Binders

24import Language.PureScript.AST.Declarations

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

46 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

52 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

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

286

287parseObjectLiteral :: TokenParser Expr

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

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

289

290−parseIdentifierAndValue :: TokenParser (String, Expr)

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

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

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

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

293+ where

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

293

295

294parseAbs :: TokenParser Expr

296parseAbs :: TokenParser Expr

295parseAbs = do

297parseAbs = do

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

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

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

438

440

439parseNullBinder :: TokenParser Binder

441parseNullBinder :: TokenParser Binder

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

442+parseNullBinder = underscore *> return NullBinder

441

443

442parseIdentifierAndBinder :: TokenParser (String, Binder)

444parseIdentifierAndBinder :: TokenParser (String, Binder)

443parseIdentifierAndBinder = do

445parseIdentifierAndBinder = do

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

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

47 , comma

48 , semi

49 , at

50+ , underscore

50 , semiSep

51 , semiSep

51 , semiSep1

52 , semiSep1

52 , commaSep

53 , commaSep

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

105 | Comma

106 | Comma

106 | Semi

107 | Semi

107 | At

108 | At

109+ | Underscore

108 | LName String

110 | LName String

109 | UName String

111 | UName String

110 | Qualifier String

112 | Qualifier String

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

133prettyPrintToken Comma = ","

135prettyPrintToken Comma = ","

134prettyPrintToken Semi = ";"

136prettyPrintToken Semi = ";"

135prettyPrintToken At = "@"

137prettyPrintToken At = "@"

138+prettyPrintToken Underscore = "_"

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

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

137prettyPrintToken (LName s) = show s

140prettyPrintToken (LName s) = show s

138prettyPrintToken (UName s) = show s

141prettyPrintToken (UName s) = show s

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

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

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

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

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

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

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

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

199 , LName <$> parseLName

203 , LName <$> parseLName

200 , do uName <- parseUName

204 , do uName <- parseUName

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

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

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

349at :: TokenParser ()

353at :: TokenParser ()

350at = match At

354at = match At

351

355

356+underscore :: TokenParser ()

357+underscore = match Underscore

358+

352-- |

359-- |

353-- Parse zero or more values separated by semicolons

360-- Parse zero or more values separated by semicolons

354--

361--

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

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

45parseObject = braces $ TypeApp tyObject <$> parseRow

46

47parseTypeWildcard :: TokenParser Type

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

48+parseTypeWildcard = underscore >> return TypeWildcard

49

50parseTypeVariable :: TokenParser Type

51parseTypeVariable = do

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

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

23import Language.PureScript.Errors

24import Language.PureScript.Supply

25

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

30import Language.PureScript.Sugar.BindingGroups as S

26import 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

32import Language.PureScript.Sugar.Names as S

29import 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

33

34

34-- |

35-- |

35-- The desugaring pipeline proceeds as follows:

36-- The desugaring pipeline proceeds as follows:

36--

37--

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

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

38--

39--

39−-- * Rebracket user-defined binary operators

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

40--

41--

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

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

42--

43--

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

44--

45--

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

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

46--

47--

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

48−--

49-- * Qualify any unqualified names and types

48-- * Qualify any unqualified names and types

50--

49--

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

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

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

52desugar = map removeSignedLiterals

57desugar = map removeSignedLiterals

58+ >>> map desugarObjectConstructors

53 >>> mapM desugarDoModule

59 >>> mapM desugarDoModule

54 >=> desugarCasesModule

60 >=> desugarCasesModule

55 >=> lift . (desugarTypeDeclarationsModule

61 >=> 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)))