2786ca1 · rowtype-yoga/purescript-native

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

Merge pull request #847 from purescript/supply-object-wildcards

Supply object wildcards

commit2786ca16013cbeea7e123c6ccb8e5b41a9108ac8 authorPhil Freeman <paf31@cantab.net> dateSat 7 Feb 2015, 18:16 (12 years ago) parent80ecc42 51338be

5 files changed+87−29

compare with golang

unifiedsplit

examples/passing/ObjectUpdater.purs+20−11 examples/passing/ObjectWildcards.purs+17 src/Language/PureScript/AST/Traversals.hs+24 src/Language/PureScript/Sugar.hs+2−2 src/Language/PureScript/Sugar/ObjectWildcards.hs+24−16

examples/passing/ObjectUpdater.purs+20−11

@@ -3,21 +3,30 @@ module Main where

33import Control.Monad.Eff

44import Debug.Trace

6−foreign import data Error :: !

7−

8−foreign import error

6+foreign import eqeqeq

97 """

10− function error() {

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

12− }

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

8+ function eqeqeq(x) {

9+ return function (y) {

10+ if (x == y) return x;

11+ throw new Error("Unexpected result: " + x + " /== " + y);

12+ };

13+ };

14+ """ :: forall a. a -> a -> a

15+

16+(===) = eqeqeq

17+infixl 4 ===

1418

1519getValue :: forall e. Eff (| e) Boolean

1620getValue = return true

1721

1822main = do

1923 let record = { value: false }

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

21− if record2.value

22− then trace "Done"

23− else error

24+ record' <- record { value = _ } <$> getValue

25+ print $ record'.value === true

26+

27+ let point = { x: 1, y: 1 }

28+ x = 10

29+ point' = (point { x = _, y = x }) 100

30+

31+ print $ point'.x === 100

32+ print $ point'.y === 10

examples/passing/ObjectWildcards.purs+17

@@ -8,7 +8,24 @@ mkRecord = { foo: _, bar: _, baz: "baz" }

88getValue :: forall e. Eff (| e) Boolean

99getValue = return true

1010

11+foreign import eqeqeq

12+ """

13+ function eqeqeq(x) {

14+ return function (y) {

15+ if (x == y) return x;

16+ throw new Error("Unexpected result: " + x + " /== " + y);

17+ };

18+ };

19+ """ :: forall a. a -> a -> a

20+

21+(===) = eqeqeq

22+infixl 4 ===

23+

1124main = do

1225 obj <- { value: _ } <$> getValue

1326 print obj.value

27+ let x = 1

28+ point <- { x: _, y: x } <$> return 2

29+ print $ point.x === 2

30+ print $ point.y === 1

1431 trace (mkRecord 1 "Done!").bar

src/Language/PureScript/AST/Traversals.hs+24

@@ -15,6 +15,7 @@

1515module Language.PureScript.AST.Traversals where

1616

1717import Data.Monoid (Monoid(..), mconcat)

18+import Data.Maybe (mapMaybe)

1819

1920import Control.Applicative

2021import Control.Monad

@@ -44,12 +45,15 @@ everywhereOnValues f g h = (f', g', h')

4445 g' (UnaryMinus v) = g (UnaryMinus (g' v))

4546 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

4647 g' (Parens v) = g (Parens (g' v))

48+ g' (OperatorSection op (Left v)) = g (OperatorSection op (Left $ g' v))

49+ g' (OperatorSection op (Right v)) = g (OperatorSection op (Right $ g' v))

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

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

4952 g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

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

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

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

56+ g' (ObjectUpdater obj vs) = g (ObjectUpdater (g' obj) (map (second (fmap g')) vs))

5357 g' (Abs name v) = g (Abs name (g' v))

5458 g' (App v1 v2) = g (App (g' v1) (g' v2))

5559 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

@@ -100,11 +104,15 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

100104 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

101105 g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')

102106 g' (Parens v) = Parens <$> (g v >>= g')

107+ g' (OperatorSection op (Left v)) = OperatorSection op . Left <$> (g v >>= g')

108+ g' (OperatorSection op (Right v)) = OperatorSection op . Right <$> (g v >>= g')

103109 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

104110 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

111+ g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs

105112 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

106113 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

107114 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

115+ g' (ObjectUpdater obj vs) = ObjectUpdater <$> (g obj >>= g') <*> mapM (sndM $ maybeM (g' <=< g)) vs

108116 g' (Abs name v) = Abs name <$> (g v >>= g')

109117 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

110118 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

@@ -149,11 +157,15 @@ everywhereOnValuesM f g h = (f', g', h')

149157 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

150158 g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g

151159 g' (Parens v) = (Parens <$> g' v) >>= g

160+ g' (OperatorSection op (Left v)) = (OperatorSection op . Left <$> g' v) >>= g

161+ g' (OperatorSection op (Right v)) = (OperatorSection op . Right <$> g' v) >>= g

152162 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

153163 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

164+ g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g

154165 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

155166 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

156167 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

168+ g' (ObjectUpdater obj vs) = (ObjectUpdater <$> g' obj <*> mapM (sndM $ maybeM g') vs) >>= g

157169 g' (Abs name v) = (Abs name <$> g' v) >>= g

158170 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

159171 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

@@ -201,11 +213,15 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

201213 g' v@(UnaryMinus v1) = g v <> g' v1

202214 g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2

203215 g' v@(Parens v1) = g v <> g' v1

216+ g' v@(OperatorSection _ (Left v1)) = g v <> g' v1

217+ g' v@(OperatorSection _ (Right v1)) = g v <> g' v1

204218 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

205219 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

220+ g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

206221 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

207222 g' v@(Accessor _ v1) = g v <> g' v1

208223 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

224+ g' v@(ObjectUpdater obj vs) = foldl (<>) (g v <> g' obj) (map g' (mapMaybe snd vs))

209225 g' v@(Abs _ v1) = g v <> g' v1

210226 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

211227 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

@@ -264,11 +280,15 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

264280 g' s (UnaryMinus v1) = g'' s v1

265281 g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2

266282 g' s (Parens v1) = g'' s v1

283+ g' s (OperatorSection _ (Left v)) = g'' s v

284+ g' s (OperatorSection _ (Right v)) = g'' s v

267285 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

268286 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

287+ g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

269288 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

270289 g' s (Accessor _ v1) = g'' s v1

271290 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

291+ g' s (ObjectUpdater obj vs) = foldl (<>) (g'' s obj) (map (g'' s) (mapMaybe snd vs))

272292 g' s (Abs _ v1) = g'' s v1

273293 g' s (App v1 v2) = g'' s v1 <> g'' s v2

274294 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

@@ -330,11 +350,15 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

330350 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

331351 g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2

332352 g' s (Parens v) = Parens <$> g'' s v

353+ g' s (OperatorSection op (Left v)) = OperatorSection op . Left <$> g'' s v

354+ g' s (OperatorSection op (Right v)) = OperatorSection op . Right <$> g'' s v

333355 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

334356 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

357+ g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs

335358 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

336359 g' s (Accessor prop v) = Accessor prop <$> g'' s v

337360 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

361+ g' s (ObjectUpdater obj vs) = ObjectUpdater <$> g'' s obj <*> mapM (sndM $ maybeM (g'' s)) vs

338362 g' s (Abs name v) = Abs name <$> g'' s v

339363 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

340364 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

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

@@ -57,8 +57,8 @@ import Language.PureScript.Sugar.TypeDeclarations as S

5757--

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

5959desugar = map removeSignedLiterals

60− >>> map desugarObjectConstructors

61− >>> mapM desugarOperatorSections

60+ >>> mapM desugarObjectConstructors

61+ >=> mapM desugarOperatorSections

6262 >=> mapM desugarDoModule

6363 >=> desugarCasesModule

6464 >=> lift . (desugarTypeDeclarationsModule

src/Language/PureScript/Sugar/ObjectWildcards.hs+24−16

@@ -16,35 +16,43 @@ module Language.PureScript.Sugar.ObjectWildcards (

1616 desugarObjectConstructors

1717) where

1818

19+import Control.Applicative

1920import Control.Arrow (second)

2021

2122import Data.List (partition)

22−import Data.Maybe (isJust, fromJust)

23+import Data.Maybe (isJust, fromJust, catMaybes)

2324

2425import Language.PureScript.AST

26+import Language.PureScript.Errors

2527import Language.PureScript.Names

28+import Language.PureScript.Supply

2629

27−desugarObjectConstructors :: Module -> Module

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

30+desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module

31+desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts

2932 where

3033

31− desugarDecl :: Declaration -> Declaration

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

34+ desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

35+ (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

3336

34− desugarExpr :: Expr -> Expr

37+ desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr

3538 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

3639 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+ desugarExpr (ObjectGetter prop) = do

41+ arg <- Ident <$> freshName

42+ return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

43+ desugarExpr e = return e

4044

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

45+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr

4246 wrapLambda mkVal ps =

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

4448 in if null args

45− then mkVal $ second fromJust `map` props

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

47−

48− mkProp :: (String, Maybe Expr) -> (String, Expr)

49− mkProp (name, Just e) = (name, e)

50− mkProp (name, Nothing) = (name, Var (Qualified Nothing (Ident name)))

49+ then return . mkVal $ second fromJust `map` props

50+ else do

51+ (args', ps') <- unzip <$> mapM mkProp ps

52+ return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

53+

54+ mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))

55+ mkProp (name, Just e) = return (Nothing, (name, e))

56+ mkProp (name, Nothing) = do

57+ arg <- Ident <$> freshName

58+ return (Just arg, (name, Var (Qualified Nothing arg)))