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