------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {- LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- -- | -- Module : SAI.Data.Generics.Shape.SYB.Filter -- Copyright : (c) Andrew Seniuk, 2014 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : rasfar@gmail.com -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- -- This package provides SYB shape support: generic mapping to -- homogeneous types, and related features. Complements existing -- Uniplate and TH shape libraries. See <http://www.fremissant.net/shape-syb> -- for more information. -- -- The present module provides limited support for structure-changing -- transformations, some generic, others on the homogeneous types. -- ----------------------------------------------------------------------------- module SAI.Data.Generics.Shape.SYB.Filter ( -- * Lifted result, but good structure preservation (via glue nodes) -- | These functions simplify the structure by removing all possible -- 'Nothing' nodes, without disrupting the lineal relations obtaining -- between 'Just' nodes. -- -- Recall that -- -- @type 'HomoM' r = 'Homo' ('Maybe' r)@ -- -- and -- -- @type 'BiM' r = 'Bi' ('Maybe' r) = 'Homo' ('Dynamic', ('Maybe' r))@ -- -- See "Shape.SYB" for other functions involving 'HomoM' and 'BiM'. filterHomoM , filterBiM , -- * Lifted argument, as well as result; same transformation -- | Note that these functions don't take a predicate; -- the filtering predicate is encoded in the @'Maybe' r@ input. filterHomoMM , filterBiMM , -- * Unlifted result, but less structure preserved (no glue nodes) -- | These filter functions produce trees containing only nodes -- which satisfy the predicate, and yet which inherit the structure -- of the argument to some extent. -- -- For each node N, the algorithm acts on all children C of N which -- fail the predicate. The transformation is to move the -- grandchildren of N via C into child position, in place of C, -- which is elided. Recurse to fixed point. (You'd think one of -- bottom-up or top-down would do it in one pass, but ... maybe I -- did something wrong...) -- -- Other transformations are possible; see also 'filterHomoM_. filterHomo , filterHetero , filterBi , -- * Lifted argument, less structure preservation (no glue nodes) -- | These don't require a predicate or default values, depending -- instead on 'Nothing' for default, and on the predicate being -- encoded as 'Nothing' / 'Just'. filterHomoM_ , filterHomoM_' , -- * Experimental... gfilter , gfilter_ , mkQP , -- XXX unfortunately the user must deal with this shapeOf_ , ) where ------------------------------------------------------------------------------- import Data.Data ( cast ) import Data.Data ( gfoldl ) import Data.Data ( gmapQ ) import Data.Data ( Data ) import Data.Data ( Typeable ) import Data.Generics.Aliases ( GenericQ ) import Data.Generics.Aliases ( mkQ ) import Data.Generics.Aliases ( extQ ) --import Data.Function ( fix ) import Data.Dynamic --import Data.HList import Data.Maybe import SAI.Data.Generics.Shape.SYB import Debug.Trace ( trace ) ------------------------------------------------------------------------------- filterHomo :: (r -> Bool) -> Homo r -> Homo r filterHomo p = condenseHomo (filterHomo' p) --filterHetero :: (r -> Bool) -> Hetero -> Hetero filterHetero :: Typeable r => (r -> Bool) -> Hetero -> Hetero --filterHetero :: (Show r,Typeable r) => (r -> Bool) -> Hetero -> Hetero --filterHetero p = condenseHetero (trace "==================" $ filterHetero' p) filterHetero p = condenseHetero (filterHetero' p) filterBi :: (r -> Bool) -> Bi r -> Bi r filterBi p = condenseBi (filterBi' p) ------------------------------------------------------------------------------- filterHomo' :: (r -> Bool) -> Homo r -> Homo r filterHomo' p (Node rp chsp) = Node rp chsp' -- XXX root stays... where chsp' = map (filterHomo' p) $ concatMap f chsp -- top-down -- chsp' = concatMap f chsp -- bottom-up -- How come these all give errors? (see also filterBi') -- f :: Rose r -> [ Rose r ] -- f :: Homo r -> [ Homo r ] -- f :: Homo r' -> [ Homo r' ] f c@(Node rc chsc) | p rc = [c] | otherwise = chsc' where chsc' = chsc -- top-down -- chsc' = map (filterHomo' p) chsc -- bottom-up --filterHetero' :: (r -> Bool) -> Hetero -> Hetero filterHetero' :: Typeable r => (r -> Bool) -> Hetero -> Hetero --filterHetero' :: (Show r,Typeable r) => (r -> Bool) -> Hetero -> Hetero filterHetero' p (Node d chsp) = Node d chsp' -- XXX root stays... where chsp' = map (filterHetero' p) $ concatMap f chsp -- It seems this one does not give an error (no type vars?): f :: Rose Dynamic -> [ Rose Dynamic ] f c@(Node dc chsc) #if 1 | isNothing mrc = chsc' | p rc = [c] | otherwise = chsc' #else | isNothing mrc = trace ("*1> "++showDyn dc) $ chsc' | p rc = trace ("*2> "++showDyn dc) $ [c] | otherwise = trace ("*3> "++showDyn dc) $ chsc' #endif where -- mrc = cast dc :: Typeable r => Maybe r -- mrc = cast dc mrc = fromDynamic dc rc = fromJust mrc chsc' = chsc filterBi' :: (r -> Bool) -> Bi r -> Bi r filterBi' p (Node (d,rp) chsp) = Node (d,rp) chsp' -- XXX root stays... where chsp' = map (filterBi' p) $ concatMap f chsp -- How come these all give errors? -- f :: Rose (Dynamic,r) -> [ Rose (Dynamic,r) ] -- f :: Bi r' -> [ Bi r' ] -- f :: Bi r -> [ Bi r ] -- f :: forall r. Bi r -> [ Bi r ] -- f :: forall r'. Bi r' -> [ Bi r' ] f c@(Node (_,rc) chsc) | p rc = [c] | otherwise = chsc' where chsc' = chsc ------------------------------------------------------------------------------- -- condense can (in principle) diverge, so watch your algorithm... condenseHomo :: (Homo a -> Homo a) -> Homo a -> Homo a condenseHomo = condenseRose condenseHetero :: (Hetero -> Hetero) -> Hetero -> Hetero condenseHetero = condenseRose condenseBi :: (Bi a -> Bi a) -> Bi a -> Bi a condenseBi = condenseRose -- Had kept the original Eq versions; but there's simply no point, -- as the values are never changed by the algorithm! -- See cotemp (20140616131313) ./t01... ------------------------------------------------------------------------------- -- I started by assuming the "fix" function would be appropriate, -- then didn't figure out how to use it. Then I wrote this; although -- Math.Sequence.Converge could be used, it's such little code for -- and extra library dep. I toyed with names "myfix", "converge", -- "limit", and finally settled on "condense". condenseRose :: (Rose a -> Rose a) -> Rose a -> Rose a -- can diverge!... condenseRose f z = condenseRose' $ iterate f z --condenseRose f z = condenseRose' $ ( iterate f z :: [ Rose a ] ) where -- It would be preferable to accumulate the size info with f, -- that is, to wrap f into an f' which also accumulates and -- returns the size; there's no excuse to traverse it twice, -- and I highly doubt this will fuse... condenseRose' :: [ Rose a ] -> Rose a condenseRose' (x:y:t) | sizeOfRose x == sizeOfRose y = x | otherwise = condenseRose' (y:t) -- no other cases needed -- we know the argument is infinite -- May as well provide it since it makes sense and is the most general: condenseEq :: Eq a => (a -> a) -> a -> a -- can diverge!... condenseEq f z = condenseEq' $ iterate f z where condenseEq' (x:y:t) | x == y = x | otherwise = condenseEq' (y:t) -- condenseEq' [x] = x -- condenseEq' [] = error "condenseEq: empty list" -- no other cases needed -- we know the argument is infinite -- (this function must not be exported for this reason, however) ------------------------------------------------------------------------------- -- ============================================================================ -- -- Experimental code follows!... -- -- ============================================================================ ------------------------------------------------------------------------------- -- | Later yet: It didn't quite work out. (However, using Dynamic -- may be a way to get around?) The trouble is, the user ... -- actually there\'s one more thing I can test ... was thinking -- about this while falling asleep -- how to automatically -- \"lift and extend\" a user-defined non-generic function -- -- @f :: SomeType -> Result@ -- -- to -- -- @f :: SomeType -> Maybe Result@ -- -- also automatically providing the default case (which the user -- can't provide without either lifting their type themself, or -- constructing some value of type (can use undefined?...) -- Going to try this possibility first... In a \"gfilter2\". -- -- Later: -- Do the following procedure: -- (Going to try allowing passing of non-generic p and f, first. -- However, if would have used extQ, this will not allow it...) -- -- 1. Wrap f to f', which uses Maybe r. -- -- 2. Do the generic homomorphism to Maybe r, using Nothing -- for a node iff the predicate fails. -- -- 3. Call filterHomo on the result (Homo (Maybe a)), -- with predicate (not . isNothing). -- -- 4. Unwrap Homo (Maybe a) result of 3., to final Homo a result. -- -- Old comments: -- Intended for use with fully generic predicate, NOT as -- a stop condition, but as a structure-modifying tree rewrite -- as done for filterHomo. Nodes are retained if and only if -- they satisfy the predicate. An effort is made to preserve -- structure, it's simple enough to be in the canonical regime, -- but other transformations are possible. -- It seems the caller must also call mkQP? gfilter :: forall r d. Data d => -- forall r d. (Show r, Data d) => -- forall r d. (Show r, Eq r, Data d) => -- forall r d. (Eq r, Data d) => -- (forall d. (Data d, Typeable d) => d -> Bool) -- GenericQ Bool --- -> (r -> r -> r) (forall d. (Data d, Typeable d) => d -> Maybe r) -- GenericQ r -> d -> [Homo r] gfilter fmk x = #if 0 #elif 1 filterHomoM_ $ ghom fmk x #elif 0 ( filterHomoM_ $ ghom fmk x ) :: [ Homo r ] #elif 0 map (fmap fromJust) $ ( ( filterHomoM_ (not . isNothing) $ ( ghom fmk x ) :: HomoM r ) :: [ HomoM r ] ) #endif -- | Analogous to 'gfilter', but takes a default value in @r@ and -- returns a single tree (instead of a forest). Uses 'filterHomoM_''. gfilter_ :: forall r d. Data d => -- forall r d. (Show r, Data d) => -- forall r d. (Show r, Eq r, Data d) => r -> (forall d. (Data d, Typeable d) => d -> Maybe r) -> d -> Homo r gfilter_ rdflt fmk x = ( filterHomoM_' rdflt $ ghom fmk x ) :: Homo r -- | Another alternative (may not work): -- Take non-generic predicate and transform, and do here all of: -- - lifting to Maybe -- - providing the default case needed by mkQ -- - doing mkQ on the predicate and transform -- This has obvious appeal as the API user need not use -- and generics functions directly. However, a weakness -- is, only a single type for predicate, and only a single -- (possibly other) type for the transform, can be dealt with. -- So there is also gfilter3 which takes generic predicate -- and function, so the user can use extQ as needed to cover -- more than a single type. -- There may be an even better way, maybe using Data.Dynamic?... #if 0 gfilter2 :: forall r d. (Show r, Data d) => -- forall r d. (Show r, Eq r, Data d) => -- forall r d. (Eq r, Data d) => #if 1 ((Data d, Typeable d) => d -> Bool) ((Data e, Typeable e) => e -> r) #else -- (forall d. (Data d, Typeable d) => d -> Bool) (forall d. (Data d, Typeable d) => d -> r) -- GenericQ r #endif -> d -> [Homo r] gfilter2 f x = filterHomoM_ $ ghom fmk x #endif #if 0 -- | XXX This is not working yet. Is it possible? Not clear from -- the errors whether it can't be done, or it's just my mistakes... --------- -- Similar to gfilter2, but slightly less automated: -- The user must provide generic predicate and transform, -- prepared upstream using mkQ -- however, they may omit -- the default case! (If they include it it's okay.) -- The default case for predicate is always p x = False. -- The default for transform CAN perhaps be f x = undefined. -- -- Maybe it won't make sense to have a generic predicate... gfilter3 :: forall r d d1 d2. ({-Data r,-} Typeable r, Show r, -- forall r d d1 d2. ({-Data r,-} Typeable r, Show r, Eq r, Data d, Data d1, Data d2, Typeable d, Typeable d1, Typeable d2) => (d1 -> Bool) -> (d2 -> r) -> d -> [Homo r] gfilter3 pg fg x = filterHomoM_ $ ghom fmk x where #if 0 #elif 0 f'' = cast fg :: Maybe (d2 -> Maybe r) #elif 1 f'' = cast fg :: Maybe (forall d3. (Data d3, Typeable d3) => d3 -> Maybe r) #elif 0 f'' = cast fg #elif 0 f'' = fg #elif 0 f' = unmkQ fg f'' | ... #endif -- fmk = mkQ Nothing $ fromJust f'' :: d2 -> Maybe r -- fmk = mkQ Nothing $ ( ( fromJust f'' ) :: d2 -> Maybe r ) :: d2 -> Maybe r -- fmk = mkQ Nothing $ ( ( fromJust f'' ) :: d2 -> Maybe r ) :: (forall d3. Data d3 => d3 -> Maybe r) fmk = mkQ Nothing $ fromJust f'' #endif ------------------------------------------------------------------------------- -- | Would like to be able to call this automatically from gfilter, -- but I think the user code must call it, and pass the result -- to gfilter... #if 0 #elif 0 -- nope (compiles, but get type errors when try to use) mkQP :: forall r a. Typeable a => (r -> Bool) -> (a -> Maybe r) -> a -> Maybe r #elif 0 -- nope mkQP :: forall r a. Typeable a => (r -> Bool) -> (forall b. Typeable b => b -> Maybe r) -> a -> Maybe r #elif 0 -- nope mkQP :: forall r t. ( Typeable t -- , Eq r ) => (r -> Bool) -> (forall u. Typeable u => u -> Maybe r) -> t -> Maybe r #elif 1 -- This one works. -- You don't need the quantification, if you drop the explicit -- expression sig (:: Maybe b) in the function definition. mkQP :: forall r a b. ( Typeable a , Typeable b -- , Eq r ) => (r -> Bool) -- (forall c. Data c => c -> Bool) -> (b -> Maybe r) -- -> (b -> r) -> a -> Maybe r #endif mkQP p br a = case cast a :: Maybe b of Just b -> let brb = br b in if isNothing brb then Nothing else if p (fromJust brb) then brb else Nothing Nothing -> Nothing ------------------------------------------------------------------------------- -- | 'filterHomoM_' acts on a lifted type to avoid needing to -- specify any default values; however, the root node cannot -- be eliminated by this algorithm, so in case the root is -- a 'Nothing', we need to return its child branches as a forest. filterHomoM_ :: HomoM r -> [Homo r] --filterHomoM_ :: Show r => HomoM r -> [Homo r] filterHomoM_ x --- | trace (show final) $ False = undefined | otherwise = map (fmap fromJust) forest where p = not . isNothing forest | p r_root = [final] | otherwise = chs_root #if 0 final@(Node r_root chs_root) = condenseHomo (filterHomo' p) x #else -- Needed! (and the error hasn't fired so far...) final@(Node r_root chs_root) = prune $ condenseHomo (filterHomo' p) x prune (Node r chs) = Node r (map prune chs') where chs' = filter pp chs pp (Node rx chsx) | null chsx = not $ isNothing rx | otherwise = error "filterHomo-prune: interior non-root Nothing!" #endif -- | 'filterHomoM_' plus a root default value in the homogeneous type; -- this allows us to always return a single rooted tree in type @'Homo' r@. -- Compare to 'filterHomoM_' which, lacking such a root default, -- is obliged to return @['Homo' r]@. filterHomoM_' :: r -> HomoM r -> Homo r --filterHomoM_' :: Show r => r -> HomoM r -> Homo r filterHomoM_' rdflt x | null forest = error "filterHomoM_': null forest" | length forest > 1 = Node rdflt forest | otherwise = head forest -- this sucks (not just b/c it's -- using "unsafe" head -- it's safe here -- for the moment, as semantically we -- know it's non-empty if get to this case; -- but such code is fragile, since cases -- have a tendency to see code change, which -- can be arbitrarily lexically-decoupled -- from the head call; and it just sucks -- for being so inexpressive/obscure... where forest = filterHomoM_ x ------------------------------------------------------------------------------- -- | Tolerate lifted nodes in the result, in exchange for -- better structure preservation. -- -- Lineal ordering is preserved among 'Just' nodes. -- -- In the end, this is probably the most useful (unless one that -- takes a generic predicate, and acts on original types obtained -- via fromDyn[amic]...). filterHomoM :: (r -> Bool) -> Homo r -> HomoM r filterHomoM p x = x'' where p' y = if p y then Just y else Nothing x_ = fmap p' x -- x_ = fmap (\ r -> p' r ) x -- XXX oops, we don't even need the weights, done this way... x' = condenseHomo defuzz x_ -- Surely can do bottom-up and avoid iterating, but let's -- get a correct output first!... defuzz :: HomoM r -> HomoM r defuzz (Node v chs) = Node v $ map defuzz chs' where chs' = filter g chs g (Node Nothing []) = False g _ = True x'' = condenseHomo contractGlue x' -- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x' -- x'' = contractGlue x' contractGlue :: HomoM r -> HomoM r contractGlue (Node r chs) = Node r $ map contractGlue chs' where chs' = map contractNothing1 chs contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch contractNothing1 v = v -- | As per 'filterHomoM', but we string along the 'Dynamic' component. filterBiM :: (r -> Bool) -> Bi r -> BiM r filterBiM p x = x'' where p' y = if p y then Just y else Nothing x_ = fmap (\ (d,r) -> (d,p' r) ) x -- XXX oops, we don't even need the weights, done this way... x' = condenseBi defuzz x_ -- Surely can do bottom-up and avoid iterating, but let's -- get a correct output first!... defuzz :: BiM r -> BiM r defuzz (Node v chs) = Node v $ map defuzz chs' where chs' = filter g chs g (Node (_,Nothing) []) = False g _ = True x'' = condenseBi contractGlue x' -- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x' -- x'' = contractGlue x' contractGlue :: BiM r -> BiM r contractGlue (Node r chs) = Node r $ map contractGlue chs' where chs' = map contractNothing1 chs contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch contractNothing1 v = v ------------------------------------------------------------------------------- -- | Tolerate lifted nodes in the result, in exchange for -- better structure preservation. -- -- Lineal ordering is preserved among 'Just' nodes. filterHomoMM :: HomoM r -> HomoM r --filterHomoMM :: Show r => HomoM r -> HomoM r filterHomoMM x = x'' where #if 1 -- XXX oops, we don't even need the weights, done this way... x' = condenseHomo defuzz x -- Surely can do bottom-up and avoid iterating, but let's -- get a correct output first!... defuzz :: HomoM r -> HomoM r defuzz (Node v chs) = Node v $ map defuzz chs' where chs' = filter g chs g (Node Nothing []) = False g _ = True x'' = condenseHomo contractGlue x' -- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x' -- x'' = contractGlue x' contractGlue :: HomoM r -> HomoM r contractGlue (Node r chs) = Node r $ map contractGlue chs' where chs' = map contractNothing1 chs contractNothing1 (Node Nothing [ch@(Node _ chs)]) = ch contractNothing1 v = v #else -- What is wanted here is standard zipping (in combining sense) -- of rose trees, not generic ghom. xw = f x f (Node Nothing []) = Node (Nothing,0) [] f (Node (Just v) []) = Node (Just v,1) [] f (Node v chs) = Node (v,n) chs' where chs' = map f chs -- :: [ Homo (Maybe r, Int) ] -- XXX where's our base case?! n = sum $ map (\ (Node (_,m) _) -> m) chs' x'' = defuzz xw defuzz :: Homo (Maybe r, Int) -> Homo (Maybe r, Int) defuzz (Node v chs) = Node v $ map defuzz chs' where chs' = filter g chs g (Node (Nothing,_) []) = False g _ = True -- You can't do this unless you want to require Data r: -- xw = ghomK (+) (\y->case y of { Nothing -> 0 ; Just _ -> 1 }) x #if 1 x''' = prune x'' -- :: HomoM r #else x'' = zipRose x xw -- :: Homo (Maybe r, Int) x''' = prune x'' -- :: HomoM r #endif -- XXX This is wrong: prune :: Homo (Maybe r, Int) -> HomoM r prune (Node (v,0) _) = Node v [] prune (Node (v,_) chs) = Node v $ map prune chs x'''' = trace ("FOO"++show x''++"BAZ"++show x'''++"BAR") $ contractGlue x''' contractGlue :: HomoM r -> HomoM r contractGlue (Node Nothing [R Nothing chs]) = Node Nothing $ map contractGlue chs contractGlue (Node v chs) = Node v $ map contractGlue chs #endif -- | As per 'filterHomoMM', but we string along the 'Dynamic' component. filterBiMM :: BiM r -> BiM r --filterBiMM :: Show r => BiM r -> BiM r filterBiMM x = x'' where -- XXX oops, we don't even need the weights, done this way... x' = condenseBi defuzz x -- Surely can do bottom-up and avoid iterating, but let's -- get a correct output first!... defuzz :: BiM r -> BiM r defuzz (Node v chs) = Node v $ map defuzz chs' where chs' = filter g chs g (Node (_,Nothing) []) = False g _ = True x'' = condenseBi contractGlue x' -- x'' = trace ("FOO"++show x'++"BAR") $ contractGlue x' -- x'' = contractGlue x' contractGlue :: BiM r -> BiM r contractGlue (Node r chs) = Node r $ map contractGlue chs' where chs' = map contractNothing1 chs contractNothing1 (Node (_,Nothing) [ch@(Node _ chs)]) = ch contractNothing1 v = v ------------------------------------------------------------------------------- -- | Attempt to stop traversal on 'String's. -- This should be in Shape.SYB, but it would be cyclical imports -- which GHC can't handle. -- XXX This seems not to be working. -- The stop condition is not being done properly. -- Refer to everythingBut (again) to remind how to do... shapeOf_ :: forall d. Data d => d -> Shape shapeOf_ x = unliftHomoM () $ filterHomoMM $ ghom fg x --shapeOf_ x = filterHomoM_' () $ ghom fg x where fg :: forall d'. Data d' => d' -> Maybe () fg = (const (Just ())) `extQ` f_String -- fg = (const (Just ())) `SYB.extQ` f_String `SYB.extQ` f_FastString --- fg = Just `SYB.extQ` f_String `SYB.extQ` f_FastString f_String :: String -> Maybe () f_String x = Nothing -- f_FastString :: GHC.FastString -> Maybe () -- f_FastString x = Nothing -------------------------------------------------------------------------------