-------------------------------------------------------------------------------

{-# 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

-------------------------------------------------------------------------------