diff --git a/polyplate/Data/Generics/Polyplate.hs b/polyplate/Data/Generics/Polyplate.hs index f25ab60..c7ecea9 100644 --- a/polyplate/Data/Generics/Polyplate.hs +++ b/polyplate/Data/Generics/Polyplate.hs @@ -129,7 +129,7 @@ module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(. -- makeRecurseQ, RecurseQ, -- makeDescendQ, DescendQ, BaseOp, baseOp, - ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp + ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpMRoute, OneOpM, OneOp, TwoOpM, TwoOp ) where import Control.Monad.Identity @@ -329,6 +329,8 @@ extOpMRoute ops f = (f, ops) extOp :: opT -> (t -> t) -> ExtOp opT t extOp ops f = (f, ops) +-- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateMRoute'. +type OneOpMRoute m t outer = ExtOpMRoute m BaseOp t outer -- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'. type OneOpM m t = ExtOpM m BaseOp t -- | A handy synonym for an ops set with only one item, to use with 'Polyplate'. diff --git a/polyplate/Data/Generics/Polyplate/Schemes.hs b/polyplate/Data/Generics/Polyplate/Schemes.hs index 3438135..e9581a5 100644 --- a/polyplate/Data/Generics/Polyplate/Schemes.hs +++ b/polyplate/Data/Generics/Polyplate/Schemes.hs @@ -95,6 +95,15 @@ listifyDepth qf = flip execState [] . applyBottomUpM qf' where qf' x = if qf x then modify (x:) >> return x else return x +-- | Like listifyDepth, but with routes +listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute (State [(s, Route s t)]) s t) () (State [(s, Route s t)]) t + ,PolyplateMRoute s () (OneOpMRoute (State [(s, Route s t)]) s t) (State [(s, Route s t)]) t) + => ((s, Route s t) -> Bool) -> t -> [(s, Route s t)] +listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf' + where + qf' x = if qf x then modify (x:) >> return (fst x) else return (fst x) + + -- * Check functions to apply monadic checks throughout a data structure -- | Given a monadic function that operates on items of type \"s\" (without modifying @@ -132,6 +141,14 @@ applyBottomUpM f = makeRecurseM ops where ops = baseOp `extOpM` makeBottomUpM ops f +applyBottomUpMRoute :: (PolyplateMRoute t (OneOpMRoute m s t) () m t, + PolyplateMRoute s () (OneOpMRoute m s t) m t) => + ((s, Route s t) -> m s) -> t -> m t +applyBottomUpMRoute f x = transformMRoute ops () (x, identityRoute) + where + ops = baseOp `extOpMRoute` makeBottomUpMRoute ops f + + -- | As 'applyBottomUpM', but applies two functions. These should not be modifying -- the same type. applyBottomUpM2 :: (PolyplateM t (TwoOpM m sA sB) () m,