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

{-# LANGUAGE CPP #-}

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

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

-----------------------------------------------------------------------------
-- |
-- 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 ,
    ghomP ,
    ghomE ,
    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@

    biToHomo ,
    biToHetero ,
    heteroToBi ,

    -- * Conversions concerning lifted types

    liftHomoM ,
    liftBiM ,
    unliftHomoM ,
    unliftBiM ,

    -- * Progressive refinement and accumulation

    gempty ,
    grefine ,
    gaccum ,

    -- * For convenience

    shapeOf ,
    shapeOf_ ,
    sizeOf ,

    symmorphic ,
    (~~) ,

    weightedShapeOf ,
    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 ,
    showHomoWhen ,
    showHomoM ,

    showAsParens ,
    showAsParensBool ,
    showAsParensEnriched ,
    showAsParensEnrichedWhen ,
    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.
  --
  -- 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 "| "

  showHomoWhen :: Show r => (r -> Bool) -> Rose r -> String
  showHomoWhen p = show' 0
   where show' n (Node r chs)
            = indent n ++ s ++ "\n" ++ concatMap (show' (1+n)) chs
          where indent n = concat $ replicate n "| "
                s = if p r then show r else "."

  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])

  -- | Like 'ghom', but also filter branches using a generic predicate,
  -- retaining the stop nodes. The @'GenericQ' r@ argument can be specialised
  -- for the stop node type(s), for instance to summarise stop branches.
  -- (See 'ghomE' for more flexibility.)
  ghomP :: forall r s d. Data d =>
              GenericQ Bool  -- defines stop nodes
           -> GenericQ r     -- what to do with nodes (typically including a case for stop nodes)
           -> d
           -> Homo r
  ghomP p f x
   | p x         = Node (f x) []
   | otherwise   = foldl k b (gmapQ (ghomP p f) x)
   where
     b = Node (f x) []
     k (Node r chs) nod = Node r (chs++[nod])

  -- | Like 'ghom', but also filter branches using a generic predicate,
  -- retaining the stop nodes and summarising their branches in
  -- 'Right' values; default values are placed in the non-stop, 'Left' nodes.
  -- You can fmap your own function @(s -> r)@ to the result, then collapse
  -- from @'Either' r r@ to @r@ in the obvious way. (The function 'ghomP' is
  -- probably sufficient in most cases.)
  ghomE :: forall r s d. Data d =>
              GenericQ Bool  -- defines stop nodes
           -> GenericQ r     -- Left : what to do with non-stop nodes
           -> GenericQ s     -- Right : what to do with stop nodes
           -> d
           -> Homo (Either r s)
  ghomE p f f_stop x
   | p x        = Node (Right (f_stop x)) []
   | otherwise  = foldl k b (gmapQ (ghomE p f f_stop) x)
   where
     b = Node (Left (f x)) []
     k (Node r chs) nod = Node r (chs++[nod])

  -- | Uses "Data.Dynamic" to support mutiple types homogeneously.
  -- Unlike 'ghom', this is invertible ('unGhomDyn').
  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])

  -- | @'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 f x = zipRose (ghomDyn x) $ ghom f x

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

  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

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

  -- | 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)

  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

  -- | 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
  symmorphic x y = shapeOf x == shapeOf y

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

  -- | Operator for 'not . symmorphic'.
  (/~) :: forall d1 d2. (Data d1,Data d2) => d1 -> d2 -> Bool
  (/~) x y = not $ symmorphic x y
--(/~) = not . 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)
  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

#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
    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'))
     b = Node (r,1) []
     k' (Node rw chs) nod@(Node rw' _) = Node (rw `k` rw') (chs++[nod])

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

  -- | Stop traversal on 'String's.
  shapeOf_ :: forall d. Data d => d -> Shape
  shapeOf_ x = ghomP pg fg x 
   where
    pg :: forall d'. Data d' => d' -> Bool
    pg = mkQ False p_String
    p_String :: String -> Bool
    p_String _ = True
    fg :: forall d''. Data d'' => d'' -> ()
    fg = const ()

  -- | Stop traversal on 'String's, using the length of the string
  -- as the weight for the node rooting the 'String'.
  -- XXX Using 2*length + 1 would be more consistent?
  weightedShapeOf_ :: forall d. Data d => d -> Homo Int
  weightedShapeOf_ x = weightedRoseSpecial $ ghomP pg fg x
   where
    pg :: forall d'. Data d' => d' -> Bool
    pg = mkQ False p_String
    p_String :: String -> Bool
    p_String x = True
    fg :: forall d''. Data d'' => d'' -> Int
    fg = mkQ 1 f_String
    f_String :: String -> Int
    f_String x = length x
    weightedRoseSpecial :: Rose Int -> Rose Int
    weightedRoseSpecial (Node r chs) = foldl k' b (map weightedRoseSpecial chs)
     where
       b = Node r []
       k' (Node rw chs) nod@(Node rw' _) = Node (rw + rw') (chs++[nod])

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

  -- | One-line, parentheses language representation of the shape of a @'Homo' r@.
  showAsParens :: Homo r -> String
  showAsParens (Node _ []) = "*"
  showAsParens (Node _ chs) = "(" ++ concatMap showAsParens chs ++ ")"

  -- | One-line, parentheses language representation of the shape of a 'Homo' 'Bool', enriched by symbols for 'True' (@*@) and 'False' (@.@).
  --
  -- (While parentheses around the leaves can in principle be omitted,
  -- the loss in readability is not compensated by the shortening.)
  showAsParensBool :: Homo Bool -> String
  showAsParensBool (Node r chs)
#if 0
   | null chs   = s  -- if want to omit parentheses around leaves
#endif
   | otherwise  = "(" ++ s ++ concatMap showAsParensBool chs ++ ")"
   where s = if r then "*" else "."

  -- | One-line, parentheses language representation of the shape of a @'Homo' r@, and nodes adorned with @'show' r@.
  showAsParensEnriched :: Show r => Homo r -> String
  showAsParensEnriched nod@(Node r [])
   | s == "()"  = showAsParens nod where s = show r
  showAsParensEnriched (Node r chs)
   = "(" ++ show r ++ concatMap showAsParensEnriched chs ++ ")"

  -- | One-line, parentheses language representation of the shape of a @'Homo' r@, and nodes adorned with @'show' r@ when the predicate holds (and with @.@ otherwise).
  showAsParensEnrichedWhen :: Show r => (r -> Bool) -> Homo r -> String
  showAsParensEnrichedWhen p (Node r chs)
   = "(" ++ s ++ concatMap (showAsParensEnrichedWhen p) chs ++ ")"
   where s = if p r then show r else "."

  -- | One-line, parentheses language representation of the shape of a @'HomoM' r@, with 'Just' nodes designated by @'show' r@ (and 'Nothing' nodes by @.@).
  showAsParensEnrichedM :: Show r => HomoM r -> String
  showAsParensEnrichedM (Node Nothing []) = "."
  showAsParensEnrichedM (Node (Just r) []) = show r
  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
-- The space marked ---V is the only difference, but the space is preferable!
#if 0
  showBi = showHomo
#else
  showBi = showBi' 0
   where
    showBi' n (Node (d,r) chs)             ---V
       =    indent n ++ "(" ++ showDyn d ++ ", " ++ show r ++ ")" ++ "\n"
         ++ concatMap (showBi' (1+n)) chs
     where
      indent n = replicate (2*n) ' '
#endif

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

#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 = 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.
  --
  -- XXX /Still only calls error, when should throw an exception./
  grefine :: forall r d. (Typeable r,Data d,Typeable d) => (d -> Maybe r) -> BiM r -> BiM r
  grefine f x = x'
   where
    fg = mkQ Nothing f
    x' = grefine' x
     where
      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"

  -- | 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
    x' = gaccum' x
     where
      gaccum' (Node (xd,mr) chs) = x'
       where
        md = fromDynamic xd :: Maybe d
        r = fromJust mr
        mr_ = fg $ fromJust md
        r_ = fromJust mr_
        mr' | isNothing md  = mr
            | isNothing mr_ = mr
            | isNothing mr  = mr_
            | otherwise     = Just $ r `k` r_
        x' = Node (xd,mr') $ map gaccum' chs

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