From d97b50f82a86725918024b30680f78bed4c9e502 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Mon, 12 Jan 2009 15:52:49 +0000 Subject: [PATCH] Switched CheckFramework over to use the new Polyplate library --- checks/CheckFramework.hs | 255 ++++++++++--------- polyplate/Data/Generics/Polyplate.hs | 8 +- polyplate/Data/Generics/Polyplate/Schemes.hs | 15 ++ 3 files changed, 160 insertions(+), 118 deletions(-) diff --git a/checks/CheckFramework.hs b/checks/CheckFramework.hs index f829f21..56c1a96 100644 --- a/checks/CheckFramework.hs +++ b/checks/CheckFramework.hs @@ -17,7 +17,9 @@ with this program. If not, see . -} module CheckFramework (CheckOptM, CheckOptASTM, forAnyASTTopDown, forAnyASTStructTopDown, substitute, restartForAnyAST, - CheckOptASTM', forAnyASTStructBottomUpAccum, askAccum, + CheckOptASTM', + forAnyASTStructBottomUpAccum, + askAccum, runChecks, runChecksPass, getFlowGraph, withChild, varsTouchedAfter, getCachedAnalysis, getCachedAnalysis', forAnyFlowNode, getFlowLabel, getFlowMeta, CheckOptFlowM) where @@ -258,122 +260,139 @@ getFlowMeta = CheckOptFlowM $ forAnyParItems :: (ParItems a -> CheckOptM ()) -> CheckOptM () forAnyParItems = undefined - --- Like mkM, but with no return value, and this funny monad with routes, but also --- we give an error if the plain function is ever triggered (given the typeset --- stuff, it shouldn't be) -mkMR :: forall a. Data a => TransFunc a -> (forall b. Data b => TransFunc b) -mkMR f = plain `extMR` f - where - plain :: (forall c. Data c => TransFunc c) - plain _ = dieP emptyMeta "Unexpected call of mkMR.plain" - --- Like extM, but with no return value, and this funny monad with routes: -extMR :: forall b. Data b => - (forall a. Data a => TransFunc a) -> - (TransFunc b) -> - (forall c. Data c => TransFunc c) -extMR generalF specificF (x, r) = case cast x of - Nothing -> liftM (fromJust . cast) (generalF (x, unsafeCoerce# r)) - Just y -> liftM (fromJust . cast) (specificF (y, unsafeCoerce# r)) - --- Like extM, but with no return value, and this funny monad with routes: -extMRAccS :: forall b acc z. Data b => - (forall a. Data a => TransFuncS acc z a) -> - (TransFuncS acc z b) -> - (forall c. Data c => TransFuncS acc z c) -extMRAccS generalF specificF (x, r) = case cast x of - Nothing -> liftM (fromJust . cast) (generalF (x, unsafeCoerce# r)) - Just y -> liftM (fromJust . cast) (specificF (y, unsafeCoerce# r)) - -mkMRAcc :: forall a acc. Data a => TransFuncAcc acc a -> (forall b. Data b => TransFuncAcc acc b) -mkMRAcc f = plain `extMRAcc` f - where - plain :: (forall c. Data c => TransFuncAcc acc c) - plain (x,_,_) = return $ Right x -- lift $ dieP emptyMeta "Unexpected call of mkMRAcc.plain" - -extMRAcc :: forall b acc. Data b => - (forall a. Data a => TransFuncAcc acc a) -> - (TransFuncAcc acc b) -> - (forall c. Data c => TransFuncAcc acc c) -extMRAcc generalF specificF (x, r, acc) = case cast x of - Nothing -> liftM (fromJust . cast) (generalF (x, unsafeCoerce# r,acc)) - Just y -> liftM (fromJust . cast) (specificF (y, unsafeCoerce# r,acc)) - - -- | This function currently only supports one type -forAnyASTTopDown :: forall a. Data a => (a -> CheckOptASTM a ()) -> CheckOptM () +forAnyASTTopDown :: forall a. + (PolyplateMRoute A.AST ((a, Route a A.AST) -> RestartT CheckOptM a, ()) () (RestartT CheckOptM) A.AST + ,PolyplateMRoute a () ((a, Route a A.AST) -> RestartT CheckOptM a, ()) (RestartT CheckOptM) A.AST + ) => + (a -> CheckOptASTM a ()) -> CheckOptM () forAnyASTTopDown origF = CheckOptM $ do tr <- get >>* ast - doTree typeSet (applyTopDown typeSet (mkMR (deCheckOptASTM origF))) tr - where - typeSet :: TypeSet - typeSet = makeTypeSet [typeKey (undefined :: a)] - + doTree ops transformMRoute tr + where + ops = baseOp `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM origF) forAnyASTStructTopDown :: (forall a. Data a => (A.Structured a -> CheckOptASTM (A.Structured a) ())) -> CheckOptM () forAnyASTStructTopDown origF = CheckOptM $ do tr <- get >>* ast - doTree typeSet (applyTopDown typeSet allF) tr + doTree ops transformMRoute tr where - allF :: (forall c. Data c => TransFunc c) - allF - = mkMR (deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured A.ExpressionList -> CheckOptASTM (A.Structured A.ExpressionList) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured A.Choice -> CheckOptASTM (A.Structured A.Choice) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ())) - `extMR` (deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ())) - - typeSet :: TypeSet - typeSet = makeTypeSet - [typeKey (undefined :: A.Structured A.Variant) - ,typeKey (undefined :: A.Structured A.Process) - ,typeKey (undefined :: A.Structured A.Option) - ,typeKey (undefined :: A.Structured A.ExpressionList) - ,typeKey (undefined :: A.Structured A.Choice) - ,typeKey (undefined :: A.Structured A.Alternative) - ,typeKey (undefined :: A.Structured ()) - ] + ops + = baseOp + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.ExpressionList -> CheckOptASTM (A.Structured A.ExpressionList) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Choice -> CheckOptASTM (A.Structured A.Choice) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ())) + `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ())) -forAnyASTStructBottomUpAccum :: forall b. Data b => +type AccumOp b a = (A.Structured a, Route (A.Structured a) A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (A.Structured a) + +type ExtAcc a b = (b, a) + +type AccumOps b = + BaseOp + `ExtAcc` AccumOp b A.Variant + `ExtAcc` AccumOp b A.Process + `ExtAcc` AccumOp b A.Option + `ExtAcc` AccumOp b A.ExpressionList + `ExtAcc` AccumOp b A.Choice + `ExtAcc` AccumOp b A.Alternative + `ExtAcc` AccumOp b () + `ExtAcc` ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b) + +type SingleOps b + = ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) + +type AccumMap b = Map.Map [Int] b + +findSub :: [Int] -> AccumMap b -> [b] +findSub r m = [v | (k, v) <- Map.toList m, r `isPrefixOf` k] + -- TODO this could be made more efficient by picking out a range in the map + +filterSub :: [Int] -> AccumMap b -> AccumMap b +filterSub r = Map.filterWithKey (\k _ -> not $ r `isPrefixOf` k) + +-- I know the constraints here look horrendous, but it's really just three groups. +forAnyASTStructBottomUpAccum :: forall b. (Data b, + -- Allow us to descend into the AST with our full set of ops: + PolyplateMRoute A.AST (AccumOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + + -- Allow us to recurse into each Structured item (and b) with our full set of + -- ops: + PolyplateMRoute (A.Structured A.Variant) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Process) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Option) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.ExpressionList) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Choice) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Alternative) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured ()) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute b () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + + -- Allow us to descend into each Structured item with just our ops for + -- b, when our accumulated stuff becomes invalidated + PolyplateMRoute (A.Structured A.Variant) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Process) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Option) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Choice) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + PolyplateMRoute (A.Structured ()) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, + -- For b, we will recurse, not descend: + PolyplateMRoute b () (SingleOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST + + ) => (forall a. Data a => (A.Structured a) -> CheckOptASTM' [b] (A.Structured a) ()) -> CheckOptM () forAnyASTStructBottomUpAccum origF = CheckOptM $ do tr <- get >>* ast - doTree (makeTypeSet $ typeKey (undefined::b) : typeKeys) - (flip evalStateT [] . applyAccum ([],(:),(++)) typeKeys allF) - tr + doTree ops (\x y z -> flip evalStateT (Map.empty :: AccumMap b) $ transformMRoute x y z) tr where - allF :: (forall c. Data c => TransFuncAcc [b] c) - allF - = mkMRAcc (lift . deCheckOptASTM' (origF :: (A.Structured A.Variant) -> - CheckOptASTM' [b] (A.Structured A.Variant) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured A.Process) -> - CheckOptASTM' [b] (A.Structured A.Process) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured A.Option) -> - CheckOptASTM' [b] (A.Structured A.Option) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured A.ExpressionList) -> - CheckOptASTM' [b] (A.Structured A.ExpressionList) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured A.Choice) -> - CheckOptASTM' [b] (A.Structured A.Choice) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured A.Alternative) -> - CheckOptASTM' [b] (A.Structured A.Alternative) ())) - `extMRAcc` (lift . deCheckOptASTM' (origF :: (A.Structured ()) -> - CheckOptASTM' [b] (A.Structured ()) ())) - - typeKeys :: [TypeKey] - typeKeys = - [typeKey (undefined :: A.Structured A.Variant) - ,typeKey (undefined :: A.Structured A.Process) - ,typeKey (undefined :: A.Structured A.Option) - ,typeKey (undefined :: A.Structured A.ExpressionList) - ,typeKey (undefined :: A.Structured A.Choice) - ,typeKey (undefined :: A.Structured A.Alternative) - ,typeKey (undefined :: A.Structured ()) - ] + ops :: AccumOps b + ops = applyAccum (undefined::b) allF + keepApplying' :: + PolyplateMRoute t ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) + () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST + => ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (Either t t)) -> + ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) t) + keepApplying' f xr = do x' <- f xr + case x' of + Right y -> return y + Left y -> do -- remove all sub-items from state, + -- and then scan the item anew: + modify $ filterSub (routeId $ snd xr) + transformMRoute (applyAccum (undefined::b) ()) () (y, snd xr) + keepApplying' f (y, snd xr) + + wrap :: forall a. (Data a, + PolyplateMRoute (A.Structured a) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST + , PolyplateMRoute (A.Structured a) ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) + () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST + ) => ((A.Structured a, Route (A.Structured a) A.AST, [b]) -> RestartT + CheckOptM (Either (A.Structured a) (A.Structured a))) -> (A.Structured a, Route (A.Structured + a) A.AST) -> StateT (AccumMap b) (RestartT + CheckOptM) (A.Structured a) + wrap f = makeBottomUpMRoute ops $ keepApplying' $ \(x, y) -> get >>= \z -> lift (f (x, y, findSub + (routeId y) z)) + + allF + = baseOp + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) -> + CheckOptASTM' [b] (A.Structured A.Variant) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Process) -> + CheckOptASTM' [b] (A.Structured A.Process) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Option) -> + CheckOptASTM' [b] (A.Structured A.Option) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.ExpressionList) -> + CheckOptASTM' [b] (A.Structured A.ExpressionList) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Choice) -> + CheckOptASTM' [b] (A.Structured A.Choice) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Alternative) -> + CheckOptASTM' [b] (A.Structured A.Alternative) ())) + `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured ()) -> + CheckOptASTM' [b] (A.Structured ()) ())) type TransFunc a = (a, Route a A.AST) -> RestartT CheckOptM (Either a a) type TransFuncAcc acc a = (a, Route a A.AST, acc) -> StateT acc (RestartT CheckOptM) (Either a a) @@ -382,24 +401,26 @@ type TransFuncS acc b a = (a, Route a b) -> StateT acc (RestartT CheckOptM) a -- | Given a TypeSet, a function to apply to everything of type a, a route -- location to begin at and an AST, transforms the tree. Handles any restarts -- that are requested. -doTree :: TypeSet -> (forall b. Data b => (b, Route b A.AST) -> RestartT CheckOptM b) -> - A.AST -> StateT CheckOptData PassM () +doTree :: ops -> + (ops -> () -> (A.AST, Route A.AST A.AST) -> RestartT CheckOptM A.AST) -> A.AST -> StateT CheckOptData PassM () -- This line applies "apply" to the first thing of the right type in - -- the given AST; from there, apply recurses for itself -doTree typeSet apply tr - = do x <- deCheckOptM (getRestartT (gmapMForRoute typeSet apply tr >> return ())) + -- the given AST; from there, ops recurses for itself +doTree ops trans tr + = do x <- deCheckOptM (getRestartT (trans ops () (tr, routeIdentity) >> return ())) case x of Left _ -> do -- Restart tr' <- get >>* ast - doTree typeSet apply tr' + doTree ops trans tr' Right _ -> return () -applyAccum :: forall acc t. (Data t) => (acc, t -> acc -> acc, acc -> acc -> acc) -> - [TypeKey] -> (forall a. Data a => TransFuncAcc acc a) -> - (forall b. Data b => (b, Route b A.AST) -> StateT acc (RestartT CheckOptM) b) -applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum' +applyAccum :: forall t ops. + PolyplateMRoute t () ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops) + (StateT (AccumMap t) (RestartT CheckOptM)) A.AST + => t -> ops -> ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops) +applyAccum _ ops = ops' where - typeSet = makeTypeSet $ typeKey (undefined :: t) : typeKeysGiven + ops' :: ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops) + ops' = (accum, ops) extF :: (forall a. Data a => TransFuncS acc z a) -> @@ -409,7 +430,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum' applyAccum' :: (forall a. Data a => TransFuncAcc acc a) -> (forall b. Data b => (b, Route b A.AST) -> StateT acc (RestartT CheckOptM) b) applyAccum' f (x, route) - = do when (findMeta_Data x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x} + = do when (findMeta x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x} (x', acc) <- lift $ flip runStateT accEmpty (gmapMForRoute typeSet (extF wrap) x) r <- f' (x', route, acc) modify (`accJoinF` acc) @@ -428,7 +449,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum' applyTopDown :: TypeSet -> (forall a. Data a => TransFunc a) -> (forall b. Data b => (b, Route b A.AST) -> RestartT CheckOptM b) applyTopDown typeSet f (x, route) - = do when (findMeta_Data x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x} + = do when (findMeta x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x} z <- f' (x, route) gmapMForRoute typeSet (\(y, route') -> applyTopDown typeSet f (y, route @-> route')) z where @@ -437,8 +458,8 @@ applyTopDown typeSet f (x, route) f' (x, route) = do x' <- f (x, route) case x' of - Left y -> f' (y, route) - Right y -> return y + Left y -> keepApplying f (y, route) + Right y -> return y -- | For both of these functions I'm going to need to mark all analyses as no longer -- valid, but more difficult will be to maintain the current position (if possible diff --git a/polyplate/Data/Generics/Polyplate.hs b/polyplate/Data/Generics/Polyplate.hs index 22b6f36..c4dd715 100644 --- a/polyplate/Data/Generics/Polyplate.hs +++ b/polyplate/Data/Generics/Polyplate.hs @@ -34,7 +34,7 @@ module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(. -- makeRecurseQ, RecurseQ, -- makeDescendQ, DescendQ, BaseOp, baseOp, - ExtOpM, extOpM, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp, + ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp, ExtOpQ, extOpQ, OneOpQ, TwoOpQ) where import Control.Monad.Identity @@ -212,6 +212,8 @@ baseOp = () -- same list. type ExtOpM m opT t = (t -> m t, opT) +type ExtOpMRoute m opT t outer = ((t, Route t outer) -> m t, opT) + -- | The type that extends an ops set (opT) to be applied to the given type (t). -- You cannot mix monadic and non-monadic operations in the same list. type ExtOp opT t = (t -> t, opT) @@ -226,6 +228,10 @@ type ExtOpQ a opQ t = (t -> a, opQ) extOpM :: opT -> (t -> m t) -> ExtOpM m opT t extOpM ops f = (f, ops) +extOpMRoute :: opT -> ((t, Route t outer) -> m t) -> ExtOpMRoute m opT t outer +extOpMRoute ops f = (f, ops) + + -- | The function that extends an ops set (opT) in the given monad (m) to be applied to -- the given type (t). You cannot mix monadic and non-monadic operations in the -- same list. diff --git a/polyplate/Data/Generics/Polyplate/Schemes.hs b/polyplate/Data/Generics/Polyplate/Schemes.hs index 0557ebe..135fe77 100644 --- a/polyplate/Data/Generics/Polyplate/Schemes.hs +++ b/polyplate/Data/Generics/Polyplate/Schemes.hs @@ -23,6 +23,7 @@ import Data.Maybe import Data.Tree import Data.Generics.Polyplate +import Data.Generics.Polyplate.Route -- | Given a list of operations and a modifier function, augments that modifier -- function to first descend into the value before then applying the modifier function. @@ -31,6 +32,13 @@ import Data.Generics.Polyplate makeBottomUpM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t makeBottomUpM ops f v = makeDescendM ops v >>= f +makeBottomUpMRoute :: PolyplateMRoute t () opT m outer => + opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t +makeBottomUpMRoute ops f (v, r) + = do v' <- transformMRoute () ops (v, r) + f (v', r) + + -- | Given a list of operations and a modifier function, augments that modifier -- function to first apply the modifier function before then descending into the value. -- This can be used to perform a top-down depth-first traversal of a structure @@ -38,6 +46,13 @@ makeBottomUpM ops f v = makeDescendM ops v >>= f makeTopDownM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t makeTopDownM ops f v = f v >>= makeDescendM ops +makeTopDownMRoute :: PolyplateMRoute t () opT m outer => + opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t +makeTopDownMRoute ops f (v, r) + = do v' <- f (v, r) + transformMRoute () ops (v', r) + + -- | Given a list of operations and a modifier function, augments that modifier -- function to first descend into the value before then applying the modifier function. -- This can be used to perform a bottom-up depth-first traversal of a structure