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

{-# LANGUAGE CPP #-}

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

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-  LANGUAGE ImpredicativeTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  SAI.Data.Generics.Shape.SYB
-- 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 the main types and functions.
--
-----------------------------------------------------------------------------

  module SAI.Data.Generics.Shape.SYB (

    -- * Types

    Homo ,
    Hetero ,
    Bi ,
    Shape ,
    HomoM ,
    BiM ,

    -- * Rose Tree Type

#if USE_DATA_TREE
    Rose ,
#else
    Rose(..) ,
#endif
--  Hose(..) ,  -- heterogeneous Rose HList

    -- * Homomorphisms

    ghom ,
    ghomK ,
    ghomDyn ,
    ghomBi ,

    -- * Inverses where possible

    unGhomDyn ,
    unGhomBi ,

    -- * Conversions
    -- | These conversion functions should obey at least the following laws.
    --
    --   @'ghom' f = 'biToHomo' . 'ghomBi' f@
    --
    --   @'biToHetero' . 'ghomBi' g = 'biToHetero' . 'ghomBi' f@
    --
    --   @'ghomBi' f = 'heteroToBi' f . 'ghomDyn'@
    --
    --   @'ghomBi' g = 'heteroToBi' g . 'biToHetero' . 'ghomBi' f@

#if 1
    biToHomo ,
    biToHetero ,
#else
    biToHomo_forgetful ,
    biToHetero_faithful ,
#endif
    heteroToBi ,

    -- * Conversions concerning lifted types

    liftHomoM ,
    liftBiM ,
    unliftHomoM ,
    unliftBiM ,

    -- * Progressive refinement and accumulation

    gempty ,
    grefine ,
--  grefineG ,  -- XXX still not rid of compiler instance errors...
    gaccum ,
#if 0
--  gassim ,
#endif

    -- * For convenience

    shapeOf ,
--  shapeOf_ ,  -- can't define here in logical place, due to cyclic imports
    sizeOf ,

    symmorphic ,
    (~~) ,

    weightedShapeOf ,

    weightedRose ,
    weightedRoseJust ,

    sizeOfRose ,

    zipRose ,
    unzipRose ,
    zipBi ,
    unzipBi ,

    zip ,
    unzip ,

    -- * Showing values
    -- | Pretty-printing of rose trees, including compact representations. Also, show functions for a subset of Dynamic values, which show the value and not just @\<\<@/type/@\>\>@.
    --- | In addition to a Show instance for Rose a which pretty-prints the tree, there are several compact representations available. Also, show functions for a subset of Dynamic values, which show the value and not just @\<\<@/type/@\>\>@.

    showHomo ,
    showHomoM ,

    showAsParens ,
    showAsParensBool ,
    showAsParensEnriched ,
    showAsParensEnrichedM ,

    showDyn ,
    showHetero ,
    showBi ,

#if USE_DATA_TREE
    -- * Re-exported from Data.Tree
    Tree(Node) , Forest ,
--  Tree(Node) ,
--  Rose(Node) ,
--  Data.Tree.Tree, Data.Tree.Node,
--  module Data.Tree ,
#else
    toDataTree ,
    fromDataTree ,
#endif

  ) where

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

  import Data.Generics.Aliases ( GenericQ )
  import Data.Generics.Aliases ( mkQ )
--import Data.Generics.Aliases ( extQ )
  import Data.Data ( Data, gmapQ )
  import Data.Dynamic
  import Data.Maybe

  -- XXX
  --
  -- Unfortunately, I think it's impossible to import a data (or type)
  -- constructor under a different name; nor is it possible to alias
  -- the name locally.  It's a shame -- we'd need toTree and fromTree
  -- just to gain access to all the standard tree library functionality.
  -- Even if we make that totally fuse, it's unpleasant.
  --
  -- The reason want custom Rose datatype is:
  --  (1) I like my Show instance better -- is it possible to override
  --      an instance of an externally-defined datatype?...
  --  (2) I like my single-character constructor "R" -- if alias
  --      Data.Tree, will need to substitute "Node" for "R" everywhere.
  --      (Obviously, I won't be writting CPP branch for this.)
  --
  -- I just scourered Data.Typeable[.Internal] and Data.Data again,
  -- but I don't see how to create a data constructor alias using
  -- those tools...
#if USE_DATA_TREE
  import Data.Tree ( Tree(Node), Forest )
--import Data.Tree ( Tree(Node) )
--import qualified Data.Tree ( Tree(Node) )
#else
  import qualified Data.Tree ( Tree(Node) )  -- still needed for to/from
#endif

  import Prelude hiding ( zip, unzip, zipWith )
  import qualified Prelude as P ( zip, unzip, zipWith )
  import Control.Applicative ( (<*>) )  -- on its own line b/c looks so cool
  import Control.Applicative ( Applicative )
--import Control.Applicative ( Applicative, (<*>) )

  import Debug.Trace ( trace )

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

  type Homo r = Rose r
  type Hetero = Homo Dynamic
  type Bi r = Homo (Dynamic, r)
  type Shape = Homo ()
  type HomoM r = Homo (Maybe r)
  type BiM r = Bi (Maybe r)
--type Homo = Rose  -- seems fine ... but I prefer the explicitly-param'sd
--type Hetero = Rose HList  -- a possible alternative to Dynamic

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

#if USE_DATA_TREE
  -- | From "Data.Tree" we have, essentially
  --
  -- @data 'Tree' r = 'Node' r ['Tree' r]@
  type Rose = Data.Tree.Tree
--R = Data.Tree.Node  -- we wish...
#else
-- Later: try this:
--data Rose f r = Node r (f (Rose f r)) deriving (Applicative,Functor)
  data Rose r = Node r [Rose r] deriving Functor
--data Rose f r = R r (f (Rose f r)) deriving (Applicative,Functor)
--data Rose r = R r [Rose r] deriving Functor
  type Tree = Rose

  instance Show r => Show (Rose r) where
    show = show' 0
     where show' n (Node r chs) =
                indent n ++ show r ++ "\n"
             ++ concatMap (show' (1+n)) chs
             where indent n = replicate (2*n) ' '

  -- (was used, but not used at the moment)
  instance Eq r => Eq (Rose r) where
     (==) = eq
      where
       eq (Node r []) (Node r' []) = r == r'
       eq (Node _ []) (Node _ _) = False
       eq (Node _ _) (Node _ []) = False
       eq (Node r chs) (Node r' chs')
        = r == r' && and (zipWith eq chs chs')
#endif

  showHomo :: Show r => Rose r -> String
  showHomo = show' 0
   where show' n (Node r chs) =
              indent n ++ show r ++ "\n"
           ++ concatMap (show' (1+n)) chs
           where indent n = concat $ replicate n "| "

  showHomoM :: Show r => Rose (Maybe r) -> String
  showHomoM = show' 0
   where show' n (Node mr chs) =
           ( case mr of
              Nothing -> indent n ++ "\n"
              Just r -> indent n ++ show r ++ "\n"
           ) ++ concatMap (show' (1+n)) chs
           where indent n = concat $ replicate n "| "

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

  -- | Map an arbitrary data constructor application expression to
  -- a homogeneous representation preserving structure.
  -- This is a one-way trip; what value information is preserved
  -- depends on the mapping function you provide.
  -- Use 'ghomDyn' or 'ghomBi' if you need to be able
  -- to recover the original, heterogeneous data.
  ghom :: forall r d. Data d => GenericQ r -> d -> Homo r
  ghom f x = foldl k b (gmapQ (ghom f) x)
   where
     b = Node (f x) []
     k (Node r chs) nod = Node r (chs++[nod])

  -- | Like ghom, but use a custom combining function, instead of
  -- the default @(\\r _->r)@.
  ghomK :: forall r d. Data d =>
             (r -> r -> r)
          -> GenericQ r
          -> d
          -> Homo r
  ghomK k f x = foldl k' b (gmapQ (ghomK k f) x)
   where
     b = Node (f x) []
     k' (Node r chs) nod@(Node r' _) = Node (r `k` r') (chs++[nod])

  -- | Uses "Data.Dynamic" to support mutiple types homogeneously.
  -- Unlike 'ghom', this is invertible ('unGhomDyn').
#if 1
  ghomDyn :: forall d. Data d => d -> Hetero
  ghomDyn x = foldl k b (gmapQ ghomDyn x)
   where
     b = Node (toDyn x) []
     k (Node r chs) nod = Node r (chs++[nod])
#else
  ghomDyn :: forall r d. (Typeable r, Data d) => GenericQ r -> d -> Hetero
  ghomDyn f x = foldl k b (gmapQ (ghomDyn f) x)
   where
     b = Node (toDyn (x, f x)) []
     k (Node r chs) nod = Node r (chs++[nod])
#endif

  -- | @'ghomBi' f x = 'zipRose' ('ghomDyn' x) ('ghom' f x)@
  --
  -- Unlike 'ghom', you can recover the original, polytypic term ('unGhomBi').
  ghomBi :: forall r d. Data d => GenericQ r -> d -> Bi r
--ghomBi :: forall r d. (Show d, Show r, Data d) => GenericQ r -> d -> Bi r
#if 1
  ghomBi f x = zipRose (ghomDyn x) $ ghom f x
--ghomBi f x = trace (show (ghomDyn x) ++ "\n" ++ show (ghom f x)) $ zipRose (ghomDyn x) $ ghom f x
#else
  ghomBi f x = foldl k b (gmapQ (ghomBi f) x)
   where
     b = Node (toDyn x, f x) []
     k (Node r chs) nod = Node r (chs++[nod])
#endif

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

  unGhomDyn :: Typeable a => Hetero -> a
  unGhomDyn (Node xd chs) = fromJust $ fromDynamic xd

  unGhomBi :: Typeable a => Bi r -> a
  unGhomBi (Node (xd,r) chs) = fromJust $ fromDynamic xd

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

#if 1
  -- | Drops the 'Dynamic' component.
  biToHomo :: Bi r -> Homo r
  biToHomo (Node (_,r) chs) = Node r (map biToHomo chs)

  -- | Drops the homogeneous component (type @r@).
  biToHetero :: Bi r -> Hetero
  biToHetero (Node (d,_) chs) = Node d (map biToHetero chs)
#else
  -- | \"Forgetful\" since pre-homomorphism info is discarded.
  biToHomo_forgetful :: Bi r -> Homo r
  biToHomo_forgetful (Node (_,r) chs) = Node r (map biToHomo_forgetful chs)

  -- | \"Faithful\" since you can apply 'heteroToBi' with the original
  -- mapping function to obtain a 'Bi' again.
  biToHetero_faithful :: Bi r -> Hetero
  biToHetero_faithful (Node (d,_) chs) = Node d (map biToHetero_faithful chs)
#endif

  heteroToBi :: forall r d.(Data d,Typeable d,Typeable r) =>
                   r
                -> (d -> r)
                -> Hetero -> Bi r
  heteroToBi z f (Node dc chs) = Node (dc, fx) chs'
   where
    chs' = map (heteroToBi z f) chs
    fg = mkQ z f :: GenericQ r
    fx | isNothing mrc  = z
       | otherwise      = fg rc
    mrc = fromDynamic dc :: Maybe d
    rc = fromJust mrc

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

  -- | Conversion from 'Homo' to 'HomoM' by wrapping values in 'Just'.
  liftHomoM :: Homo r -> HomoM r
  liftHomoM = fmap Just

  -- | Analogous to 'liftHomoM'.
  liftBiM :: Bi r -> BiM r
  liftBiM (Node (d,r) chs) = Node (d,Just r) $ map liftBiM chs

  -- | Sometimes it makes sense to replace the 'Nothing' nodes with
  -- a default value in type @r@.
  --
  -- The best default value will often be some function
  -- of the filtered, 'Just' items.
  --
  -- @'unliftHomoM' = 'fmap' . 'flip' 'maybe' 'id'@
  --
  -- Lineal ordering is preserved among 'Just' nodes.
  unliftHomoM :: r -> HomoM r -> Homo r
  unliftHomoM = fmap . flip maybe id
--unliftHomoM z = fmap (maybe z id)

  -- | Analogous to 'unliftHomoM'.
  unliftBiM :: r -> BiM r -> Bi r
  unliftBiM z (Node (d,mr) chs) = Node (d,r) $ map (unliftBiM z) chs
   where
    r | isNothing mr  = z
      | otherwise     = fromJust mr

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

  -- | Trivial homomorphism that discards all value information.
  shapeOf :: forall d. Data d => d -> Shape
  shapeOf = ghom (const ())

  -- | Generic number of nodes in a polytypic term.
  sizeOf :: forall d. Data d => d -> Int
  sizeOf = sizeOfRose . shapeOf 

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

  -- | Compare two general polytypic values for shape equality.
  symmorphic :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
#if 1
  symmorphic x y = shapeOf x == shapeOf y
#else
  symmorphic (Node v1 []) (Node v2 []) = True
  symmorphic (Node v1 []) (Node v2 _) = False
  symmorphic (Node v1 _) (Node v2 []) = False
  symmorphic (Node v1 chs1) (Node v2 chs2)
   = and $ P.zipWith symmorphic chs1 chs2
#endif

  -- | Operator synonymous with 'symmorphic'.
  (~~) :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
  (~~) = symmorphic

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

  -- | Number of nodes in a rose tree.
  sizeOfRose :: Rose a -> Int
  sizeOfRose (Node _ chs) = 1 + sum (map sizeOfRose chs)

  -- | Combine two rose trees with identical shape, by tupling their values.
  zipRose :: Rose r -> Rose s -> Rose (r,s)
#if 0
  zipRose = zip
#else
  zipRose (Node v1 []) (Node v2 []) = Node (v1,v2) []  -- yes it's needed!
  zipRose (Node v1 []) (Node v2 _) = error "zipRose: differently shaped arguments"
  zipRose (Node v1 _) (Node v2 []) = error "zipRose: differently shaped arguments"
  zipRose (Node v1 chs1) (Node v2 chs2) = Node (v1,v2) $ P.zipWith zipRose chs1 chs2
--zipRose (Node v1 chs1) (Node v2 chs2) = Node (v1,v2) $ zipWith zipRose chs1 chs2
#endif

#if 1
  -- Just wrote a bit about the dissymmetry here.
  -- It seems strange that zip should require Applicative,
  -- but unzip not require it, since the two representations
  -- are isomorphic.  It wouldn't seem strange if BOTH required
  -- both Applicative and Functor; but only one requires Applicative...
  --
  -- I get the feeling it would be wrong to conclude that, since we
  -- have an unzip which requires only Functor, it should follow
  -- there /must/ exist a zip which requires only Functor...

  -- Hey! I did it! I figured out to use Applicative, in a
  -- nice natural way (my first use of it).
#if 1
  -- to make the comparison to unzip better:
  zip :: (Applicative f, Functor f) => (f a, f b) -> f (a,b)
  zip (fa, fb) = fmap (\x -> (\y -> (x,y))) fa <*> fb
#else
  zip :: (Applicative f, Functor f) => f a -> f b -> f (a,b)
--zip :: forall a b f. Functor f => f a -> f b -> f (a,b)
  zip fa fb = fmap (\x -> (\y -> (x,y))) fa <*> fb
--zip fa fb = (<*>) ( fmap (\x -> (\y -> (x,y))) fa ) fb
#endif

#if 0
  zipWith :: Functor f => (a->b->c) -> f a -> f b -> f c
  zipWith f fa fb = (fmap (\x -> f x) fa) ...
#else
  zipWith :: (Applicative f, Functor f) => (a->b->c) -> f a -> f b -> f c
  zipWith f fa fb = fmap (\x -> (\y -> f x y)) fa <*> fb
#endif

  -- Now to try for unzip -- and yeah this works; however,
  -- the unzipRose found an efficient expression. This is 2x
  -- more work than necessary, on the same idea as unzipRose,
  -- I'm quite sure...  If it was an Arrow, then maybe...
  unzip :: Functor f => f (a,b) -> (f a, f b)
--unzip :: (Applicative f, Functor f) => f (a,b) -> (f a, f b)
  unzip fab = (fmap (\ (x,y) -> x) fab, fmap (\ (x,y) -> y) fab)
#endif

  -- XXX broken; will I have better luck using a fold?...
-- Here's unzip from GHC.List:
{-
-- | 'unzip' transforms a list of pairs into a list of first components
-- and a list of second components.
unzip    :: [(a,b)] -> ([a],[b])
{-# INLINE unzip #-}
unzip    =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
-}
  -- | Inverse of zipRose (up to Currying).
#if 0
#elif 0
  unzipRose :: Rose (r, s) -> (Rose r, Rose s)
  unzipRose rtree = (left,right)
   where
    left = fmap (\(x,y) -> x) rtree
    right = fmap (\(x,y) -> y) rtree
--unzipRose' :: Rose (r, s) -> Rose r -> Rose s -> (Rose r, Rose s)
#elif 1
  -- accumulating version?
  unzipRose :: Rose (r, s) -> (Rose r, Rose s)
  unzipRose (Node (x,y) ns) = (Node x xns, Node y yns)
   where
    (xns,yns) = unzip $ map unzipRose ns
--  (xns,yns) = P.unzip $ map unzipRose ns
#elif 0
  -- This clearly cannot work!
  unzipRose :: Rose (r, s) -> (Rose r, Rose s)
  unzipRose (Node (v1,v2) []) = (Node v1 [], Node v2 [])  -- yes it's needed!
  unzipRose (Node (v1,v2) chs) = Node (v1,v2) $ map unzipRose chs
  unzipRose' :: Rose (r, s) -> Rose r -> Rose s -> (Rose r, Rose s)
  unzipRose' (Node (v1,v2) []) acc_r acc_s = (acc_r,acc_s)
  unzipRose' (Node (v1,v2) chs) acc_r acc_s = map unzipRose chs
#endif

  -- | Zip two 'Bi's. It is the caller's responsibility to assure that
  -- the 'Dynamic' component is the same in both arguments (in addition
  -- to assuring that the shapes are compatible).
  zipBi :: Bi r -> Bi s -> Bi (r,s)
  zipBi (Node (d,v1) []) (Node (_,v2) []) = Node (d,(v1,v2)) []  -- yes it's needed!
  zipBi (Node (d,v1) []) (Node (_,v2) _) = error "zipBi: differently shaped arguments"
  zipBi (Node (d,v1) _) (Node (_,v2) []) = error "zipBi: differently shaped arguments"
  zipBi (Node (d,v1) chs1) (Node (_,v2) chs2) = Node (d,(v1,v2)) $ zipWith zipBi chs1 chs2

  unzipBi :: Bi (r, s) -> (Bi r, Bi s)
  unzipBi (Node (d,(x,y)) ns) = (Node (d,x) xns, Node (d,y) yns)
   where
    (xns,yns) = unzip $ map unzipBi ns

  -- | Produce a zipped rose tree, where the second component
  -- at a node is the number of non-'Nothing' (/i.e./ 'Just') descendants,
  -- plus one for itself if it is 'Just'.
  weightedRoseJust :: Rose (Maybe r) -> Rose (Maybe r, Int)
  weightedRoseJust (Node Nothing []) = Node (Nothing,0) []
  weightedRoseJust (Node (Just v) []) = Node (Just v,1) []
  weightedRoseJust (Node v chs) = Node (v,n) chs'
   where
    chs' = map weightedRoseJust chs -- :: [ Homo (Maybe r, Int) ]
    -- XXX where's our base case?!
    n = sum $ map (\ (Node (_,m) _) -> m) chs'

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

  -- | Weight of a node is defined as the number of descendants, plus 1.
  weightedShapeOf :: forall d. Data d => d -> Homo Int
  weightedShapeOf = ghomK (+) (const 1)

  -- Almost got away with using ghomK, but it would require
  -- Data r constraint, which is otherwise bad.
  weightedRose :: Rose r -> Rose (r, Int)
  weightedRose (Node r chs) = foldl k' b (map weightedRose chs)
   where
     k = (\ (r,w) (r',w') -> (r,w+w'))
     f = (\ r -> (r,1))
     b = Node (r,1) []
     k' (Node rw chs) nod@(Node rw' _) = Node (rw `k` rw') (chs++[nod])

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

  showAsParens :: Homo r -> String
  showAsParens (Node _ []) = "*"
  showAsParens (Node _ chs) = "(" ++ concatMap showAsParens chs ++ ")"

  showAsParensBool :: Homo Bool -> String
  showAsParensBool (Node r chs) = "(" ++ (if r then "*" else ".") ++ concatMap showAsParensBool chs ++ ")"
--showAsParensBool (Node r chs) = "(" ++ (if r then "T" else "F") ++ concatMap showAsParensBool chs ++ ")"

  showAsParensEnriched :: Show r => Homo r -> String
  showAsParensEnriched (Node r chs) = "(" ++ show r ++ concatMap showAsParensEnriched chs ++ ")"

  showAsParensEnrichedM :: Show r => HomoM r -> String
  showAsParensEnrichedM (Node Nothing chs) = "(" ++ concatMap showAsParensEnrichedM chs ++ ")"
  showAsParensEnrichedM (Node (Just r) chs) = "(" ++ show r ++ concatMap showAsParensEnrichedM chs ++ ")"

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

-- XXX There is no satisfactory solution here yet.
-- What we want is, to use the type's natural show when it's
-- an instance of Show, and otherwise use Dynamic's Show instance.
#if 0
#elif 0
  -- Doesn't work, unfortunately.
  showDyn :: Dynamic -> String
  showDyn xd
--- | typeOf x == typeOf (undefined::Show a => a)  = show x  -- would be nice!
   | test mx (undefined::Int)  = show (fromJust mx::Int)
   | test mx (undefined::[Int])  = show (fromJust mx::[Int])
   | test mx (undefined::[[Int]])  = show (fromJust mx::[[Int]])
   | otherwise  = show xd  -- use default Dynamic show instance
   where
    test m val = isJust m && typeOf (fromJust m) == typeOf val
    mx = fromDynamic xd
#elif 1
  -- Working!
  showDyn :: Dynamic -> String
  showDyn xd
--- | typeOf x == typeOf (undefined::Show a => a)  = show x  -- would be nice!
   | test mx_Int (undefined::Int)  = show (fromJust mx_Int::Int)
   | test mx_LInt (undefined::[Int])  = show (fromJust mx_LInt::[Int])
   | test mx_LLInt (undefined::[[Int]])  = show (fromJust mx_LLInt::[[Int]])
   | otherwise  = show xd  -- use default Dynamic show instance
   where
    test mx val = isJust mx && typeOf (fromJust mx) == typeOf val
    mx_Int = fromDynamic xd
    mx_LInt = fromDynamic xd
    mx_LLInt = fromDynamic xd
#else
  -- Doesn't work for me...
  showDyn :: Dynamic -> String
  showDyn xd
   | isNothing mx  = show xd  -- use default Dynamic show instance
   | otherwise     = show x   -- use the instance for the Showable type
   where
    mx = fromDynamic xd :: (Show a,Typeable a) => Maybe a
    x = fromJust mx
#endif

  showHetero :: Hetero -> String
  showHetero = showHetero' 0
   where
    showHetero' n (Node d chs)
     =    indent n ++ showDyn d ++ "\n"
       ++ concatMap (showHetero' (1+n)) chs
     where
      indent n = replicate (2*n) ' '

  showBi :: Show r => Bi r -> String
  showBi = showBi' 0
   where
    showBi' n (Node (d,r) chs)
     =    indent n ++ "(" ++ showDyn d ++ ", " ++ show r ++ ")" ++ "\n"
       ++ concatMap (showBi' (1+n)) chs
     where
      indent n = replicate (2*n) ' '

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

#if ! USE_DATA_TREE

  -- | Provided so we can use 'R' for node constructor, and
  -- so that the Show instance is nicer.
#if 1
  toDataTree :: Rose a -> Data.Tree.Tree a
  toDataTree (Node v chs) = Data.Tree.Node v $ map toDataTree chs
#else
-- (tried numerous other things too; trying to use higher-order)
  toDataTree :: forall a. (Typeable a, Rose a) => Rose a -> Data.Tree.Tree a
  toDataTree = fmap (\v -> fromJust $ cast v :: Data.Tree.Tree a)
--toDataTree = gmap (\v -> fromJust $ cast v :: Data.Tree.Tree a)
#endif

  fromDataTree :: Data.Tree.Tree a -> Rose a
  fromDataTree (Data.Tree.Node v chs) = Node v $ map fromDataTree chs

#endif

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

  -- Why is it r that needs to be typeable??...
  -- | Sets up a @'BiM' r@ using a default 'GenericQ' which
  -- assigns all values to 'Nothing'.
  --
  -- Use an expression type signature at the call site, to constrain
  -- the type @r@ (the usual trick)
  --
  --  >  ( gempty x :: BiM ( Int , Data.IntMap Text , [Float] ) )
  --
  -- so your choice type @r@ is a triple, but the @'BiM' r@ value
  -- returned contains 'Nothing' at every node. This prepares it
  -- for refinement and accumulation.
  gempty :: forall r d. (Typeable r,Data d) => d -> BiM r
--gempty :: forall r d. (Show r,Typeable r,Show d,Data d) => d -> BiM r
  gempty = ghomBi (mkQ Nothing id)

  -- XXX This should call gaccum if possible, rather than clone?...
  -- | Given a monomorphic function you provide, returning r,
  -- automatically makes a @'GenericQ' r@ from this. It then maps
  -- the generic query over the source polytypic tree, the latter
  -- being recovered from the 'Dynamic' component of the 'BiM'.
  --
  -- The target is updated with write-once semantics enforced;
  -- that is to say, 'grefine' will throw an exception if it finds
  -- a 'Just' already present at any place in the result tree that
  -- it would update.
  grefine :: forall r d. (Typeable r,Data d,Typeable d) => (d -> Maybe r) -> BiM r -> BiM r
--grefine :: forall r d. (Typeable r,Data d,Typeable d) => (d -> r) -> BiM r -> BiM r
--grefine :: forall r a d. (Typeable a,Data d) => (a -> r) -> BiM r -> BiM r
--grefine :: Typeable a => (a -> r) -> BiM r -> BiM r
  grefine f x = x'
   where
    f' = f -- :: d -> Maybe r
    fg = mkQ Nothing f' :: d -> Maybe r
    x' = grefine' x
     where
--    grefine' :: 
      grefine' (Node (xd,mr) chs) = x'
       where
        x' = Node (xd,r') $ map grefine' chs
        md = fromDynamic xd :: Maybe d
        r' | isNothing md = Nothing
           | isNothing mr = fg $ fromJust md
           | otherwise    = error "grefine: multiple updates attempted at a node"
#if 0
    Node (xd,mr) chs = x
    x' = Node (xd,r') $ map grefine chs
    r' | isNothing mr = fg $ fromJust $ (fromDynamic xd :: Maybe d)
       | otherwise    = error "grefine: multiple updates attempted at a node"
#endif

-- XXX Not working yet!
#if 0
--grefineG :: forall r d. (Typeable r,Data d) => (d -> Maybe r) -> BiM r -> BiM r
  grefineG :: forall r d. (Typeable r,Data d,Typeable d) => (d -> Maybe r) -> BiM r -> BiM r
  grefineG fg x = x'
   where
    x' = grefine' x
     where
--    grefine' :: 
      grefine' (Node (xd,mr) chs) = x'
       where
        x' = Node (xd,r') $ map grefine' chs
        md = fromDynamic xd :: Maybe d
        r' | isNothing md = Nothing
           | isNothing mr = fg $ fromJust md
           | otherwise    = error "grefine: multiple updates attempted at a node"
#endif

  -- | Like 'grefine', but rather than throw exception, it
  -- takes a combining function argument to cope with that situation.
  gaccum :: forall r d. (Typeable r,Data d,Typeable d) =>
            (r -> r -> r) -> (d -> Maybe r) -> BiM r -> BiM r
  gaccum k f x = x'
   where
    fg = mkQ Nothing f :: d -> Maybe r
    x' = gaccum' x
     where
--    gaccum' :: 
      gaccum' (Node (xd,mr) chs) = x'
       where
        md = fromDynamic xd :: Maybe d
        r = fromJust mr
        mr_ = fg $ fromJust md
        r_ = fromJust mr_
#if 0
#elif 1
        mr' | isNothing md  = mr
            | isNothing mr_ = mr
            | isNothing mr  = mr_
            | otherwise     = Just $ r `k` r_
#elif 0
--      mr' | isNothing md  = trace "*1*" $ Nothing  -- why does this seem to stop recursion?
        mr' | isNothing md  = trace "*1*" $ mr
            | isNothing mr_ = trace "*2*" $ mr
            | isNothing mr  = trace "*3*" $ mr_
            | otherwise     = trace "*4*" $ Just $ r `k` r_
#elif 0
        mr' | isNothing md  = Nothing
            | isNothing mr_ = Nothing
            | isNothing mr  = mr_
            | otherwise     = Just $ r `k` r_
#endif
        x' = Node (xd,mr') $ map gaccum' chs

--gassim :: ...

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