@@ -3,19 +3,48 @@ module Language.PureScript.Sugar.ObjectWildcards
33 , desugarDecl
44 ) where
55
6−import Prelude.Compat
6+import Prelude.Compat
77
8−import Control.Monad (forM)
9−import Control.Monad.Error.Class (MonadError(..))
10−import Control.Monad.Supply.Class
8+import Control.Monad (forM, foldM)
9+import Control.Monad.Error.Class (MonadError(..))
10+import Control.Monad.Supply.Class
11+import Data.List (partition)
12+import Data.List.NonEmpty (NonEmpty(..))
13+import Data.Map (Map)
14+import qualified Data.Map as M
15+import Data.Maybe (catMaybes)
16+import Language.PureScript.AST
17+import Language.PureScript.Environment (NameKind(..))
18+import Language.PureScript.Errors
19+import Language.PureScript.Label (Label(..))
20+import Language.PureScript.Names
21+import Language.PureScript.PSString (PSString)
1122
12−import Data.List (partition)
13−import Data.Maybe (catMaybes)
14−
15−import Language.PureScript.AST
16−import Language.PureScript.Errors
17−import Language.PureScript.Names
18−import 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
1948
2049desugarObjectConstructors
2150 :: forall m
@@ -46,6 +75,7 @@ desugarDecl other = fn other
4675 obj <- freshIdent'
4776 Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
4877 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
78+ desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps
4979 desugarExpr (Accessor prop u)
5080 | Just props <- peelAnonAccessorChain u = do
5181 arg <- freshIdent'
@@ -62,14 +92,67 @@ desugarDecl other = fn other
6292 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
6393 desugarExpr e = return e
6494
65− wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
66− wrapLambda mkVal ps =
95+ transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr
96+ transformNestedUpdate obj ps = do
97+ -- 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.
99+ val <- freshIdent'
100+ if isAnonymousArgument obj
101+ then Abs (Left val) <$> wrapLambdaM (build val) ps
102+ else wrapLambdaM (fmap (buildLet val) . build val) ps
103+ where
104+ build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs
105+ 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.
133+ buildUpdates :: Expr -> PathTree -> Expr
134+ buildUpdates val vs = ObjectUpdate val (goLayer [] <$> M.toList vs) where
135+ goLayer :: [PSString] -> (PSString, PathNode) -> (PSString, Expr)
136+ goLayer _ (key, Leaf expr) = (key, expr)
137+ goLayer path (key, Branch branch) =
138+ let path' = path ++ [key]
139+ updates = goLayer path' <$> M.toList branch
140+ accessor = foldr Accessor val path'
141+ objectUpdate = ObjectUpdate accessor updates
142+ in (key, objectUpdate)
143+
144+ wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr
145+ wrapLambdaM mkVal ps =
67146 let (args, props) = partition (isAnonymousArgument . snd) ps
68147 in if null args
69− then return $ mkVal props
148+ then mkVal props
70149 else do
71150 (args', ps') <- unzip <$> mapM mkProp ps
72− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
151+ val <- mkVal ps'
152+ return $ foldr (Abs . Left) val (catMaybes args')
153+
154+ wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr
155+ wrapLambda mkVal = wrapLambdaM (return . mkVal)
73156
74157 stripPositionInfo :: Expr -> Expr
75158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
@@ -86,7 +169,7 @@ desugarDecl other = fn other
86169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
87170 isAnonymousArgument _ = False
88171
89− mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))
172+ mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr))
90173 mkProp (name, e) = do
91174 arg <- freshIfAnon e
92175 return (arg, (name, maybe e argToExpr arg))