Changed Polyplate to use a different system of ops-sets, that's looking quite nice
This commit is contained in:
Neil Brown
parent
aaa3ffe3f3
commit
efa5c57fd0
|
|
@ -128,7 +128,8 @@ module Data.Generics.Polyplate (PolyplateMRoute(..), PolyplateM(..), Polyplate(.
|
|||
makeDescendM, DescendM, makeDescend, Descend,
|
||||
-- makeRecurseQ, RecurseQ,
|
||||
-- makeDescendQ, DescendQ,
|
||||
BaseOp, baseOp,
|
||||
BaseOp(..), BaseOpM(..), BaseOpMRoute(..), baseOp, baseOpM, baseOpM', baseOpMRoute,
|
||||
(:-)(..), (:-*)(..), (:-@)(..),
|
||||
ExtOpM, extOpM, ExtOpMRoute, extOpMRoute, ExtOp, extOp, OneOpMRoute, OneOpM, OneOp, TwoOpM, TwoOp
|
||||
) where
|
||||
|
||||
|
|
@ -178,7 +179,7 @@ import Data.Generics.Polyplate.Route
|
|||
-- Generally you will not use this function or type-class directly, but will instead
|
||||
-- use the helper functions lower down in this module.
|
||||
class Monad m => PolyplateMRoute t o o' m outer where
|
||||
transformMRoute :: o -> o' -> (t, Route t outer) -> m t
|
||||
transformMRoute :: o m outer -> o' m outer -> (t, Route t outer) -> m t
|
||||
|
||||
-- | A derivative of PolyplateMRoute without all the route stuff.
|
||||
--
|
||||
|
|
@ -217,7 +218,7 @@ class Monad m => PolyplateMRoute t o o' m outer where
|
|||
-- Generally you will not use this function or type-class directly, but will instead
|
||||
-- use the helper functions lower down in this module.
|
||||
class (Monad m) => PolyplateM t o o' m where
|
||||
transformM :: o -> o' -> t -> m t
|
||||
transformM :: o m -> o' m -> t -> m t
|
||||
|
||||
|
||||
instance (Monad m
|
||||
|
|
@ -242,25 +243,25 @@ instance (PolyplateM t mo mo' Identity, ConvertOpsToIdentity o mo, ConvertOpsToI
|
|||
|
||||
-- | A type representing a monadic modifier function that applies the given ops
|
||||
-- (opT) in the given monad (m) directly to the given type (t).
|
||||
type RecurseM m opT = forall t. PolyplateM t opT () m => t -> m t
|
||||
type RecurseM m opT = forall t. PolyplateM t opT BaseOpM m => t -> m t
|
||||
|
||||
-- | Given a set of operations (as described in the 'PolyplateM' type-class),
|
||||
-- makes a recursive modifier function.
|
||||
makeRecurseM :: Monad m => opT -> RecurseM m opT
|
||||
makeRecurseM ops = transformM ops ()
|
||||
makeRecurseM :: Monad m => opT m -> RecurseM m opT
|
||||
makeRecurseM ops = transformM ops baseOpM
|
||||
|
||||
-- | A type representing a monadic modifier function that applies the given ops
|
||||
-- (opT) in the given monad (m) to the children of the given type (t).
|
||||
type DescendM m opT = forall t. PolyplateM t () opT m => t -> m t
|
||||
type DescendM m opT = forall t. PolyplateM t BaseOpM opT m => t -> m t
|
||||
|
||||
-- | Given a set of operations (as described in the 'PolyplateM' type-class),
|
||||
-- makes a descent modifier function that applies the operation to the type's children.
|
||||
makeDescendM :: Monad m => opT -> DescendM m opT
|
||||
makeDescendM ops = transformM () ops
|
||||
makeDescendM :: Monad m => opT m -> DescendM m opT
|
||||
makeDescendM ops = transformM baseOpM ops
|
||||
|
||||
-- | A type representing a modifier function that applies the given ops
|
||||
-- (opT) directly to the given type (t).
|
||||
type Recurse opT = forall t. Polyplate t opT () => t -> t
|
||||
type Recurse opT = forall t. Polyplate t opT BaseOp => t -> t
|
||||
|
||||
-- | Given a set of operations (as described in the 'Polyplate' type-class),
|
||||
-- makes a modifier function that applies the operations directly.
|
||||
|
|
@ -296,48 +297,72 @@ type BaseOp = ()
|
|||
baseOp :: BaseOp
|
||||
baseOp = ()
|
||||
|
||||
baseOpM :: BaseOpM m
|
||||
baseOpM = BaseOpM
|
||||
|
||||
baseOpM' :: (a -> m a) -> BaseOpM m
|
||||
baseOpM' = const BaseOpM
|
||||
|
||||
baseOpMRoute :: BaseOpMRoute m outer
|
||||
baseOpMRoute = BaseOpMRoute
|
||||
|
||||
-- | The type 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. This is for use with the 'PolyplateM' class.
|
||||
type ExtOpM m opT t = (t -> m t, opT)
|
||||
--data ((t :: *) :-* (opT :: (* -> *) -> *)) m = (t -> m t) :-* (opT m)
|
||||
data (t :-* opT) m = (t -> m t) :-* (opT m)
|
||||
--data E t (opT :: (* -> *) -> *) m = (:-*) (t -> m t) (opT m)
|
||||
|
||||
infixr 7 :-*
|
||||
|
||||
type ExtOpM m opT t = (t :-* opT) m
|
||||
|
||||
data BaseOpM m = BaseOpM
|
||||
|
||||
data (t :-@ opT) m outer = ((t, Route t outer) -> m t) :-@ (opT m outer)
|
||||
|
||||
data BaseOpMRoute m outer = BaseOpMRoute
|
||||
|
||||
-- | The type that extends an ops set (opT) in the given monad (m) to be applied
|
||||
-- to the given type (t) with routes to the outer type (outer). This is for use
|
||||
-- with the 'PolyplateMRoute' class.
|
||||
type ExtOpMRoute m opT t outer = ((t, Route t outer) -> m t, opT)
|
||||
type ExtOpMRoute m opT t outer = (t :-@ opT) m 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. This is
|
||||
-- for use with the 'Polyplate' class.
|
||||
type ExtOp opT t = (t -> t, opT)
|
||||
data t :- opT = (t -> t) :- opT
|
||||
|
||||
type ExtOp opT t = t :- opT
|
||||
|
||||
-- | 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. This is for use with the 'PolyplateM' class.
|
||||
extOpM :: opT -> (t -> m t) -> ExtOpM m opT t
|
||||
extOpM ops f = (f, ops)
|
||||
extOpM :: opT m -> (t -> m t) -> ExtOpM m opT t
|
||||
extOpM 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) with routes to the outer type (outer). This is for use
|
||||
-- with the 'PolyplateMRoute' class.
|
||||
extOpMRoute :: opT -> ((t, Route t outer) -> m t) -> ExtOpMRoute m opT t outer
|
||||
extOpMRoute ops f = (f, ops)
|
||||
extOpMRoute :: opT m outer -> ((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. This is for use with the 'Polyplate' class.
|
||||
extOp :: opT -> (t -> t) -> ExtOp opT t
|
||||
extOp ops f = (f, ops)
|
||||
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
|
||||
type OneOpMRoute t = t :-@ BaseOpMRoute
|
||||
-- | A handy synonym for a monadic ops set with only one item, to use with 'PolyplateM'.
|
||||
type OneOpM m t = ExtOpM m BaseOp t
|
||||
type OneOpM t = t :-* BaseOpM
|
||||
-- | A handy synonym for an ops set with only one item, to use with 'Polyplate'.
|
||||
type OneOp t = ExtOp BaseOp t
|
||||
|
||||
-- | A handy synonym for a monadic ops set with only two items, to use with 'PolyplateM'.
|
||||
type TwoOpM m s t = ExtOpM m (ExtOpM m BaseOp s) t
|
||||
type TwoOpM s t = (s :-* t :-* BaseOpM) --ExtOpM m (ExtOpM m BaseOpM s) t
|
||||
-- | A handy synonym for an ops set with only two items, to use with 'Polyplate'.
|
||||
type TwoOp s t = ExtOp (ExtOp BaseOp s) t
|
||||
|
||||
|
|
@ -347,13 +372,13 @@ type TwoOp s t = ExtOp (ExtOp BaseOp s) t
|
|||
-- | A helper class to convert non-monadic transformations into monadic ones in
|
||||
-- the Identity monad.
|
||||
class ConvertOpsToIdentity o o' | o -> o' where
|
||||
convertOpsToIdentity :: o -> o'
|
||||
convertOpsToIdentity :: o -> o' Identity
|
||||
|
||||
instance ConvertOpsToIdentity () () where
|
||||
convertOpsToIdentity = id
|
||||
instance ConvertOpsToIdentity BaseOp BaseOpM where
|
||||
convertOpsToIdentity = const baseOpM
|
||||
|
||||
instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a -> a, r) (a -> Identity a, r') where
|
||||
convertOpsToIdentity (f, r) = (return . f, convertOpsToIdentity r)
|
||||
instance ConvertOpsToIdentity r r' => ConvertOpsToIdentity (a :- r) (a :-* r') where
|
||||
convertOpsToIdentity (f :- r) = (return . f) :-* (convertOpsToIdentity r)
|
||||
|
||||
{-
|
||||
-- | A helper class to convert operation lists to have FullSpine at their base
|
||||
|
|
@ -371,14 +396,18 @@ instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r')
|
|||
-- | A helper class to convert operations not expecting a route to those that ignore
|
||||
-- the route (which will have the unit type as its outer type).
|
||||
class ConvertOpsToIgnoreRoute o o' | o -> o' where
|
||||
convertOpsToIgnoreRoute :: o -> o'
|
||||
convertOpsToIgnoreRoute :: Monad m => o m -> o' m ()
|
||||
|
||||
instance ConvertOpsToIgnoreRoute () () where
|
||||
convertOpsToIgnoreRoute = id
|
||||
instance ConvertOpsToIgnoreRoute BaseOpM BaseOpMRoute where
|
||||
convertOpsToIgnoreRoute = const baseOpMRoute
|
||||
|
||||
instance ConvertOpsToIgnoreRoute r r' =>
|
||||
ConvertOpsToIgnoreRoute (t -> m t, r) ((t, Route t ()) -> m t, r') where
|
||||
convertOpsToIgnoreRoute (f, r) = (f . fst, convertOpsToIgnoreRoute r)
|
||||
|
||||
ConvertOpsToIgnoreRoute (t :-* r) (t :-@ r') where
|
||||
convertOpsToIgnoreRoute (f :-* r) = (f . fst) :-@ (convertOpsToIgnoreRoute r)
|
||||
{-
|
||||
instance ConvertOpsToIgnoreRoute (r m) (r' m ()) =>
|
||||
ConvertOpsToIgnoreRoute ((t :-* r) m) ((t :-@ r') m ()) where
|
||||
convertOpsToIgnoreRoute (f :-* r) = (f . fst) :-@ (convertOpsToIgnoreRoute r)
|
||||
-}
|
||||
|
||||
-- }}}
|
||||
|
|
|
|||
|
|
@ -129,13 +129,13 @@ genMapInstance k v
|
|||
modify (Map.insert tk (show $ typeOf m,
|
||||
Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v]
|
||||
(\(funcSameType, funcNewType) ->
|
||||
[funcSameType ++ " () ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in"
|
||||
," do m <- mapM (" ++ funcNewType ++ " ops ()) mns"
|
||||
[funcSameType ++ " _ ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in"
|
||||
," do m <- mapM (" ++ funcNewType ++ " ops BaseOpMRoute) mns"
|
||||
," return (Map.fromList m)"
|
||||
])
|
||||
(\(funcSameType, funcNewType) ->
|
||||
[funcSameType ++ " () ops q v = Node q (map ("
|
||||
++ funcNewType ++ " ops () Nothing) (Map.toList v))"
|
||||
[funcSameType ++ " _ ops q v = Node q (map ("
|
||||
++ funcNewType ++ " ops BaseOpMRoute Nothing) (Map.toList v))"
|
||||
])
|
||||
))
|
||||
where
|
||||
|
|
@ -153,13 +153,13 @@ genSetInstance x
|
|||
modify (Map.insert tk (show $ typeOf s,
|
||||
Detailed (DataBox s) [DataBox x]
|
||||
(\(funcSameType, funcNewType) ->
|
||||
[funcSameType ++ " () ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in"
|
||||
," do s <- mapM (" ++ funcNewType ++ " ops ()) sns"
|
||||
[funcSameType ++ " _ ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in"
|
||||
," do s <- mapM (" ++ funcNewType ++ " ops BaseOpMRoute) sns"
|
||||
," return (Set.fromList s)"
|
||||
])
|
||||
(\(funcSameType, funcNewType) ->
|
||||
[funcSameType ++ " () ops q v = Node q (map ("
|
||||
++ funcNewType ++ " ops () Nothing) (Set.toList v))"
|
||||
[funcSameType ++ " _ ops q v = Node q (map ("
|
||||
++ funcNewType ++ " ops BaseOpMRoute Nothing) (Set.toList v))"
|
||||
])
|
||||
))
|
||||
where
|
||||
|
|
@ -347,23 +347,23 @@ instancesFrom genOverlapped genClass boxes w
|
|||
baseInst :: Maybe ([DataBox], (String, String) -> [String]) -> [String]
|
||||
baseInst mdoChildren
|
||||
= concat
|
||||
[genInst context "()" "(f, ops)" $
|
||||
[genInst context "BaseOpMRoute" "(f :-@ ops)" $
|
||||
maybe
|
||||
(if isAlgType wDType
|
||||
-- An algebraic type: apply to each child if we're following.
|
||||
then (concatMap constrCase wCtrs)
|
||||
-- A primitive (or non-represented) type: just return it.
|
||||
else [funcSameType ++ " () _ (v,_) = return v"])
|
||||
else [funcSameType ++ " _ _ (v, _) = return v"])
|
||||
(\(_,f) -> f (funcSameType, funcNewType)) mdoChildren
|
||||
,genInst [] "()" "()" [funcSameType ++ " () () (v,_) = return v"]
|
||||
,genInst [] "BaseOpMRoute" "BaseOpMRoute" [funcSameType ++ " _ _ (v, _) = return v"]
|
||||
,if genOverlapped == GenWithoutOverlapped then [] else
|
||||
genInst
|
||||
[ contextSameType "r" "ops" ]
|
||||
"((a, Route a outer) -> m a, r)" "ops"
|
||||
[funcSameType ++ " (_, rest) ops vr = " ++ funcSameType ++ " rest ops vr"]
|
||||
"(a :-@ r)" "ops"
|
||||
[funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"]
|
||||
,if genClass == GenClassPerType
|
||||
then ["class Monad m => PolyplateMRoute" ++ wMunged ++ " o o' m outer where"
|
||||
," " ++ funcSameType ++ " :: o -> o' -> (" ++ wName
|
||||
," " ++ funcSameType ++ " :: o m outer -> o' m outer -> (" ++ wName
|
||||
++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")"
|
||||
,""
|
||||
,"instance (Monad m, " ++ contextSameType "o0" "o1" ++ ") =>"
|
||||
|
|
@ -378,7 +378,7 @@ instancesFrom genOverlapped genClass boxes w
|
|||
-- this type, so we can recurse into them.
|
||||
context :: [String]
|
||||
context
|
||||
= [ contextNewType argType "(f,ops)" "()"
|
||||
= [ contextNewType argType "(f :-@ ops)" "BaseOpMRoute"
|
||||
| argType <- nub $ sort $ concatMap ctrArgTypes $
|
||||
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
|
||||
|
||||
|
|
@ -387,11 +387,11 @@ instancesFrom genOverlapped genClass boxes w
|
|||
-- then stick it back together.
|
||||
constrCase :: Constr -> [String]
|
||||
constrCase ctr
|
||||
= [ funcSameType ++ " () " ++ (if argNums == [] then "_" else "ops") ++
|
||||
" (" ++ ctrInput ++ ", " ++ (if argNums == [] then "_" else "rt") ++ ")"
|
||||
= [ funcSameType ++ " _ " ++ (if argNums == [] then "_" else "ops") ++
|
||||
" (" ++ ctrInput ++ " , " ++ (if argNums == [] then "_" else "rt") ++ ")"
|
||||
, " = do"
|
||||
] ++
|
||||
[ " r" ++ show i ++ " <- " ++ funcNewType ++ " ops () (a" ++ show i
|
||||
[ " r" ++ show i ++ " <- " ++ funcNewType ++ " ops BaseOpMRoute (a" ++ show i
|
||||
++ ", rt @-> makeRoute [" ++ show i ++ "] "
|
||||
++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i
|
||||
++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ "))))"
|
||||
|
|
@ -414,7 +414,7 @@ instancesFrom genOverlapped genClass boxes w
|
|||
otherInst wKey containedKeys c cKey
|
||||
= if not shouldGen then [] else
|
||||
genInst context
|
||||
("((" ++ cName ++ ", Route (" ++ cName ++ ") outer) -> m (" ++ cName ++ "), r)")
|
||||
("((" ++ cName ++ ") :-@ r)")
|
||||
"ops"
|
||||
impl
|
||||
where
|
||||
|
|
@ -424,19 +424,19 @@ instancesFrom genOverlapped genClass boxes w
|
|||
| wKey == cKey
|
||||
= (True
|
||||
,[]
|
||||
,[funcSameType ++ " (f, _) _ vr = f vr"])
|
||||
,[funcSameType ++ " (f :-@ _) _ vr = f vr"])
|
||||
-- This type might contain the type that the transformation acts
|
||||
-- upon
|
||||
| cKey `Set.member` containedKeys
|
||||
= (True
|
||||
,[contextSameType "r" ("((" ++ cName ++ ", Route (" ++ cName ++ ") outer) -> m (" ++ cName ++ "), ops)")]
|
||||
,[funcSameType ++ " (f, rest) ops vr = " ++ funcSameType ++ " rest (f, ops) vr"])
|
||||
,[contextSameType "r" ("((" ++ cName ++ ") :-@ ops)")]
|
||||
,[funcSameType ++ " (f :-@ rest) ops vr = " ++ funcSameType ++ " rest (f :-@ ops) vr"])
|
||||
-- This type can't contain the transformed type; just move on to the
|
||||
-- next transformation.
|
||||
| genOverlapped == GenWithoutOverlapped
|
||||
= (True
|
||||
,[contextSameType "r" "ops"]
|
||||
,[funcSameType ++ " (_, rest) ops vr = " ++ funcSameType ++ " rest ops vr"])
|
||||
,[funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"])
|
||||
-- This is covered by one big overlapping instance:
|
||||
| otherwise = (False,[],[])
|
||||
|
||||
|
|
|
|||
|
|
@ -30,22 +30,25 @@ import Data.Generics.Polyplate.Route
|
|||
-- 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
|
||||
-- (see 'applyBottomUp').
|
||||
makeBottomUp :: Polyplate t () opT => opT -> (t -> t) -> t -> t
|
||||
makeBottomUp :: Polyplate t BaseOp opT => opT -> (t -> t) -> t -> t
|
||||
makeBottomUp ops f v = f (makeDescend ops v)
|
||||
|
||||
-- | Given a list of operations and a monadic 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
|
||||
-- (see 'applyBottomUpM').
|
||||
makeBottomUpM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t
|
||||
makeBottomUpM :: PolyplateM t BaseOpM opT m => opT m -> (t -> m t) -> t -> m t
|
||||
makeBottomUpM ops f v = makeDescendM ops v >>= f
|
||||
|
||||
-- | As makeBottomUpM, but with routes as well.
|
||||
makeBottomUpMRoute :: PolyplateMRoute t () opT m outer =>
|
||||
opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t
|
||||
makeBottomUpMRoute :: forall m opT t outer. PolyplateMRoute t BaseOpMRoute opT m outer =>
|
||||
opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t
|
||||
makeBottomUpMRoute ops f (v, r)
|
||||
= do v' <- transformMRoute () ops (v, r)
|
||||
= do v' <- transformMRoute base ops (v, r)
|
||||
f (v', r)
|
||||
where
|
||||
base :: BaseOpMRoute m outer
|
||||
base = baseOpMRoute
|
||||
|
||||
-- | 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.
|
||||
|
|
@ -58,15 +61,15 @@ makeTopDown ops f v = makeDescend ops (f v)
|
|||
-- 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
|
||||
-- (see 'applyTopDownM').
|
||||
makeTopDownM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t
|
||||
makeTopDownM :: PolyplateM t BaseOpM opT m => opT m -> (t -> m t) -> t -> m t
|
||||
makeTopDownM ops f v = f v >>= makeDescendM ops
|
||||
|
||||
-- | As makeTopDownM, but with routes as well.
|
||||
makeTopDownMRoute :: PolyplateMRoute t () opT m outer =>
|
||||
opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t
|
||||
makeTopDownMRoute :: PolyplateMRoute t BaseOpMRoute opT m outer =>
|
||||
opT m outer -> ((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)
|
||||
transformMRoute baseOpMRoute ops (v', r)
|
||||
|
||||
|
||||
|
||||
|
|
@ -86,8 +89,8 @@ makeCheckM ops f v
|
|||
-- the item in the list, False to drop it), finds all items of type \"s\" in some
|
||||
-- larger item (of type \"t\") that satisfy this function, listed in depth-first
|
||||
-- order.
|
||||
listifyDepth :: (PolyplateM t (OneOpM (State [s]) s) () (State [s])
|
||||
,PolyplateM s () (OneOpM (State [s]) s) (State [s])) => (s -> Bool) -> t -> [s]
|
||||
listifyDepth :: (PolyplateM t (OneOpM s) BaseOpM (State [s])
|
||||
,PolyplateM s BaseOpM (OneOpM s) (State [s])) => (s -> Bool) -> t -> [s]
|
||||
-- We use applyBottomUp because we are prepending to the list. If we prepend from
|
||||
-- the bottom up, that's the same as appending from the top down, which is what
|
||||
-- this function is meant to be doing.
|
||||
|
|
@ -96,8 +99,8 @@ listifyDepth qf = flip execState [] . applyBottomUpM qf'
|
|||
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)
|
||||
listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) (State [(s, Route s t)]) t
|
||||
,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) (State [(s, Route s t)]) t)
|
||||
=> ((s, Route s t) -> Bool) -> t -> [(s, Route s t)]
|
||||
listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'
|
||||
where
|
||||
|
|
@ -112,15 +115,15 @@ listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'
|
|||
--
|
||||
-- This can be used, for example, to perform checks on items in an error monad,
|
||||
-- or to accumulate information in a state monad.
|
||||
checkDepthM :: (Monad m, PolyplateM t (OneOpM m s) () m
|
||||
, PolyplateM s () (OneOpM m s) m) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM m
|
||||
, PolyplateM s BaseOpM (OneOpM s) m) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return ()
|
||||
|
||||
-- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the
|
||||
-- other on type \"s\").
|
||||
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM m r s) () m
|
||||
, PolyplateM r () (TwoOpM m r s) m
|
||||
, PolyplateM s () (TwoOpM m r s) m
|
||||
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM) m
|
||||
, PolyplateM r (BaseOpM) (TwoOpM r s) m
|
||||
, PolyplateM s (BaseOpM) (TwoOpM r s) m
|
||||
) =>
|
||||
(r -> m ()) -> (s -> m ()) -> t -> m ()
|
||||
checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
|
||||
|
|
@ -134,31 +137,35 @@ checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
|
|||
-- traversal in order of a constructor's children (assuming you are using one of
|
||||
-- the generated instances, not your own), descending first and applying the function
|
||||
-- afterwards on the way back up.
|
||||
applyBottomUpM :: (PolyplateM t (OneOpM m s) () m,
|
||||
PolyplateM s () (OneOpM m s) m) =>
|
||||
applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM m,
|
||||
PolyplateM s BaseOpM (OneOpM s) m) =>
|
||||
(s -> m s) -> t -> m t
|
||||
applyBottomUpM f = makeRecurseM ops
|
||||
where
|
||||
ops = baseOp `extOpM` makeBottomUpM ops f
|
||||
ops = baseOpM `extOpM` makeBottomUpM ops f
|
||||
|
||||
applyBottomUpMRoute :: (PolyplateMRoute t (OneOpMRoute m s t) () m t,
|
||||
PolyplateMRoute s () (OneOpMRoute m s t) m t) =>
|
||||
applyBottomUpMRoute :: forall m s t.
|
||||
(PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) m t,
|
||||
PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) m t) =>
|
||||
((s, Route s t) -> m s) -> t -> m t
|
||||
applyBottomUpMRoute f x = transformMRoute ops () (x, identityRoute)
|
||||
applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute)
|
||||
where
|
||||
ops = baseOp `extOpMRoute` makeBottomUpMRoute ops f
|
||||
base :: BaseOpMRoute m t
|
||||
base = baseOpMRoute
|
||||
|
||||
ops = base `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,
|
||||
PolyplateM sA () (TwoOpM m sA sB) m,
|
||||
PolyplateM sB () (TwoOpM m sA sB) m
|
||||
applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM) m,
|
||||
PolyplateM sA (BaseOpM) (TwoOpM sA sB) m,
|
||||
PolyplateM sB (BaseOpM) (TwoOpM sA sB) m
|
||||
) =>
|
||||
(sA -> m sA) -> (sB -> m sB) -> t -> m t
|
||||
applyBottomUpM2 fA fB = makeRecurseM ops
|
||||
where
|
||||
ops = baseOp `extOpM` makeBottomUpM ops fA `extOpM` makeBottomUpM ops fB
|
||||
ops = makeBottomUpM ops fA :-* makeBottomUpM ops fB :-* baseOpM
|
||||
|
||||
-- | As 'applyBottomUpM', but non-monadic.
|
||||
applyBottomUp :: (Polyplate t (OneOp s) (),
|
||||
|
|
@ -183,23 +190,23 @@ applyBottomUp2 fA fB = makeRecurse ops
|
|||
-- traversal in order of a constructor's children (assuming you are using one of
|
||||
-- the generated instances, not your own), applying the function first and then
|
||||
-- descending.
|
||||
applyTopDownM :: (PolyplateM t (OneOpM m s) () m,
|
||||
PolyplateM s () (OneOpM m s) m) =>
|
||||
applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM m,
|
||||
PolyplateM s BaseOpM (s :-* BaseOpM) m) =>
|
||||
(s -> m s) -> t -> m t
|
||||
applyTopDownM f = makeRecurseM ops
|
||||
where
|
||||
ops = baseOp `extOpM` makeTopDownM ops f
|
||||
ops = makeTopDownM ops f :-* baseOpM
|
||||
|
||||
-- | As applyTopDownM, but applies two functions. These should not be modifying
|
||||
-- the same type.
|
||||
applyTopDownM2 :: (PolyplateM t (TwoOpM m sA sB) () m,
|
||||
PolyplateM sA () (TwoOpM m sA sB) m,
|
||||
PolyplateM sB () (TwoOpM m sA sB) m
|
||||
applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM m,
|
||||
PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM) m,
|
||||
PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM) m
|
||||
) =>
|
||||
(sA -> m sA) -> (sB -> m sB) -> t -> m t
|
||||
applyTopDownM2 fA fB = makeRecurseM ops
|
||||
where
|
||||
ops = baseOp `extOpM` makeTopDownM ops fA `extOpM` makeTopDownM ops fB
|
||||
ops = makeTopDownM ops fA :-* makeTopDownM ops fB :-* baseOpM
|
||||
|
||||
|
||||
{- TODO
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user