2786ca1 · rowtype-yoga/purescript-native

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

on golang help sign in

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

2786ca1Phil Freeman12 years ago

examples/passing/ObjectUpdater.purs+20−11

compare with golang

unifiedsplit

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

3import Control.Monad.Eff

4import Debug.Trace

6−foreign import data Error :: !

6+foreign import eqeqeq

7−

8−foreign import error

9 """

7 """

10− function error() {

8+ function eqeqeq(x) {

9+ return function (y) {

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

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

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

12+ };

12− }

13+ };

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

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

15+

16+(===) = eqeqeq

17+infixl 4 ===

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

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

16getValue = return true

20getValue = return true

18main = do

22main = do

19 let record = { value: false }

23 let record = { value: false }

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

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

21− if record2.value

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

22− then trace "Done"

26+

23− else error

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

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

9getValue = return true

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+

11main = do

24main = do

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

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

13 print obj.value

26 print obj.value

27+ let x = 1

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

29+ print $ point.x === 2

30+ print $ point.y === 1

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

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

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

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

15module Language.PureScript.AST.Traversals where

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

18+import Data.Maybe (mapMaybe)

19import Control.Applicative

20import Control.Applicative

20import Control.Monad

21import Control.Monad

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

44 g' (UnaryMinus v) = g (UnaryMinus (g' v))

45 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

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

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

47 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))

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

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

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

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

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

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

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

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

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

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

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

55 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))

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

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

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

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

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

59 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)

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

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

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

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

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

106 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')

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

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

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

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

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

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

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

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

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

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

114 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

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

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

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

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

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

118 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')

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

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

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

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

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

159 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

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

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

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

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

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

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

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

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

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

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

167 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

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

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

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

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

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

171 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')

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

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

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

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

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

215 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

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

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

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

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

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

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

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

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

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

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

223 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))

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

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

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

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

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

227 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'

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

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

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

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

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

282 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

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

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

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

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

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

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

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

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

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

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

290 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))

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

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

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

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

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

294 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

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

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

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

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

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

352 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

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

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

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

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

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

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

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

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

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

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

360 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

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

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

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

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

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

364 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

57--

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

59desugar = map removeSignedLiterals

60− >>> map desugarObjectConstructors

60+ >>> mapM desugarObjectConstructors

61− >>> mapM desugarOperatorSections

61+ >=> mapM desugarOperatorSections

62 >=> mapM desugarDoModule

63 >=> desugarCasesModule

64 >=> lift . (desugarTypeDeclarationsModule

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

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

16 desugarObjectConstructors

17) where

19+import Control.Applicative

19import Control.Arrow (second)

20import Control.Arrow (second)

21import Data.List (partition)

22import Data.List (partition)

22−import Data.Maybe (isJust, fromJust)

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

24import Language.PureScript.AST

25import Language.PureScript.AST

26+import Language.PureScript.Errors

25import Language.PureScript.Names

27import Language.PureScript.Names

28+import Language.PureScript.Supply

27−desugarObjectConstructors :: Module -> Module

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

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

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

29 where

32 where

31− desugarDecl :: Declaration -> Declaration

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

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

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

34− desugarExpr :: Expr -> Expr

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

35 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

38 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

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

39 desugarExpr (ObjectUpdater obj ps) = wrapLambda (ObjectUpdate obj) ps

37− desugarExpr (ObjectGetter prop) =

40+ desugarExpr (ObjectGetter prop) = do

41+ arg <- Ident <$> freshName

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

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

39− desugarExpr e = e

43+ desugarExpr e = return e

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

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

42 wrapLambda mkVal ps =

46 wrapLambda mkVal ps =

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

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

44 in if null args

48 in if null args

45− then mkVal $ second fromJust `map` props

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

50+ else do

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

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

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

47−

53+

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

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

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

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

56+ mkProp (name, Nothing) = do

57+ arg <- Ident <$> freshName

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

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