@@ -5,46 +5,18 @@ module Language.PureScript.Sugar.ObjectWildcards
55
66import Prelude.Compat
77
8−import Control.Monad (forM, foldM)
8+import Control.Monad (forM)
99import Control.Monad.Error.Class (MonadError(..))
1010import 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
11+import Data.Foldable (toList)
12+import Data.List (foldl')
1513import Data.Maybe (catMaybes)
1614import Language.PureScript.AST
1715import Language.PureScript.Environment (NameKind(..))
1816import Language.PureScript.Errors
19−import Language.PureScript.Label (Label(..))
2017import Language.PureScript.Names
2118import Language.PureScript.PSString (PSString)
2219
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
4820
4921desugarObjectConstructors
5022 :: forall m
@@ -70,11 +42,7 @@ desugarDecl other = fn other
7042 , BinaryNoParens op u val <- b'
7143 , isAnonymousArgument u = do arg <- freshIdent'
7244 return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
73− desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (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
45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps
7846 desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps
7947 desugarExpr (Accessor prop u)
8048 | Just props <- peelAnonAccessorChain u = do
@@ -92,67 +60,42 @@ desugarDecl other = fn other
9260 return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
9361 desugarExpr e = return e
9462
95− transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr
63+ transformNestedUpdate :: Expr -> PathTree Expr -> m Expr
9664 transformNestedUpdate obj ps = do
9765 -- If we don't have an anonymous argument then we need to generate a let wrapper
9866 -- so that the object expression isn't re-evaluated for each nested update.
9967 val <- freshIdent'
68+ let valExpr = argToExpr val
10069 if isAnonymousArgument obj
101− then Abs (Left val) <$> wrapLambdaM (build val) ps
102− else wrapLambdaM (fmap (buildLet val) . build val) ps
70+ then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps
71+ else wrapLambda (buildLet val . buildUpdates valExpr) ps
10372 where
104− build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs
10573 buildLet val = Let [ValueDeclaration val Public [] (Right obj)]
10674
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)
75+ -- recursively build up the nested `ObjectUpdate` expressions
76+ buildUpdates :: Expr -> PathTree Expr -> Expr
77+ buildUpdates val (PathTree vs) = ObjectUpdate val (goLayer [] <$> runAssocList vs) where
78+ goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
13679 goLayer _ (key, Leaf expr) = (key, expr)
137− goLayer path (key, Branch branch) =
80+ goLayer path (key, Branch (PathTree branch)) =
13881 let path' = path ++ [key]
139− updates = goLayer path' <$> M.toList branch
140− accessor = foldr Accessor val path'
82+ updates = goLayer path' <$> runAssocList branch
83+ accessor = foldl' (flip Accessor) val path'
14184 objectUpdate = ObjectUpdate accessor updates
14285 in (key, objectUpdate)
14386
144− wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr
145− wrapLambdaM mkVal ps =
146− let (args, props) = partition (isAnonymousArgument . snd) 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')
87+ wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr
88+ wrapLambda mkVal ps = do
89+ args <- traverse processExpr ps
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)
15396
154− wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr
155− wrapLambda mkVal = wrapLambdaM (return . mkVal)
97+ wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
98+ wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList
15699
157100 stripPositionInfo :: Expr -> Expr
158101 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
@@ -169,11 +112,6 @@ desugarDecl other = fn other
169112 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
170113 isAnonymousArgument _ = False
171114
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−
177115 freshIfAnon :: Expr -> m (Maybe Ident)
178116 freshIfAnon u
179117 | isAnonymousArgument u = Just <$> freshIdent'