fixplate 0.1.2 → 0.1.3

raw patch · 11 files changed

+398/−24 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Generics/Fixplate.hs +4/−0
• Data/Generics/Fixplate/Attributes.hs +244/−9
• Data/Generics/Fixplate/Base.hs +11/−3
• Data/Generics/Fixplate/Misc.hs +7/−1
• Data/Generics/Fixplate/Morphisms.hs +112/−1
• Data/Generics/Fixplate/Open.hs +4/−1
• Data/Generics/Fixplate/Tests.hs +1/−0
• Data/Generics/Fixplate/Traversals.hs +2/−1
• Data/Generics/Fixplate/Zipper.hs +2/−1
• LICENSE +1/−1
• fixplate.cabal +10/−6

@@ -49,6 +49,10 @@ -- the @Rank2Types@ extension. For compatibility, the functionality
 -- of this module is at the moment only provided when compiled with GHC or Hugs.
 --
+-- Note: to obtain 'Eq', 'Ord', 'Show', 'Read' and other instances for 
+-- fixed point types like @Mu Expr1@, consult the documentation of the
+-- 'EqF' type class (cf. the related 'OrdF', 'ShowF' and 'ReadF' classes)
+--
 module Data.Generics.Fixplate 
   ( module Data.Generics.Fixplate.Base
   , module Data.Generics.Fixplate.Traversals

@@ -6,7 +6,16 @@   ( Attrib(..)
   , annMap
   -- * Synthetised attributes
-  , synthetise , synthetise' , synthetiseList , synthetiseM
+  , synthetise  
+  , synthetise' , synthetiseList
+  , synthetiseM
+  -- * Synthetised attributes as generalized cata- and paramorphisms
+  , synthCata   , scanCata
+  , synthPara   , synthPara' , scanPara
+  , synthZygo_  , synthZygo  , synthZygoWith
+  , synthAccumCata , synthAccumPara 
+  , mapAccumCata
+  , synthCataM  , synthParaM  , synthParaM'
   -- * Inherited attributes
   , inherit , inherit'
   , inheritM , inheritM_
@@ -25,9 +34,20 @@ #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
@@ -44,6 +64,11 @@ 
 #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 
@@ -68,30 +93,152 @@ --
 -- (note that @sum@ here is @Data.Foldable.sum == Prelude.sum . Data.Foldable.toList@)
 --
+-- See also 'synthCata'.
 synthetise :: Functor f => (f a -> a) -> Mu f -> Attr f a
-synthetise h = go where
-  go (Fix x) = Fix $ Ann (h a) y where 
-    y  =  fmap go x  
-    a  =  fmap attribute y
+synthetise = synthCata
  
--- | Generalization of @scanr@ for trees.
+-- | Generalization of @scanr@ for trees. See also 'scanCata'.
 synthetise' :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
 synthetise' h = go where
   go (Fix (Ann b x)) = Fix $ Ann (h b a) y where 
     y  =  fmap go x  
     a  =  fmap attribute y
 
+-- | List version of 'synthetise' (compare with Uniplate)
 synthetiseList :: (Functor f, Foldable f) => ([a] -> a) -> Mu f -> Attr f a
 synthetiseList h = synthetise (h . toList)
 
 -- | Monadic version of 'synthetise'.
 synthetiseM  ::  (Traversable f, Monad m) =>  (f a -> m a) -> Mu f -> m (Attr f a)
-synthetiseM act = go where
+synthetiseM = synthCataM 
+
+--------------------------------------------------------------------------------
+-- Synthetised attributes as generalized cata- and paramorphisms
+
+-- | Synonym for 'synthetise', motivated by the equation
+--
+-- >  attribute . synthCata f == cata f
+--
+-- That is, it attributes all subtrees with the result of the corresponding catamorphism.
+synthCata :: Functor f => (f a -> a) -> Mu f -> Attr f a
+synthCata h = go where
+  go (Fix x) = Fix $ Ann (h a) y where 
+    y  =  fmap go x  
+    a  =  fmap attribute y
+
+-- | Synonym for 'synthetise''. Note that this could be a special case of 'synthCata':
+--
+-- > scanCata f == annZipWith (flip const) . synthCata (\(Ann a x) -> f a x)
+--
+-- Catamorphim ('cata') is the generalization of @foldr@ from lists to trees; 
+-- 'synthCata' is one generalization of @scanr@, and 'scanCata' is another generalization.
+scanCata :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
+scanCata h =  go where
+  go (Fix (Ann a x)) = Fix $ Ann (h a b) y where 
+    y  =  fmap go x  
+    b  =  fmap attribute y
+
+-- | Attributes all subtrees with the result of the corresponding paramorphism.
+--
+-- >  attribute . synthPara f == para f
+--
+synthPara :: Functor f => (Mu f -> f a -> a) -> Mu f -> Attr f a
+synthPara h = go where
+  go t@(Fix x) = Fix $ Ann (h t a) y where 
+    y  =  fmap go x  
+    a  =  fmap attribute y
+
+-- | Another version of 'synthPara'. This satisfies
+--
+-- >  attribute . synthPara' f == para' f
+--
+synthPara' :: Functor f => (f (Mu f, a) -> a) -> Mu f -> Attr f a
+synthPara' h = snd . go where
+  go orig@(Fix x) = ( orig , Fix $ Ann (h lft) rht ) where 
+    lft = fmap (\(s,t) -> (s, attribute t)) uv
+    rht = fmap snd uv    -- :: f (Attr f a)
+    uv  = fmap go x      -- :: f (Mu f , Attr f a)
+
+scanPara :: Functor f => (Attr f a -> f b -> b) -> Attr f a -> Attr f b
+scanPara h = go where
+  go t@(Fix (Ann a x)) = Fix $ Ann (h t b) y where 
+    y  =  fmap go x  
+    b  =  fmap attribute y
+
+-- | Synthetising zygomorphism. 
+-- 
+-- > attribute . synthZygo_ g h == zygo_ g h
+synthZygo_ :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> Attr f a
+synthZygo_ = synthZygoWith (flip const)
+
+synthZygo :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> Attr f (b,a)
+synthZygo = synthZygoWith (,)
+
+synthZygoWith :: Functor f => (b -> a -> c) -> (f b -> b) -> (f (b,a) -> a) -> Mu f -> Attr f c
+synthZygoWith u g h = snd . go where
+  go (Fix t) = ( (b,a) , Fix (Ann (u b a) s) ) where
+    b  = g (fmap fst ba)  
+    a  = h ba             
+    (ba,s) = unzipF (fmap go t)  -- :: ( f (b,a) , f (Attr f c) )
+
+-- | Accumulating catamorphisms. Generalization of 'mapAccumR' from lists to trees.
+synthAccumCata :: Functor f => (f acc -> (acc,b)) -> Mu f -> (acc, Attr f b)
+synthAccumCata h = go where
+  go (Fix x) = (a, Fix (Ann b (fmap snd y))) where
+    y = fmap go x
+    (a,b) = h (fmap fst y)
+
+-- | Accumulating paramorphisms.  
+synthAccumPara :: Functor f => (Mu f -> f acc -> (acc,b)) -> Mu f -> (acc, Attr f b)
+synthAccumPara h = go where
+  go t@(Fix x) = (a, Fix (Ann b (fmap snd y))) where
+    y = fmap go x
+    (a,b) = h t (fmap fst y)
+
+-- | Could be a special case of 'synthAccumCata':
+--
+-- > mapAccumCata f == second (annZipWith (flip const)) . synthAccumCata (\(Ann b t) -> f b t) 
+-- >   where second g (x,y) = (x, g y)
+--
+mapAccumCata :: Functor f => (f acc -> b -> (acc,c)) -> Attr f b -> (acc, Attr f c)
+mapAccumCata h = go where
+  go (Fix (Ann b x)) = (acc, Fix (Ann c (fmap snd y))) where
+    y = fmap go x
+    (acc,c) = h (fmap fst y) b
+
+-- | Synonym for 'synthetiseM'. If you don't need the result, use 'cataM_' instead.
+synthCataM  ::  (Traversable f, Monad m) =>  (f a -> m a) -> Mu f -> m (Attr f a)
+synthCataM act = go where
   go (Fix x) = do
     y  <-  mapM go x    
     a  <-  act $ fmap attribute y
     return (Fix (Ann a y))
 
+-- | Monadic version of 'synthPara'. If you don't need the result,  use 'paraM_' instead.
+synthParaM  ::  (Traversable f, Monad m) => (Mu f -> f a -> m a) -> Mu f -> m (Attr f a)
+synthParaM act = go where
+  go t@(Fix x) = do
+    y  <-  mapM go x  
+    a  <-  act t $ fmap attribute y
+    return (Fix (Ann a y))
+
+-- | Monadic version of 'synthPara''. 
+synthParaM'  ::  (Traversable f, Monad m) =>  (f (Mu f, a) -> m a) -> Mu f -> m (Attr f a)
+synthParaM' act tree = liftM snd (go tree) where
+  go orig@(Fix x) = do 
+    uv <- mapM go x      
+    let lft = fmap (\(s,t) -> (s, attribute t)) uv
+    let rht = fmap snd uv 
+    a <- act lft
+    return ( orig , Fix $ Ann a rht ) 
+{-
+synthParaM' act = go where
+  go (Fix x) = do
+    y  <-  mapM go x    
+    a  <-  act $ unsafeZipWithF (,) x (fmap attribute y)
+    return (Fix (Ann a y))
+-}
+
 --------------------------------------------------------------------------------
 -- Inherited attributes
 
@@ -106,7 +253,7 @@ inherit h root = go root where
   go p s@(Fix t) = let a = h s p in Fix (Ann a (fmap (go a) t))
 
--- | Generalization of @scanl@ for trees
+-- | Generalization of @scanl@ from lists to trees.
 inherit' :: Functor f => (a -> b -> a) -> a -> Attr f b -> Attr f a
 inherit' h root = go root where
   go p (Fix (Ann a t)) = let b = h p a in Fix (Ann b (fmap (go b) t))
@@ -247,11 +394,19 @@ -- 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)]
@@ -267,7 +422,87 @@   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 + 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 + 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
 --------------------------------------------------------------------------------
 

@@ -32,8 +32,11 @@ -- | The fixed-point type.
 newtype Mu f = Fix { unFix :: f (Mu f) }
 
--- | Annotations.
-data Ann f a b  =  Ann { attr :: a , unAnn :: f b }
+-- | Annotated functors.
+data Ann f a b  =  Ann 
+  { attr  :: a           -- ^ the annotation
+  , unAnn :: f b         -- ^ the original functor
+  }
 
 -- | Annotated fixed-point type.
 type Attr f a   =  Mu (Ann f a)
@@ -101,10 +104,15 @@ #endif
             
 --------------------------------------------------------------------------------
-        
+
+-- | NOTE: The 'EqF' instance for annotations compares both the annotations and the original part. 
 instance (Eq a, EqF f) => EqF (Ann f a) where 
   equalF (Ann a x) (Ann b y) = a == b && equalF x y
 
+-- | NOTE: The 'OrdF' instance for annotations first compares the /annotations/, and then 
+-- the functor part. If this is not the desired behaviour (it's not clear to me at the moment
+-- what is the good default here), you can use the standard newtype trick to define a new
+-- behaviour.
 instance (Ord a, OrdF f) => OrdF (Ann f a) where 
   compareF (Ann a x) (Ann b y) = case compare a b of
     LT -> LT

@@ -5,8 +5,8 @@ --------------------------------------------------------------------------------
 
 import Prelude hiding (mapM,mapM_)
-import Control.Monad (liftM)
 import Data.Traversable
+--import Control.Monad (liftM)
 --import Control.Monad.Trans.State
 
 --------------------------------------------------------------------------------
@@ -39,6 +39,12 @@ 
 (<#>) :: (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)
 
 --------------------------------------------------------------------------------
 

@@ -6,22 +6,28 @@ 
 --------------------------------------------------------------------------------
 
+import Prelude hiding ( mapM )
 import Data.Foldable
+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
 
 -- | A /paramorphism/ is a generalized (right) fold.
 para :: Functor f => (Mu f -> f a -> a) -> Mu f -> a
 para h = go where
   go t = h t (fmap go $ unFix t) 
 
+-- | Another version of 'para' (more natural in some sense; compare with 'apo').
 para' :: Functor f => (f (Mu f, a) -> a) -> Mu f -> a
 para' h = go where
   go (Fix t) = h (fmap go' $ t)
@@ -36,15 +42,120 @@ cata h = go where
   go = h . fmap go . unFix
 
--- | An /anamorphism/ is simply an unfold.
+-- | An /anamorphism/ is simply an unfold. Probably not very useful in this context.
 ana :: Functor f => (a -> f a) -> a -> Mu f
 ana h = go where
   go = Fix . fmap go . h
   -- go x = Fix (fmap go (h x))
 
+-- | An /apomorphism/ is a generalization of the anamorphism.
+apo :: Functor f => (a -> f (Either (Mu f) a)) -> a -> Mu f
+apo h = go where
+  go = Fix . fmap worker . h 
+  worker ei = case ei of 
+    Left  t -> t
+    Right a -> go a
+
 -- | A /hylomorphism/ is the composition of a catamorphism and an anamorphism.
 hylo :: Functor f => (f a -> a) -> (b -> f b) -> (b -> a) 
 hylo g h = cata g . ana h
 
 --------------------------------------------------------------------------------
+-- * More exotic stuff
 
+-- | A /zygomorphism/ is a basically a catamorphism inside another catamorphism.
+-- It could be implemented (somewhat wastefully) by first annotating each subtree
+-- with the corresponding values of the inner catamorphism ('synthCata'), then running 
+-- a paramorphims on the annotated tree:
+-- 
+-- > zygo_ g h == para' u . synthCata g 
+-- >   where
+-- >     u = h . fmap (first attribute) . unAnn
+-- >     first f (x,y) = (f x, y)
+--
+zygo_ :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> a
+zygo_ g h = snd . zygo g h  
+
+zygo :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> (b,a)
+zygo g h = go where
+  go (Fix t) = (b,a) where
+    b  = g (fmap fst ba)  -- :: b
+    a  = h ba             -- :: a
+    ba = fmap go t        -- :: f (b,a)
+
+newtype Free   f a = Free   { unFree   :: Either a (f (Free f a)) }
+newtype CoFree f a = CoFree { unCoFree :: (a , f (CoFree f a))    }
+
+-- | Futumorphism. Whatever it does.
+futu :: Functor f => (a -> f (Free f a)) -> a -> Mu f
+futu h = go where
+  -- go :: a -> Mu f
+  go = Fix . fmap worker . h 
+  -- worker :: Free f a -> Mu f
+  worker (Free ei) = case ei of
+    Left  x -> go x
+    Right t -> Fix (fmap worker t)
+
+-- | Histomorphism. Whatever it does.
+histo :: Functor f => (f (CoFree f a) -> a) -> Mu f -> a
+histo h = go where
+  -- go :: Mu f -> a
+  go = h . fmap worker . unFix
+  -- worker :: Mu f -> CoFree f
+  worker t@(Fix s) = CoFree ( go t , fmap worker s )
+
+--------------------------------------------------------------------------------
+-- * Monadic versions
+
+-- | Monadic paramorphism.
+paraM :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m a
+paraM h = go where
+  go t = mapM go (unFix t) >>= h t
+
+paraM_ :: (Monad m, Traversable f) => (Mu f -> f a -> m a) -> Mu f -> m ()
+paraM_ h t = do { _ <- paraM h t ; return () }
+
+-- | Monadic catamorphism.
+cataM :: (Monad m, Traversable f) => (f a -> m a) -> Mu f -> m a
+cataM h = go where
+  go (Fix t) = mapM go t >>= h
+
+cataM_ :: (Monad m, Traversable f) => (f a -> m a) -> Mu f -> m ()
+cataM_ h t = do { _ <- cataM h t ; return () }
+
+--------------------------------------------------------------------------------
+#ifdef WITH_QUICKCHECK
+-- * Tests
+
+runtests_Morphisms :: IO ()
+runtests_Morphisms = do
+  quickCheck prop_para
+  quickCheck prop_paraList
+  -- 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
+
+#endif
+--------------------------------------------------------------------------------

@@ -50,7 +50,7 @@ 
 -- | The children together with functions replacing that particular child.    
 holes :: Traversable f => f a -> f (a, a -> f a)
-holes tree = mapAccumL_ ithHole 0 tree where
+holes tree = mapAccumL_ ithHole (0::Int) tree where
   ithHole i x = (i+1, (x,h)) where          
     h y = mapAccumL_ g 0 tree where         
       g j z = (j+1, if i==j then y else z)  
@@ -69,6 +69,7 @@ builder :: Traversable f => f a -> [b] -> f b
 builder tree xs = mapAccumL_ g xs tree where
   g (x:xs) _ = (xs,x)
+  g _ _ = error "Open/builder: shouldn't happen"
 
 --------------------------------------------------------------------------------
 
@@ -153,6 +154,7 @@ unsafeZipWithF f x y = z where
   z = mapAccumL_ g (toList y) x
   g (b:bs) a = (bs, f a b)
+  g _ _ = error "Open/unsafeZipWithF: shouldn't happen"
 
 --------------------------------------------------------------------------------
 
@@ -166,6 +168,7 @@ unsafeZipWithFM :: (Traversable f, Monad m) => (a -> b -> m c) -> f a -> f b -> m (f c)
 unsafeZipWithFM f x y = liftM snd $ mapAccumM g (toList y) x where
   g (b:bs) a = f a b >>= \r -> return (bs, r)
+  g _ _ = error "Open/unsafeZipWithFM: shouldn't happen"
 
 --------------------------------------------------------------------------------
 

@@ -26,5 +26,6 @@   putStrLn "tests for traversals..."      ; runtests_Traversals
   putStrLn "tests for Attributes..."      ; runtests_Attributes
   putStrLn "tests for zippers..."         ; runtests_Zipper
+  putStrLn "tests for morphisms..."       ; runtests_Morphisms
 
 --------------------------------------------------------------------------------

@@ -13,7 +13,7 @@ 
 import Data.Generics.Fixplate.Base 
 import Data.Generics.Fixplate.Open
-import Data.Generics.Fixplate.Misc
+--import Data.Generics.Fixplate.Misc
 
 #ifdef WITH_QUICKCHECK
 import Test.QuickCheck
@@ -123,6 +123,7 @@ 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

@@ -21,11 +21,11 @@ import Data.Generics.Fixplate.Base
 import Data.Generics.Fixplate.Open
 import Data.Generics.Fixplate.Misc
-import Data.Generics.Fixplate.Traversals
 
 #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 
@@ -476,6 +476,7 @@   
 --------------------------------------------------------------------------------
 
+runtests_Zipper :: IO ()
 runtests_Zipper = do
   quickCheck prop_ReadShowLoc
   quickCheck prop_findLoc

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

@@ -1,11 +1,11 @@  Name:                fixplate-Version:             0.1.2-Synopsis:            Uniplate-style generic traversals for fixed-point types, with some extras.+Version:             0.1.3+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 a generic zipper.-                     See the module "Data.Generics.Fixplate" and then the individual modules-                     for more detailed information.+                     optionally annotated with attributes. We also provide recursion schemes,+                     and a generic zipper. See the module "Data.Generics.Fixplate" and then +                     the individual modules for more detailed information. License:             BSD3 License-file:        LICENSE Author:              Balazs Komuves@@ -15,8 +15,12 @@ Stability:           Experimental Category:            Generics Tested-With:         GHC == 7.0.3-Cabal-Version:       >= 1.2+Cabal-Version:       >= 1.6 Build-Type:          Simple++source-repository head+  type:     darcs+  location: http://code.haskell.org/~bkomuves/projects/fixplate/  Flag withQuickCheck   Description: Compile with the QuickCheck tests.