sai-shape-syb-0.2.2: src/SAI/Data/Generics/Shape/SYB.hs
-------------------------------------------------------------------------------
{-# 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 :: ...
-------------------------------------------------------------------------------