fixplate 0.1.6 → 0.1.7

raw patch · 31 files changed

+1502/−1955 lines, 31 filesdep +fixplatedep +tastydep +tasty-quickcheckdep ~QuickCheckdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fixplate, tasty, tasty-quickcheck

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• Data/Generics/Fixplate.hs +2/−2
• Data/Generics/Fixplate/Attributes.hs +0/−143
• Data/Generics/Fixplate/Base.hs +3/−3
• Data/Generics/Fixplate/Draw.hs +3/−2
• Data/Generics/Fixplate/Functor.hs +2/−1
• Data/Generics/Fixplate/Hash.hs +1/−1
• Data/Generics/Fixplate/Misc.hs +1/−1
• Data/Generics/Fixplate/Morphisms.hs +0/−65
• Data/Generics/Fixplate/Open.hs +3/−3
• Data/Generics/Fixplate/Pretty.hs +1/−1
• Data/Generics/Fixplate/Test/Instances.hs +0/−129
• Data/Generics/Fixplate/Test/Tools.hs +0/−182
• Data/Generics/Fixplate/Tests.hs +0/−40
• Data/Generics/Fixplate/Traversals.hs +0/−39
• Data/Generics/Fixplate/Trie.hs +2/−242
• Data/Generics/Fixplate/Util/Hash/Class.hs +0/−99
• Data/Generics/Fixplate/Util/Hash/FNV/FNV32.hs +0/−94
• Data/Generics/Fixplate/Util/Hash/FNV/FNV64.hs +0/−97
• Data/Generics/Fixplate/Util/Hash/Table.hs +0/−530
• Data/Generics/Fixplate/Zipper.hs +2/−250
• LICENSE +1/−1
• fixplate.cabal +42/−30
• tests/TestSuite/Attributes.hs +159/−0
• tests/TestSuite/Instances.hs +170/−0
• tests/TestSuite/Misc.hs +141/−0
• tests/TestSuite/Morphisms.hs +95/−0
• tests/TestSuite/Tools.hs +183/−0
• tests/TestSuite/Traversals.hs +72/−0
• tests/TestSuite/Trie.hs +287/−0
• tests/TestSuite/Zipper.hs +295/−0
• tests/test-suite.hs +37/−0

@@ -100,7 +100,7 @@ -- import Data.Generics.Fixplate.Zipper
 import Data.Generics.Fixplate.Draw
 
-import Data.Foldable
-import Data.Traversable
+import Data.Foldable    ()
+import Data.Traversable ()
 
 --------------------------------------------------------------------------------

@@ -36,24 +36,6 @@   -- * Stacking attributes
   , annZip  , annZipWith
   , annZip3 , annZipWith3  
-#ifdef WITH_QUICKCHECK
-  -- * Tests
-  , runtests_Attributes  
-  , scanCataNaive , mapAccumCataNaive
-  , prop_synthAccumL
-  , prop_synthAccumR
-  , prop_synthetise
-  , prop_synthCata
-  , prop_synthPara
-  , prop_synthPara'
-  , prop_scanCata 
-  , prop_mapAccumCata
-  -- * Morphism tests which are here to avoid circular imports
-  , zygoNaive_
-  , zygoNaive
-  , prop_zygo
-  , prop_zygo_
-#endif  
   )
   where
 
@@ -67,17 +49,6 @@ import Data.Generics.Fixplate.Base
 import Data.Generics.Fixplate.Open
 
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-import Data.List (intercalate)
-import Data.Char (ord)
-import qualified Prelude
-import Data.Generics.Fixplate.Misc
-import Data.Generics.Fixplate.Morphisms
-import Data.Generics.Fixplate.Traversals
-import Data.Generics.Fixplate.Test.Tools
-#endif 
-
 --------------------------------------------------------------------------------
 
 -- | Map over annotations 
@@ -407,119 +378,5 @@ annZipWith3 h = go where 
   go (Fix (Ann z (Ann y (Ann x t)))) = Fix (Ann (h x y z) (fmap go t))
 
---------------------------------------------------------------------------------
--- Tests
-#ifdef WITH_QUICKCHECK
-
-runtests_Attributes :: IO ()
-runtests_Attributes = do
-  quickCheck prop_synthAccumL
-  quickCheck prop_synthAccumR
-  quickCheck prop_synthetise
-  quickCheck prop_synthCata
-  quickCheck prop_synthPara
-  quickCheck prop_synthPara'
-  quickCheck prop_scanCata 
-  quickCheck prop_mapAccumCata
-  quickCheck prop_zygo
-  quickCheck prop_zygo_
-
-prop_synthAccumL :: FixT Label -> Bool
-prop_synthAccumL tree = 
-  toList (Attrib (synthAccumL_ (\i _ -> (i+1,i)) 1 tree)) == [1..length (universe tree)]
-
-prop_synthAccumR :: FixT Label -> Bool
-prop_synthAccumR tree = 
-  toList (Attrib (synthAccumR_ (\i _ -> (i+1,i)) 1 tree)) == reverse [1..length (universe tree)]
-
-prop_synthetise :: FixT Label -> Bool
-prop_synthetise tree = 
-  map attribute (universe $ synthetise (\(TreeF (Label l) xs) -> l ++ concat xs) tree)
-  ==
-  map fold (universe tree)
-  where
-    fold = foldLeft (\s (Fix (TreeF (Label l) _)) -> s++l) []
-
-prop_synthCata :: FixT Label -> Bool
-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 
-  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
-    sizs = map (cata f) ts
-    f t = (1::Int) + 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 
-  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
-      siz = cata (\t -> (1::Int) + Data.Foldable.sum t) tree
-
-scanCataNaive :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
-scanCataNaive f = annZipWith (flip const) . synthCata (\(Ann a x) -> f a x)
-
-prop_scanCata :: Attr (TreeF Label) String -> Bool
-prop_scanCata tree = scanCata f tree == scanCataNaive f tree where
-  f :: (String -> TreeF Label Integer -> Integer) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
-  f str t = Prelude.product (toList t) + sumchar str
-  sumchar :: String -> Integer
-  sumchar = fromIntegral . Prelude.sum . map ord 
---   tree = synthetise (\(TreeF (Label l) xs) -> map toUpper l ++ concat xs) tree) tree0
-
-mapAccumCataNaive :: Functor f => (f acc -> b -> (acc,c)) -> Attr f b -> (acc, Attr f c)
-mapAccumCataNaive f = second (annZipWith (flip const)) . synthAccumCata (\(Ann b t) -> f t b)
-
-prop_mapAccumCata :: Attr (TreeF Label) String -> Bool
-prop_mapAccumCata tree = mapAccumCata f tree == mapAccumCataNaive f tree where
-  f :: (TreeF Label Integer -> String -> (Integer,String)) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
-  f t str = ( k - fromIntegral (length str) + sumchar str , "<" ++ show k ++ "," ++ str ++ ">") where 
-    ls = toList t
-    k  = Prelude.product ls
-  sumchar :: String -> Integer
-  sumchar = fromIntegral . Prelude.sum . map ord 
-  -- tree = synthetise (\(TreeF (Label l) xs) -> map toLower l ++ concat xs) tree) tree0
-
---------------------------------------------------------------------------------
--- 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 :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> (b,a)
-zygoNaive g h tree = (attribute tmp, para h1 tmp) where 
-  tmp = synthCata g tree
-  h1 = h . fmap (first attribute) . unAnn
-
-prop_zygo :: FixT Label -> Bool
-prop_zygo tree = zygo g h tree == zygoNaive g h tree where
-  g :: TreeF Label Integer -> Integer
-  g (TreeF (Label label) child) = Prelude.product child + sumchar label
-
-  h :: TreeF Label (Integer,String) -> String
-  h (TreeF (Label label) child) = "[" ++ label ++ "]<" ++ intercalate "," (map f child) ++ ">"
-
-  f (k,s) = show k ++ "_" ++ s
-
-  sumchar = fromIntegral . Prelude.sum . map ord 
-
-prop_zygo_ :: FixT Label -> Bool
-prop_zygo_ tree = zygo_ g h tree == zygoNaive_ g h tree where
-  g :: TreeF Label Integer -> Integer
-  g (TreeF (Label label) child) = Prelude.product child + prodchar label
-
-  h :: TreeF Label (Integer,String) -> String
-  h (TreeF (Label label) child) = "<" ++ intercalate "," (map f child) ++ ">" ++ "[" ++ label ++ "]"
-
-  f (k,s) = s ++ "_" ++ show k
-
-  prodchar = fromIntegral . Prelude.product . map ord 
-
-#endif
 --------------------------------------------------------------------------------
 

@@ -7,12 +7,12 @@ --------------------------------------------------------------------------------
 
 import Control.Applicative
-import Control.Monad ( liftM , ap)
+import Control.Monad ( liftM , ap )
 import Data.Foldable
 import Data.Traversable
-import Prelude hiding ( foldl , foldr , mapM , mapM_ , concat , concatMap)
+import Prelude hiding ( foldl , foldr , mapM , mapM_ , concat , concatMap )
 
-import Text.Show
+import Text.Show ()
 import Text.Read
 
 import Data.Generics.Fixplate.Misc

@@ -25,7 +25,7 @@ --------------------------------------------------------------------------------
 
 import Data.Foldable
-import Data.Traversable
+import Data.Traversable ()
 
 import Data.Generics.Fixplate.Base
 import Data.Generics.Fixplate.Open
@@ -62,7 +62,7 @@ 
 --------------------------------------------------------------------------------
 
-type Step = [Bool]
+-- type Step = [Bool]
 
 --------------------------------------------------------------------------------
 
@@ -88,6 +88,7 @@   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 
+  mkLine ([]  , _  ) = error "showTreeWith/mkLine: shouldn't happen"
 
   style = defaultStyle 
 

@@ -17,7 +17,8 @@ --------------------------------------------------------------------------------
 
 import Prelude hiding ( foldl , foldr , mapM )
-import Control.Applicative ( (<$>) , (<*>) )
+
+import Control.Applicative ()
 import Control.Monad ( liftM )
 
 import Data.Generics.Fixplate

@@ -25,7 +25,7 @@ import Prelude as Prelude
 
 import Control.Monad ( liftM )
-import Control.Applicative ( (<$>) )
+import Control.Applicative ()
 
 import Data.Generics.Fixplate
 import Data.Foldable    as F

@@ -11,7 +11,7 @@ 
 import Data.Traversable
 
-import Control.Applicative ( Applicative(..) )
+import Control.Applicative ()
 import Control.Monad ( ap , liftM )
 
 --import Control.Monad.Trans.State

@@ -11,14 +11,6 @@ import Data.Traversable
 import Data.Generics.Fixplate.Base
 
-#ifdef WITH_QUICKCHECK
-import Data.Char ( ord )
-import Data.List ( intercalate )
-import Test.QuickCheck
--- import Data.Generics.Fixplate.Traversals
-import Data.Generics.Fixplate.Test.Tools
-#endif 
-
 --------------------------------------------------------------------------------
 -- * Classic ana\/cata\/para\/hylo-morphisms
 
@@ -161,61 +153,4 @@ paraM_ h t = do { _ <- paraM h t ; return () }
 -}
 
---------------------------------------------------------------------------------
-#ifdef WITH_QUICKCHECK
--- * Tests
-
-runtests_Morphisms :: IO ()
-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 :: 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
-
-prop_paraList :: FixT Label -> Bool
-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
 --------------------------------------------------------------------------------

@@ -29,10 +29,10 @@ 
 --------------------------------------------------------------------------------
 
-import Control.Monad (liftM)
+import Control.Monad ( liftM )
 import Data.Foldable
-import Data.Traversable ( Traversable(..) , mapAccumL , mapAccumR )
-import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+import Data.Traversable ( mapAccumL , mapAccumR )
+import Prelude hiding ( foldl , foldr , mapM , mapM_ , concat , concatMap )
 
 import Data.Generics.Fixplate.Base 
 import Data.Generics.Fixplate.Misc

@@ -17,7 +17,7 @@ import Data.List ( intersperse )
 
 import Data.Generics.Fixplate
-import Data.Foldable ( toList )
+import Data.Foldable 
 
 import Text.Show ()
 

@@ -1,129 +0,0 @@-
-
-{-# LANGUAGE 
-      CPP, 
-      DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving,
-      FlexibleInstances
-  #-}
-module Data.Generics.Fixplate.Test.Instances where
-
---------------------------------------------------------------------------------
-
-import Control.Applicative
-import Control.Monad hiding (mapM, mapM_, forM, forM_)
-import Data.List (sort)
-import Data.Foldable
-import Data.Traversable
-import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
-
-import Data.Generics.Fixplate.Base
-import Data.Generics.Fixplate.Misc
-import Data.Generics.Fixplate.Test.Tools
-
-import Test.QuickCheck
-
---------------------------------------------------------------------------------
--- * Misc
-
-prop_forget :: Attr (TreeF Label) Int -> Bool
-prop_forget tree =
-  fromFixT (forget tree) == fmap fst (fromAttr tree)
-  
-prop_fromToFixT :: FixT Label -> Bool  
-prop_fromToFixT tree =
-  toFixT (fromFixT tree) == tree
-
-prop_toFromFixT :: Tree Label -> Bool  
-prop_toFromFixT tree =
-  fromFixT (toFixT tree) == tree
-
-prop_fromToAttr :: Attr (TreeF Label) Int -> Bool  
-prop_fromToAttr tree =
-  toAttr (fromAttr tree) == tree
-
-prop_toFromAttr :: Tree (Label,Int) -> Bool  
-prop_toFromAttr tree =
-  fromAttr (toAttr tree) == tree
-  
-runtests_InstancesMisc = do
-  quickCheck prop_forget
-  quickCheck prop_fromToFixT 
-  quickCheck prop_toFromFixT
-  quickCheck prop_fromToAttr
-  quickCheck prop_toFromAttr
-  
---------------------------------------------------------------------------------
--- * Read/Show.
-
-prop_ReadShowMuLabel   :: Mu (TreeF Label ) -> Bool
-prop_ReadShowMuInt     :: Mu (TreeF Int   ) -> Bool
-prop_ReadShowMuString  :: Mu (TreeF String) -> Bool
-
-prop_ReadShowMuLabel  t = read (show t) == t 
-prop_ReadShowMuInt    t = read (show t) == t 
-prop_ReadShowMuString t = read (show t) == t 
-
-prop_ReadShowAttrLabelInt    :: Attr (TreeF Label ) Int   -> Bool
-prop_ReadShowAttrStringLabel :: Attr (TreeF String) Label -> Bool
-
-prop_ReadShowAttrLabelInt    t = read (show t) == t 
-prop_ReadShowAttrStringLabel t = read (show t) == t 
-
-runtests_ReadShow = do
-  quickCheck prop_ReadShowMuLabel
-  quickCheck prop_ReadShowMuInt
-  quickCheck prop_ReadShowMuString
-  quickCheck prop_ReadShowAttrLabelInt
-  quickCheck prop_ReadShowAttrStringLabel
-  
---------------------------------------------------------------------------------
--- * Attrib wrapper.
-
-prop_AttribFMap :: Attr (TreeF Label) Int -> Bool
-prop_AttribFMap tree = 
-  unAttrib (fmap f (Attrib tree)) == toAttr (fmap (id<#>f) (fromAttr tree)) 
-    where f n = show n ++ "_"
-
---------------------------------------------------------------------------------
-
-prop_AttribFoldr :: Attr (TreeF Label) Int -> Bool
-prop_AttribFoldr tree = 
-  foldr (:) [] (Attrib tree) == map snd (foldr (:) [] (fromAttr tree))
-
-prop_AttribFoldl :: Attr (TreeF Label) Int -> Bool
-prop_AttribFoldl tree = 
-  foldl (flip (:)) [] (Attrib tree) == map snd (foldl (flip (:)) [] (fromAttr tree))
-
---------------------------------------------------------------------------------
-
-prop_AttribMapAccumL :: Attr (TreeF Label) Integer -> Bool
-prop_AttribMapAccumL tree = 
-  (id<#>unAttrib) (mapAccumL f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumL f2 666 (fromAttr tree)) where 
-    f1 :: Integer -> Integer -> (Integer,String)
-    f1 old input = (new, show residue) where 
-      new     = old*3 - input
-      residue = old*2 + input*7
-    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
-    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))
-
-prop_AttribMapAccumR :: Attr (TreeF Label) Integer -> Bool
-prop_AttribMapAccumR tree = 
-  (id<#>unAttrib) (mapAccumR f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumR f2 666 (fromAttr tree)) where 
-    f1 :: Integer -> Integer -> (Integer,String)
-    f1 old input = (new, show residue) where 
-      new     = old*3 - input
-      residue = old*2 + input*7
-    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
-    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))
-
--- | We compare GHC-derived Functor, Foldable and Traversable instances (for Tree)
--- with our implementation (for Attrib).
-runtests_Attrib = do
-  quickCheck prop_AttribFMap
-  quickCheck prop_AttribFoldr
-  quickCheck prop_AttribFoldl
-  quickCheck prop_AttribMapAccumL
-  quickCheck prop_AttribMapAccumR
-  
---------------------------------------------------------------------------------
-  

@@ -1,182 +0,0 @@-
-{-# LANGUAGE CPP, 
-             DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving,
-             FlexibleInstances, TypeSynonymInstances
-  #-}
-module Data.Generics.Fixplate.Test.Tools where
-
---------------------------------------------------------------------------------
-
-import Control.Applicative
-import Control.Monad hiding (mapM, mapM_, forM, forM_)
-import Data.List (sort)
-import Data.Foldable
-import Data.Traversable
-import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
-
-import Text.Show
-import Text.Read
-
-import Data.Generics.Fixplate.Base
-
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-#endif 
-
---------------------------------------------------------------------------------
-
-maxChildren :: Int
-maxChildren = 7
-
-data Tree label
-  = Tree label [Tree label] 
-  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
-
-data TreeF label t 
-  = TreeF label [t]
-  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
-  
-type FixT label = Mu (TreeF label)  
-  
-instance Eq   label => EqF   (TreeF label) where equalF     = (==)
-instance Ord  label => OrdF  (TreeF label) where compareF   = compare
-instance Show label => ShowF (TreeF label) where showsPrecF = showsPrec
-#ifdef __GLASGOW_HASKELL__
-instance Read label => ReadF (TreeF label) where readPrecF  = readPrec
-#else
-instance Read label => ReadF (TreeF label) where readsPrecF = readsPrec
-#endif
-  
-treeF :: l -> [Mu (TreeF l)] -> Mu (TreeF l)
-treeF s = Fix . TreeF s
-
-attrTreeF :: a -> l -> [Attr (TreeF l) a] -> Attr (TreeF l) a
-attrTreeF x s = Fix . Ann x . TreeF s
-
---------------------------------------------------------------------------------
--- * draw trees
-
-printTree :: Tree Label -> IO ()
-printTree = printTree' (\(Label s) -> s)
-
-printTreeF :: FixT Label -> IO ()
-printTreeF = printTreeF' (\(Label s) -> s)
-
-printTree' :: (a -> String) -> Tree a -> IO ()
-printTree' h = go 0 where
-  go i (Tree label children) = do
-    putStrLn $ if i>0 
-      then concat (replicate (i-1) "| " ++ ["|-", h label])
-      else h label
-    mapM_ (go (i+1)) children
-
-printTreeF' :: (a -> String) -> Mu (TreeF a) -> IO ()
-printTreeF' h = go 0 where
-  go i (Fix (TreeF label children)) = do
-    putStrLn $ if i>0 
-      then concat (replicate (i-1) "| " ++ ["|-", h label])
-      else h label
-    mapM_ (go (i+1)) children
-    
---------------------------------------------------------------------------------
--- * random trees
-
-rndTree :: IO (Tree Label)
-rndTree = liftM (!!7) $ sample' arbitrary
-
-rndFixT :: IO (FixT Label)
-rndFixT = liftM (!!7) $ sample' arbitrary
-
---------------------------------------------------------------------------------
--- * conversion
-
-toFixT :: Tree l -> Mu (TreeF l)
-toFixT (Tree s ts) = treeF s (map toFixT ts)
-
-fromFixT :: FixT l -> Tree l
-fromFixT (Fix (TreeF s ts)) = Tree s (map fromFixT ts)
-
-fromAttr :: Attr (TreeF l) a -> Tree (l,a)
-fromAttr (Fix (Ann x (TreeF s ts))) = Tree (s,x) (map fromAttr ts)
-
-toAttr :: Tree (l,a) -> Attr (TreeF l) a 
-toAttr (Tree (s,x) ts) = Fix (Ann x (TreeF s (map toAttr ts)))
-
---------------------------------------------------------------------------------
--- * arbitrary
-
-pairs :: [a] -> [(a,a)]
-pairs (x:xs@(y:_)) = (x,y):(pairs xs)
-pairs [_]          = []
-pairs []           = error "pairs: empty list"
-
--- | @genPartition n k@ partitions n elements into k groups randomly,
--- and gives back the sizes (which can be zero, too)
-genPartition :: Int -> Int -> Gen [Int]
-genPartition n k = do
-  sep <- replicateM (k-1) $ choose (0,n)
-  let ps = pairs (0 : sort sep ++ [n]) 
-  return (map (\(x,y) -> (y-x)) ps)
-
-newtype Label = Label String deriving (Eq,Ord,Show,Read)
-
-unLabel :: Label -> String
-unLabel (Label s) = s
-
-instance Arbitrary Label where
-  arbitrary = do
-    n <- choose (2, 8)
-    liftM Label $ vectorOf n $ oneof [ choose ('a','z') , choose ('A','Z') ]
-  
-instance Arbitrary l => Arbitrary (Tree l) where
-  shrink (Tree s sub) = [ Tree s sub' | sub' <- shrink sub ] 
-  arbitrary = sized mkTree where
-    mkTree n = do
-      s <- arbitrary
-      case n of
-        0 -> return (Tree s [])
-        1 -> mkTree 0 >>= \t -> return (Tree s [t])
-        _ -> do
-          k <- choose (1, min maxChildren n)
-          ls <- genPartition (n-1) k
-          subtrees <- forM ls $ \l -> mkTree l
-          return (Tree s subtrees)
-
-instance Arbitrary l => Arbitrary (Mu (TreeF l)) where
-  shrink (Fix (TreeF s sub)) = [ Fix (TreeF s sub') | sub' <- shrink sub ] 
-  arbitrary = sized mkTree  where
-    mkTree n = do
-      s <- arbitrary
-      case n of
-        0 -> return (treeF s [])
-        1 -> mkTree 0 >>= \t -> return (treeF s [t])
-        _ -> do
-          k <- choose (1, min maxChildren n)
-          ls <- genPartition (n-1) k
-          subtrees <- forM ls $ \l -> mkTree l
-          return (treeF s subtrees)
-
-{-          
-instance (Arbitrary a, Arbitrary x) => Arbitrary (Ann TreeF a x) where
-  shrink (Ann a x) = [ Ann a y | y <- shrink x ]
-  arbitrary = do
-    a <- arbitrary
-    x <- arbitrary
--}
-
-instance (Arbitrary a, Arbitrary l) => Arbitrary (Attr (TreeF l) a) where
-  shrink (Fix (Ann a (TreeF s sub))) = [ Fix (Ann a (TreeF s sub')) | sub' <- shrink sub ] 
-  arbitrary = sized mkTree  where
-    mkTree n = do
-      s <- arbitrary
-      a <- arbitrary
-      case n of
-        0 -> return (attrTreeF a s [])
-        1 -> mkTree 0 >>= \t -> return (attrTreeF a s [t])
-        _ -> do
-          k <- choose (1, min maxChildren n)
-          ls <- genPartition (n-1) k
-          subtrees <- forM ls $ \l -> mkTree l
-          return (attrTreeF a s subtrees)
-              
---------------------------------------------------------------------------------

@@ -1,40 +0,0 @@-
--- | Run all the tests
-{-# LANGUAGE CPP #-}
-module Data.Generics.Fixplate.Tests where
-  
---------------------------------------------------------------------------------
-  
-import Data.Generics.Fixplate.Base
-import Data.Generics.Fixplate.Traversals
-import Data.Generics.Fixplate.Morphisms
-import Data.Generics.Fixplate.Attributes
-import Data.Generics.Fixplate.Zipper
-import Data.Generics.Fixplate.Trie
-
-import Data.Generics.Fixplate.Test.Tools
-import Data.Generics.Fixplate.Test.Instances
-
-import Test.QuickCheck
-
-#ifdef WITH_UTILITY_MODULES
-import Data.Generics.Fixplate.Util.Hash.Table
-#endif
-
---------------------------------------------------------------------------------
-
-run_all_tests :: IO ()
-run_all_tests = do
-  putStrLn "tests for instances..."       ; runtests_InstancesMisc
-  putStrLn "tests for Read/Show..."       ; runtests_ReadShow
-  putStrLn "tests for Attrib wrapper..."  ; runtests_Attrib
-  putStrLn "tests for traversals..."      ; runtests_Traversals
-  putStrLn "tests for Attributes..."      ; runtests_Attributes
-  putStrLn "tests for zippers..."         ; runtests_Zipper
-  putStrLn "tests for morphisms..."       ; runtests_Morphisms
-  putStrLn "tests for tries..."           ; runtests_Trie
-#ifdef WITH_UTILITY_MODULES
-  putStrLn "tests for hash tables..."     ; runtests_HashTable
-#endif
-
---------------------------------------------------------------------------------

@@ -38,11 +38,6 @@ import Data.Generics.Fixplate.Open
 --import Data.Generics.Fixplate.Misc
 
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-import Data.Generics.Fixplate.Test.Tools
-#endif
-
 --------------------------------------------------------------------------------
 -- * Queries
 
@@ -155,38 +150,4 @@ foldRight h x0 t = go t x0 where
   go t x = h t $ foldr go x $ unFix t 
 
---------------------------------------------------------------------------------
-#ifdef WITH_QUICKCHECK
--- * Tests
-
-universeNaive :: Foldable f => Mu f -> [Mu f]
-universeNaive x = x : concatMap universeNaive (children x)
-
-runtests_Traversals :: IO ()
-runtests_Traversals = do
-  quickCheck prop_leftFold
-  quickCheck prop_leftFoldLazy
-  quickCheck prop_rightFold
-  quickCheck prop_universe1
-  quickCheck prop_universe2
-  
-prop_universe1 :: FixT Label -> Bool
-prop_universe1 tree = universe tree == universeNaive tree
-
-prop_universe2 :: FixT Label -> Bool
-prop_universe2 tree = universe tree == foldRight (:) [] tree
-  
-prop_leftFold :: FixT Label -> Bool
-prop_leftFold tree = 
-  foldLeft (\xs (Fix (TreeF l s)) -> (l:xs)) [] tree == foldl (flip (:)) [] (fromFixT tree)
-
-prop_leftFoldLazy :: FixT Label -> Bool
-prop_leftFoldLazy tree = 
-  foldLeftLazy (\xs (Fix (TreeF l s)) -> (l:xs)) [] tree == foldl (flip (:)) [] (fromFixT tree)
-  
-prop_rightFold :: FixT Label -> Bool
-prop_rightFold tree = 
-  foldRight (\(Fix (TreeF l s)) xs -> (l:xs)) [] tree == foldr (:) [] (fromFixT tree)
-
-#endif
 --------------------------------------------------------------------------------

@@ -29,10 +29,6 @@   , intersection , intersectionWith
   , union        , unionWith
   , difference   , differenceWith
-#ifdef WITH_QUICKCHECK
-    -- * Tests
-  , runtests_Trie
-#endif
   ) 
   where
 
@@ -45,22 +41,12 @@ import Data.Generics.Fixplate.Traversals ( universe )
 
 import qualified Data.Foldable as Foldable
-import Data.Foldable hiding ( toList )
 
-import Data.Traversable as Traversable
+import Data.Foldable    ()
+import Data.Traversable ()
 
 import qualified Data.Map as Map ; import Data.Map (Map)
 
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-import Data.Generics.Fixplate.Test.Tools
-import Data.Generics.Fixplate.Misc
-import Data.Generics.Fixplate.Traversals
-import Data.List ( sort , group , nubBy , nub , (\\) , foldl' )
-import Control.Applicative ( (<$>) )
-import Debug.Trace
-#endif
-
 ---------------------------------------------------------------------------------
 
 -- | Creates a trie-multiset from a list of trees.
@@ -282,231 +268,5 @@ trieDifferenceWith :: (Functor f, Foldable f, OrdF f) => (a -> b -> Maybe a) -> Trie f a -> Trie f b -> Trie f a
 trieDifferenceWith f (Trie trie1) (Trie trie2) = Trie (Map.differenceWith worker trie1 trie2) where
   worker chain1 chain2 = chainDifferenceWith f chain1 chain2
-
----------------------------------------------------------------------------------
--- Tests
-
-#ifdef WITH_QUICKCHECK
-
-runtests_Trie :: IO ()
-runtests_Trie = do
-  quickCheck prop_difference
-  quickCheck prop_differenceWith
-  quickCheck prop_union
-  quickCheck prop_intersection
-
-  quickCheck prop_unibag_naive
-  quickCheck prop_unibag_naive_2
-  quickCheck prop_christmasTree
-  quickCheck prop_christmasTree_2
-  quickCheck prop_christmasTree_3
-
-  quickCheck prop_fromList_naive
-  quickCheck prop_bag
-  quickCheck prop_bag_b
-  quickCheck prop_fromList_toList
-  quickCheck prop_multiSetToList_b
-  quickCheck prop_insert
-  quickCheck prop_delete
-  quickCheck prop_update
-  quickCheck prop_insert_delete
-  quickCheck prop_delete_insert
-  quickCheck prop_lookup
-  quickCheck prop_lookup_notfound
-  quickCheck prop_singleton
-
---------------------
-
-newtype Multiplicity = Multiplicity { unMultiplicity :: Int } deriving (Eq,Ord,Show)
-
-instance Arbitrary Multiplicity where
-  arbitrary = do
-    n <- choose (1, 7)
-    return (Multiplicity n)
-
-newtype MultiSet = MultiSet { unMultiSet :: [(Multiplicity, FixT Label)] } deriving (Eq,Ord,Show)
-
-instance Arbitrary MultiSet where arbitrary = MultiSet <$> arbitrary
-
-multiSetToList :: MultiSet -> [FixT Label]
-multiSetToList (MultiSet mxs) = go mxs where
-  go [] = []
-  go ((Multiplicity n, x):rest) = replicate n x ++ go rest
-
-multiSetToList_b :: MultiSet -> [FixT Label]
-multiSetToList_b (MultiSet mxs) = go mxs [] where
-  go [] [] = []
-  go [] ys = go ys []
-  go ((Multiplicity n, x):rest) ys = if n>0 
-    then x : go rest ( (Multiplicity (n-1), x) : ys )
-    else go rest ys
-
-newtype FiniteMap = FiniteMap { unFiniteMap :: [(FixT Label,Char)] } deriving (Eq,Ord,Show)
-
-instance Arbitrary FiniteMap where arbitrary = (FiniteMap . nubBy (equating fst)) <$> arbitrary
-
-type TrieT = Trie (TreeF Label) Char
-
-finiteMap :: FiniteMap -> TrieT
-finiteMap (FiniteMap fmap) = fromList fmap
-
---------------------
-
-fromListNaive :: (Traversable f, OrdF f) => [(Mu f, a)] -> Trie f a
-fromListNaive ts = Prelude.foldl worker emptyTrie ts where
-  worker trie (tree,value) = trieInsertWith id const tree value trie 
-
-universeBagNaive :: (Functor f, Foldable f, OrdF f) => Mu f -> Trie f Int
-universeBagNaive = bag . universe
-
-mapBag :: Ord a => [a] -> Map a Int
-mapBag xs = Data.List.foldl' f Map.empty xs where
-  f old x = Map.insertWith (+) x 1 old
-
---------------------
-    
-prop_unibag_naive :: FixT Label -> Bool
-prop_unibag_naive tree = toList (universeBag tree) == toList (universeBagNaive tree)
-
-prop_unibag_naive_2 :: FixT Bool -> Bool
-prop_unibag_naive_2 tree = toList (universeBag tree) == toList (universeBagNaive tree)
-
-prop_fromList_naive :: FiniteMap -> Bool
-prop_fromList_naive (FiniteMap list) = toList (fromList list) == toList (fromListNaive list)
-
-prop_bag :: MultiSet -> Bool
-prop_bag mset = (sort $ toList $ bag $ multiSetToList mset) == sort (map f $ unMultiSet mset) where
-  f (Multiplicity k, x) = (x,k)
-
-prop_bag_b :: MultiSet -> Bool
-prop_bag_b mset = (sort $ toList $ bag $ multiSetToList_b mset) == sort (map f $ unMultiSet mset) where
-  f (Multiplicity k, x) = (x,k)
-
-prop_fromList_toList :: FiniteMap -> Bool
-prop_fromList_toList (FiniteMap list) = sort (toList (fromList list)) == sort list
-
-prop_multiSetToList_b :: MultiSet -> Bool
-prop_multiSetToList_b mset = toList (bag (multiSetToList mset)) == toList (bag (multiSetToList_b mset)) 
-
-prop_insert :: FixT Label -> Char -> FiniteMap -> Bool
-prop_insert key ch (FiniteMap list) = sort (toList (insert key ch trie)) == sort ((key,ch) : toList trie) where
-  trie = fromList list
-
-prop_delete :: Int -> FiniteMap -> Bool
-prop_delete i (FiniteMap list) = (n==0) || (toList (delete key trie) == toList trie \\ [(key,value)]) where
-  trie = fromList list
-  n = length list
-  k = mod i n
-  (key,value) = list!!k
-
-prop_update :: Char -> Int -> FiniteMap -> Bool
-prop_update new i (FiniteMap list) = (n==0) || (toList (update f key trie) == replace (toList trie)) where
-  trie = fromList list
-  n = length list
-  k = mod i n
-  (key,value) = list!!k
-  replace [] = []
-  replace (this@(k,x):rest) = if k==key 
-    then case f x of 
-      Nothing -> rest
-      Just y  -> (k,y) : replace rest
-    else this : replace rest    
-  f old = if old < 'A' then Nothing else Just new
-
-prop_insert_delete :: FixT Label -> Char -> FiniteMap -> Bool
-prop_insert_delete key ch (FiniteMap list) = toList (delete key (insert key ch trie)) == toList trie where
-  trie = delete key (fromList list)   -- !
-
-prop_delete_insert :: Int -> FiniteMap -> Bool
-prop_delete_insert i (FiniteMap list) = (n==0) || (toList (insert key value (delete key trie)) == toList trie) where
-  trie = fromList list
-  n = length list
-  k = mod i n
-  (key,value) = list!!k
-
-prop_lookup :: Int -> FiniteMap -> Bool
-prop_lookup i (FiniteMap list) = (n==0) || (Just value == lookup key trie) where
-  trie = fromList list
-  n = length list
-  k = mod i n
-  (key,value) = list!!k
-
-prop_lookup_notfound :: FixT Label -> FiniteMap -> Bool
-prop_lookup_notfound key (FiniteMap list) = lookup key trie == Nothing where
-  trie = delete key (fromList list)   -- !#endif
-
-prop_singleton :: FixT Label -> Char -> Bool
-prop_singleton tree ch = toList (singleton tree ch) == [(tree,ch)]
-
-prop_intersection :: MultiSet -> Bool
-prop_intersection mset = {- trace ("--"++show n++"--") -} (itrie == imap) where
-
-  list = multiSetToList_b mset
-  n = length list
-  k = div n 3
-  l = div (2*n) 3
-  xs = take l list
-  ys = drop k list
-
-  itrie = sort $     toList $     intersectionWith (+) (   bag xs) (   bag ys)
-  imap  = sort $ Map.toList $ Map.intersectionWith (+) (mapBag xs) (mapBag ys) 
-
-prop_union :: MultiSet -> Bool
-prop_union mset = {- trace ("--"++show n++"--") -} (utrie == umap) where
-
-  list = multiSetToList_b mset
-  n = length list
-  k = div n 3
-  l = div (2*n) 3
-  xs = take l list
-  ys = drop k list
-
-  utrie = sort $     toList $     unionWith (+) (   bag xs) (   bag ys)
-  umap  = sort $ Map.toList $ Map.unionWith (+) (mapBag xs) (mapBag ys) 
-
-prop_difference :: MultiSet -> Bool
-prop_difference mset = {- trace ("--"++show [length xs , length ys, length dtrie]++"--") -} (dtrie == dmap) where
-
-  list = multiSetToList_b mset
-  n = length list
-  k = div n 3
-  l = div (2*n) 3
-  xs = take l list
-  ys = drop k list
-
-  dtrie = sort $     toList $     difference (   bag xs) (   bag ys)
-  dmap  = sort $ Map.toList $ Map.difference (mapBag xs) (mapBag ys) 
-
-prop_differenceWith :: MultiSet -> Bool
-prop_differenceWith mset = {- trace ("--"++show [length xs , length ys, length dtrie]++"--") -} (dtrie == dmap) where
-
-  list = multiSetToList_b mset
-  n = length list
-  k = div n 3
-  l = div (2*n) 3
-  xs = take l list
-  ys = drop k list
-
-  f x y = if y<=2 then Just (x+1) else Nothing
-
-  dtrie = sort $     toList $     differenceWith f (   bag xs) (   bag ys)
-  dmap  = sort $ Map.toList $ Map.differenceWith f (mapBag xs) (mapBag ys) 
-
-prop_christmasTree :: FixT Label -> Bool
-prop_christmasTree tree = toList (attribute (christmasTree tree)) == toList (universeBag tree)
-
-prop_christmasTree_3 :: FixT Bool -> Bool
-prop_christmasTree_3 tree = toList (attribute (christmasTree tree)) == toList (universeBag tree)
-
--- we reduce the labels so that there is more chance for collisions
-prop_christmasTree_2 :: Bool -> FixT Label -> Bool
-prop_christmasTree_2 b tree0 = toList (attribute (christmasTree tree)) == toList (universeBag tree) where
-  tree = transform f tree0
-  f = if b 
-    then \(Fix (TreeF (Label label) ts)) -> Fix $ TreeF (Label (take 1 label)) ts
-    else \(Fix (TreeF (Label label) ts)) -> Fix $ TreeF (Label ""            ) ts
-
-
-#endif
 
 ---------------------------------------------------------------------------------

@@ -1,99 +0,0 @@-
--- | Haskell98 polymorphic Hash interface
-module Data.Generics.Fixplate.Util.Hash.Class where
-
---------------------------------------------------------------------------------
-
-import Data.Char
-import Data.Word
-import Data.Bits
-import Data.List
--- import Data.Int
-
---------------------------------------------------------------------------------
-
--- | 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)) 
-
---------------------------------------------------------------------------------
-

@@ -1,94 +0,0 @@---- | 32-bit FNV-1a (Fowler-Noll-Vo) hash--{-# LANGUAGE CPP #-}-module Data.Generics.Fixplate.Util.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.Util.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))-----------------------------------------------------------------------------------

@@ -1,97 +0,0 @@---- | 64-bit FNV-1a (Fowler-Noll-Vo) hash--{-# LANGUAGE CPP #-}-module Data.Generics.Fixplate.Util.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.Util.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))------------------------------------------------------------------------------------

@@ -1,530 +0,0 @@-
--- | Hash tables, implemented as a structure similar to @Map hash (Map key value)]@.
---
--- What this data structure can also give you is a unique value (a @(hash,Int)@ pair)
--- for each key, even during building the table: It is guaranteed to be unique 
--- in the past and future lifetime of a single hashtable (that is, one realization 
--- of the world-line), among all the keys appearing in that history.
---
--- Set operations (union, intersection) clearly break this principle; this is
--- resolved by declaring these operations to be /left-biased/, in the sense that
--- they retain the unique values of the left table (so @union t1 t2@ belongs to
--- to @t1@'s world-line, but not to @t2@'s one).
---
--- If a key is first removed then added back again, it will get a new 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.
---
-
-{-# LANGUAGE CPP #-}
-module Data.Generics.Fixplate.Util.Hash.Table
-  ( HashTable , Bucket(..) , Leaf(..)
-  , getHashValue , unHashTable
-    -- * Construction and deconstruction
-  , empty , singleton
-  , fromList , toList 
-  , null 
-  , bag
-    -- * Membership
-  , lookup , member 
-    -- * Insertion / deletion
-  , insert , insertWith
-  , delete
-    -- * Union
-  , union , unionWith         
-  , unionsWith , unionsWith'
-    -- * Intersection
-  , intersection, intersectionWith 
-  , intersectionsWith , intersectionsWith'
-    -- * Difference
-  , difference , differenceWith
-    -- * Unique indices
-  , getUniqueIndex
-  , keysWith
-  , mapWithUniqueIndices
-#ifdef WITH_QUICKCHECK
-    -- * Tests
-  , runtests_HashTable  
-  , prop_insert       , prop_delete
-  , prop_insertDelete , prop_deleteInsert
-  , prop_insertInsert , prop_deleteDelete
-  , prop_fromListToList
-  , prop_intersection , prop_intersectionWith
-  , prop_union        , prop_unionWith
-  , prop_difference   , prop_differenceWith
-  , prop_uniqueValues
-#endif
-  ) 
-  where
-
---------------------------------------------------------------------------------
-
-import Prelude hiding ( lookup , null )
-
-import Data.List ( foldl' )
-
-import qualified Data.Map as Map ; import Data.Map (Map) 
--- import qualified Data.Set as Set ; import Data.Set (Set) 
-
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-import Test.QuickCheck.Modifiers
-import Data.Generics.Fixplate.Misc
-import Data.List ( sort , group , nubBy , nub , (\\) , foldl' , scanl )
-import Control.Monad
-import Control.Applicative ( (<$>) )
-import Debug.Trace
-#endif
-
---------------------------------------------------------------------------------
--- 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
--}
-
---------------------------------------------------------------------------------
--- buckets
-
-data Leaf v     = Leaf   {-# UNPACK #-} !Int v                    -- the index of the key, plus a value
-data Bucket k v = Bucket {-# UNPACK #-} !Int !(Map k (Leaf v))    -- the next free index, plus the elements in the bucket
-
-fromLeaf :: Leaf v -> v
-fromLeaf (Leaf _ x) = x
-
-emptyBucket :: Bucket k v
-emptyBucket = Bucket 0 (Map.empty)
-
-bucketSingleton :: k -> v -> Bucket k v
-bucketSingleton k x = Bucket 1 (Map.singleton k (Leaf 0 x))
-
-bucketInsert :: Ord k => k -> v -> Bucket k v -> Bucket k v
-bucketInsert = bucketInsertWith id const    -- not (flip const), since a -> v -> v !!!
-
-bucketInsertWith :: Ord k => (a -> v) -> (a -> v -> v) -> k -> a -> Bucket k v -> Bucket k v
-bucketInsertWith f g k x (Bucket n table) = x `seq` new where
-  new = Bucket (n+1) (Map.alter worker k table)
-  worker Nothing            =          Just $! (Leaf n (f x))
-  worker (Just (Leaf j y))  = y `seq` (Just $! (Leaf j (g x y)))
-
-{-
-bucketIsSingleton :: Bucket k v -> Maybe (k,v)
-bucketIsSingleton (Bucket _ table) = if Map.size table == 1 
-  then let [(k,Leaf _ v)] = Map.toList table in Just (k,v)
-  else Nothing
-
-bucketIsSingleton_ :: Bucket k v -> Maybe v
-bucketIsSingleton_ (Bucket _ table) = if Map.size table == 1 
-  then let [Leaf _ v] = Map.elems table in Just v
-  else Nothing
--}
-
---------------------------------------------------------------------------------
-
-data HashTable hash k v = HashTable 
-  { getHashValue :: k -> hash
-  , unHashTable  :: Map hash (Bucket 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 (bucketSingleton 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)
-
--- | Note that the returned list is ordered by hash, /not/ by keys like 'Data.Map'!
-toList :: Ord k => HashTable hash k v -> [(k,v)]
-toList (HashTable _ table) = 
-  [ (k,v) 
-  | Bucket _ sub  <- Map.elems table 
-  , (k, Leaf _ v) <- Map.toList sub 
-  ]
-
-null :: (Ord hash, Ord k) => HashTable hash k v -> Bool
-null t = case toList t of
-  [] -> True
-  _  -> False
-
--- | Keys together with their associated unique values
-keysWith :: Ord k => (k -> hash -> Int -> a) -> HashTable hash k v -> [a]
-keysWith f (HashTable _ table) = 
-  [ f k hash j 
-  | (hash, Bucket _ sub) <- Map.toList table 
-  , (k, Leaf j _) <- Map.toList sub 
-  ]
-
---------------------------------------------------------------------------------
-
-lookup :: (Ord hash, Ord k) => k -> HashTable hash k v -> Maybe v
-lookup key (HashTable gethash table) = 
-  case Map.lookup h table of
-    Just (Bucket n sub) -> case Map.lookup key sub of
-      Just (Leaf _ v) -> Just v
-      Nothing         -> Nothing
-    Nothing  -> Nothing      
-  where
-    h = gethash key
-
--- | Look up a unique index, in the form of a @(hash,Int)@ pair, for any key.
--- If the user-supplied function is /injective/, then the result is guaranteed to be uniquely
--- associated to the given key in the past and future history of this table (but of
--- course not unique among different future histories).
---
-getUniqueIndex :: (Ord hash, Ord k) => (hash -> Int -> a) -> k -> HashTable hash k v -> Maybe a
-getUniqueIndex f key (HashTable gethash table) = 
-  case Map.lookup h table of
-    Just bucket@(Bucket _ sub) -> case Map.lookup key sub of
-      Just (Leaf j _) -> Just (f h j)
-      Nothing         -> Nothing       
-    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     = bucketSingleton k v
-  g v sub = bucketInsert    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     = bucketSingleton k (ff x)
-  g x sub = bucketInsertWith ff gg k x sub
-
-delete :: (Ord hash, Ord k) => k -> HashTable hash k v -> HashTable hash k v
-delete k (HashTable gethash table) = HashTable gethash $ Map.alter worker h table where
-  h = gethash k
-  worker Nothing               = Nothing
-  worker (Just (Bucket n sub)) = Just $ Bucket n (Map.delete k sub)
-
---------------------------------------------------------------------------------
--- union
-
--- | > union == unionWith const
-union :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k a -> HashTable hash k a
-union = unionWith const
-
--- | This is unsafe in the sense that the two @getHash@ functions 
--- (supplied when the hash tables were created) must agree. The same applies for all the set operations.
---
--- It is also left-biased in the sense that the unique indices from the left hashtable are retained,
--- while the unique indices from the right hashtable are /changed/.
-unionWith :: (Ord hash, Ord k) => (v -> v -> v) -> HashTable hash k v -> HashTable hash k v -> HashTable hash k v 
-unionWith g (HashTable gethash table1) (HashTable _ table2) = HashTable gethash (Map.unionWith worker table1 table2)
-  where
-    worker (Bucket n sub1) (Bucket m sub2) = Bucket (n+m) (Map.unionWith h sub1 $ Map.map offset sub2) where
-      h (Leaf i x) (Leaf _ y) = Leaf i (g x y)
-      offset       (Leaf j y) = Leaf (n+j) y
-
--- | This is unsafe both in the above sense and also that it does not accepts the empty list (for the same reason).
--- The result belongs to the world-line of the first table.
-unionsWith :: (Ord hash, Ord k) => (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v 
-unionsWith g tables = case tables of
-  [x]    -> x
-  []     -> error "HashTable/unionsWith: empty list"
-  xs     -> foldl1 (unionWith g) xs
-
--- | This one accepts the empty list. The empty imput creates a new world-line.
-unionsWith' :: (Ord hash, Ord k) => (k -> hash) -> (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v 
-unionsWith' gethash g tables = case tables of
-  [x]    -> x
-  []     -> empty gethash
-  xs     -> foldl1 (unionWith g) xs
-
---------------------------------------------------------------------------------
--- intersection
-
--- | > intersection == intersectionWith const
-intersection :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k b -> HashTable hash k a
-intersection = intersectionWith const
- 
--- NOTE the `Map.union` and `Map.difference` here!!!!!
--- This is necessary so that the world-line property remains true: if there is a hash present in the left table
--- but not in the right table, then we have to put an empty bucket in the resulting table while retaining the 
--- next unique index value). Unfortunately "Data.Map" does not have a flexible enough set operation to be used here...
-intersectionWith :: (Ord hash, Ord k) => (a -> b -> c) -> HashTable hash k a -> HashTable hash k b -> HashTable hash k c
-intersectionWith g (HashTable gethash table1) (HashTable _ table2) = 
-  HashTable gethash (Map.union a_minus_b a_cap_b) {- disjoint union -} where
-    a_cap_b   = Map.intersectionWith cap_worker table1 table2
-    a_minus_b = Map.map empty_worker (Map.difference table1 table2)
-  
-    cap_worker (Bucket n sub1) (Bucket _ sub2) = Bucket n (Map.intersectionWith h sub1 sub2) where
-      h (Leaf i x) (Leaf _ y) = Leaf i (g x y)
-
-    -- empty_worker :: Bucket k a -> Bucket k c
-    empty_worker (Bucket n sub1) = Bucket n (Map.empty)
-
-intersectionsWith :: (Ord hash, Ord k) => (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v 
-intersectionsWith g tables = case tables of
-  [x]    -> x
-  []     -> error "HashTable/intersectionWith: empty list"
-  xs     -> foldl1 (intersectionWith g) xs
-
-intersectionsWith' :: (Ord hash, Ord k) => (k -> hash) -> (v -> v -> v) -> [HashTable hash k v] -> HashTable hash k v 
-intersectionsWith' gethash g tables = case tables of
-  [x]    -> x
-  []     -> empty gethash
-  xs     -> foldl1 (intersectionWith g) xs
-
---------------------------------------------------------------------------------
--- difference
-
-difference :: (Ord hash, Ord k) => HashTable hash k a -> HashTable hash k b -> HashTable hash k a
-difference = differenceWith (\_ _ -> Nothing)
-
-differenceWith :: (Ord hash, Ord k) => (a -> b -> Maybe a) -> HashTable hash k a -> HashTable hash k b -> HashTable hash k a
-differenceWith g (HashTable gethash table1) (HashTable _ table2) = HashTable gethash (Map.differenceWith worker table1 table2) 
-  where
-    worker (Bucket n sub1) (Bucket _ sub2) = Just (Bucket n (Map.differenceWith h sub1 sub2)) where
-      h (Leaf i x) (Leaf _ y) = case g x y of
-        Just z  -> Just (Leaf i z)
-        Nothing -> Nothing
-  
---------------------------------------------------------------------------------
-
--- | 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)
-
---------------------------------------------------------------------------------
-
-mapWithUniqueIndices :: (Ord hash, Ord k) => (hash -> Int -> a -> b) -> HashTable hash k a -> HashTable hash k b
-mapWithUniqueIndices user (HashTable gethash table) = HashTable gethash (Map.mapWithKey worker table) where
-  worker hash (Bucket n sub) = Bucket n (Map.map g sub) where
-    g (Leaf j x) = Leaf j (user hash j x)
-
---------------------------------------------------------------------------------
-#ifdef WITH_QUICKCHECK
--- * tests
-
-runtests_HashTable :: IO ()
-runtests_HashTable = do
-  quickCheck prop_insert
-  quickCheck prop_delete
-  quickCheck prop_insertDelete
-  quickCheck prop_deleteInsert
-  quickCheck prop_insertInsert
-  quickCheck prop_deleteDelete
-  quickCheck prop_fromListToList
-  quickCheck prop_intersection
-  quickCheck prop_intersectionWith
-  quickCheck prop_union
-  quickCheck prop_unionWith
-  quickCheck prop_difference
-  quickCheck prop_differenceWith
-  replicateM_ 5 $ quickCheck prop_uniqueValues
---  quickCheck prop_
---  quickCheck prop_
-
--------------------------
-
-debug x y = trace ("-- " ++ show x ++ " --") y
-
-newtype Key = Key Int deriving (Eq,Ord,Show)
-
-instance (Ord k, Ord hash, Show k, Show v) => Show (HashTable hash k v) where
-  show t = "HashTable<< " ++ show (toList t) ++ " >>"
-
-instance Arbitrary Key where
-  arbitrary = do
-    n <- choose (0, 255)
-    return (Key n)
-
-newtype Hash = Hash Int deriving (Eq,Ord,Show)
-
-calcHash :: Key -> Hash 
-calcHash (Key k) = Hash (mod k 17)
-
-newtype Table v = Table (HashTable Hash Key v) deriving Show 
-
-instance Arbitrary v => Arbitrary (Table v) where
-  arbitrary = do
-    xs <- arbitrary
-    let t = fromList calcHash xs
-    {- debug (length xs) $ -}
-    return (Table t)
-
-newtype NonEmptyTable v = NonEmptyTable (HashTable Hash Key v) deriving Show 
-
-instance Arbitrary v => Arbitrary (NonEmptyTable v) where
-  arbitrary = do
-    NonEmpty xs <- arbitrary
-    let t = fromList calcHash xs
-    {- debug (length xs) $ -}
-    return (NonEmptyTable t)
-
-data Pointed v = Pointed (HashTable Hash Key v) (Key,v) deriving Show
-
-instance Arbitrary v => Arbitrary (Pointed v) where
-  arbitrary = do
-    NonEmptyTable t <- arbitrary
-    let list = toList t
-        n = length list
-    i <- choose (0,n-1)
-    let kv =list!!i
-    return (Pointed t kv)
-
-sortedToList :: Ord a => HashTable Hash Key a -> [(Key,a)]
-sortedToList = sort . toList
-
--------------------------
-
-data Step v
-  = Insert     Key v 
-  | InsertWith Key v
-  | Delete     Key  
-  | Union      (Table v)
-  | Intersect  (Table v)
-  | Difference (Table v)
-  deriving Show
-
-instance Arbitrary v => Arbitrary (Step v) where
-  arbitrary = do
-    frequency
-      [ ( 10 , do { k<-arbitrary ; v<-arbitrary ; return (Insert     k v) } )
-      , (  5 , do { k<-arbitrary ; v<-arbitrary ; return (InsertWith k v) } )
-      , ( 10 , do { k<-arbitrary ; return (Delete k)       } )
-      , (  3 , do { t<-arbitrary ; return (Union      t  ) } )
-      , (  2 , do { t<-arbitrary ; return (Difference t  ) } )
-      , (  1 , do { t<-arbitrary ; return (Intersect  t  ) } )
-      ]
-
-newtype NoDeleteStep v = NoDeleteStep (Step v)
-
-instance Arbitrary v => Arbitrary (NoDeleteStep v) where
-  arbitrary = NoDeleteStep <$> do
-    frequency
-      [ ( 10 , do { k<-arbitrary ; v<-arbitrary ; return (Insert     k v) } )
-      , (  5 , do { k<-arbitrary ; v<-arbitrary ; return (InsertWith k v) } )
-      , (  3 , do { t<-arbitrary ;                return (Union      t  ) } )
-      ]
-
-step :: (v -> v -> v) -> Step v -> HashTable Hash Key v -> HashTable Hash Key v 
-step f step old = case step of
-  Insert     k v       -> insert          k v old
-  InsertWith k v       -> insertWith id f k v old
-  Delete     k         -> delete          k   old
-  Union      (Table t) -> union        old t
-  Intersect  (Table t) -> intersection old t
-  Difference (Table t) -> difference   old t
-
-type History v = [Step v]
-
-runHistory :: (v -> v -> v) -> History v -> HashTable Hash Key v -> [HashTable Hash Key v]
-runHistory f steps ini = scanl (flip (step f)) ini steps
-
-data U = U Hash Int deriving (Eq,Ord,Show)
-
--------------------------
-
-prop_insert :: Key -> Char -> Table Char -> Bool
-prop_insert k v (Table table) = lookup k (insert k v table) == Just v
-
-prop_delete :: Pointed Char -> Bool
-prop_delete (Pointed table (k,_)) = lookup k (delete k table) == Nothing 
-
-prop_insertInsert :: Key -> Char -> Table Char -> Bool
-prop_insertInsert k v (Table table) = toList (insert k v table) == toList (insert k v (insert k v table))
-
-prop_deleteDelete :: Pointed Char -> Bool
-prop_deleteDelete (Pointed table (k,_)) = toList (delete k table) == toList (delete k (delete k table))
-
-prop_insertDelete :: Key -> Char -> Table Char -> Bool
-prop_insertDelete k v (Table table) = lookup k (delete k $ insert k v table) == Nothing
-
-prop_deleteInsert :: Pointed Char -> Bool
-prop_deleteInsert (Pointed table (k,v)) = lookup k (insert k v $ delete k table) == Just v 
-
-prop_fromListToList :: [(Key,Char)] -> Bool
-prop_fromListToList xs = sortedToList (fromList calcHash xs) == Map.toList (Map.fromList xs)
-
-prop_intersection :: [(Key,Char)] -> [(Key,Bool)] -> Bool
-prop_intersection xs ys = sortedToList (intersection t1 t2) == Map.toList (Map.intersection m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-
-prop_intersectionWith :: [(Key,Char)] -> [(Key,String)] -> Bool
-prop_intersectionWith xs ys = sortedToList (intersectionWith (:) t1 t2) == Map.toList (Map.intersectionWith (:) m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-
-prop_union :: [(Key,Char)] -> [(Key,Char)] -> Bool
-prop_union xs ys = sortedToList (union t1 t2) == Map.toList (Map.union m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-
-prop_unionWith :: [(Key,String)] -> [(Key,String)] -> Bool
-prop_unionWith xs ys = sortedToList (unionWith (++) t1 t2) == Map.toList (Map.unionWith (++) m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-
-prop_difference :: [(Key,Char)] -> [(Key,Bool)] -> Bool
-prop_difference xs ys = sortedToList (difference t1 t2) == Map.toList (Map.difference m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-
-prop_differenceWith :: [(Key,Char)] -> [(Key,Bool)] -> Bool
-prop_differenceWith xs ys = sortedToList (differenceWith f t1 t2) == Map.toList (Map.differenceWith f m1 m2) where
-  t1 = fromList calcHash xs
-  t2 = fromList calcHash ys
-  m1 = Map.fromList xs
-  m2 = Map.fromList ys
-  f x b = if b then Just x else Nothing
-
--- we try to test whether values are really unique and really constant during a wordline
-prop_uniqueValues :: History Float -> Table Float -> Bool
-prop_uniqueValues history (Table initial) = areUnique && areInjective {- && ... -} where
-  worldline = runHistory (\x y -> x-y) history initial :: [HashTable Hash Key Float]
-  lists = ((flip map) worldline $ \table -> keysWith (\k h j -> (U h j, k)) table) :: [[(U,Key)]]
-
-  -- at each point in time, a single value must appear only once in the table
-  areUnique = and [ isUnique xs | xs <- lists ]
-  isUnique uks = let us = map fst uks in sort us == sort (nub us)
-
-  -- taking the whole wordline, it must be true that to a single unique value there is only a single key associated
-  -- (the opposite is not true, since a key can be deleted then reinserted, gaining a new value)
-  areInjective = and $ map test $ groupSortOn fst $ concat lists where
-    test :: [(U,Key)] -> Bool
-    test xs = (length (groupSortOn fst xs) == 1)     -- this is redundant, but hey, we are also testing the test :)
-           && (length (groupSortOn snd xs) == 1)
- 
-
-#endif
---------------------------------------------------------------------------------

@@ -12,24 +12,16 @@ 
 import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
 import Data.Foldable
-import Data.Traversable
+import Data.Traversable ()
 import Data.Maybe
 
-import Text.Show
+import Text.Show ()
 import Text.Read 
 
 import Data.Generics.Fixplate.Base
 import Data.Generics.Fixplate.Open
 import Data.Generics.Fixplate.Misc
 
-#ifdef WITH_QUICKCHECK
-import Test.QuickCheck
-import Data.Generics.Fixplate.Attributes
-import Data.Generics.Fixplate.Traversals
-import Data.Generics.Fixplate.Test.Tools
-import Control.Monad (liftM)
-#endif 
-
 --------------------------------------------------------------------------------
 -- * Types
 
@@ -385,244 +377,4 @@ unsafeMoveRight = unsafe moveRight "unsafeMoveRight: cannot move right"    
 
 --------------------------------------------------------------------------------
-#ifdef WITH_QUICKCHECK
--- * Tests
-
-type LocT a = Loc (TreeF a)
-
-{-
-data Step
-  = StepUp
-  | StepLeft
-  | StepRight
-  | StepDown Int
-  | StepDownL
-  | StepDownR
-  deriving (Eq,Ord,Show)
-
-newtype Walk = Walk [Step] deriving (Eq,Ord,Show)
-  
-walk :: Traversable f => Walk -> Loc f -> Loc f  
-walk (Walk steps) loc = foldl (flip singleStep) loc steps
-
-singleStep :: Traversable f => Step -> Loc f -> Loc f
-singleStep s loc = case stepMaybe s loc of { Nothing -> loc ; Just new -> new }
-
-stepMaybe :: Traversable f => Step -> Loc f -> Maybe (Loc f)
-stepMaybe s = case s of
-  StepUp     -> moveUp
-  StepLeft   -> moveLeft
-  StepRight  -> moveRight
-  StepDown j -> moveDown j
-  StepDownL  -> moveLeft
-  StepDownR  -> moveRight
-  
-instance Arbitrary Step where
-  arbitrary = oneof
-    [ return StepUp
-    , return StepLeft
-    , return StepRight
-    , do { j <- choose (1,7) ; return (StepDown j) }
-    , return StepDownL
-    , return StepDownR
-    ]
-
-instance Arbitrary Walk where
-  arbitrary = liftM Walk arbitrary
-  shrink (Walk steps) = map Walk (shrink steps)
--}
-
--- | Assuming a left-to-right canonical numbering, we find the given
--- location.
-findLoc :: Traversable f => Int -> Loc (Ann f Int) -> Loc (Ann f Int) 
-findLoc k = go where
-  go loc = 
-    case compare j k of
-      GT -> error "findLoc: shouldn't happen?"
-      EQ -> loc
-      LT -> case moveDownL loc of
-        Just xx -> go xx
-        Nothing -> case moveRight loc of
-          Just yy -> go yy
-          Nothing -> goUpR (unsafeMoveUp loc)
-    where
-      Fix (Ann j _) = focus loc
-  goUpR loc = case moveRight loc of
-    Nothing -> goUpR (unsafeMoveUp loc)
-    Just zz -> go zz
-
-----
-tmp = treeF "root"
-  [ treeF "a" [ treeF "a1" [] , treeF "a2" [] ]
-  , treeF "b" []
-  , treeF "c" [ treeF "c1" [] , treeF "c2" [] , treeF "c3" [] ]
-  ]
-----
-  
-instance Arbitrary a => Arbitrary (LocT a) where
-  arbitrary = do
-    tree <- arbitrary 
-    let (n,numbered) = enumerateNodes tree
-    k <- choose (0,n-1)
-    return $ locForget $ findLoc k (root numbered)
-
-rndLoc :: IO (LocT Label)
-rndLoc = liftM (!!7) $ sample' arbitrary
-  
-newtype ChildIndex = ChildIndex Int deriving Show
-
-instance Arbitrary ChildIndex where
-  arbitrary = liftM ChildIndex $ choose (0,7)
-  
---------------------------------------------------------------------------------
-
-runtests_Zipper :: IO ()
-runtests_Zipper = do
-  quickCheck prop_ReadShowLoc
-  quickCheck prop_findLoc
-  quickCheck prop_locationsList
-  quickCheck prop_contextList
-  quickCheck prop_Top
-  quickCheck prop_defocus
-  quickCheck prop_horizontalPos
-  quickCheck prop_fullPathDown
-  quickCheck prop_fullPathUp
-  quickCheck prop_fullPathUp2
-  quickCheck prop_leftmost
-  quickCheck prop_rightmost
-  quickCheck prop_DownLUp
-  quickCheck prop_DownRUp
-  quickCheck prop_UpDownL 
-  quickCheck prop_UpDownR
-  quickCheck prop_DownL
-  quickCheck prop_DownR
-  quickCheck prop_UpDownJ
-  quickCheck prop_LeftRight
-  quickCheck prop_RightLeft
-
-----------------------------------------
-
-leftmostNaive :: Traversable f => Loc f -> Loc f
-leftmostNaive = tillNothing moveLeft
-
-rightmostNaive :: Traversable f => Loc f -> Loc f
-rightmostNaive = tillNothing moveRight
-
-fullPathUpNaive :: Traversable f => Loc f -> [Int]
-fullPathUpNaive = go where
-  go loc@(Loc _ path) = case path of
-    Top -> []
-    _   -> horizontalPos loc : go (unsafeMoveUp loc)
-
-----------------------------------------
-
-prop_ReadShowLoc :: LocT Label -> Bool
-prop_ReadShowLoc loc = read (show loc) == loc
-
-prop_locationsList :: FixT Label -> Bool
-prop_locationsList tree = locationsList tree == [ locForget $ findLoc i top | i<-[0..n-1] ] where
-  top = root numbered
-  (n,numbered) = enumerateNodes tree
-
-prop_findLoc :: FixT Label -> Bool
-prop_findLoc tree = [0..n-1] == [ attribute $ focus $ findLoc i top | i<-[0..n-1] ] where
-  top = root numbered
-  (n,numbered) = enumerateNodes tree
-
-prop_contextList :: FixT Label -> Bool  
-prop_contextList tree =
-  map (\(Fix (TreeF l ts),replace) -> replace (Fix (TreeF (h l) ts))) (contextList tree)
-  ==
-  [ defocus $ modify (\(Fix (TreeF l ts)) -> Fix (TreeF (h l) ts) ) $ locForget $ findLoc i top | i<-[0..n-1] ]
-  where
-    top = root numbered
-    (n,numbered) = enumerateNodes tree
-    h (Label xs) = Label ('_':xs)
-  
-prop_Top :: LocT Label -> Bool
-prop_Top loc = root (defocus loc) == moveTop loc
-
-prop_defocus :: FixT Label -> Bool
-prop_defocus tree = 
-  Prelude.and [ defocus (findLoc i top) == numbered | i<-[0..n-1] ] 
-  where
-    top = root numbered
-    (n,numbered) = enumerateNodes tree
-
-----------------------------------------
-
-prop_horizontalPos :: LocT Label -> Bool
-prop_horizontalPos loc = 
-  loc == iterateN (horizontalPos loc) unsafeMoveRight (leftmost loc)
-
-prop_fullPathDown :: LocT Label -> Bool
-prop_fullPathDown loc = 
-  loc == foldl (flip unsafeMoveDown) (moveTop loc) (fullPathDown loc)
-
-prop_fullPathUp :: LocT Label -> Bool
-prop_fullPathUp loc = 
-  fullPathUp loc == fullPathUpNaive loc
-
-prop_fullPathUp2 :: LocT Label -> Bool 
-prop_fullPathUp2 loc = 
-  loc == foldr unsafeMoveDown (moveTop loc) (fullPathUp loc)  
-  
-----------------------------------------
-    
-prop_leftmost :: LocT Label -> Bool
-prop_leftmost loc = leftmost loc == leftmostNaive loc
-
-prop_rightmost :: LocT Label -> Bool
-prop_rightmost loc = rightmost loc == rightmostNaive loc
-    
-prop_DownLUp :: LocT Label -> Property
-prop_DownLUp loc = 
-  (not $ isBottom loc) 
-  ==> unsafeMoveUp (unsafeMoveDownL loc) == loc
-
-prop_DownRUp :: LocT Label -> Property  
-prop_DownRUp loc = 
-  (not $ isBottom loc) 
-  ==> unsafeMoveUp (unsafeMoveDownR loc) == loc
-
-prop_UpDownL :: LocT Label -> Property
-prop_UpDownL loc = 
-  (not $ isTop loc) 
-  ==> unsafeMoveDownL (unsafeMoveUp loc) == leftmost loc
-
-prop_UpDownR :: LocT Label -> Property
-prop_UpDownR loc = 
-  (not $ isTop loc) 
-  ==> unsafeMoveDownR (unsafeMoveUp loc) == rightmost loc
-
-prop_DownL :: LocT Label -> Property
-prop_DownL loc =
-  (not $ isBottom loc)
-  ==> unsafeMoveDownL loc == unsafeMoveDown 0 loc
-
-prop_DownR :: LocT Label -> Property
-prop_DownR loc =
-  (not $ isBottom loc)
-  ==> let k = length $ children $ focus loc
-      in  unsafeMoveDownR loc == unsafeMoveDown (k-1) loc
-
-prop_UpDownJ :: ChildIndex -> LocT Label -> Property
-prop_UpDownJ (ChildIndex j) loc = 
-  (not $ isTop loc) 
-  ==> (j < (length $ children $ focus $ unsafeMoveUp loc))  
-  ==> unsafeMoveDown j (unsafeMoveUp loc) == iterateN j unsafeMoveRight (leftmost loc)
-
-prop_LeftRight :: LocT Label -> Property
-prop_LeftRight loc = 
-  (not $ isLeftmost loc)
-  ==> unsafeMoveRight (unsafeMoveLeft loc) == loc  
-
-prop_RightLeft :: LocT Label -> Property
-prop_RightLeft loc = 
-  (not $ isRightmost loc)
-  ==> (unsafeMoveLeft (unsafeMoveRight loc) == loc)  
-
---------------------------------------------------------------------------------
-
-#endif 
 

@@ -1,4 +1,4 @@-Copyright (c) 2011-2015, Balazs Komuves+Copyright (c) 2011-2016, Balazs Komuves All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,6 +1,6 @@  Name:                fixplate-Version:             0.1.6+Version:             0.1.7 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,@@ -10,38 +10,33 @@ License:             BSD3 License-file:        LICENSE Author:              Balazs Komuves-Copyright:           (c) 2011-2015 Balazs Komuves+Copyright:           (c) 2011-2016 Balazs Komuves Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com Homepage:            http://code.haskell.org/~bkomuves/ Stability:           Experimental Category:            Generics-Tested-With:         GHC == 7.10.2+Tested-With:         GHC == 7.10.3 Cabal-Version:       >= 1.10 Build-Type:          Simple +----------------------------------------+ source-repository head   type:     darcs   location: http://code.haskell.org/~bkomuves/projects/fixplate/ -Flag withQuickCheck-  Description: Compile with the QuickCheck tests. -  default: False+-- Flag withUtils+--   Description: Include utility modules+--   default: True -Flag withUtils-  Description: Include utility modules-  default: True+----------------------------------------  Library -  Build-Depends:       base >= 4 && < 5--  if flag(withUtils)-    Build-Depends:       containers-    cpp-options:         -DWITH_UTILITY_MODULES+  Build-Depends:       base >= 4 && < 5, containers -  if flag(withQuickCheck)-    Build-Depends:       QuickCheck > 2.4-    cpp-options:         -DWITH_QUICKCHECK+--  if flag(withUtils)+--    cpp-options:         -DWITH_UTILITY_MODULES    Exposed-Modules:     Data.Generics.Fixplate                        Data.Generics.Fixplate.Base@@ -56,21 +51,14 @@                        Data.Generics.Fixplate.Trie                        Data.Generics.Fixplate.Hash -  if flag(withUtils)-    Exposed-Modules:     -                         Data.Generics.Fixplate.Util.Hash.Class-                         Data.Generics.Fixplate.Util.Hash.Table-                         Data.Generics.Fixplate.Util.Hash.FNV.FNV32-                         Data.Generics.Fixplate.Util.Hash.FNV.FNV64+--  if flag(withUtils)+--    Exposed-Modules:     +--                         Data.Generics.Fixplate.Util.Hash.Class+--                         Data.Generics.Fixplate.Util.Hash.Table+--                         Data.Generics.Fixplate.Util.Hash.FNV.FNV32+--                         Data.Generics.Fixplate.Util.Hash.FNV.FNV64    Other-Modules:       Data.Generics.Fixplate.Misc--  if flag(withQuickCheck)  -    Exposed-Modules:     Data.Generics.Fixplate.Test.Tools-                         Data.Generics.Fixplate.Test.Instances-                         Data.Generics.Fixplate.Tests--    other-extensions:    TypeSynonymInstances     default-extensions:  CPP   other-extensions:    TypeOperators@@ -83,5 +71,29 @@   Default-Language:    Haskell2010    ghc-options:         -Wall -fno-warn-unused-matches -fno-warn-name-shadowing++----------------------------------------++test-suite fixplate-tests+                      +  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             test-suite.hs+  +  other-modules:       TestSuite.Attributes+                       TestSuite.Instances+                       TestSuite.Morphisms+                       TestSuite.Traversals+                       TestSuite.Trie+                       TestSuite.Zipper+                       TestSuite.Tools+                       TestSuite.Misc++  build-depends:       base >= 4 && < 5, containers, +                       QuickCheck >= 2, tasty, tasty-quickcheck,+                       fixplate++  Default-Language:    Haskell2010+  Default-Extensions:  CPP, BangPatterns, TypeSynonymInstances     

@@ -0,0 +1,159 @@+
+-- | Tests for attributes
+
+module TestSuite.Attributes where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck
+
+import Control.Applicative
+import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
+import Data.List ( sort , intercalate )
+import Data.Char ( ord )
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Morphisms
+import Data.Generics.Fixplate.Traversals
+
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Attributes :: TestTree
+testgroup_Attributes = testGroup "Attributes"
+  [ testProperty "synthAccumL"            prop_synthAccumL
+  , testProperty "synthAccumR"            prop_synthAccumR
+  , testProperty "synthetise"             prop_synthetise
+  , testProperty "synthCata"              prop_synthCata
+  , testProperty "synthPara"              prop_synthPara
+  , testProperty "synthPara'"             prop_synthPara'
+  , testProperty "scanCata"               prop_scanCata 
+  , testProperty "mapAccumCata"           prop_mapAccumCata
+  , testProperty "zygo"                   prop_zygo
+  , testProperty "zygo_"                  prop_zygo_
+  ]
+
+--------------------------------------------------------------------------------
+
+{-
+runtests_Attributes :: IO ()
+runtests_Attributes = do
+  quickCheck prop_synthAccumL
+  quickCheck prop_synthAccumR
+  quickCheck prop_synthetise
+  quickCheck prop_synthCata
+  quickCheck prop_synthPara
+  quickCheck prop_synthPara'
+  quickCheck prop_scanCata 
+  quickCheck prop_mapAccumCata
+  quickCheck prop_zygo
+  quickCheck prop_zygo_
+-}
+
+prop_synthAccumL :: FixT Label -> Bool
+prop_synthAccumL tree = 
+  toList (Attrib (synthAccumL_ (\i _ -> (i+1,i)) 1 tree)) == [1..length (universe tree)]
+
+prop_synthAccumR :: FixT Label -> Bool
+prop_synthAccumR tree = 
+  toList (Attrib (synthAccumR_ (\i _ -> (i+1,i)) 1 tree)) == reverse [1..length (universe tree)]
+
+prop_synthetise :: FixT Label -> Bool
+prop_synthetise tree = 
+  map attribute (universe $ synthetise (\(TreeF (Label l) xs) -> l ++ concat xs) tree)
+  ==
+  map fold (universe tree)
+  where
+    fold = foldLeft (\s (Fix (TreeF (Label l) _)) -> s++l) []
+
+prop_synthCata :: FixT Label -> Bool
+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 
+  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
+    sizs = map (cata f) ts
+    f t = (1::Int) + 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 
+  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
+      siz = cata (\t -> (1::Int) + Data.Foldable.sum t) tree
+
+scanCataNaive :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
+scanCataNaive f = annZipWith (flip const) . synthCata (\(Ann a x) -> f a x)
+
+prop_scanCata :: Attr (TreeF Label) String -> Bool
+prop_scanCata tree = scanCata f tree == scanCataNaive f tree where
+  f :: (String -> TreeF Label Integer -> Integer) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
+  f str t = Prelude.product (toList t) + sumchar str
+  sumchar :: String -> Integer
+  sumchar = fromIntegral . Prelude.sum . map ord 
+--   tree = synthetise (\(TreeF (Label l) xs) -> map toUpper l ++ concat xs) tree) tree0
+
+mapAccumCataNaive :: Functor f => (f acc -> b -> (acc,c)) -> Attr f b -> (acc, Attr f c)
+mapAccumCataNaive f = second (annZipWith (flip const)) . synthAccumCata (\(Ann b t) -> f t b)
+
+prop_mapAccumCata :: Attr (TreeF Label) String -> Bool
+prop_mapAccumCata tree = mapAccumCata f tree == mapAccumCataNaive f tree where
+  f :: (TreeF Label Integer -> String -> (Integer,String)) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
+  f t str = ( k - fromIntegral (length str) + sumchar str , "<" ++ show k ++ "," ++ str ++ ">") where 
+    ls = toList t
+    k  = Prelude.product ls
+  sumchar :: String -> Integer
+  sumchar = fromIntegral . Prelude.sum . map ord 
+  -- tree = synthetise (\(TreeF (Label l) xs) -> map toLower l ++ concat xs) tree) tree0
+
+--------------------------------------------------------------------------------
+-- 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 :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> (b,a)
+zygoNaive g h tree = (attribute tmp, para h1 tmp) where 
+  tmp = synthCata g tree
+  h1 = h . fmap (first attribute) . unAnn
+
+prop_zygo :: FixT Label -> Bool
+prop_zygo tree = zygo g h tree == zygoNaive g h tree where
+  g :: TreeF Label Integer -> Integer
+  g (TreeF (Label label) child) = Prelude.product child + sumchar label
+
+  h :: TreeF Label (Integer,String) -> String
+  h (TreeF (Label label) child) = "[" ++ label ++ "]<" ++ intercalate "," (map f child) ++ ">"
+
+  f (k,s) = show k ++ "_" ++ s
+
+  sumchar = fromIntegral . Prelude.sum . map ord 
+
+prop_zygo_ :: FixT Label -> Bool
+prop_zygo_ tree = zygo_ g h tree == zygoNaive_ g h tree where
+  g :: TreeF Label Integer -> Integer
+  g (TreeF (Label label) child) = Prelude.product child + prodchar label
+
+  h :: TreeF Label (Integer,String) -> String
+  h (TreeF (Label label) child) = "<" ++ intercalate "," (map f child) ++ ">" ++ "[" ++ label ++ "]"
+
+  f (k,s) = s ++ "_" ++ show k
+
+  prodchar = fromIntegral . Prelude.product . map ord 
+  
+--------------------------------------------------------------------------------
+  

@@ -0,0 +1,170 @@+
+-- | Tests for instances (like @Read@ \/ @Show@)
+
+module TestSuite.Instances where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Tasty
+
+import Control.Applicative
+import Control.Monad hiding (mapM, mapM_, forM, forM_)
+import Data.List (sort)
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Instances :: TestTree
+testgroup_Instances = testGroup "Instances"
+  [ testgroup_Instances_Misc
+  , testgroup_Instances_ReadShow
+  , testgroup_Instances_Attrib 
+  ]
+
+testgroup_Instances_Misc :: TestTree
+testgroup_Instances_Misc = testGroup "Misc"
+  [ testProperty "forget"                prop_forget
+  , testProperty "toFixT . fromFixT"     prop_fromToFixT 
+  , testProperty "fromFixT . toFixT"     prop_toFromFixT
+  , testProperty "toAttr . fromAttr"     prop_fromToAttr
+  , testProperty "fromAttr . toAttr"     prop_toFromAttr
+  ]
+
+testgroup_Instances_ReadShow :: TestTree
+testgroup_Instances_ReadShow = testGroup "Read / Show"
+  [ testProperty "Mu/Label"              prop_ReadShowMuLabel
+  , testProperty "Mu/Int"                prop_ReadShowMuInt
+  , testProperty "Mu/String"             prop_ReadShowMuString
+  , testProperty "Attr/Label/Int"        prop_ReadShowAttrLabelInt
+  , testProperty "Attr/String/Label"     prop_ReadShowAttrStringLabel
+  ]
+
+testgroup_Instances_Attrib :: TestTree
+testgroup_Instances_Attrib = testGroup "derived vs. Attrib"
+  [ testProperty "fmap"                  prop_AttribFMap
+  , testProperty "foldr"                 prop_AttribFoldr
+  , testProperty "foldl"                 prop_AttribFoldl
+  , testProperty "mapAccumL"             prop_AttribMapAccumL
+  , testProperty "mapAccumR"             prop_AttribMapAccumR
+  ]
+
+--------------------------------------------------------------------------------
+-- * Misc
+
+prop_forget :: Attr (TreeF Label) Int -> Bool
+prop_forget tree =
+  fromFixT (forget tree) == fmap fst (fromAttr tree)
+  
+prop_fromToFixT :: FixT Label -> Bool  
+prop_fromToFixT tree =
+  toFixT (fromFixT tree) == tree
+
+prop_toFromFixT :: Tree Label -> Bool  
+prop_toFromFixT tree =
+  fromFixT (toFixT tree) == tree
+
+prop_fromToAttr :: Attr (TreeF Label) Int -> Bool  
+prop_fromToAttr tree =
+  toAttr (fromAttr tree) == tree
+
+prop_toFromAttr :: Tree (Label,Int) -> Bool  
+prop_toFromAttr tree =
+  fromAttr (toAttr tree) == tree
+
+{-  
+runtests_InstancesMisc = do
+  quickCheck prop_forget
+  quickCheck prop_fromToFixT 
+  quickCheck prop_toFromFixT
+  quickCheck prop_fromToAttr
+  quickCheck prop_toFromAttr
+-}
+  
+--------------------------------------------------------------------------------
+-- * Read/Show.
+
+prop_ReadShowMuLabel   :: Mu (TreeF Label ) -> Bool
+prop_ReadShowMuInt     :: Mu (TreeF Int   ) -> Bool
+prop_ReadShowMuString  :: Mu (TreeF String) -> Bool
+
+prop_ReadShowMuLabel  t = read (show t) == t 
+prop_ReadShowMuInt    t = read (show t) == t 
+prop_ReadShowMuString t = read (show t) == t 
+
+prop_ReadShowAttrLabelInt    :: Attr (TreeF Label ) Int   -> Bool
+prop_ReadShowAttrStringLabel :: Attr (TreeF String) Label -> Bool
+
+prop_ReadShowAttrLabelInt    t = read (show t) == t 
+prop_ReadShowAttrStringLabel t = read (show t) == t 
+
+{-
+runtests_ReadShow = do
+  quickCheck prop_ReadShowMuLabel
+  quickCheck prop_ReadShowMuInt
+  quickCheck prop_ReadShowMuString
+  quickCheck prop_ReadShowAttrLabelInt
+  quickCheck prop_ReadShowAttrStringLabel
+-}
+  
+--------------------------------------------------------------------------------
+-- * Attrib wrapper.
+
+prop_AttribFMap :: Attr (TreeF Label) Int -> Bool
+prop_AttribFMap tree = 
+  unAttrib (fmap f (Attrib tree)) == toAttr (fmap (id<#>f) (fromAttr tree)) 
+    where f n = show n ++ "_"
+
+--------------------------------------------------------------------------------
+
+prop_AttribFoldr :: Attr (TreeF Label) Int -> Bool
+prop_AttribFoldr tree = 
+  foldr (:) [] (Attrib tree) == map snd (foldr (:) [] (fromAttr tree))
+
+prop_AttribFoldl :: Attr (TreeF Label) Int -> Bool
+prop_AttribFoldl tree = 
+  foldl (flip (:)) [] (Attrib tree) == map snd (foldl (flip (:)) [] (fromAttr tree))
+
+--------------------------------------------------------------------------------
+
+prop_AttribMapAccumL :: Attr (TreeF Label) Integer -> Bool
+prop_AttribMapAccumL tree = 
+  (id<#>unAttrib) (mapAccumL f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumL f2 666 (fromAttr tree)) where 
+    f1 :: Integer -> Integer -> (Integer,String)
+    f1 old input = (new, show residue) where 
+      new     = old*3 - input
+      residue = old*2 + input*7
+    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
+    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))
+
+prop_AttribMapAccumR :: Attr (TreeF Label) Integer -> Bool
+prop_AttribMapAccumR tree = 
+  (id<#>unAttrib) (mapAccumR f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumR f2 666 (fromAttr tree)) where 
+    f1 :: Integer -> Integer -> (Integer,String)
+    f1 old input = (new, show residue) where 
+      new     = old*3 - input
+      residue = old*2 + input*7
+    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
+    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))
+
+{-
+-- | We compare GHC-derived Functor, Foldable and Traversable instances (for Tree)
+-- with our implementation (for Attrib).
+runtests_Attrib = do
+  quickCheck prop_AttribFMap
+  quickCheck prop_AttribFoldr
+  quickCheck prop_AttribFoldl
+  quickCheck prop_AttribMapAccumL
+  quickCheck prop_AttribMapAccumR
+-}
+  
+--------------------------------------------------------------------------------
+  

@@ -0,0 +1,141 @@+
+-- | Miscellaneous utility functions
+module TestSuite.Misc where
+
+--------------------------------------------------------------------------------
+
+import Prelude hiding ( mapM , mapM_ )
+
+import Data.List ( sortBy , groupBy )
+import Data.Ord
+
+import Data.Traversable
+
+import Control.Applicative ( Applicative(..) )
+import Control.Monad ( ap , liftM )
+
+--import Control.Monad.Trans.State
+
+--------------------------------------------------------------------------------
+        
+data Two a b 
+  =  Empty 
+  |  One a
+  |  Two b
+  deriving Show
+  
+data Both a b 
+  =  None
+  |  First a
+  |  Both  a b
+  deriving Show
+
+--------------------------------------------------------------------------------
+
+equating :: Eq b => (a -> b) -> a -> a -> Bool
+equating f x y = f x == f y
+
+groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]]
+groupSortOn f xs = groupBy (equating f) $ sortBy (comparing f) xs
+
+mapGroupSortOn :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b,[c])]
+mapGroupSortOn f g = mapGroupSortOn' f (map g)
+
+mapGroupSortOn' :: Ord b => (a -> b) -> ([a] -> c) -> [a] -> [(b,c)]
+mapGroupSortOn' f g xs = map h $ groupBy (equating f) $ sortBy (comparing f) xs where
+  h ys = (f (head ys), g ys)
+
+--------------------------------------------------------------------------------
+
+unsafe :: (a -> Maybe b) -> String -> a -> b
+unsafe safe msg loc = case safe loc of
+  Just new -> new
+  Nothing  -> error msg
+  
+--------------------------------------------------------------------------------
+
+app_prec :: Int
+app_prec = 10
+
+--------------------------------------------------------------------------------
+
+(<#>) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)
+(f <#> g) (x,y) = (f x, g y)
+
+first :: (a -> b) -> (a,c) -> (b,c)
+first f (x,y) = (f x, y)
+
+second :: (b -> c) -> (a,b) -> (a,c)
+second g (x,y) = (x, g y)
+
+--------------------------------------------------------------------------------
+
+tillNothing :: (a -> Maybe a) -> a -> a
+tillNothing f = go where 
+  go x = case f x of { Nothing -> x ; Just y -> go y }
+  
+chain :: [a -> Maybe a] -> a -> Maybe a
+chain [] x = return x
+chain (f:fs) x = (f x) >>= chain fs 
+  
+chainJust :: [a -> Maybe a] -> a -> a
+chainJust fs x = case chain fs x of
+  Nothing -> error "chainJust: Nothing"
+  Just y  -> y
+  
+--------------------------------------------------------------------------------  
+
+iterateN :: Int -> (a -> a) -> a -> a
+iterateN n f = go n where 
+  go 0 x = x
+  go n x = go (n-1) (f x)
+
+--------------------------------------------------------------------------------  
+
+{-
+mapM_ :: (Traversable t, Monad m) => (a -> m ()) -> t a -> m ()
+mapM_ act t = do
+  _ <- mapM act t
+  return ()
+-}
+
+mapAccumM :: (Traversable t, Monad m) => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
+mapAccumM user x0 t = liftM swap $ runStateT (mapM action t) x0 where
+  action x = StateT $ \acc -> do
+    (acc', y) <- user acc x 
+    return (y, acc') 
+
+swap :: (a,b) -> (b,a)
+swap (x,y) = (y,x)
+
+--------------------------------------------------------------------------------  
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+instance (Functor m) => Functor (StateT s m) where
+  fmap f m = StateT $ \s -> fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s
+
+instance (Functor m, Monad m) => Applicative (StateT s m) where
+  pure  = return
+  (<*>) = ap
+
+instance (Monad m) => Monad (StateT s m) where
+  return a = state $ \s -> (a, s)
+  m >>= k  = StateT $ \s -> do
+    ~(a, s') <- runStateT m s
+    runStateT (k a) s'
+  fail str = StateT $ \_ -> fail str
+
+state :: (Monad m) => (s -> (a,s)) -> StateT s m a 
+state f = StateT (return . f)
+
+sget :: (Monad m) => StateT s m s
+sget = state $ \s -> (s,s)
+
+sput :: (Monad m) => s -> StateT s m ()
+sput s = state $ \_ -> ((),s)
+
+smodify :: (Monad m) => (s -> s) -> StateT s m ()
+smodify f = state $ \s -> ((), f s)
+
+--------------------------------------------------------------------------------  

@@ -0,0 +1,95 @@+
+-- | Tests for morphisms
+
+module TestSuite.Morphisms where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck
+
+import Control.Applicative
+import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
+import Data.List ( sort , intercalate )
+import Data.Char ( ord )
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+-- import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Morphisms
+-- import Data.Generics.Fixplate.Traversals
+
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Morphisms :: TestTree
+testgroup_Morphisms = testGroup "Morphisms"
+  [ testProperty "para"                prop_para
+  , testProperty "paraList"            prop_paraList
+  , testProperty "cataHisto"           prop_cataHisto
+  , testProperty "paraHisto"           prop_paraHisto
+  ]
+
+--------------------------------------------------------------------------------
+-- Tests
+
+{-
+runtests_Morphisms :: IO ()
+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 :: 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
+
+prop_paraList :: FixT Label -> Bool
+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
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,183 @@+
+-- | Auxillary functions useful for testing
+
+{-# LANGUAGE CPP, 
+             DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving,
+             FlexibleInstances, TypeSynonymInstances
+  #-}
+module TestSuite.Tools where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative
+import Control.Monad hiding (mapM, mapM_, forM, forM_)
+import Data.List (sort)
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Text.Show
+import Text.Read
+
+import Data.Generics.Fixplate.Base
+
+import Test.QuickCheck
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+maxChildren :: Int
+maxChildren = 7
+
+data Tree label
+  = Tree label [Tree label] 
+  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+
+data TreeF label t 
+  = TreeF label [t]
+  deriving (Eq,Ord,Show,Read,Functor,Foldable,Traversable)
+  
+type FixT label = Mu (TreeF label)  
+  
+instance Eq   label => EqF   (TreeF label) where equalF     = (==)
+instance Ord  label => OrdF  (TreeF label) where compareF   = compare
+instance Show label => ShowF (TreeF label) where showsPrecF = showsPrec
+#ifdef __GLASGOW_HASKELL__
+instance Read label => ReadF (TreeF label) where readPrecF  = readPrec
+#else
+instance Read label => ReadF (TreeF label) where readsPrecF = readsPrec
+#endif
+  
+treeF :: l -> [Mu (TreeF l)] -> Mu (TreeF l)
+treeF s = Fix . TreeF s
+
+attrTreeF :: a -> l -> [Attr (TreeF l) a] -> Attr (TreeF l) a
+attrTreeF x s = Fix . Ann x . TreeF s
+
+--------------------------------------------------------------------------------
+-- * draw trees
+
+printTree :: Tree Label -> IO ()
+printTree = printTree' (\(Label s) -> s)
+
+printTreeF :: FixT Label -> IO ()
+printTreeF = printTreeF' (\(Label s) -> s)
+
+printTree' :: (a -> String) -> Tree a -> IO ()
+printTree' h = go 0 where
+  go i (Tree label children) = do
+    putStrLn $ if i>0 
+      then concat (replicate (i-1) "| " ++ ["|-", h label])
+      else h label
+    mapM_ (go (i+1)) children
+
+printTreeF' :: (a -> String) -> Mu (TreeF a) -> IO ()
+printTreeF' h = go 0 where
+  go i (Fix (TreeF label children)) = do
+    putStrLn $ if i>0 
+      then concat (replicate (i-1) "| " ++ ["|-", h label])
+      else h label
+    mapM_ (go (i+1)) children
+    
+--------------------------------------------------------------------------------
+-- * random trees
+
+rndTree :: IO (Tree Label)
+rndTree = liftM (!!7) $ sample' arbitrary
+
+rndFixT :: IO (FixT Label)
+rndFixT = liftM (!!7) $ sample' arbitrary
+
+--------------------------------------------------------------------------------
+-- * conversion
+
+toFixT :: Tree l -> Mu (TreeF l)
+toFixT (Tree s ts) = treeF s (map toFixT ts)
+
+fromFixT :: FixT l -> Tree l
+fromFixT (Fix (TreeF s ts)) = Tree s (map fromFixT ts)
+
+fromAttr :: Attr (TreeF l) a -> Tree (l,a)
+fromAttr (Fix (Ann x (TreeF s ts))) = Tree (s,x) (map fromAttr ts)
+
+toAttr :: Tree (l,a) -> Attr (TreeF l) a 
+toAttr (Tree (s,x) ts) = Fix (Ann x (TreeF s (map toAttr ts)))
+
+--------------------------------------------------------------------------------
+-- * arbitrary
+
+pairs :: [a] -> [(a,a)]
+pairs (x:xs@(y:_)) = (x,y):(pairs xs)
+pairs [_]          = []
+pairs []           = error "pairs: empty list"
+
+-- | @genPartition n k@ partitions n elements into k groups randomly,
+-- and gives back the sizes (which can be zero, too)
+genPartition :: Int -> Int -> Gen [Int]
+genPartition n k = do
+  sep <- replicateM (k-1) $ choose (0,n)
+  let ps = pairs (0 : sort sep ++ [n]) 
+  return (map (\(x,y) -> (y-x)) ps)
+
+newtype Label = Label String deriving (Eq,Ord,Show,Read)
+
+unLabel :: Label -> String
+unLabel (Label s) = s
+
+instance Arbitrary Label where
+  arbitrary = do
+    n <- choose (2, 8)
+    liftM Label $ vectorOf n $ oneof [ choose ('a','z') , choose ('A','Z') ]
+  
+instance Arbitrary l => Arbitrary (Tree l) where
+  shrink (Tree s sub) = [ Tree s sub' | sub' <- shrink sub ] 
+  arbitrary = sized mkTree where
+    mkTree n = do
+      s <- arbitrary
+      case n of
+        0 -> return (Tree s [])
+        1 -> mkTree 0 >>= \t -> return (Tree s [t])
+        _ -> do
+          k <- choose (1, min maxChildren n)
+          ls <- genPartition (n-1) k
+          subtrees <- forM ls $ \l -> mkTree l
+          return (Tree s subtrees)
+
+instance Arbitrary l => Arbitrary (Mu (TreeF l)) where
+  shrink (Fix (TreeF s sub)) = [ Fix (TreeF s sub') | sub' <- shrink sub ] 
+  arbitrary = sized mkTree  where
+    mkTree n = do
+      s <- arbitrary
+      case n of
+        0 -> return (treeF s [])
+        1 -> mkTree 0 >>= \t -> return (treeF s [t])
+        _ -> do
+          k <- choose (1, min maxChildren n)
+          ls <- genPartition (n-1) k
+          subtrees <- forM ls $ \l -> mkTree l
+          return (treeF s subtrees)
+
+{-          
+instance (Arbitrary a, Arbitrary x) => Arbitrary (Ann TreeF a x) where
+  shrink (Ann a x) = [ Ann a y | y <- shrink x ]
+  arbitrary = do
+    a <- arbitrary
+    x <- arbitrary
+-}
+
+instance (Arbitrary a, Arbitrary l) => Arbitrary (Attr (TreeF l) a) where
+  shrink (Fix (Ann a (TreeF s sub))) = [ Fix (Ann a (TreeF s sub')) | sub' <- shrink sub ] 
+  arbitrary = sized mkTree  where
+    mkTree n = do
+      s <- arbitrary
+      a <- arbitrary
+      case n of
+        0 -> return (attrTreeF a s [])
+        1 -> mkTree 0 >>= \t -> return (attrTreeF a s [t])
+        _ -> do
+          k <- choose (1, min maxChildren n)
+          ls <- genPartition (n-1) k
+          subtrees <- forM ls $ \l -> mkTree l
+          return (attrTreeF a s subtrees)
+              
+--------------------------------------------------------------------------------

@@ -0,0 +1,72 @@+
+-- | Tests for traversals
+
+module TestSuite.Traversals where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck
+
+import Control.Applicative
+import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+-- import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Morphisms
+import Data.Generics.Fixplate.Traversals
+
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Traversals :: TestTree
+testgroup_Traversals = testGroup "Traversals"
+  [ testProperty "left fold"        prop_leftFold
+  , testProperty "lazy left fold"   prop_leftFoldLazy
+  , testProperty "right fold"       prop_rightFold
+  , testProperty "universe /1"      prop_universe1
+  , testProperty "universe /2"      prop_universe2
+  ]
+
+--------------------------------------------------------------------------------
+-- Tests
+
+universeNaive :: Foldable f => Mu f -> [Mu f]
+universeNaive x = x : concatMap universeNaive (children x)
+
+{-
+runtests_Traversals :: IO ()
+runtests_Traversals = do
+  quickCheck prop_leftFold
+  quickCheck prop_leftFoldLazy
+  quickCheck prop_rightFold
+  quickCheck prop_universe1
+  quickCheck prop_universe2
+-}
+  
+prop_universe1 :: FixT Label -> Bool
+prop_universe1 tree = universe tree == universeNaive tree
+
+prop_universe2 :: FixT Label -> Bool
+prop_universe2 tree = universe tree == foldRight (:) [] tree
+  
+prop_leftFold :: FixT Label -> Bool
+prop_leftFold tree = 
+  foldLeft (\xs (Fix (TreeF l s)) -> (l:xs)) [] tree == foldl (flip (:)) [] (fromFixT tree)
+
+prop_leftFoldLazy :: FixT Label -> Bool
+prop_leftFoldLazy tree = 
+  foldLeftLazy (\xs (Fix (TreeF l s)) -> (l:xs)) [] tree == foldl (flip (:)) [] (fromFixT tree)
+  
+prop_rightFold :: FixT Label -> Bool
+prop_rightFold tree = 
+  foldRight (\(Fix (TreeF l s)) xs -> (l:xs)) [] tree == foldr (:) [] (fromFixT tree)
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,287 @@+
+-- | Tests for tries
+
+module TestSuite.Trie where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck
+
+import Prelude hiding ( mapM , mapM_ , concat , concatMap , lookup )
+
+import Control.Applicative
+import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
+import Data.Foldable hiding ( toList )
+import Data.Traversable
+import Data.List ( sort , group , nubBy , nub , (\\) , foldl' )
+
+import Data.Map (Map)
+import qualified Data.Map as Map 
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Morphisms
+import Data.Generics.Fixplate.Traversals
+import Data.Generics.Fixplate.Trie as Trie
+
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Trie :: TestTree
+testgroup_Trie = testGroup "Trie"
+  [ testProperty "difference"        prop_difference
+  , testProperty "differenceWith"    prop_differenceWith
+  , testProperty "union"             prop_union
+  , testProperty "intersection"      prop_intersection
+
+  , testProperty "universeBag"       prop_unibag_naive
+  , testProperty "universeBag /2"    prop_unibag_naive_2
+  , testProperty "christmasTree"     prop_christmasTree
+  , testProperty "christmasTree /2"  prop_christmasTree_2
+  , testProperty "christmasTree /3"  prop_christmasTree_3
+
+  , testProperty "fromList"          prop_fromList_naive
+  , testProperty "bag"               prop_bag
+  , testProperty "bag /b"            prop_bag_b
+  , testProperty "toList . fromList" prop_fromList_toList
+  , testProperty "multiSetToList"    prop_multiSetToList_b
+
+  , testProperty "insert"            prop_insert
+  , testProperty "delete"            prop_delete
+  , testProperty "update"            prop_update
+  , testProperty "delete . insert"   prop_insert_delete
+  , testProperty "insert . delete"   prop_delete_insert
+  , testProperty "lookup"            prop_lookup
+  , testProperty "lookup /notfound"  prop_lookup_notfound
+  , testProperty "singleton"         prop_singleton
+  ]
+
+--------------------------------------------------------------------------------
+-- Tests
+
+{-
+runtests_Trie :: IO ()
+runtests_Trie = do
+  quickCheck prop_difference
+  quickCheck prop_differenceWith
+  quickCheck prop_union
+  quickCheck prop_intersection
+
+  quickCheck prop_unibag_naive
+  quickCheck prop_unibag_naive_2
+  quickCheck prop_christmasTree
+  quickCheck prop_christmasTree_2
+  quickCheck prop_christmasTree_3
+
+  quickCheck prop_fromList_naive
+  quickCheck prop_bag
+  quickCheck prop_bag_b
+  quickCheck prop_fromList_toList
+  quickCheck prop_multiSetToList_b
+  quickCheck prop_insert
+  quickCheck prop_delete
+  quickCheck prop_update
+  quickCheck prop_insert_delete
+  quickCheck prop_delete_insert
+  quickCheck prop_lookup
+  quickCheck prop_lookup_notfound
+  quickCheck prop_singleton
+-}
+
+--------------------
+
+newtype Multiplicity = Multiplicity { unMultiplicity :: Int } deriving (Eq,Ord,Show)
+
+instance Arbitrary Multiplicity where
+  arbitrary = do
+    n <- choose (1, 7)
+    return (Multiplicity n)
+
+newtype MultiSet = MultiSet { unMultiSet :: [(Multiplicity, FixT Label)] } deriving (Eq,Ord,Show)
+
+instance Arbitrary MultiSet where arbitrary = MultiSet <$> arbitrary
+
+multiSetToList :: MultiSet -> [FixT Label]
+multiSetToList (MultiSet mxs) = go mxs where
+  go [] = []
+  go ((Multiplicity n, x):rest) = replicate n x ++ go rest
+
+multiSetToList_b :: MultiSet -> [FixT Label]
+multiSetToList_b (MultiSet mxs) = go mxs [] where
+  go [] [] = []
+  go [] ys = go ys []
+  go ((Multiplicity n, x):rest) ys = if n>0 
+    then x : go rest ( (Multiplicity (n-1), x) : ys )
+    else go rest ys
+
+newtype FiniteMap = FiniteMap { unFiniteMap :: [(FixT Label,Char)] } deriving (Eq,Ord,Show)
+
+instance Arbitrary FiniteMap where arbitrary = (FiniteMap . nubBy (equating fst)) <$> arbitrary
+
+type TrieT = Trie (TreeF Label) Char
+
+finiteMap :: FiniteMap -> TrieT
+finiteMap (FiniteMap fmap) = fromList fmap
+
+--------------------
+
+fromListNaive :: (Traversable f, OrdF f) => [(Mu f, a)] -> Trie f a
+fromListNaive ts = Prelude.foldl worker Trie.empty ts where
+  worker trie (tree,value) = Trie.insertWith id const tree value trie 
+
+universeBagNaive :: (Functor f, Foldable f, OrdF f) => Mu f -> Trie f Int
+universeBagNaive = bag . universe
+
+mapBag :: Ord a => [a] -> Map a Int
+mapBag xs = Data.List.foldl' f Map.empty xs where
+  f old x = Map.insertWith (+) x 1 old
+
+--------------------
+    
+prop_unibag_naive :: FixT Label -> Bool
+prop_unibag_naive tree = toList (universeBag tree) == toList (universeBagNaive tree)
+
+prop_unibag_naive_2 :: FixT Bool -> Bool
+prop_unibag_naive_2 tree = toList (universeBag tree) == toList (universeBagNaive tree)
+
+prop_fromList_naive :: FiniteMap -> Bool
+prop_fromList_naive (FiniteMap list) = toList (fromList list) == toList (fromListNaive list)
+
+prop_bag :: MultiSet -> Bool
+prop_bag mset = (sort $ toList $ bag $ multiSetToList mset) == sort (map f $ unMultiSet mset) where
+  f (Multiplicity k, x) = (x,k)
+
+prop_bag_b :: MultiSet -> Bool
+prop_bag_b mset = (sort $ toList $ bag $ multiSetToList_b mset) == sort (map f $ unMultiSet mset) where
+  f (Multiplicity k, x) = (x,k)
+
+prop_fromList_toList :: FiniteMap -> Bool
+prop_fromList_toList (FiniteMap list) = sort (toList (fromList list)) == sort list
+
+prop_multiSetToList_b :: MultiSet -> Bool
+prop_multiSetToList_b mset = toList (bag (multiSetToList mset)) == toList (bag (multiSetToList_b mset)) 
+
+prop_insert :: FixT Label -> Char -> FiniteMap -> Bool
+prop_insert key ch (FiniteMap list) = sort (toList (insert key ch trie)) == sort ((key,ch) : toList trie) where
+  trie = fromList list
+
+prop_delete :: Int -> FiniteMap -> Bool
+prop_delete i (FiniteMap list) = (n==0) || (toList (delete key trie) == toList trie \\ [(key,value)]) where
+  trie = fromList list
+  n = length list
+  k = mod i n
+  (key,value) = list!!k
+
+prop_update :: Char -> Int -> FiniteMap -> Bool
+prop_update new i (FiniteMap list) = (n==0) || (toList (update f key trie) == replace (toList trie)) where
+  trie = fromList list
+  n = length list
+  k = mod i n
+  (key,value) = list!!k
+  replace [] = []
+  replace (this@(k,x):rest) = if k==key 
+    then case f x of 
+      Nothing -> rest
+      Just y  -> (k,y) : replace rest
+    else this : replace rest    
+  f old = if old < 'A' then Nothing else Just new
+
+prop_insert_delete :: FixT Label -> Char -> FiniteMap -> Bool
+prop_insert_delete key ch (FiniteMap list) = toList (delete key (insert key ch trie)) == toList trie where
+  trie = delete key (fromList list)   -- !
+
+prop_delete_insert :: Int -> FiniteMap -> Bool
+prop_delete_insert i (FiniteMap list) = (n==0) || (toList (insert key value (delete key trie)) == toList trie) where
+  trie = fromList list
+  n = length list
+  k = mod i n
+  (key,value) = list!!k
+
+prop_lookup :: Int -> FiniteMap -> Bool
+prop_lookup i (FiniteMap list) = (n==0) || (Just value == lookup key trie) where
+  trie = fromList list
+  n = length list
+  k = mod i n
+  (key,value) = list!!k
+
+prop_lookup_notfound :: FixT Label -> FiniteMap -> Bool
+prop_lookup_notfound key (FiniteMap list) = lookup key trie == Nothing where
+  trie = delete key (fromList list)   -- !#endif
+
+prop_singleton :: FixT Label -> Char -> Bool
+prop_singleton tree ch = toList (singleton tree ch) == [(tree,ch)]
+
+prop_intersection :: MultiSet -> Bool
+prop_intersection mset = {- trace ("--"++show n++"--") -} (itrie == imap) where
+
+  list = multiSetToList_b mset
+  n = length list
+  k = div n 3
+  l = div (2*n) 3
+  xs = take l list
+  ys = drop k list
+
+  itrie = sort $     toList $     intersectionWith (+) (   bag xs) (   bag ys)
+  imap  = sort $ Map.toList $ Map.intersectionWith (+) (mapBag xs) (mapBag ys) 
+
+prop_union :: MultiSet -> Bool
+prop_union mset = {- trace ("--"++show n++"--") -} (utrie == umap) where
+
+  list = multiSetToList_b mset
+  n = length list
+  k = div n 3
+  l = div (2*n) 3
+  xs = take l list
+  ys = drop k list
+
+  utrie = sort $     toList $     unionWith (+) (   bag xs) (   bag ys)
+  umap  = sort $ Map.toList $ Map.unionWith (+) (mapBag xs) (mapBag ys) 
+
+prop_difference :: MultiSet -> Bool
+prop_difference mset = {- trace ("--"++show [length xs , length ys, length dtrie]++"--") -} (dtrie == dmap) where
+
+  list = multiSetToList_b mset
+  n = length list
+  k = div n 3
+  l = div (2*n) 3
+  xs = take l list
+  ys = drop k list
+
+  dtrie = sort $     toList $     difference (   bag xs) (   bag ys)
+  dmap  = sort $ Map.toList $ Map.difference (mapBag xs) (mapBag ys) 
+
+prop_differenceWith :: MultiSet -> Bool
+prop_differenceWith mset = {- trace ("--"++show [length xs , length ys, length dtrie]++"--") -} (dtrie == dmap) where
+
+  list = multiSetToList_b mset
+  n = length list
+  k = div n 3
+  l = div (2*n) 3
+  xs = take l list
+  ys = drop k list
+
+  f x y = if y<=2 then Just (x+1) else Nothing
+
+  dtrie = sort $     toList $     differenceWith f (   bag xs) (   bag ys)
+  dmap  = sort $ Map.toList $ Map.differenceWith f (mapBag xs) (mapBag ys) 
+
+prop_christmasTree :: FixT Label -> Bool
+prop_christmasTree tree = toList (attribute (christmasTree tree)) == toList (universeBag tree)
+
+prop_christmasTree_3 :: FixT Bool -> Bool
+prop_christmasTree_3 tree = toList (attribute (christmasTree tree)) == toList (universeBag tree)
+
+-- we reduce the labels so that there is more chance for collisions
+prop_christmasTree_2 :: Bool -> FixT Label -> Bool
+prop_christmasTree_2 b tree0 = toList (attribute (christmasTree tree)) == toList (universeBag tree) where
+  tree = transform f tree0
+  f = if b 
+    then \(Fix (TreeF (Label label) ts)) -> Fix $ TreeF (Label (take 1 label)) ts
+    else \(Fix (TreeF (Label label) ts)) -> Fix $ TreeF (Label ""            ) ts
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,295 @@+
+-- | Tests for zippers
+
+{-# LANGUAGE FlexibleInstances #-}
+module TestSuite.Zipper where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.QuickCheck
+
+import Control.Applicative
+import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+
+import Data.Generics.Fixplate.Base
+-- import Data.Generics.Fixplate.Misc
+import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Morphisms
+import Data.Generics.Fixplate.Traversals
+import Data.Generics.Fixplate.Zipper
+
+import TestSuite.Tools
+import TestSuite.Misc
+
+--------------------------------------------------------------------------------
+
+testgroup_Zipper :: TestTree
+testgroup_Zipper = testGroup "Zipper"
+  [ testProperty "Loc: Read/Show"    prop_ReadShowLoc
+  , testProperty "findLoc"           prop_findLoc
+  , testProperty "locationsList"     prop_locationsList
+  , testProperty "contextList"       prop_contextList
+  , testProperty "Top"               prop_Top
+  , testProperty "defocus"           prop_defocus
+  , testProperty "horizontalDown"    prop_horizontalPos
+  , testProperty "pathDown"          prop_fullPathDown
+  , testProperty "pathUp"            prop_fullPathUp
+  , testProperty "pathUp /2"         prop_fullPathUp2
+  , testProperty "leftmost"          prop_leftmost
+  , testProperty "rightmost"         prop_rightmost
+  , testProperty "up . downL"        prop_DownLUp
+  , testProperty "up . downR"        prop_DownRUp
+  , testProperty "downL . up"        prop_UpDownL 
+  , testProperty "downR . up"        prop_UpDownR
+  , testProperty "downL"             prop_DownL
+  , testProperty "downR"             prop_DownR
+  , testProperty "downJ . up"        prop_UpDownJ
+  , testProperty "right . left"      prop_LeftRight
+  , testProperty "left . right"      prop_RightLeft
+  ]
+
+--------------------------------------------------------------------------------
+-- Tests
+
+type LocT a = Loc (TreeF a)
+
+{-
+data Step
+  = StepUp
+  | StepLeft
+  | StepRight
+  | StepDown Int
+  | StepDownL
+  | StepDownR
+  deriving (Eq,Ord,Show)
+
+newtype Walk = Walk [Step] deriving (Eq,Ord,Show)
+  
+walk :: Traversable f => Walk -> Loc f -> Loc f  
+walk (Walk steps) loc = foldl (flip singleStep) loc steps
+
+singleStep :: Traversable f => Step -> Loc f -> Loc f
+singleStep s loc = case stepMaybe s loc of { Nothing -> loc ; Just new -> new }
+
+stepMaybe :: Traversable f => Step -> Loc f -> Maybe (Loc f)
+stepMaybe s = case s of
+  StepUp     -> moveUp
+  StepLeft   -> moveLeft
+  StepRight  -> moveRight
+  StepDown j -> moveDown j
+  StepDownL  -> moveLeft
+  StepDownR  -> moveRight
+  
+instance Arbitrary Step where
+  arbitrary = oneof
+    [ return StepUp
+    , return StepLeft
+    , return StepRight
+    , do { j <- choose (1,7) ; return (StepDown j) }
+    , return StepDownL
+    , return StepDownR
+    ]
+
+instance Arbitrary Walk where
+  arbitrary = liftM Walk arbitrary
+  shrink (Walk steps) = map Walk (shrink steps)
+-}
+
+-- | Assuming a left-to-right canonical numbering, we find the given
+-- location.
+findLoc :: Traversable f => Int -> Loc (Ann f Int) -> Loc (Ann f Int) 
+findLoc k = go where
+  go loc = 
+    case compare j k of
+      GT -> error "findLoc: shouldn't happen?"
+      EQ -> loc
+      LT -> case moveDownL loc of
+        Just xx -> go xx
+        Nothing -> case moveRight loc of
+          Just yy -> go yy
+          Nothing -> goUpR (unsafeMoveUp loc)
+    where
+      Fix (Ann j _) = focus loc
+  goUpR loc = case moveRight loc of
+    Nothing -> goUpR (unsafeMoveUp loc)
+    Just zz -> go zz
+
+----
+tmp = treeF "root"
+  [ treeF "a" [ treeF "a1" [] , treeF "a2" [] ]
+  , treeF "b" []
+  , treeF "c" [ treeF "c1" [] , treeF "c2" [] , treeF "c3" [] ]
+  ]
+----
+  
+instance Arbitrary a => Arbitrary (LocT a) where
+  arbitrary = do
+    tree <- arbitrary 
+    let (n,numbered) = enumerateNodes tree
+    k <- choose (0,n-1)
+    return $ locForget $ findLoc k (root numbered)
+
+rndLoc :: IO (LocT Label)
+rndLoc = liftM (!!7) $ sample' arbitrary
+  
+newtype ChildIndex = ChildIndex Int deriving Show
+
+instance Arbitrary ChildIndex where
+  arbitrary = liftM ChildIndex $ choose (0,7)
+  
+--------------------------------------------------------------------------------
+
+{-
+runtests_Zipper :: IO ()
+runtests_Zipper = do
+  quickCheck prop_ReadShowLoc
+  quickCheck prop_findLoc
+  quickCheck prop_locationsList
+  quickCheck prop_contextList
+  quickCheck prop_Top
+  quickCheck prop_defocus
+  quickCheck prop_horizontalPos
+  quickCheck prop_fullPathDown
+  quickCheck prop_fullPathUp
+  quickCheck prop_fullPathUp2
+  quickCheck prop_leftmost
+  quickCheck prop_rightmost
+  quickCheck prop_DownLUp
+  quickCheck prop_DownRUp
+  quickCheck prop_UpDownL 
+  quickCheck prop_UpDownR
+  quickCheck prop_DownL
+  quickCheck prop_DownR
+  quickCheck prop_UpDownJ
+  quickCheck prop_LeftRight
+  quickCheck prop_RightLeft
+-}
+
+----------------------------------------
+
+leftmostNaive :: Traversable f => Loc f -> Loc f
+leftmostNaive = tillNothing moveLeft
+
+rightmostNaive :: Traversable f => Loc f -> Loc f
+rightmostNaive = tillNothing moveRight
+
+fullPathUpNaive :: Traversable f => Loc f -> [Int]
+fullPathUpNaive = go where
+  go loc@(Loc _ path) = case path of
+    Top -> []
+    _   -> horizontalPos loc : go (unsafeMoveUp loc)
+
+----------------------------------------
+
+prop_ReadShowLoc :: LocT Label -> Bool
+prop_ReadShowLoc loc = read (show loc) == loc
+
+prop_locationsList :: FixT Label -> Bool
+prop_locationsList tree = locationsList tree == [ locForget $ findLoc i top | i<-[0..n-1] ] where
+  top = root numbered
+  (n,numbered) = enumerateNodes tree
+
+prop_findLoc :: FixT Label -> Bool
+prop_findLoc tree = [0..n-1] == [ attribute $ focus $ findLoc i top | i<-[0..n-1] ] where
+  top = root numbered
+  (n,numbered) = enumerateNodes tree
+
+prop_contextList :: FixT Label -> Bool  
+prop_contextList tree =
+  map (\(Fix (TreeF l ts),replace) -> replace (Fix (TreeF (h l) ts))) (contextList tree)
+  ==
+  [ defocus $ modify (\(Fix (TreeF l ts)) -> Fix (TreeF (h l) ts) ) $ locForget $ findLoc i top | i<-[0..n-1] ]
+  where
+    top = root numbered
+    (n,numbered) = enumerateNodes tree
+    h (Label xs) = Label ('_':xs)
+  
+prop_Top :: LocT Label -> Bool
+prop_Top loc = root (defocus loc) == moveTop loc
+
+prop_defocus :: FixT Label -> Bool
+prop_defocus tree = 
+  Prelude.and [ defocus (findLoc i top) == numbered | i<-[0..n-1] ] 
+  where
+    top = root numbered
+    (n,numbered) = enumerateNodes tree
+
+----------------------------------------
+
+prop_horizontalPos :: LocT Label -> Bool
+prop_horizontalPos loc = 
+  loc == iterateN (horizontalPos loc) unsafeMoveRight (leftmost loc)
+
+prop_fullPathDown :: LocT Label -> Bool
+prop_fullPathDown loc = 
+  loc == foldl (flip unsafeMoveDown) (moveTop loc) (fullPathDown loc)
+
+prop_fullPathUp :: LocT Label -> Bool
+prop_fullPathUp loc = 
+  fullPathUp loc == fullPathUpNaive loc
+
+prop_fullPathUp2 :: LocT Label -> Bool 
+prop_fullPathUp2 loc = 
+  loc == foldr unsafeMoveDown (moveTop loc) (fullPathUp loc)  
+  
+----------------------------------------
+    
+prop_leftmost :: LocT Label -> Bool
+prop_leftmost loc = leftmost loc == leftmostNaive loc
+
+prop_rightmost :: LocT Label -> Bool
+prop_rightmost loc = rightmost loc == rightmostNaive loc
+    
+prop_DownLUp :: LocT Label -> Property
+prop_DownLUp loc = 
+  (not $ isBottom loc) 
+  ==> unsafeMoveUp (unsafeMoveDownL loc) == loc
+
+prop_DownRUp :: LocT Label -> Property  
+prop_DownRUp loc = 
+  (not $ isBottom loc) 
+  ==> unsafeMoveUp (unsafeMoveDownR loc) == loc
+
+prop_UpDownL :: LocT Label -> Property
+prop_UpDownL loc = 
+  (not $ isTop loc) 
+  ==> unsafeMoveDownL (unsafeMoveUp loc) == leftmost loc
+
+prop_UpDownR :: LocT Label -> Property
+prop_UpDownR loc = 
+  (not $ isTop loc) 
+  ==> unsafeMoveDownR (unsafeMoveUp loc) == rightmost loc
+
+prop_DownL :: LocT Label -> Property
+prop_DownL loc =
+  (not $ isBottom loc)
+  ==> unsafeMoveDownL loc == unsafeMoveDown 0 loc
+
+prop_DownR :: LocT Label -> Property
+prop_DownR loc =
+  (not $ isBottom loc)
+  ==> let k = length $ children $ focus loc
+      in  unsafeMoveDownR loc == unsafeMoveDown (k-1) loc
+
+prop_UpDownJ :: ChildIndex -> LocT Label -> Property
+prop_UpDownJ (ChildIndex j) loc = 
+  (not $ isTop loc) 
+  ==> (j < (length $ children $ focus $ unsafeMoveUp loc))  
+  ==> unsafeMoveDown j (unsafeMoveUp loc) == iterateN j unsafeMoveRight (leftmost loc)
+
+prop_LeftRight :: LocT Label -> Property
+prop_LeftRight loc = 
+  (not $ isLeftmost loc)
+  ==> unsafeMoveRight (unsafeMoveLeft loc) == loc  
+
+prop_RightLeft :: LocT Label -> Property
+prop_RightLeft loc = 
+  (not $ isRightmost loc)
+  ==> (unsafeMoveLeft (unsafeMoveRight loc) == loc)  
+
+--------------------------------------------------------------------------------

@@ -0,0 +1,37 @@+
+
+module Main where
+
+--------------------------------------------------------------------------------
+
+import Test.Tasty
+import Test.Tasty.QuickCheck
+
+import TestSuite.Attributes         ( testgroup_Attributes )
+import TestSuite.Instances          ( testgroup_Instances  )
+import TestSuite.Morphisms          ( testgroup_Morphisms  )
+import TestSuite.Traversals         ( testgroup_Traversals )
+import TestSuite.Trie               ( testgroup_Trie       )
+import TestSuite.Zipper             ( testgroup_Zipper     )
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain tests
+
+setN :: Int -> TestTree -> TestTree
+setN n = localOption (QuickCheckTests n)
+
+tests :: TestTree
+tests 
+  = setN 250 
+  $ testGroup "tests"
+      [ testgroup_Morphisms
+      , testgroup_Instances
+      , testgroup_Traversals
+      , testgroup_Attributes
+      , testgroup_Zipper
+      , setN 100 $ testgroup_Trie
+      ]
+
+--------------------------------------------------------------------------------