fixplate 0.1.3 → 0.1.4

raw patch · 12 files changed

+1020/−85 lines, 12 filesdep +containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers

API changes (from Hackage documentation)

Files

• Data/Generics/Fixplate.hs +9/−5
• Data/Generics/Fixplate/Attributes.hs +44/−36
• Data/Generics/Fixplate/Base.hs +126/−8
• Data/Generics/Fixplate/Draw.hs +161/−0
• Data/Generics/Fixplate/Hash.hs +150/−0
• Data/Generics/Fixplate/Hash/Class.hs +99/−0
• Data/Generics/Fixplate/Hash/FNV/FNV32.hs +94/−0
• Data/Generics/Fixplate/Hash/FNV/FNV64.hs +97/−0
• Data/Generics/Fixplate/Hash/Table.hs +109/−0
• Data/Generics/Fixplate/Morphisms.hs +89/−29
• Data/Generics/Fixplate/Open.hs +25/−6
• fixplate.cabal +17/−1

@@ -1,16 +1,18 @@ 
--- | This library provides Uniplate-style generic traversals for fixed-point types.
--- The advantages of using fixed-point types instead of explicit recursion are the following:
+-- | This library provides Uniplate-style generic traversals and other recursion schemes for fixed-point types.
+-- There are many advantages of using fixed-point types instead of explicit recursion:
 --
 --   * we can add attributes to the nodes of an existing tree;
 --
 --   * there is no need for a custom type class, we can build everything on the top of
---     @Functor@, @Foldable@ and @Traversable@, for which GHC can derive the instances for us;
+--     'Functor', 'Foldable' and 'Traversable', for which GHC can derive the instances for us;
 --
+--   * we can provide interesting recursion schemes
+-- 
 --   * some operations can retain the structure of the tree, instead flattening
 --     it into a list;
 --
---   * it is quite straightforward to provide a generic zipper.
+--   * it is quite straightforward to provide a generic zipper, generic tree drawing, generic hashing, etc...
 --
 -- The main disadvantage is that it does not work well for
 -- mutually recursive data types, and that pattern matching becomes
@@ -42,7 +44,7 @@ -- The functions in this library work on types like that: 'Mu'@ f@,
 -- where @f@ is a functor, and sometimes explicitely on 'Attr'@ f a@.
 -- 
--- This module re-exports most of the functionality present in the library.
+-- This module re-exports most, but not all of the functionality present in the library.
 --
 -- The library should be fully Haskell98 compatible, with the exception
 -- of the module "Data.Generics.Fixplate.Structure", which needs
@@ -60,6 +62,7 @@   , module Data.Generics.Fixplate.Attributes
 --  , module Data.Generics.Fixplate.Zipper
   , module Data.Generics.Fixplate.Structure
+  , module Data.Generics.Fixplate.Draw
   , Functor(..) , Foldable(..) , Traversable(..)
   )
   where
@@ -72,6 +75,7 @@ import Data.Generics.Fixplate.Attributes
 -- import Data.Generics.Fixplate.Zipper
 import Data.Generics.Fixplate.Structure  
+import Data.Generics.Fixplate.Draw
 
 import Data.Foldable
 import Data.Traversable

@@ -1,5 +1,5 @@ 
--- | Synthetising attributes, partly motivated by Attribute Grammars.
+-- | Synthetising attributes, partly motivated by Attribute Grammars, and partly by recursion schemes.
 
 {-# LANGUAGE CPP #-}
 module Data.Generics.Fixplate.Attributes
@@ -11,13 +11,15 @@   , synthetiseM
   -- * Synthetised attributes as generalized cata- and paramorphisms
   , synthCata   , scanCata
-  , synthPara   , synthPara' , scanPara
+  , synthPara   , synthPara' 
+  , scanPara
   , synthZygo_  , synthZygo  , synthZygoWith
-  , synthAccumCata , synthAccumPara 
+  , synthAccumCata , synthAccumPara'
   , mapAccumCata
-  , synthCataM  , synthParaM  , synthParaM'
+  , synthCataM  , synthParaM , synthParaM'
   -- * Inherited attributes
   , inherit , inherit'
+  , inherit2
   , inheritM , inheritM_
   -- * Top-down folds
   , topDownSweepM , topDownSweepM'
@@ -142,23 +144,24 @@ --
 -- >  attribute . synthPara f == para f
 --
-synthPara :: Functor f => (Mu f -> f a -> a) -> Mu f -> Attr f a
-synthPara h = go where
-  go t@(Fix x) = Fix $ Ann (h t a) y where 
-    y  =  fmap go x  
-    a  =  fmap attribute y
-
--- | Another version of 'synthPara'. This satisfies
---
--- >  attribute . synthPara' f == para' f
---
-synthPara' :: Functor f => (f (Mu f, a) -> a) -> Mu f -> Attr f a
-synthPara' h = snd . go where
+synthPara :: Functor f => (f (Mu f, a) -> a) -> Mu f -> Attr f a
+synthPara h = snd . go where
   go orig@(Fix x) = ( orig , Fix $ Ann (h lft) rht ) where 
     lft = fmap (\(s,t) -> (s, attribute t)) uv
     rht = fmap snd uv    -- :: f (Attr f a)
     uv  = fmap go x      -- :: f (Mu f , Attr f a)
 
+-- | Another version of 'synthPara'.
+--
+-- >  attribute . synthPara' f == para' f
+--
+synthPara' :: Functor f => (Mu f -> f a -> a) -> Mu f -> Attr f a
+synthPara' h = go where
+  go t@(Fix x) = Fix $ Ann (h t a) y where 
+    y  =  fmap go x  
+    a  =  fmap attribute y
+
+
 scanPara :: Functor f => (Attr f a -> f b -> b) -> Attr f a -> Attr f b
 scanPara h = go where
   go t@(Fix (Ann a x)) = Fix $ Ann (h t b) y where 
@@ -189,8 +192,8 @@     (a,b) = h (fmap fst y)
 
 -- | Accumulating paramorphisms.  
-synthAccumPara :: Functor f => (Mu f -> f acc -> (acc,b)) -> Mu f -> (acc, Attr f b)
-synthAccumPara h = go where
+synthAccumPara' :: Functor f => (Mu f -> f acc -> (acc,b)) -> Mu f -> (acc, Attr f b)
+synthAccumPara' h = go where
   go t@(Fix x) = (a, Fix (Ann b (fmap snd y))) where
     y = fmap go x
     (a,b) = h t (fmap fst y)
@@ -215,16 +218,8 @@     return (Fix (Ann a y))
 
 -- | Monadic version of 'synthPara'. If you don't need the result,  use 'paraM_' instead.
-synthParaM  ::  (Traversable f, Monad m) => (Mu f -> f a -> m a) -> Mu f -> m (Attr f a)
-synthParaM act = go where
-  go t@(Fix x) = do
-    y  <-  mapM go x  
-    a  <-  act t $ fmap attribute y
-    return (Fix (Ann a y))
-
--- | Monadic version of 'synthPara''. 
-synthParaM'  ::  (Traversable f, Monad m) =>  (f (Mu f, a) -> m a) -> Mu f -> m (Attr f a)
-synthParaM' act tree = liftM snd (go tree) where
+synthParaM  ::  (Traversable f, Monad m) =>  (f (Mu f, a) -> m a) -> Mu f -> m (Attr f a)
+synthParaM act tree = liftM snd (go tree) where
   go orig@(Fix x) = do 
     uv <- mapM go x      
     let lft = fmap (\(s,t) -> (s, attribute t)) uv
@@ -232,13 +227,21 @@     a <- act lft
     return ( orig , Fix $ Ann a rht ) 
 {-
-synthParaM' act = go where
+synthParaM act = go where
   go (Fix x) = do
     y  <-  mapM go x    
     a  <-  act $ unsafeZipWithF (,) x (fmap attribute y)
     return (Fix (Ann a y))
 -}
 
+-- | Monadic version of 'synthPara''. 
+synthParaM'  ::  (Traversable f, Monad m) => (Mu f -> f a -> m a) -> Mu f -> m (Attr f a)
+synthParaM' act = go where
+  go t@(Fix x) = do
+    y  <-  mapM go x  
+    a  <-  act t $ fmap attribute y
+    return (Fix (Ann a y))
+
 --------------------------------------------------------------------------------
 -- Inherited attributes
 
@@ -253,6 +256,11 @@ inherit h root = go root where
   go p s@(Fix t) = let a = h s p in Fix (Ann a (fmap (go a) t))
 
+-- | Generalization of `inherit'. TODO: better name?
+inherit2 :: Functor f => (Mu f -> a -> (b,a)) -> a -> Mu f -> Attr f b
+inherit2 h root = go root where
+  go p s@(Fix t) = let (b,a) = h s p in Fix (Ann b (fmap (go a) t))
+
 -- | Generalization of @scanl@ from lists to trees.
 inherit' :: Functor f => (a -> b -> a) -> a -> Attr f b -> Attr f a
 inherit' h root = go root where
@@ -427,9 +435,9 @@ prop_synthCata tree = attribute (synthCata f tree) == cata f tree where 
   f :: TreeF Label String -> String
   f (TreeF (Label label) xs) = label++"(" ++ intercalate "," xs ++ ")"
-  
-prop_synthPara :: FixT Label -> Bool
-prop_synthPara tree = attribute (synthPara h tree) == para h tree where 
+
+prop_synthPara' :: FixT Label -> Bool
+prop_synthPara' tree = attribute (synthPara' h tree) == para' h tree where 
   h :: FixT Label -> TreeF Label String -> String
   h tree@(Fix (TreeF label ts)) ys = unLabel label++"_"++show siz++"(" ++ intercalate "," (zipWith c (toList ys) sizs) ++ ")" where
     siz = cata f tree
@@ -437,8 +445,8 @@     f t = 1 + Data.Foldable.sum t
     c str j = str ++ "<" ++ show j ++ ">"
 
-prop_synthPara' :: FixT Label -> Bool
-prop_synthPara' tree = attribute (synthPara' g tree) == para' g tree where 
+prop_synthPara :: FixT Label -> Bool
+prop_synthPara tree = attribute (synthPara g tree) == para g tree where 
   g :: TreeF Label (FixT Label , String) -> String
   g (TreeF (Label label) xs) = label++"(" ++ intercalate "," (map u xs) ++ ")" where
     u (tree,a) = show siz ++ "_" ++ a where
@@ -472,10 +480,10 @@ -- Morphism tests which are here to avoid circular imports
 
 zygoNaive_ :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> a
-zygoNaive_ g h = para' (h . fmap (first attribute) . unAnn) . synthCata g 
+zygoNaive_ g h = para (h . fmap (first attribute) . unAnn) . synthCata g 
 
 zygoNaive :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> (b,a)
-zygoNaive g h tree = (attribute tmp, para' h1 tmp) where 
+zygoNaive g h tree = (attribute tmp, para h1 tmp) where 
   tmp = synthCata g tree
   h1 = h . fmap (first attribute) . unAnn
 

@@ -19,6 +19,12 @@ 
 --------------------------------------------------------------------------------
 
+-- | The fixed-point type.
+newtype Mu f = Fix { unFix :: f (Mu f) }
+
+--------------------------------------------------------------------------------
+-- * Attributes
+
 -- | The attribute of the root node.
 attribute :: Attr f a -> a
 attribute = attr . unFix
@@ -28,21 +34,46 @@ forget = Fix . fmap forget . unAnn . unFix
 
 --------------------------------------------------------------------------------
-
--- | The fixed-point type.
-newtype Mu f = Fix { unFix :: f (Mu f) }
+-- * Annotations
 
--- | Annotated functors.
-data Ann f a b  =  Ann 
+-- | Type of annotations
+data Ann f a b = Ann 
   { attr  :: a           -- ^ the annotation
   , unAnn :: f b         -- ^ the original functor
   }
+  deriving (Eq,Ord,Show)
 
--- | Annotated fixed-point type.
-type Attr f a   =  Mu (Ann f a)
+-- | Annotated fixed-point type. Equivalent to @CoFree f a@
+type Attr f a = Mu (Ann f a)
 
 --------------------------------------------------------------------------------
+-- * Co-annotations
 
+-- | Categorical dual of 'Ann'.
+data CoAnn f a b 
+  = Pure a 
+  | CoAnn (f b)
+  deriving (Eq,Ord,Show)
+
+-- | Categorical dual of 'Attr'. Equivalent to @Free f a@
+type CoAttr f a = Mu (CoAnn f a)
+
+--------------------------------------------------------------------------------
+-- * Holes
+
+-- | This a data type defined to be a place-holder for childs.
+-- It is used in tree drawing, hashing, and 'Shape'.
+-- 
+-- It is deliberately not made an instance of 'Show', so that 
+-- you can choose your preferred style. For example, an acceptable choice is
+--
+-- > instance Show Hole where show _ = "_"
+--
+data Hole = Hole deriving (Eq,Ord)
+
+--------------------------------------------------------------------------------
+-- * Higher-order type classes
+
 -- | \"Functorised\" versions of standard type classes. 
 -- If you have your a structure functor, for example
 --
@@ -78,6 +109,12 @@ #else
                               readsPrecF ::  Read a  =>  Int -> ReadS (f a)                              
 #endif                        
+
+showF :: (ShowF f, Show a) => f a -> String
+showF x = showsF x ""
+
+showsF :: (ShowF f, Show a) => f a -> ShowS
+showsF = showsPrecF 0
       
 --------------------------------------------------------------------------------
 
@@ -143,6 +180,29 @@             , (x,t) <- readsPrec  (app_prec+1) s]) r    
             , (m,u) <- readsPrecF (app_prec+1) t]) r    
 #endif
+
+--------------------------------------------------------------------------------
+
+instance (Eq a, EqF f) => EqF (CoAnn f a) where 
+  equalF (Pure  a) (Pure  b) = a == b
+  equalF (CoAnn x) (CoAnn y) = equalF x y
+  equalF _         _         = False
+
+instance (Ord a, OrdF f) => OrdF (CoAnn f a) where 
+  compareF (Pure  a) (Pure  b) = compare a b
+  compareF (CoAnn x) (CoAnn y) = compareF x y
+  compareF (Pure  _) (CoAnn _) = LT
+  compareF (CoAnn _) (Pure  _) = GT
+
+instance (Show a, ShowF f) => ShowF (CoAnn f a) where 
+  showsPrecF d (CoAnn t) 
+    = showParen (d>app_prec) 
+      $ showString "CoAnn " 
+      . (showsPrecF (app_prec+1) t)    
+  showsPrecF d (Pure x) 
+    = showParen (d>app_prec) 
+      $ showString "Pure " 
+      . (showsPrec (app_prec+1) x) 
       
 --------------------------------------------------------------------------------
 
@@ -156,12 +216,35 @@ instance Traversable f => Traversable (Ann f a) where
   traverse f (Ann x t) = Ann x <$> traverse f t
   mapM f (Ann x t) = liftM (Ann x) (mapM f t)
+
+--------------------------------------------------------------------------------
  
+instance Functor f => Functor (CoAnn f a) where
+  fmap f (CoAnn t) = CoAnn (fmap f t)
+  fmap f (Pure  x) = Pure  x
+
+instance Foldable f => Foldable (CoAnn f a) where
+  foldl f a (CoAnn t) = foldl f a t
+  foldl f a (Pure  x) = a
+
+  foldr f a (CoAnn t) = foldr f a t
+  foldr f a (Pure  x) = a
+
+instance Traversable f => Traversable (CoAnn f a) where
+  traverse f (CoAnn t) = CoAnn <$> traverse f t
+  traverse f (Pure  x) = pure (Pure x)
+
+  mapM f (CoAnn t) = liftM CoAnn (mapM f t)
+  mapM f (Pure  x) = return (Pure x)
+ 
 --------------------------------------------------------------------------------
+-- * Attrib (cofree comonad)
 
 -- | A newtype wrapper around @Attr f a@ so that we can make @Attr f@ 
--- an instance of Functor, Foldable and Traversable. This is necessary
+-- an instance of Functor, Foldable and Traversable (and Comonad). This is necessary
 -- since Haskell does not allow partial application of type synonyms.
+--
+-- Equivalent to the co-free comonad.
 newtype Attrib f a = Attrib { unAttrib :: Attr f a }
 
 instance (ShowF f, Show a) => Show (Attrib f a) where
@@ -181,5 +264,40 @@ instance Traversable f => Traversable (Attrib f) where
   traverse h (Attrib y) = Attrib <$> go y where
     go (Fix (Ann x t)) = Fix <$> (Ann <$> h x <*> traverse go t)
+
+--------------------------------------------------------------------------------
+-- * CoAttrib (free monad)
+
+-- | Categorial dual of 'Attrib'. Equivalent to the free monad.
+newtype CoAttrib f a = CoAttrib { unCoAttrib :: CoAttr f a }
+
+instance (ShowF f, Show a) => Show (CoAttrib f a) where
+  showsPrec d (CoAttrib x) 
+    = showParen (d>app_prec) 
+      $ showString "CoAttrib " 
+      . (showsPrec (app_prec+1) x) 
+
+instance Functor f => Functor (CoAttrib f) where
+  fmap h (CoAttrib y) = CoAttrib (go y) where
+    go (Fix (CoAnn t)) = Fix $ CoAnn (fmap go t)
+    go (Fix (Pure  x)) = Fix $ Pure  (h x)
+
+instance Foldable f => Foldable (CoAttrib f) where
+  foldl h a (CoAttrib y) = go a y where 
+     go b (Fix (CoAnn t)) = foldl go b t
+     go b (Fix (Pure  x)) = h b x
+  foldr h a (CoAttrib y) = go y a where 
+     go (Fix (CoAnn t)) b = foldr go b t
+     go (Fix (Pure  x)) b = h x b 
+
+instance Traversable f => Traversable (CoAttrib f) where
+  traverse h (CoAttrib y) = CoAttrib <$> go y where
+    go (Fix (CoAnn t)) = Fix <$> (CoAnn <$> traverse go t)
+    go (Fix (Pure  x)) = Fix <$> (Pure  <$> h x)
+
+instance Functor f => Monad (CoAttrib f) where
+  return x = CoAttrib (Fix (Pure x))
+  CoAttrib (Fix (CoAnn t))  >>=  u  =  CoAttrib (Fix (CoAnn (fmap (unCoAttrib . (>>=u) . CoAttrib) t)))
+  CoAttrib (Fix (Pure  x))  >>=  u  =  u x
 
 --------------------------------------------------------------------------------

@@ -0,0 +1,161 @@+
+-- | Generic ascii art \/ graphviz drawing of trees.
+--
+-- Suggestions for drawing styles are welcome. 
+--
+-- TODO:
+--
+--  * make the style customizable
+--
+--  * the same for graphviz
+--
+module Data.Generics.Fixplate.Draw
+  (
+    -- * Default tree drawing, using Show instancess
+    drawTree 
+  , showTree
+  , graphvizTree
+    -- * Customizable tree drawing
+  , drawTreeWith
+  , showTreeWith
+  , graphvizTreeWith
+  )
+  where
+
+--------------------------------------------------------------------------------
+
+import Data.Foldable
+import Data.Traversable
+
+import Data.Generics.Fixplate.Base
+import Data.Generics.Fixplate.Open
+
+import Data.Generics.Fixplate.Attributes ( enumerateNodes_ )
+import Data.Generics.Fixplate.Traversals ( universe )
+
+--------------------------------------------------------------------------------
+
+{-
+-- | This a data type defined to be a place-holder for childs.
+-- So that you can define it to be an instance of your own pretty-printer.
+--
+-- For the fastest result, you want to define something like
+-- 
+-- > instance Show Hole where show _ = "_"
+--
+-- We don't do this so that you can customize to your preferred drawing style.
+-- However, `drawTree' and `showTree' does exactly this.
+data Hole = Hole
+-}
+
+--------------------------------------------------------------------------------
+
+-- | Prints a tree. It is defined simply as
+--
+-- > drawTree = putStrLn . showTree
+--
+drawTree :: (Functor f, Foldable f, ShowF f) => Mu f -> IO ()
+drawTree = putStrLn . showTree
+
+drawTreeWith :: (Functor f, Foldable f) => (f Hole -> String) -> Mu f -> IO ()
+drawTreeWith pp = putStrLn . showTreeWith pp
+
+--------------------------------------------------------------------------------
+
+type Step = [Bool]
+
+--------------------------------------------------------------------------------
+
+-- this is distinct from Hole so that we that user can defined his own 'Show' instnace for 'Hole'
+data Void = Void ; instance Show Void where show _ = "_"
+
+-- | Creates a string representation which can be printed with 'putStrLn'.
+showTree :: (Functor f, Foldable f, ShowF f) => Mu f -> String
+showTree = showTreeWith pp where
+  pp t = showF (fmap (const Void) t) 
+
+--------------------------------------------------------------------------------
+
+showTreeWith :: (Functor f, Foldable f) => (f Hole -> String) -> Mu f -> String
+showTreeWith pprint = unlines . map mkLine . go [False] where
+
+--  go :: Step -> Mu f -> [(Step,String)]
+  go bars (Fix s) = ( bars , this ) : rest where    
+    this = pprint $ fmap (const Hole) s
+    rest = Prelude.concat $ reverse $ zipWith worker theBars (toRevList s)
+    worker b t = go (b:bars) t 
+
+  theBars = False : repeat True     -- last child is drawn differently when it has subchilds
+
+  mkLine (b:bs, str) = Prelude.concatMap (_branch style) (reverse bs) ++ (_twig style b) ++ str 
+
+  style = defaultStyle 
+
+--------------------------------------------------------------------------------
+
+-- customizable ascii art style
+
+defaultStyle :: Style
+defaultStyle = Style 
+  { _twigNorm   = " |-- "
+  , _twigLast   = " \\-- "
+  , _branchNorm = " |   "
+  , _branchLast = "     "
+  }
+
+{-
+someStyle :: Style
+someStyle = Style 
+  { _twigNorm   = ">- "
+  , _twigLast   = "|- "
+  , _branchNorm = "|  "
+  , _branchLast = "   "
+  }
+-}
+
+data Style = Style 
+  { _twigNorm   :: !String
+  , _twigLast   :: !String
+  , _branchNorm :: !String
+  , _branchLast :: !String
+  }
+
+_twig :: Style -> Bool -> String
+_twig style b = if b then _twigNorm style  else _twigLast style 
+
+_branch :: Style -> Bool -> String
+_branch style b = if b then _branchNorm style  else _branchLast style 
+
+
+--------------------------------------------------------------------------------
+
+-- | Generate a graphviz @.dot@ file 
+graphvizTree :: (Traversable f, ShowF f) => Mu f -> String
+graphvizTree = graphvizTreeWith pp where
+  pp t = showF (fmap (const Void) t)
+
+graphvizTreeWith :: (Traversable f) => (f Hole -> String) -> Mu f -> String
+graphvizTreeWith pp tree = unlines dot where
+  dot = header : viznodes ++ vizedges ++ [footer] 
+  header = "digraph tree {"
+  footer = "}"
+  enum = enumerateNodes_ tree
+  node i = "node" ++ show i
+  only = fmap (const Hole)
+  viznodes = 
+    [ node i ++ " [ label=\"" ++ escape (pp (only s)) ++ "\" ] ;"
+    | Fix (Ann i s) <- universe enum
+    ]
+  vizedges = Prelude.concat 
+    [ [ node i ++ " -> " ++ node j ++ " ;"
+      | Fix (Ann j _) <- toList s
+      ]
+    | Fix (Ann i s) <- universe enum
+    ]
+
+escape :: String -> String
+escape = Prelude.concatMap f where
+  f c = if Prelude.elem c stuff then '\\':c:[] else c:[]
+  stuff = "\\\""
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,150 @@+
+-- | Generic hashing on trees. We recursively compute hashes of all subtrees,
+-- giving fast inequality testing, and a fast, but meaningless (more-or-less random)
+-- ordering on the set of trees (so that we can put them into Map-s).
+--
+-- The way it works is that when we compute the hash of a node, we use the hashes of the 
+-- children directly; this way, you can also incrementally build up a hashed tree.
+--
+module Data.Generics.Fixplate.Hash
+  ( -- * Type classes for different hash functions
+    module Data.Generics.Fixplate.Hash.Class
+    -- * Hashed tree type
+  , HashAnn(..) , getHash , unHashAnn
+  , HashMu , topHash
+  , forgetHash
+    -- * Hashing tres
+  , hashTree , hashTreeWith
+  , hashNode , hashNodeWith
+  ) where
+
+--------------------------------------------------------------------------------
+
+import Data.Generics.Fixplate.Hash.Class
+
+import Control.Monad ( liftM )
+import Control.Applicative ( (<$>) )
+
+import Data.Generics.Fixplate
+import Data.Foldable    as F
+import Data.Traversable as T
+
+import Text.Show
+
+--------------------------------------------------------------------------------
+
+-- | Hash annotation (question: should the Hash field be strict? everything else in the library is lazy...)
+--
+-- This is custom datatype instead of reusing 'Ann' because of the different Eq\/Ord instances we need.
+--
+data HashAnn hash f a = HashAnn hash (f a) deriving Show
+
+getHash :: HashAnn hash f a -> hash
+getHash (HashAnn hash _) = hash
+
+unHashAnn :: HashAnn hash f a -> f a
+unHashAnn (HashAnn _ x) = x
+
+--------------------------------------------------------------------------------
+
+-- | A tree annotated with hashes of all subtrees. This gives us fast inequality testing,
+-- and fast (but meaningless!) ordering for 'Map'-s.
+type HashMu hash f = Mu (HashAnn hash f) 
+
+-- | The hash of the complete tree.
+topHash :: HashMu hash f -> hash
+topHash (Fix (HashAnn hash _)) = hash
+
+--------------------------------------------------------------------------------
+
+{-
+-- | This is a newtype so that we can define the 'Hashable' instance in Haskell98.
+-- With the @FlexibleInstances@ extensions, this is not necessary.
+newtype HashableHashMu hash f = HHMu { unHHMu :: HashMu hash f } deriving (Eq,Ord,Show)
+
+-- | This is a rather tricky instance, in the sense that
+-- 
+-- > computeHash tree /= topHash tree
+--
+-- Actually, the above does not even type-checks... 
+-- But in practice, we would use the same type for both sides, so be careful.
+--
+instance HashValue hash => Hashable (HashableHashMu hash f) where
+  hashDigest t = hashDigest (topHash (unHHMu t))
+-}
+
+--------------------------------------------------------------------------------
+
+instance Functor f => Functor (HashAnn hash f) where
+  fmap f (HashAnn attr t) = HashAnn attr (fmap f t)
+
+instance Foldable f => Foldable (HashAnn hash f) where
+  foldl f x (HashAnn _ t) = F.foldl f x t
+  foldr f x (HashAnn _ t) = F.foldr f x t
+
+instance Traversable f => Traversable (HashAnn hash f) where
+  traverse f (HashAnn x t) = HashAnn x <$> T.traverse f t
+  mapM f (HashAnn x t) = liftM (HashAnn x) (T.mapM f t)
+
+--------------------------------------------------------------------------------
+
+instance (Eq hash, EqF f) => EqF (HashAnn hash f) where
+  equalF (HashAnn h1 x1) (HashAnn h2 x2) = if h1 /= h2 then False else equalF x1 x2 
+
+instance (Ord hash, OrdF f) => OrdF (HashAnn hash f) where
+  compareF (HashAnn h1 x1) (HashAnn h2 x2) = case compare h1 h2 of
+    LT -> LT
+    GT -> GT
+    EQ -> compareF x1 x2
+
+instance (Eq hash, ShowF f, Show hash) => ShowF (HashAnn hash f) where
+  showsPrecF d (HashAnn hash x) = showParen (d>app_prec) 
+    $ showString "HashAnn " 
+    . showsPrec  (app_prec+1) hash 
+    . showChar ' '
+    . showsPrecF (app_prec+1) x
+    where
+      app_prec = 10
+
+--------------------------------------------------------------------------------
+
+forgetHash :: Functor f => HashMu hash f -> Mu f
+forgetHash = go where
+  go = Fix . fmap go . unHashAnn . unFix 
+
+--------------------------------------------------------------------------------
+
+data Void = Void ; instance Show Void where show _ = "_"
+
+{-# INLINE showDigest #-}
+showDigest :: (Functor f, ShowF f, HashValue hash) => f a -> hash -> hash
+showDigest t = hashDigest $ showF (fmap (const Void) t) 
+
+--------------------------------------------------------------------------------
+
+-- | This function uses the 'ShowF' instance to compute
+-- the hash of a node; this way you always have a working
+-- version without writing any additional code.
+--
+-- However, you can also supply your own hash implementation 
+-- (which can be more efficient, for example), if you use 'hashTreeWith' instead.
+hashTree :: (Foldable f, Functor f, ShowF f, HashValue hash) => Mu f -> HashMu hash f 
+hashTree = hashTreeWith showDigest
+
+hashTreeWith :: (Foldable f, Functor f, HashValue hash) => (f Hole -> hash -> hash) -> Mu f -> HashMu hash f 
+hashTreeWith user = go where
+  go (Fix x) = hashNodeWith user (fmap go x)
+
+--------------------------------------------------------------------------------
+
+-- | Build a hashed node from the children.
+hashNode :: (Foldable f, Functor f, ShowF f, HashValue hash) => f (HashMu hash f) -> HashMu hash f 
+hashNode = hashNodeWith showDigest
+
+hashNodeWith :: (Foldable f, Functor f, HashValue hash) => (f Hole -> hash -> hash) -> f (HashMu hash f) -> HashMu hash f 
+hashNodeWith user x = Fix (HashAnn h x) where
+  h  = user (fmap (const Hole) x) h0
+  h0 = computeHash $ toList $ fmap (getHash . unFix) x
+--  h0 = foldl' (flip hashHash) emptyHash $ toList $ fmap (getHash . unFix) x
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,99 @@+
+-- | Haskell98 polymorphic Hash interface
+module Data.Generics.Fixplate.Hash.Class where
+
+--------------------------------------------------------------------------------
+
+import Data.Char
+import Data.Word
+import Data.Int
+import Data.Bits
+import Data.List
+
+--------------------------------------------------------------------------------
+
+-- | A type class for hashes.
+-- Minimal complete definition: 'emptyHash', 'hashWord8', 'hashHash' and 'showHex'.
+class (Eq hash, Ord hash, Hashable hash) => HashValue hash where
+
+  hashWord8  :: Word8  -> hash -> hash
+  hashWord16 :: Word16 -> hash -> hash
+  hashWord32 :: Word32 -> hash -> hash
+  hashWord64 :: Word64 -> hash -> hash
+
+  emptyHash  :: hash
+  hashHash   :: hash -> hash -> hash
+  showHex    :: hash -> String
+
+  hashWord32 w = hashWord8 a . hashWord8 b . hashWord8 c . hashWord8 d where
+    a = fromIntegral (255 .&. (       w   ))
+    b = fromIntegral (255 .&. (shiftR w  8))
+    c = fromIntegral (255 .&. (shiftR w 16))
+    d = fromIntegral (255 .&. (shiftR w 24))
+ 
+  hashWord16 w = hashWord8 a . hashWord8 b where
+    a = fromIntegral (255 .&. (       w   ))
+    b = fromIntegral (255 .&. (shiftR w  8))
+
+  hashWord64 w = hashWord32 a . hashWord32 b where
+    a = fromIntegral (0xffffffff .&. (       w   ))
+    b = fromIntegral (0xffffffff .&. (shiftR w 32))
+
+--------------------------------------------------------------------------------
+
+-- | A type class of hashable objects. An instance has to compute the hash for
+-- /any/ hash function, using the \"base\" types (eg. Word32).
+--
+-- Minimal complete definition: 'hashDigest'. The default for 'computeHash' is
+--
+-- > computeHash x = hashDigest x emptyHash
+-- 
+class Hashable a where
+  hashDigest  :: HashValue hash => a -> hash -> hash
+  computeHash :: HashValue hash => a -> hash
+
+  computeHash x = hashDigest x emptyHash
+
+--------------------------------------------------------------------------------
+
+instance Hashable Word8  where hashDigest = hashWord8
+instance Hashable Word16 where hashDigest = hashWord16
+instance Hashable Word32 where hashDigest = hashWord32
+instance Hashable Word64 where hashDigest = hashWord64
+
+instance Hashable Int  where hashDigest = hashInt
+instance Hashable Word where hashDigest = hashWord
+instance Hashable Bool where hashDigest = hashBool
+instance Hashable Char where hashDigest = hashChar
+
+--------------------------------------------------------------------------------
+
+instance Hashable a => Hashable [a] where
+  hashDigest xs h = foldl' (flip hashDigest) h xs
+
+instance (Hashable a, Hashable b) => Hashable (a,b) where
+  hashDigest (x,y) = hashDigest y . hashDigest x
+
+instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
+  hashDigest (x,y,z) = hashDigest z . hashDigest y . hashDigest x
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
+  hashDigest (x,y,z,w) = hashDigest w . hashDigest z . hashDigest y . hashDigest x
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
+  hashDigest (x,y,z,w,u) = hashDigest u . hashDigest w . hashDigest z . hashDigest y . hashDigest x
+
+--------------------------------------------------------------------------------
+
+hashInt  :: HashValue hash => Int  -> hash -> hash
+hashWord :: HashValue hash => Word -> hash -> hash
+hashBool :: HashValue hash => Bool -> hash -> hash
+hashChar :: HashValue hash => Char -> hash -> hash
+
+hashInt  k = hashWord64 (fromIntegral k)
+hashWord k = hashWord64 (fromIntegral k)
+hashBool b = hashWord8  (if b then 255 else 0)
+hashChar c = hashWord16 (fromIntegral (ord c)) 
+
+--------------------------------------------------------------------------------
+

@@ -0,0 +1,94 @@++-- | 32-bit FNV-1a (Fowler-Noll-Vo) hash++{-# LANGUAGE CPP #-}+module Data.Generics.Fixplate.Hash.FNV.FNV32 +  ( FNV32(..) +  , unFNV32 +  ) +  where++--------------------------------------------------------------------------------++import Data.Char+import Data.Word+import Data.Bits+-- import Data.Int+-- import Data.List++import Data.Generics.Fixplate.Hash.Class ++--------------------------------------------------------------------------------++newtype FNV32 = FNV32 Word32 deriving (Eq,Ord,Show)++unFNV32 :: FNV32 -> Word32+unFNV32 (FNV32 x) = x++instance Hashable FNV32 where +  hashDigest (FNV32 w) = hashDigest w++instance HashValue FNV32 where+  emptyHash = FNV32 fnv32_offset +  hashHash (FNV32 w) = hashWord32 w+  showHex  (FNV32 w) = showHex32 w+  hashWord8  x (FNV32 w) = FNV32 (fnv32_octet  x w)+  hashWord16 x (FNV32 w) = FNV32 (fnv32_word16 x w)+  hashWord32 x (FNV32 w) = FNV32 (fnv32_word32 x w)+  hashWord64 x (FNV32 w) = FNV32 (fnv32_word64 x w)++--------------------------------------------------------------------------------++showHex32 :: Word32 -> String+showHex32 h = reverse $ worker 8 h where+  worker :: Int -> Word32 -> String+  worker 0 0 = []+  worker 0 _ = error "Hash/FNV32/showHex: shouldn't happen"+  worker i w = hexdigit (w .&. 15) : worker (i-1) (shiftR w 4) +  hexdigit :: Word32 -> Char+  hexdigit n+    | k>=0 && k<=9   = chr (k+48)+    | otherwise      = chr (k+55)+    where k = fromIntegral n++--------------------------------------------------------------------------------+-- FNV-1a hash++fnv32_prime, fnv32_offset :: Word32++fnv32_prime  = 16777619   +fnv32_offset = 2166136261 ++fnv32_octet :: Word8 -> Word32 -> Word32+fnv32_octet octet old = fnv32_prime * (old `xor` fromIntegral octet)++--------------------------------------------------------------------------------+-- 32 bit++fnv32_word32 :: Word32 -> Word32 -> Word32+fnv32_word32 w = fnv32_octet a . fnv32_octet b . fnv32_octet c . fnv32_octet d where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))+  c = fromIntegral (255 .&. (shiftR w 16))+  d = fromIntegral (255 .&. (shiftR w 24))++{-+fnv32_word24 :: Word32 -> Word32 -> Word32+fnv32_word24 w = fnv32_octet a . fnv32_octet b . fnv32_octet c where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))+  c = fromIntegral (255 .&. (shiftR w 16))+-}++fnv32_word16 :: Word16 -> Word32 -> Word32+fnv32_word16 w = fnv32_octet a . fnv32_octet b where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))++fnv32_word64 :: Word64 -> Word32 -> Word32+fnv32_word64 w = fnv32_word32 a . fnv32_word32 b where+  a = fromIntegral (0xffffffff .&. (       w   ))+  b = fromIntegral (0xffffffff .&. (shiftR w 32))++--------------------------------------------------------------------------------+

@@ -0,0 +1,97 @@++-- | 64-bit FNV-1a (Fowler-Noll-Vo) hash++{-# LANGUAGE CPP #-}+module Data.Generics.Fixplate.Hash.FNV.FNV64 +  ( FNV64(..) +  , unFNV64+  ) +  where++--------------------------------------------------------------------------------++import Data.Char+import Data.Word+import Data.Bits+-- import Data.Int+-- import Data.List++import Data.Generics.Fixplate.Hash.Class++--------------------------------------------------------------------------------++instance Hashable FNV64 where +  hashDigest (FNV64 w) = hashDigest w++instance HashValue FNV64 where+  emptyHash = FNV64 fnv64_offset +  hashHash (FNV64 w) = hashWord64 w+  showHex  (FNV64 w) = showHex64 w+  hashWord8  x (FNV64 w) = FNV64 (fnv64_octet  x w)+  hashWord16 x (FNV64 w) = FNV64 (fnv64_word16 x w)+  hashWord32 x (FNV64 w) = FNV64 (fnv64_word32 x w)+  hashWord64 x (FNV64 w) = FNV64 (fnv64_word64 x w)+  +--------------------------------------------------------------------------------++newtype FNV64 = FNV64 Word64 deriving (Eq,Ord,Show)++unFNV64 :: FNV64 -> Word64+unFNV64 (FNV64 x) = x++--------------------------------------------------------------------------------++showHex64 :: Word64 -> String+showHex64 h = reverse $ worker 16 h where+  worker :: Int -> Word64 -> String+  worker 0 0 = []+  worker 0 _ = error "Hash/FNV64/showHex: shouldn't happen"+  worker i w = hexdigit (w .&. 15) : worker (i-1) (shiftR w 4) +  hexdigit :: Word64 -> Char+  hexdigit n+    | k>=0 && k<=9   = chr (k+48)+    | otherwise      = chr (k+55)+    where k = fromIntegral n++--------------------------------------------------------------------------------+-- FNV-1a hash++fnv64_prime, fnv64_offset :: Word64++fnv64_prime  = 1099511628211        +fnv64_offset = 14695981039346656037 ++fnv64_octet :: Word8 -> Word64 -> Word64+fnv64_octet octet old = fnv64_prime * (old `xor` fromIntegral octet)++--------------------------------------------------------------------------------+-- 64 bit++fnv64_word32 :: Word32 -> Word64 -> Word64+fnv64_word32 w = fnv64_octet a . fnv64_octet b . fnv64_octet c . fnv64_octet d where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))+  c = fromIntegral (255 .&. (shiftR w 16))+  d = fromIntegral (255 .&. (shiftR w 24))++{-+fnv64_word24 :: Word32 -> Word64 -> Word64+fnv64_word24 w = fnv64_octet a . fnv64_octet b . fnv64_octet c where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))+  c = fromIntegral (255 .&. (shiftR w 16))+-}+ +fnv64_word16 :: Word16 -> Word64 -> Word64+fnv64_word16 w = fnv64_octet a . fnv64_octet b where+  a = fromIntegral (255 .&. (       w   ))+  b = fromIntegral (255 .&. (shiftR w  8))++fnv64_word64 :: Word64 -> Word64 -> Word64+fnv64_word64 w = fnv64_word32 a . fnv64_word32 b where+  a = fromIntegral (0xffffffff .&. (       w   ))+  b = fromIntegral (0xffffffff .&. (shiftR w 32))++--------------------------------------------------------------------------------++

@@ -0,0 +1,109 @@+
+-- | Simple hash tables, implemented as @Map hash (Map key value)@.
+--
+-- To be Haskell98 compatible (no multi-param type classes), when constructing 
+-- a new hash table, we have to support the function computing (or just fetching, if
+-- it is cached) the hash value. This function is then stored in the data type.
+--
+module Data.Generics.Fixplate.Hash.Table
+  ( HashTable 
+  , getHashValue , unHashTable
+    -- * Construction and deconstruction
+  , empty , singleton
+  , fromList , toList 
+  , bag
+    -- * Membership
+  , lookup , member
+    -- * Insert
+  , insert , insertWith
+  )
+  where
+
+--------------------------------------------------------------------------------
+
+import Prelude hiding ( lookup )
+
+import Data.List ( foldl' )
+
+import qualified Data.Map as Map ; import Data.Map (Map) 
+-- import qualified Data.Set as Set ; import Data.Set (Set) 
+
+--------------------------------------------------------------------------------
+-- helper functions
+
+mapInsertWith :: Ord k => (a -> v) -> (a -> v -> v) -> k -> a -> Map k v ->  Map k v
+mapInsertWith f g k x = x `seq` Map.alter worker k where
+  worker Nothing   =          Just $! (f x)
+  worker (Just y)  = y `seq` (Just $! (g x y))
+
+mapIsSingleton :: Map k v -> Maybe (k,v)
+mapIsSingleton table = if Map.size table == 1 
+  then let [(k,v)] = Map.toList table in Just (k,v)
+  else Nothing
+
+mapIsSingleton_ :: Map k v -> Maybe v
+mapIsSingleton_ table = if Map.size table == 1 
+  then let [(_,v)] = Map.toList table in Just v
+  else Nothing
+
+--------------------------------------------------------------------------------
+
+--newtype HashTable hash k v = HashTable { unHashTable :: Map hash (Map k v) }
+
+data HashTable hash k v = HashTable 
+  { getHashValue :: k -> hash
+  , unHashTable  :: Map hash (Map k v) 
+  }
+
+empty :: (Ord hash, Ord k) => (k -> hash) -> HashTable hash k v
+empty gethash = HashTable gethash (Map.empty)
+
+singleton :: (Ord hash, Ord k) => (k -> hash) -> k -> v -> HashTable hash k v
+singleton gethash k v = HashTable gethash $ Map.singleton h (Map.singleton k v) where
+  h = gethash k
+
+fromList :: (Ord hash, Ord k) => (k -> hash) -> [(k,v)] -> HashTable hash k v
+fromList gethash = foldl' (\old (k,v) -> insert k v old) (empty gethash)
+
+toList :: Ord k => HashTable hash k v -> [(k,v)]
+toList (HashTable _ table) = concat [ Map.toList sub | sub <- Map.elems table ]
+
+--------------------------------------------------------------------------------
+
+lookup :: (Ord hash, Ord k) => k -> HashTable hash k v -> Maybe v
+lookup key (HashTable gethash table) = 
+  case Map.lookup h table of
+    Just sub -> case mapIsSingleton_ sub of
+      Just v  -> Just v
+      Nothing -> Map.lookup key sub
+    Nothing  -> Nothing      
+  where
+    h = gethash key
+
+member :: (Ord hash, Ord k) => k -> HashTable hash k v -> Bool
+member key table = case lookup key table of
+  Just _  -> True
+  Nothing -> False
+
+--------------------------------------------------------------------------------
+
+insert :: (Ord hash, Ord k) => k -> v -> HashTable hash k v -> HashTable hash k v
+insert k v (HashTable gethash table) = HashTable gethash $ mapInsertWith f g h v table where
+  h = gethash k
+  f v     = Map.singleton k v
+  g v sub = Map.insert    k v sub
+
+insertWith :: (Ord hash, Ord k) => (a -> v) -> (a -> v -> v) -> k -> a -> HashTable hash k v -> HashTable hash k v
+insertWith ff gg k x (HashTable gethash table) = HashTable gethash $ mapInsertWith f g h x table where
+  h = gethash k
+  f x     = Map.singleton k (ff x)
+  g x sub = mapInsertWith ff gg k x sub
+
+--------------------------------------------------------------------------------
+
+-- | Creates a multi-set from a list.
+bag :: (Ord hash, Ord k) => (k -> hash) -> [k] -> HashTable hash k Int
+bag gethash = foldl' (\old k -> insertWith id (+) k 1 old) (empty gethash)
+
+--------------------------------------------------------------------------------
+

@@ -1,5 +1,5 @@ 
--- | Scary named folds...
+-- | Recursion schemes, also known as scary named folds... 
 
 {-# LANGUAGE CPP #-}
 module Data.Generics.Fixplate.Morphisms where
@@ -22,26 +22,27 @@ --------------------------------------------------------------------------------
 -- * Classic ana\/cata\/para\/hylo-morphisms
 
--- | A /paramorphism/ is a generalized (right) fold.
-para :: Functor f => (Mu f -> f a -> a) -> Mu f -> a
+-- | A /catamorphism/ is the generalization of right fold from lists to trees.
+cata :: Functor f => (f a -> a) -> Mu f -> a
+cata h = go where
+  go = h . fmap go . unFix
+
+-- | A /paramorphism/ is a more general version of the catamorphism.
+para :: Functor f => (f (Mu f, a) -> a) -> Mu f -> a
 para h = go where
-  go t = h t (fmap go $ unFix t) 
+  go (Fix t) = h (fmap go' t)
+  go' t = (t, go t) 
 
--- | Another version of 'para' (more natural in some sense; compare with 'apo').
-para' :: Functor f => (f (Mu f, a) -> a) -> Mu f -> a
+-- | Another version of 'para' (a bit less natural in some sense).
+para' :: Functor f => (Mu f -> f a -> a) -> Mu f -> a
 para' h = go where
-  go (Fix t) = h (fmap go' $ t)
-  go' t = (t, go t) 
+  go t = h t (fmap go $ unFix t) 
 
+-- | A list version of 'para' (compare with Uniplate)
 paraList :: (Functor f, Foldable f) => (Mu f -> [a] -> a) -> Mu f -> a 
 paraList f = go where
   go t = f t (toList $ fmap go $ unFix t)
 
--- | A /catamorphism/ is a simpler version of a paramorphism
-cata :: Functor f => (f a -> a) -> Mu f -> a
-cata h = go where
-  go = h . fmap go . unFix
-
 -- | An /anamorphism/ is simply an unfold. Probably not very useful in this context.
 ana :: Functor f => (a -> f a) -> a -> Mu f
 ana h = go where
@@ -61,14 +62,14 @@ hylo g h = cata g . ana h
 
 --------------------------------------------------------------------------------
--- * More exotic stuff
+-- * Zygomorphisms
 
 -- | A /zygomorphism/ is a basically a catamorphism inside another catamorphism.
 -- It could be implemented (somewhat wastefully) by first annotating each subtree
 -- with the corresponding values of the inner catamorphism ('synthCata'), then running 
 -- a paramorphims on the annotated tree:
 -- 
--- > zygo_ g h == para' u . synthCata g 
+-- > zygo_ g h == para u . synthCata g 
 -- >   where
 -- >     u = h . fmap (first attribute) . unAnn
 -- >     first f (x,y) = (f x, y)
@@ -83,7 +84,13 @@     a  = h ba             -- :: a
     ba = fmap go t        -- :: f (b,a)
 
+--------------------------------------------------------------------------------
+-- * Futu- and histomorphisms
+
+{-
 newtype Free   f a = Free   { unFree   :: Either a (f (Free f a)) }
+
+-- | @CoFree f a@ is basically an @a@-annotated version of @Mu f@. So it is isomorphic to @Attr f a@.
 newtype CoFree f a = CoFree { unCoFree :: (a , f (CoFree f a))    }
 
 -- | Futumorphism. Whatever it does.
@@ -96,25 +103,37 @@     Left  x -> go x
     Right t -> Fix (fmap worker t)
 
--- | Histomorphism. Whatever it does.
+-- | Histomorphism. 
 histo :: Functor f => (f (CoFree f a) -> a) -> Mu f -> a
 histo h = go where
   -- go :: Mu f -> a
   go = h . fmap worker . unFix
   -- worker :: Mu f -> CoFree f
   worker t@(Fix s) = CoFree ( go t , fmap worker s )
+-}
 
---------------------------------------------------------------------------------
--- * Monadic versions
+-- | Histomorphism. This is a kind of glorified cata/paramorphism, after all:
+--
+-- > cata f == histo (f . fmap attribute)
+-- > para f == histo (f . fmap (\t -> (forget t, attribute t)))
+--
+histo :: Functor f => (f (Attr f a) -> a) -> Mu f -> a
+histo h = go where
+  go = h . fmap worker . unFix
+  worker t@(Fix s) = Fix (Ann (go t) (fmap worker s))
 
--- | Monadic paramorphism.
-paraM :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m a
-paraM h = go where
-  go t = mapM go (unFix t) >>= h t
 
-paraM_ :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m ()
-paraM_ h t = do { _ <- paraM h t ; return () }
+-- | Futumorphism. This is a more interesting unfold.
+futu :: Functor f => (a -> f (CoAttr f a)) -> a -> Mu f
+futu h = go where
+  go = Fix . fmap worker . h 
+  worker (Fix ei) = case ei of
+    Pure  x -> go x
+    CoAnn t -> Fix (fmap worker t)
 
+--------------------------------------------------------------------------------
+-- * Monadic versions
+
 -- | Monadic catamorphism.
 cataM :: (Monad m, Traversable f) => (f a -> m a) -> Mu f -> m a
 cataM h = go where
@@ -123,6 +142,25 @@ cataM_ :: (Monad m, Traversable f) => (f a -> m a) -> Mu f -> m ()
 cataM_ h t = do { _ <- cataM h t ; return () }
 
+-- | Monadic paramorphism.
+paraM :: (Monad m, Traversable f) => (f (Mu f, a) -> m a) -> Mu f -> m a
+paraM h = go where
+  go (Fix t) = mapM go' t >>= h
+  go' t = go t >>= \x -> return (t,x)
+
+paraM_ :: (Monad m, Traversable f) => (f (Mu f, a) -> m a) -> Mu f -> m ()
+paraM_ h t = do { _ <- paraM h t ; return () }
+
+-- | Another version of 'paraM'.
+paraM' :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m a
+paraM' h = go where
+  go t = mapM go (unFix t) >>= h t
+
+{-
+paraM_ :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m ()
+paraM_ h t = do { _ <- paraM h t ; return () }
+-}
+
 --------------------------------------------------------------------------------
 #ifdef WITH_QUICKCHECK
 -- * Tests
@@ -131,16 +169,18 @@ runtests_Morphisms = do
   quickCheck prop_para
   quickCheck prop_paraList
+  quickCheck prop_cataHisto
+  quickCheck prop_paraHisto
   -- quickCheck prop_zygo      -- moved to Attributes.hs, to avoid circular imports
   -- quickCheck prop_zygo_
  
 prop_para :: FixT Label -> Bool
 prop_para tree = para f tree == para' f' tree where
-  f :: FixT Label -> TreeF Label Integer -> Integer
-  f t@(Fix (TreeF (Label label) sub)) js = h label (toList sub) (toList js)
+  f' :: FixT Label -> TreeF Label Integer -> Integer
+  f' t@(Fix (TreeF (Label label) sub)) js = h label (toList sub) (toList js)
 
-  f' :: TreeF Label (FixT Label, Integer) -> Integer
-  f' t@(TreeF (Label label) subjs) = h label sub js where
+  f :: TreeF Label (FixT Label, Integer) -> Integer
+  f t@(TreeF (Label label) subjs) = h label sub js where
     (sub,js) = unzip $ toList t
 
   h :: String -> [FixT Label] -> [Integer] -> Integer
@@ -150,12 +190,32 @@   fi = fromIntegral :: Int -> Integer
 
 prop_paraList :: FixT Label -> Bool
-prop_paraList tree = para f tree == paraList flist tree where
+prop_paraList tree = para' f tree == paraList flist tree where
   f t s = flist t (toList s)
   flist :: FixT Label -> [Integer] -> Integer
   flist t@(Fix (TreeF (Label label) sub)) js = Prelude.sum $ zipWith (*) [4..] (map (fi.ord) label ++ js)
 
   fi = fromIntegral :: Int -> Integer
+
+prop_cataHisto :: FixT Label -> Bool
+prop_cataHisto tree = (cata f tree == histo (f . fmap attribute) tree) where
+
+  f :: TreeF Label String -> String
+  f t@(TreeF (Label label) child) = "<" ++ label ++ ">[" ++ intercalate "," child ++ "]"
+
+prop_paraHisto :: FixT Label -> Bool
+prop_paraHisto tree = (para f tree == histo (f . fmap (\t -> (forget t, attribute t))) tree) where
+   
+  f :: TreeF Label (FixT Label, Integer) -> Integer
+  f t@(TreeF (Label label) subjs) = h label sub js where
+    (sub,js) = unzip $ toList t
+
+  h :: String -> [FixT Label] -> [Integer] -> Integer
+  h label ts js = Prelude.sum $ zipWith (*) [3..] (map (fi.ord) label ++ map g ts ++ js)
+  g (Fix (TreeF (Label label) _)) = (Prelude.sum (map (fi.ord) label)) `mod` 59
+
+  fi = fromIntegral :: Int -> Integer
+
 
 #endif
 --------------------------------------------------------------------------------

@@ -4,7 +4,7 @@ {-# LANGUAGE CPP #-}
 module Data.Generics.Fixplate.Open 
   ( 
-    toList
+    toList , toRevList
   -- * Accumulating maps
   , mapAccumL  , mapAccumR
   , mapAccumL_ , mapAccumR_
@@ -18,8 +18,9 @@   , enumerate
   , enumerateWith
   , enumerateWith_
+  -- * Shapes
+  , Hole(..) , Shape , shape
   -- * Zips
-  , Shape , shape
   , zipF , unzipF
   , zipWithF  , unsafeZipWithF
   , zipWithFM , unsafeZipWithFM
@@ -37,6 +38,12 @@ import Data.Generics.Fixplate.Misc
 
 --------------------------------------------------------------------------------
+
+-- | Equivalent to @reverse . toList@.
+toRevList :: Foldable f => f a -> [a]
+toRevList = Data.Foldable.foldl (flip (:)) []
+
+--------------------------------------------------------------------------------
 -- Accumulating maps
 
 mapAccumL_ :: Traversable f => (a -> b -> (a, c)) -> a -> f b -> f c
@@ -121,18 +128,30 @@ -- We ignore all the fields whose type is the parameter type,
 -- but remember the rest:
 --
--- > newtype Shape f = Shape { unShape :: f () }
+-- > newtype Shape f = Shape { unShape :: f Hole }
 --
 -- This can be used to decide whether two realizations are compatible.
-newtype Shape f = Shape { unShape :: f () }
+newtype Shape f = Shape { unShape :: f Hole }
 
 -- | Extracting the \"shape\" of the functor
 shape :: Functor f => f a -> Shape f
-shape = Shape . fmap (const ())
+shape = Shape . fmap (const Hole)
 
 instance EqF   f => Eq   (Shape f) where x == y        = equalF       (unShape x) (unShape y)
 instance OrdF  f => Ord  (Shape f) where compare x y   = compareF     (unShape x) (unShape y)
-instance ShowF f => Show (Shape f) where showsPrec d x = showsPrecF d (unShape x)
+
+-- we need this dirty trick because we want at the same time have
+-- a 'Show' instance for 'Shape f' and allow the user to define
+-- his own Show instance for 'Hole'.
+data Void = Void ; instance Show Void where show _ = "_"
+
+instance (Functor f, ShowF f) => Show (Shape f) where 
+  showsPrec d x = showParen (d>app_prec) 
+    $ showString "Shape "
+    . showsPrecF (app_prec+1) (fmap (const Void) $ unShape x)
+
+--------------------------------------------------------------------------------
+-- Zips
 
 -- | Zips two structures if they are compatible.
 zipF :: (Traversable f, EqF f) => f a -> f b -> Maybe (f (a,b))

@@ -1,6 +1,6 @@  Name:                fixplate-Version:             0.1.3+Version:             0.1.4 Synopsis:            Uniplate-style generic traversals for optionally annotated fixed-point types. Description:         Uniplate-style generic traversals for fixed-point types, which can be                        optionally annotated with attributes. We also provide recursion schemes,@@ -26,10 +26,15 @@   Description: Compile with the QuickCheck tests.    default: False +Flag withHashing+  Description: Include the generic hashing functionality+  default: True+ Flag base4   Description: Base v4    Library+   if flag(base4)     Build-Depends:       base >= 4 && < 5     cpp-options:         -DBASE_VERSION=4@@ -37,6 +42,9 @@     Build-Depends:       base >= 3 && < 4     cpp-options:         -DBASE_VERSION=3 +  if flag(withHashing)+    Build-Depends:       containers+   if flag(withQuickCheck)     Build-Depends:       QuickCheck > 2.4     cpp-options:         -DWITH_QUICKCHECK@@ -48,6 +56,14 @@                        Data.Generics.Fixplate.Morphisms                        Data.Generics.Fixplate.Attributes                        Data.Generics.Fixplate.Zipper+                       Data.Generics.Fixplate.Draw++  if flag(withHashing)+    Exposed-Modules:     Data.Generics.Fixplate.Hash+                         Data.Generics.Fixplate.Hash.Class+                         Data.Generics.Fixplate.Hash.Table+                         Data.Generics.Fixplate.Hash.FNV.FNV32+                         Data.Generics.Fixplate.Hash.FNV.FNV64                           if impl(ghc)||impl(hugs)                          Exposed-Modules:     Data.Generics.Fixplate.Structure