32faa76 · rowtype-yoga/purescript-native

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

on golang help sign in

Change nested record update syntax and fix bug with depth > 2 (#2580)

32faa76Liam Goodacre10 years ago

examples/passing/NestedRecordUpdate.purs+6−5

compare with golang

unifiedsplit

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

3import Prelude

4import Control.Monad.Eff.Console

6−type T = { foo :: Int, bar :: { baz :: Int, qux :: Int } }

6+type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } }

8init :: T

9−init = { foo: 1, bar: { baz: 2, qux: 3 } }

9+init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } }

11updated :: T

12−updated = init { foo = 10, bar.baz = 20, bar.qux = 30 }

12+updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } }

14expected :: T

15−expected = { foo: 10, bar: { baz: 20, qux: 30 } }

15+expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } }

17check l r =

18 l.foo == r.foo &&

19 l.bar.baz == r.bar.baz &&

20− l.bar.qux == r.bar.qux

20+ l.bar.qux.lhs == r.bar.qux.lhs &&

21+ l.bar.qux.rhs == r.bar.qux.rhs

22main = do

23main = do

23 when (check updated expected) $ log "Done"

24 when (check updated expected) $ log "Done"

examples/passing/NestedRecordUpdateWildcards.purs+1−1

@@ -3,7 +3,7 @@ module Main where

3import Prelude

4import Control.Monad.Eff.Console

6−update = _ { foo = _, bar.baz = _, bar.qux = _ }

6+update = _ { foo = _, bar { baz = _, qux = _ } }

8init = { foo: 1, bar: { baz: 2, qux: 3 } }

src/Language/PureScript/AST/Declarations.hs+37−3

@@ -1,4 +1,6 @@

1{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveTraversable #-}

3-- |

5-- |

4-- Data types for modules and declarations

6-- Data types for modules and declarations

@@ -12,7 +14,6 @@ import Control.Monad.Identity

12import Data.Aeson.TH

14import Data.Aeson.TH

13import qualified Data.Map as M

15import qualified Data.Map as M

14import Data.Text (Text)

16import Data.Text (Text)

15−import Data.List.NonEmpty (NonEmpty(..))

17import Language.PureScript.AST.Binders

18import Language.PureScript.AST.Binders

18import Language.PureScript.AST.Literals

19import Language.PureScript.AST.Literals

@@ -587,10 +588,10 @@ data Expr

587 --

588 --

588 | ObjectUpdate Expr [(PSString, Expr)]

589 | ObjectUpdate Expr [(PSString, Expr)]

589 -- |

590 -- |

590− -- Object updates with nested support: `x { foo.bar = e }`

591+ -- Object updates with nested support: `x { foo { bar = e } }`

591 -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s

592 -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s

592 --

593 --

593− | ObjectUpdateNested Expr [(NonEmpty PSString, Expr)]

594+ | ObjectUpdateNested Expr (PathTree Expr)

594 -- |

595 -- |

595 -- Function introduction

596 -- Function introduction

596 --

597 --

@@ -706,5 +707,38 @@ data DoNotationElement

706 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

707 | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

707 deriving (Show)

708 deriving (Show)

708

709

710+

711+-- For a record update such as:

712+--

713+-- x { foo = 0

714+-- , bar { baz = 1

715+-- , qux = 2 } }

716+--

717+-- We represent the updates as the `PathTree`:

718+--

719+-- [ ("foo", Leaf 3)

720+-- , ("bar", Branch [ ("baz", Leaf 1)

721+-- , ("qux", Leaf 2) ]) ]

722+--

723+-- Which we then convert to an expression representing the following:

724+--

725+-- let x' = x

726+-- in x' { foo = 0

727+-- , bar = x'.bar { baz = 1

728+-- , qux = 2 } }

729+--

730+-- The `let` here is required to prevent re-evaluating the object expression `x`.

731+-- However we don't generate this when using an anonymous argument for the object.

732+--

733+

734+newtype PathTree t = PathTree (AssocList PSString (PathNode t))

735+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

736+

737+data PathNode t = Leaf t | Branch (PathTree t)

738+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

739+

740+newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }

741+ deriving (Show, Eq, Ord, Foldable, Functor, Traversable)

742+

709$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

743$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

710$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

744$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

src/Language/PureScript/AST/Traversals.hs+7−7

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

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

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

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

51− g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (map (fmap g') vs))

51+ g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))

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

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

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

@@ -116,7 +116,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

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

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

118 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119− g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119+ g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs

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

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

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

@@ -184,7 +184,7 @@ everywhereOnValuesM f g h = (f', g', h')

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

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

186 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

187− g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse (sndM g') vs) >>= g

187+ g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g

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

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

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

@@ -257,7 +257,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

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

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

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

260− g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

260+ g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)

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

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

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

@@ -335,7 +335,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

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

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

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

338− g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

338+ g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)

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

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

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

@@ -415,7 +415,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

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

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

417 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

418− g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (sndM (g'' s)) vs

418+ g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs

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

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

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

@@ -506,7 +506,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

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

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

508 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

509− g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

509+ g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs

510 g' s (Abs (Left name) v1) =

511 let s' = S.insert name s

512 in g'' s' v1

src/Language/PureScript/Parser/Declarations.hs+22−12

@@ -17,13 +17,12 @@ import Prelude hiding (lex)

18import Control.Applicative

19import Control.Arrow ((+++))

20+import Control.Monad (foldM)

20import Control.Monad.Error.Class (MonadError(..))

21import Control.Monad.Error.Class (MonadError(..))

21import Control.Parallel.Strategies (withStrategy, parList, rseq)

22import Control.Parallel.Strategies (withStrategy, parList, rseq)

22−import Data.Bifunctor (first)

23import Data.Functor (($>))

24−import Data.List.NonEmpty (NonEmpty(..))

25−import qualified Data.List.NonEmpty as N

26import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

25+import qualified Data.Set as S

27import Data.Text (Text)

26import Data.Text (Text)

28import Language.PureScript.AST

27import Language.PureScript.AST

29import Language.PureScript.Environment

28import Language.PureScript.Environment

@@ -399,13 +398,17 @@ parseInfixExpr

399parseHole :: TokenParser Expr

398parseHole :: TokenParser Expr

400parseHole = Hole <$> holeLit

399parseHole = Hole <$> holeLit

401

400

402−parsePropertyUpdate :: TokenParser (NonEmpty PSString, Expr)

401+parsePropertyUpdate :: TokenParser (PSString, PathNode Expr)

403parsePropertyUpdate = do

402parsePropertyUpdate = do

404 name <- parseLabel

403 name <- parseLabel

405− rest <- P.many (indented *> dot *> indented *> parseLabel)

404+ updates <- parseShallowUpdate <|> parseNestedUpdate

406− _ <- indented *> equals

407− value <- indented *> parseValue

408− return (name :| rest, value)

405+ return (name, updates)

406+ where

407+ parseShallowUpdate :: TokenParser (PathNode Expr)

408+ parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue)

409+

410+ parseNestedUpdate :: TokenParser (PathNode Expr)

411+ parseNestedUpdate = Branch <$> parseUpdaterBodyFields

409

412

410parseAccessor :: Expr -> TokenParser Expr

413parseAccessor :: Expr -> TokenParser Expr

411parseAccessor (Constructor _) = P.unexpected "constructor"

414parseAccessor (Constructor _) = P.unexpected "constructor"

@@ -455,11 +458,18 @@ parseValue = withSourceSpan PositionedValue

455 ]

458 ]

456 ]

459 ]

457

460

458−parseUpdaterBody :: Expr -> TokenParser Expr

461+parseUpdaterBodyFields :: TokenParser (PathTree Expr)

462+parseUpdaterBodyFields = do

459−parseUpdaterBody v = objectUpdate <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate)))

463+ updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate))

464+ (_, tree) <- foldM insertUpdate (S.empty, []) updates

465+ return (PathTree (AssocList (reverse tree)))

460 where

466 where

461− objectUpdate xs | all (null . N.tail . fst) xs = ObjectUpdate v (map (first N.head) xs)

467+ insertUpdate (seen, xs) (key, node)

468+ | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key)

469+ | otherwise = return (S.insert key seen, (key, node) : xs)

470+

471+parseUpdaterBody :: Expr -> TokenParser Expr

462− | otherwise = ObjectUpdateNested v xs

472+parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields

463

473

464parseAnonymousArgument :: TokenParser Expr

474parseAnonymousArgument :: TokenParser Expr

465parseAnonymousArgument = underscore *> pure AnonymousArgument

475parseAnonymousArgument = underscore *> pure AnonymousArgument

src/Language/PureScript/Pretty/Values.hs+8−10

@@ -12,7 +12,6 @@ import Prelude.Compat

12import Control.Arrow (second)

14import qualified Data.Monoid as Monoid ((<>))

15−import Data.List.NonEmpty (NonEmpty(..))

17import qualified Data.Text as T

16import qualified Data.Text as T

18import Data.Text (Text)

17import Data.Text (Text)

@@ -48,11 +47,8 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

48 prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box

47 prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box

49 prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

48 prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

51−prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, Expr)] -> Box

50+prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box

52−prettyPrintObjectUpdate printKey d o ps =

53− prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' printEntry ps

54− where

55− printEntry (key, val) = printKey key <> text " = " <> prettyPrintValue (d - 1) val

51+prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val

57-- | Pretty-print an expression

53-- | Pretty-print an expression

58prettyPrintValue :: Int -> Expr -> Box

54prettyPrintValue :: Int -> Expr -> Box

@@ -63,10 +59,12 @@ prettyPrintValue d (IfThenElse cond th el) =

63 , text "else " <> prettyPrintValueAtom (d - 1) el

59 , text "else " <> prettyPrintValueAtom (d - 1) el

64 ])

60 ])

65prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)

61prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)

66−prettyPrintValue d (ObjectUpdate o ps) = prettyPrintObjectUpdate (textT . prettyPrintObjectKey) d o ps

62+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps

67−prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintObjectUpdate printPath d o ps where

63+prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps

68− printPath (hd :| tl) = foldl combine (textT (prettyPrintObjectKey hd)) tl

64+ where

69− combine acc key = acc <> textT ("." Monoid.<> prettyPrintObjectKey key)

65+ prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree)

66+ printNode (key, Leaf val) = prettyPrintUpdateEntry d key val

67+ printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val

70prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

68prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

71prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

69prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

72prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

70prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

src/Language/PureScript/Sugar/ObjectWildcards.hs+26−88

@@ -5,46 +5,18 @@ module Language.PureScript.Sugar.ObjectWildcards

6import Prelude.Compat

8−import Control.Monad (forM, foldM)

8+import Control.Monad (forM)

9import Control.Monad.Error.Class (MonadError(..))

10import Control.Monad.Supply.Class

11−import Data.List (partition)

11+import Data.Foldable (toList)

12−import Data.List.NonEmpty (NonEmpty(..))

12+import Data.List (foldl')

13−import Data.Map (Map)

14−import qualified Data.Map as M

15import Data.Maybe (catMaybes)

13import Data.Maybe (catMaybes)

16import Language.PureScript.AST

14import Language.PureScript.AST

17import Language.PureScript.Environment (NameKind(..))

15import Language.PureScript.Environment (NameKind(..))

18import Language.PureScript.Errors

16import Language.PureScript.Errors

19−import Language.PureScript.Label (Label(..))

20import Language.PureScript.Names

17import Language.PureScript.Names

21import Language.PureScript.PSString (PSString)

18import Language.PureScript.PSString (PSString)

23−-- `PathNode` and `PathTree` are used as an intermediate form when desugaring a nested object update.

24−-- For an update such as:

25−--

26−-- x { foo = 0

27−-- , bar.baz = 1

28−-- , bar.qux = 2 }

29−--

30−-- We represent the updates as the `PathTree`:

31−--

32−-- M.fromList [ ("foo", Leaf 3)

33−-- , ("bar", Branch (M.fromList [ ("baz", Leaf 1)

34−-- , ("qux", Leaf 2) ]) ])

35−--

36−-- Which we then convert to an expression representing the following:

37−--

38−-- let x' = x

39−-- in x' { foo = 0

40−-- , bar = x'.bar { baz = 1

41−-- , qux = 2 } }

42−--

43−-- The `let` here is required to prevent re-evaluating the object expression `x`.

44−-- However we don't generate this when using an anonymous argument for the object.

45−--

46−type PathTree = Map PSString PathNode

47−data PathNode = Leaf Expr | Branch PathTree

49desugarObjectConstructors

21desugarObjectConstructors

50 :: forall m

22 :: forall m

@@ -70,11 +42,7 @@ desugarDecl other = fn other

70 , BinaryNoParens op u val <- b'

42 , BinaryNoParens op u val <- b'

71 , isAnonymousArgument u = do arg <- freshIdent'

43 , isAnonymousArgument u = do arg <- freshIdent'

72 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

44 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

73− desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps

74− desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

75− obj <- freshIdent'

76− Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps

77− desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

78 desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

46 desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps

79 desugarExpr (Accessor prop u)

47 desugarExpr (Accessor prop u)

80 | Just props <- peelAnonAccessorChain u = do

48 | Just props <- peelAnonAccessorChain u = do

@@ -92,67 +60,42 @@ desugarDecl other = fn other

92 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

60 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])

93 desugarExpr e = return e

61 desugarExpr e = return e

95− transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr

63+ transformNestedUpdate :: Expr -> PathTree Expr -> m Expr

96 transformNestedUpdate obj ps = do

64 transformNestedUpdate obj ps = do

97 -- If we don't have an anonymous argument then we need to generate a let wrapper

65 -- If we don't have an anonymous argument then we need to generate a let wrapper

98 -- so that the object expression isn't re-evaluated for each nested update.

66 -- so that the object expression isn't re-evaluated for each nested update.

99 val <- freshIdent'

67 val <- freshIdent'

68+ let valExpr = argToExpr val

100 if isAnonymousArgument obj

69 if isAnonymousArgument obj

101− then Abs (Left val) <$> wrapLambdaM (build val) ps

70+ then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps

102− else wrapLambdaM (fmap (buildLet val) . build val) ps

71+ else wrapLambda (buildLet val . buildUpdates valExpr) ps

103 where

72 where

104− build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs

105 buildLet val = Let [ValueDeclaration val Public [] (Right obj)]

73 buildLet val = Let [ValueDeclaration val Public [] (Right obj)]

106

107− -- Here we build up the intermediate `PathTree` data structure and check that

108− -- the paths are valid relative to each other - for example, the update

109− -- `{ foo.bar = 2, foo = {bar: 3} }` is invalid because there are conflicting

110− -- paths.

111− buildTree

112− :: PathTree

113− -> (NonEmpty PSString, Expr)

114− -> m PathTree

115− buildTree pathTree (path, e) = go pathTree path where

116− go tree (key :| [])

117− -- path already exists

118− | key `M.member` tree = throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps))

119− -- create new path

120− | otherwise = return (M.insert key (Leaf e) tree)

121− go tree (key :| (x : xs)) = do

122− branch <- case M.lookup key tree of

123− -- nothing at this path yet

124− Nothing -> return M.empty

125− -- already a map at this path

126− Just (Branch branch) -> return branch

127− -- sub-path already exists

128− Just (Leaf _) -> throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps))

129− M.insert key . Branch <$> go branch (x :| xs) <*> pure tree

130−

131− -- Now we have a valid collection of updates in the form of a `PathTree`

132− -- we can recursively build up the nested `ObjectUpdate` expressions.

75+ -- recursively build up the nested `ObjectUpdate` expressions

133− buildUpdates :: Expr -> PathTree -> Expr

76+ buildUpdates :: Expr -> PathTree Expr -> Expr

134− buildUpdates val vs = ObjectUpdate val (goLayer [] <$> M.toList vs) where

77+ buildUpdates val (PathTree vs) = ObjectUpdate val (goLayer [] <$> runAssocList vs) where

135− goLayer :: [PSString] -> (PSString, PathNode) -> (PSString, Expr)

78+ goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)

136 goLayer _ (key, Leaf expr) = (key, expr)

79 goLayer _ (key, Leaf expr) = (key, expr)

137− goLayer path (key, Branch branch) =

80+ goLayer path (key, Branch (PathTree branch)) =

138 let path' = path ++ [key]

81 let path' = path ++ [key]

139− updates = goLayer path' <$> M.toList branch

82+ updates = goLayer path' <$> runAssocList branch

140− accessor = foldr Accessor val path'

83+ accessor = foldl' (flip Accessor) val path'

141 objectUpdate = ObjectUpdate accessor updates

84 objectUpdate = ObjectUpdate accessor updates

142 in (key, objectUpdate)

85 in (key, objectUpdate)

143

144− wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr

87+ wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr

145− wrapLambdaM mkVal ps =

88+ wrapLambda mkVal ps = do

146− let (args, props) = partition (isAnonymousArgument . snd) ps

89+ args <- traverse processExpr ps

147− in if null args

148− then mkVal props

149− else do

150− (args', ps') <- unzip <$> mapM mkProp ps

151− val <- mkVal ps'

152− return $ foldr (Abs . Left) val (catMaybes args')

90+ return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args))

91+ where

92+ processExpr :: Expr -> m (Maybe Ident, Expr)

93+ processExpr e = do

94+ arg <- freshIfAnon e

95+ return (arg, maybe e argToExpr arg)

153

154− wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr

97+ wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr

155− wrapLambda mkVal = wrapLambdaM (return . mkVal)

98+ wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList

156

157 stripPositionInfo :: Expr -> Expr

100 stripPositionInfo :: Expr -> Expr

158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

101 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

@@ -169,11 +112,6 @@ desugarDecl other = fn other

169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

112 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

170 isAnonymousArgument _ = False

113 isAnonymousArgument _ = False

171

114

172− mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr))

173− mkProp (name, e) = do

174− arg <- freshIfAnon e

175− return (arg, (name, maybe e argToExpr arg))

176−

177 freshIfAnon :: Expr -> m (Maybe Ident)

115 freshIfAnon :: Expr -> m (Maybe Ident)

178 freshIfAnon u

116 freshIfAnon u

179 | isAnonymousArgument u = Just <$> freshIdent'

117 | isAnonymousArgument u = Just <$> freshIdent'