@@ -3,19 +3,48 @@ module Language.PureScript.Sugar.ObjectWildcards
3 , desugarDecl
3 , desugarDecl
6−import Prelude.Compat
6+import Prelude.Compat
8−import Control.Monad (forM)
8+import Control.Monad (forM, foldM)
9−import Control.Monad.Error.Class (MonadError(..))
9+import Control.Monad.Error.Class (MonadError(..))
10−import Control.Monad.Supply.Class
10+import Control.Monad.Supply.Class
11+import Data.List (partition)
12+import Data.List.NonEmpty (NonEmpty(..))
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)
12−import Data.List (partition)
23+-- `PathNode` and `PathTree` are used as an intermediate form when desugaring a nested object update.
13−import Data.Maybe (catMaybes)
24+-- For an update such as:
15−import Language.PureScript.AST
26+-- x { foo = 0
16−import Language.PureScript.Errors
27+-- , bar.baz = 1
17−import Language.PureScript.Names
28+-- , bar.qux = 2 }
18−import Language.PureScript.PSString (PSString)
29+--
30+-- We represent the updates as the `PathTree`:
32+-- M.fromList [ ("foo", Leaf 3)
33+-- , ("bar", Branch (M.fromList [ ("baz", Leaf 1)
34+-- , ("qux", Leaf 2) ]) ])
36+-- Which we then convert to an expression representing the following:
40+-- , bar = x'.bar { baz = 1
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.
46+type PathTree = Map PSString PathNode
47+data PathNode = Leaf Expr | Branch PathTree
20desugarObjectConstructors
49desugarObjectConstructors
21 :: forall m
50 :: forall m
@@ -46,6 +75,7 @@ desugarDecl other = fn other
46 obj <- freshIdent'
75 obj <- freshIdent'
47 Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
76 Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
48 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
77 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
78+ desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps
49 desugarExpr (Accessor prop u)
79 desugarExpr (Accessor prop u)
50 | Just props <- peelAnonAccessorChain u = do
80 | Just props <- peelAnonAccessorChain u = do
51 arg <- freshIdent'
81 arg <- freshIdent'
@@ -62,14 +92,67 @@ desugarDecl other = fn other
62 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
92 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
63 desugarExpr e = return e
93 desugarExpr e = return e
65− wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
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.
100+ if isAnonymousArgument obj
101+ then Abs (Left val) <$> wrapLambdaM (build val) ps
102+ else wrapLambdaM (fmap (buildLet val) . build val) ps
104+ build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs
105+ buildLet val = Let [ValueDeclaration val Public [] (Right obj)]
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
113+ -> (NonEmpty PSString, Expr)
115+ buildTree pathTree (path, e) = go pathTree path where
117+ -- path already exists
118+ | key `M.member` tree = throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps))
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
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)
144+ wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr
66− wrapLambda mkVal ps =
145+ wrapLambdaM mkVal ps =
67 let (args, props) = partition (isAnonymousArgument . snd) ps
146 let (args, props) = partition (isAnonymousArgument . snd) ps
68 in if null args
147 in if null args
69− then return $ mkVal props
148+ then mkVal props
71 (args', ps') <- unzip <$> mapM mkProp ps
150 (args', ps') <- unzip <$> mapM mkProp ps
72− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
152+ return $ foldr (Abs . Left) val (catMaybes args')
154+ wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr
155+ wrapLambda mkVal = wrapLambdaM (return . mkVal)
74 stripPositionInfo :: Expr -> Expr
157 stripPositionInfo :: Expr -> Expr
75 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
158 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
@@ -86,7 +169,7 @@ desugarDecl other = fn other
86 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
169 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
87 isAnonymousArgument _ = False
170 isAnonymousArgument _ = False
89− mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))
172+ mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr))
90 mkProp (name, e) = do
173 mkProp (name, e) = do
91 arg <- freshIfAnon e
174 arg <- freshIfAnon e
92 return (arg, (name, maybe e argToExpr arg))
175 return (arg, (name, maybe e argToExpr arg))