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

LiamGoodacre · paf31 · commit 32faa7695dc4 · 2017-01-28T18:20:52.000-08:00
* Change nested record update syntax and fix bug with depth &gt; 2

* Build update tree in parser

* Remove accidental pragmas
diff --git a/examples/passing/NestedRecordUpdate.purs b/examples/passing/NestedRecordUpdate.purs
@@ -3,21 +3,22 @@ module Main where
 import Prelude
 import Control.Monad.Eff.Console
 
-type T = { foo :: Int, bar :: { baz :: Int, qux :: Int } }
+type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } }
 
 init :: T
-init = { foo: 1, bar: { baz: 2, qux: 3 } }
+init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } }
 
 updated :: T
-updated = init { foo = 10, bar.baz = 20, bar.qux = 30 }
+updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } }
 
 expected :: T
-expected = { foo: 10, bar: { baz: 20, qux: 30 } }
+expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } }
 
 check l r =
   l.foo == r.foo &&
   l.bar.baz == r.bar.baz &&
-  l.bar.qux == r.bar.qux
+  l.bar.qux.lhs == r.bar.qux.lhs &&
+  l.bar.qux.rhs == r.bar.qux.rhs
 
 main = do
   when (check updated expected) $ log "Done"
diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/examples/passing/NestedRecordUpdateWildcards.purs
@@ -3,7 +3,7 @@ module Main where
 import Prelude
 import Control.Monad.Eff.Console
 
-update = _ { foo = _, bar.baz = _, bar.qux = _ }
+update = _ { foo = _, bar { baz = _, qux = _ } }
 
 init = { foo: 1, bar: { baz: 2, qux: 3 } }
 
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 
 -- |
 -- Data types for modules and declarations
@@ -12,7 +14,6 @@ import Control.Monad.Identity
 import Data.Aeson.TH
 import qualified Data.Map as M
 import Data.Text (Text)
-import Data.List.NonEmpty (NonEmpty(..))
 
 import Language.PureScript.AST.Binders
 import Language.PureScript.AST.Literals
@@ -587,10 +588,10 @@ data Expr
   --
   | ObjectUpdate Expr [(PSString, Expr)]
   -- |
-  -- Object updates with nested support: `x { foo.bar = e }`
+  -- Object updates with nested support: `x { foo { bar = e } }`
   -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
   --
-  | ObjectUpdateNested Expr [(NonEmpty PSString, Expr)]
+  | ObjectUpdateNested Expr (PathTree Expr)
   -- |
   -- Function introduction
   --
@@ -706,5 +707,38 @@ data DoNotationElement
   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
   deriving (Show)
 
+
+-- For a record update such as:
+--
+--  x { foo = 0
+--    , bar { baz = 1
+--          , qux = 2 } }
+--
+-- We represent the updates as the `PathTree`:
+--
+--  [ ("foo", Leaf 3)
+--  , ("bar", Branch [ ("baz", Leaf 1)
+--                   , ("qux", Leaf 2) ]) ]
+--
+-- Which we then convert to an expression representing the following:
+--
+--   let x' = x
+--   in x' { foo = 0
+--         , bar = x'.bar { baz = 1
+--                        , qux = 2 } }
+--
+-- The `let` here is required to prevent re-evaluating the object expression `x`.
+-- However we don't generate this when using an anonymous argument for the object.
+--
+
+newtype PathTree t = PathTree (AssocList PSString (PathNode t))
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+data PathNode t = Leaf t | Branch (PathTree t)
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
+
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -48,7 +48,7 @@ everywhereOnValues f g h = (f', g', h')
   g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
   g' (Accessor prop v) = g (Accessor prop (g' v))
   g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
-  g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (map (fmap g') vs))
+  g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))
   g' (Abs name v) = g (Abs name (g' v))
   g' (App v1 v2) = g (App (g' v1) (g' v2))
   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)
   g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
   g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
   g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
-  g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
+  g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs
   g' (Abs name v) = Abs name <$> (g v >>= g')
   g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
   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')
   g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
   g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
   g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
-  g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse (sndM g') vs) >>= g
+  g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g
   g' (Abs name v) = (Abs name <$> g' v) >>= g
   g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
   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')
   g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
   g' v@(Accessor _ v1) = g v <> g' v1
   g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
-  g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
+  g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)
   g' v@(Abs _ v1) = g v <> g' v1
   g' v@(App v1 v2) = g v <> g' v1 <> g' v2
   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'
   g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
   g' s (Accessor _ v1) = g'' s v1
   g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
-  g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
+  g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)
   g' s (Abs _ v1) = g'' s v1
   g' s (App v1 v2) = g'' s v1 <> g'' s v2
   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
   g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
   g' s (Accessor prop v) = Accessor prop <$> g'' s v
   g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
-  g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (sndM (g'' s)) vs
+  g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs
   g' s (Abs name v) = Abs name <$> g'' s v
   g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
   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)
   g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
   g' s (Accessor _ v1) = g'' s v1
   g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
-  g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
+  g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs
   g' s (Abs (Left name) v1) =
     let s' = S.insert name s
     in g'' s' v1
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -17,13 +17,12 @@ import           Prelude hiding (lex)
 
 import           Control.Applicative
 import           Control.Arrow ((+++))
+import           Control.Monad (foldM)
 import           Control.Monad.Error.Class (MonadError(..))
 import           Control.Parallel.Strategies (withStrategy, parList, rseq)
-import           Data.Bifunctor (first)
 import           Data.Functor (($>))
-import           Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as N
 import           Data.Maybe (fromMaybe)
+import qualified Data.Set as S
 import           Data.Text (Text)
 import           Language.PureScript.AST
 import           Language.PureScript.Environment
@@ -399,13 +398,17 @@ parseInfixExpr
 parseHole :: TokenParser Expr
 parseHole = Hole <$> holeLit
 
-parsePropertyUpdate :: TokenParser (NonEmpty PSString, Expr)
+parsePropertyUpdate :: TokenParser (PSString, PathNode Expr)
 parsePropertyUpdate = do
   name <- parseLabel
-  rest <- P.many (indented *> dot *> indented *> parseLabel)
-  _ <- indented *> equals
-  value <- indented *> parseValue
-  return (name :| rest, value)
+  updates <- parseShallowUpdate <|> parseNestedUpdate
+  return (name, updates)
+  where
+    parseShallowUpdate :: TokenParser (PathNode Expr)
+    parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue)
+
+    parseNestedUpdate :: TokenParser (PathNode Expr)
+    parseNestedUpdate = Branch <$> parseUpdaterBodyFields
 
 parseAccessor :: Expr -> TokenParser Expr
 parseAccessor (Constructor _) = P.unexpected "constructor"
@@ -455,11 +458,18 @@ parseValue = withSourceSpan PositionedValue
                 ]
               ]
 
-parseUpdaterBody :: Expr -> TokenParser Expr
-parseUpdaterBody v = objectUpdate <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate)))
+parseUpdaterBodyFields :: TokenParser (PathTree Expr)
+parseUpdaterBodyFields = do
+  updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate))
+  (_, tree) <- foldM insertUpdate (S.empty, []) updates
+  return (PathTree (AssocList (reverse tree)))
   where
-    objectUpdate xs | all (null . N.tail . fst) xs = ObjectUpdate v (map (first N.head) xs)
-                    | otherwise = ObjectUpdateNested v xs
+    insertUpdate (seen, xs) (key, node)
+      | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key)
+      | otherwise = return (S.insert key seen, (key, node) : xs)
+
+parseUpdaterBody :: Expr -> TokenParser Expr
+parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields
 
 parseAnonymousArgument :: TokenParser Expr
 parseAnonymousArgument = underscore *> pure AnonymousArgument
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
@@ -12,7 +12,6 @@ import Prelude.Compat
 import Control.Arrow (second)
 
 import qualified Data.Monoid as Monoid ((<>))
-import Data.List.NonEmpty (NonEmpty(..))
 
 import qualified Data.Text as T
 import Data.Text (Text)
@@ -48,11 +47,8 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty
   prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box
   prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value
 
-prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, Expr)] -> Box
-prettyPrintObjectUpdate printKey d o ps =
-  prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' printEntry ps
-  where
-    printEntry (key, val) = printKey key <> text " = " <> prettyPrintValue (d - 1) val
+prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box
+prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val
 
 -- | Pretty-print an expression
 prettyPrintValue :: Int -> Expr -> Box
@@ -63,10 +59,12 @@ prettyPrintValue d (IfThenElse cond th el) =
                             , text "else " <> prettyPrintValueAtom (d - 1) el
                             ])
 prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)
-prettyPrintValue d (ObjectUpdate o ps) = prettyPrintObjectUpdate (textT . prettyPrintObjectKey) d o ps
-prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintObjectUpdate printPath d o ps where
-  printPath (hd :| tl) = foldl combine (textT (prettyPrintObjectKey hd)) tl
-  combine acc key = acc <> textT ("." Monoid.<> prettyPrintObjectKey key)
+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps
+prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps
+  where
+    prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree)
+    printNode (key, Leaf val) = prettyPrintUpdateEntry d key val
+    printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val
 prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
 prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
 prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
