fixplate (empty) → 0.1

raw patch · 14 files changed

+1593/−0 lines, 14 filesdep +QuickCheckdep +basesetup-changed

Dependencies added: QuickCheck, base

Files

Data/Generics/Fixplate.hs +76/−0
Data/Generics/Fixplate/Attributes.hs +159/−0
Data/Generics/Fixplate/Base.hs +177/−0
Data/Generics/Fixplate/Misc.hs +60/−0
Data/Generics/Fixplate/Morphisms.hs +49/−0
Data/Generics/Fixplate/Structure.hs +47/−0
Data/Generics/Fixplate/Test/Instances.hs +129/−0
Data/Generics/Fixplate/Test/Tools.hs +157/−0
Data/Generics/Fixplate/Tests.hs +30/−0
Data/Generics/Fixplate/Traversals.hs +156/−0
Data/Generics/Fixplate/Zipper.hs +460/−0
LICENSE +29/−0
Setup.lhs +3/−0
fixplate.cabal +61/−0

+ Data/Generics/Fixplate.hs view

@@ -0,0 +1,76 @@+
+-- | This library provides Uniplate-style generic traversals for fixed-point types.
+-- The advantages of using fixed-point types instead of explicit recursion are the following:
+--
+--   * we can add attributes to the nodes of an existing tree;
+--
+--   * there is no need for a custom type class, we can build everything on the top of
+--     @Functor@, @Foldable@ and @Traversable@, for which GHC can derive the instances for us;
+--
+--   * some operations can retain the structure of the tree, instead flattening
+--     it into a list;
+--
+--   * it is quite straightforward to provide a generic zipper.
+--
+-- The main disadvantage is that it does not work well for
+-- mutually recursive data types, and that pattern matching becomes
+-- more tedious (but there are solutions for the latter).
+--
+-- Consider as an example the following simple expression language,
+-- encoded by a recursive algebraic data type:
+--
+-- > Expr 
+-- >   = Kst Int 
+-- >   | Var String 
+-- >   | Add Expr Expr
+-- >   deriving (Eq,Show)
+--
+-- We can open up the recursion, and obtain a /functor/ instead:
+--
+-- > Expr1 e 
+-- >   = Kst Int 
+-- >   | Var String 
+-- >   | Add e e 
+-- >   deriving (Eq,Show,Functor,Foldable,Traversable)
+--
+-- The fixed-point type 'Mu'@ Expr1@ is isomorphic to @Expr@.
+-- However, we can also add some attributes to the nodes:
+-- The type 'Attr' @Expr1 a = @'Mu'@ (@'Ann'@ Expr1 a)@ is the type of
+-- with the same structure, but with each node having an extra
+-- field of type @a@.
+--
+-- The functions in this library work on types like that: 'Mu'@ f@,
+-- where @f@ is a functor, and sometimes explicitely on 'Attr'@ f a@.
+-- 
+-- This module re-exports all the functionality present in the library.
+--
+-- The library is fully Haskell98 compatible, with the exception
+-- of the module "Data.Generics.Fixplate.Structure", which needs
+-- the @Rank2Types@ extension. For compatibility, this functionality
+-- of this module is at the moment only provided when compiled with GHC.
+--
+module Data.Generics.Fixplate 
+  ( module Data.Generics.Fixplate.Base
+  , module Data.Generics.Fixplate.Traversals
+  , module Data.Generics.Fixplate.Morphisms
+  , module Data.Generics.Fixplate.Attributes
+  , module Data.Generics.Fixplate.Zipper
+  , module Data.Generics.Fixplate.Structure
+  , Functor(..) , Foldable(..) , Traversable(..)
+  )
+  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.Structure  
+
+import Data.Foldable
+import Data.Traversable
+
+--------------------------------------------------------------------------------
+

+ Data/Generics/Fixplate/Attributes.hs view

@@ -0,0 +1,159 @@+
+-- | Synthetising attributes, motivated by Attribute Grammars.
+
+{-# LANGUAGE CPP #-}
+module Data.Generics.Fixplate.Attributes
+  ( toList
+  , Attrib(..)
+  -- * Synthetised attributes
+  , synthetise , synthetise' , synthetiseList , synthetiseM
+  -- * Inherited attributes
+  , inherit , inherit'
+  -- * Traversals
+  , synthAccumL  , synthAccumR
+  , synthAccumL_ , synthAccumR_
+  , numberNodes  , numberNodes_
+#ifdef WITH_QUICKCHECK
+  -- * Tests
+  , runtests_Attributes  
+  , prop_synthAccumL
+  , prop_synthAccumR
+  , prop_synthetise
+#endif  
+  )
+  where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad (liftM)
+import Data.Foldable
+import Data.Traversable
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap,sum)
+
+import Data.Generics.Fixplate.Base
+
+#ifdef WITH_QUICKCHECK
+import Test.QuickCheck
+import Data.Generics.Fixplate.Traversals
+import Data.Generics.Fixplate.Test.Tools
+#endif 
+
+--------------------------------------------------------------------------------
+-- Synthetised attributes
+
+-- | /Synthetised/ attributes are created in a bottom-up manner. 
+-- As an example, the @sizes@ function computes the sizes of all
+-- subtrees:
+--
+-- > sizes :: (Functor f, Foldable f) => Mu f -> Attr f Int
+-- > sizes = synthetise (\t -> 1 + sum t)
+--
+-- (note that @sum@ here is @Data.Foldable.sum == Prelude.sum . Data.Foldable.toList@)
+--
+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
+ 
+-- | Generalization of @scanr@ for trees.
+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
+
+synthetiseList :: (Functor f, Foldable f) => ([a] -> a) -> Mu f -> Attr f a
+synthetiseList h = synthetise (h . toList)
+
+synthetiseM  ::  (Traversable f, Monad m) =>  (f a -> m a) -> Mu f -> m (Attr f a)
+synthetiseM act = go where
+  go (Fix x) = do
+    y  <-  mapM go x    
+    a  <-  act $ fmap attribute y
+    return (Fix (Ann a y))
+
+--------------------------------------------------------------------------------
+-- Inherited attributes
+
+-- | /Inherited/ attributes are created in a top-down manner. 
+-- As an example, the @depths@ function computes the depth 
+-- (the distance from the root, incremented by 1) of all subtrees:
+--
+-- > depths :: Functor f => Mu f -> Attr f Int
+-- > depths = inherit (\_ i -> i+1) 0
+--
+inherit :: Functor f => (Mu f -> a -> a) -> a -> Mu f -> Attr f a
+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
+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))
+
+--------------------------------------------------------------------------------
+-- Traversals
+
+-- | Synthetising attributes via an accumulating map in a left-to-right fashion
+-- (the order is the same as in @foldl@).
+synthAccumL :: Traversable f => (a -> Mu f -> (a,b)) -> a -> Mu f -> (a, Attr f b)
+synthAccumL h x0 tree = go x0 tree where
+  go x t@(Fix sub) = 
+    let (y,a   ) = h x t 
+        (z,sub') = mapAccumL go y sub
+    in (z, Fix (Ann a sub'))
+
+-- | Synthetising attributes via an accumulating map in a right-to-left fashion
+-- (the order is the same as in @foldr@).
+synthAccumR :: Traversable f => (a -> Mu f -> (a,b)) -> a -> Mu f -> (a, Attr f b)
+synthAccumR h x0 tree = go x0 tree where
+  go x t@(Fix sub) = 
+    let (y,sub') = mapAccumR go x sub
+        (z,a   ) = h y t 
+    in (z, Fix (Ann a sub'))
+    
+synthAccumL_ :: Traversable f => (a -> Mu f -> (a,b)) -> a -> Mu f -> Attr f b
+synthAccumL_ h x t = snd (synthAccumL h x t)
+
+synthAccumR_ :: Traversable f => (a -> Mu f -> (a,b)) -> a -> Mu f -> Attr f b
+synthAccumR_ h x t = snd (synthAccumR h x t)
+
+-- | We use 'synthAccumL' to number the nodes from @0@ to @(n-1)@ in 
+-- a left-to-right traversal fashion, where
+-- @n == length (universe tree)@ is the number of substructures,
+-- which is also returned.
+numberNodes :: Traversable f => Mu f -> (Int, Attr f Int)
+numberNodes tree = synthAccumL (\i _ -> (i+1,i)) 0 tree
+
+numberNodes_ :: Traversable f => Mu f -> Attr f Int
+numberNodes_ = snd . numberNodes
+
+--------------------------------------------------------------------------------
+-- Tests
+#ifdef WITH_QUICKCHECK
+
+runtests_Attributes = do
+  quickCheck prop_synthAccumL
+  quickCheck prop_synthAccumR
+  quickCheck prop_synthetise
+ 
+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) []
+  
+#endif
+--------------------------------------------------------------------------------
+

+ Data/Generics/Fixplate/Base.hs view

@@ -0,0 +1,177 @@+
+{-# LANGUAGE CPP #-}
+
+-- | The core types of Fixplate.
+module Data.Generics.Fixplate.Base where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative
+import Control.Monad (liftM)
+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.Misc
+
+--------------------------------------------------------------------------------
+
+-- | The attribute of the root node.
+attribute :: Attr f a -> a
+attribute = attr . unFix
+  
+-- | A function forgetting all the attributes from an annotated tree.
+forget :: Functor f => Attr f a -> Mu f
+forget = Fix . fmap forget . unAnn . unFix
+
+--------------------------------------------------------------------------------
+
+-- | 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 fixed-point type.
+type Attr f a   =  Mu (Ann f a)
+
+--------------------------------------------------------------------------------
+
+-- | \"Functorised\" versions of standard type classes. 
+-- If you have your own structure functor, for example
+--
+-- > Expr e 
+-- >   = Kst Int 
+-- >   | Var String 
+-- >   | Add e e 
+-- >   deriving (Eq,Ord,Read,Show,Functor,Foldable,Traversable)
+--
+-- you should make it an instance of these, so that the 
+-- fixed-point type @Mu Expr@ can be an instance of
+-- @Eq@, @Ord@ and @Show@. Doing so is very easy:
+--
+-- > instance EqF   Expr where equalF     = (==)
+-- > instance OrdF  Expr where compareF   = compare
+-- > instance ShowF Expr where showsPrecF = showsPrec
+--
+-- The @Read@ instance depends on whether we are using GHC or not.
+-- The Haskell98 version is
+--
+-- > instance ReadF Expr where readsPrecF = readsPrec
+--
+-- while the GHC version is
+--
+-- > instance ReadF Expr where readPrecF  = readPrec
+--
+class          EqF   f  where equalF     ::  Eq   a  =>  f a -> f a -> Bool
+class EqF f => OrdF  f  where compareF   ::  Ord  a  =>  f a -> f a -> Ordering
+class          ShowF f  where showsPrecF ::  Show a  =>  Int -> f a -> ShowS
+class          ReadF f  where 
+#ifdef __GLASGOW_HASKELL__
+                              readPrecF  ::  Read a  =>  ReadPrec (f a)
+#else
+                              readsPrecF ::  Read a  =>  Int -> ReadS (f a)                              
+#endif                        
+      
+--------------------------------------------------------------------------------
+
+instance EqF f => Eq (Mu f) where Fix x == Fix y = equalF x y
+instance OrdF   f  => Ord   (Mu f) where compare (Fix x) (Fix y)  = compareF x y
+instance ShowF  f  => Show  (Mu f) where 
+  showsPrec d (Fix x) = showParen (d>app_prec) 
+    $ showString "Fix " 
+    . showsPrecF (app_prec+1) x
+
+instance ReadF  f  => Read  (Mu f) where     
+#ifdef __GLASGOW_HASKELL__
+  readPrec = parens $ 
+    (prec app_prec $ do
+      { Ident "Fix" <- lexP
+      ; m <- step readPrecF
+      ; return (Fix m)            
+      })
+#else                                  
+  readsPrec d r = readParen (d > app_prec)
+     (\r -> [ (Fix m, t) 
+            | ("Fix", s) <- lex r
+            , (m,t) <- readsPrecF (app_prec+1) s]) r    
+#endif
+            
+--------------------------------------------------------------------------------
+        
+instance (Eq a, EqF f) => EqF (Ann f a) where 
+  equalF (Ann a x) (Ann b y) = a == b && equalF x y
+
+instance (Ord a, OrdF f) => OrdF (Ann f a) where 
+  compareF (Ann a x) (Ann b y) = case compare a b of
+    LT -> LT
+    GT -> GT
+    EQ -> compareF x y
+  
+instance (Show a, ShowF f) => ShowF (Ann f a) where 
+  showsPrecF d (Ann a t) 
+    = showParen (d>app_prec) 
+      $ showString "Ann " 
+      . (showsPrec (app_prec+1) a) 
+      . showChar ' ' 
+      . (showsPrecF (app_prec+1) t)    
+
+instance (Read a, ReadF f) => ReadF (Ann f a) where 
+#ifdef __GLASGOW_HASKELL__
+  readPrecF = parens $ 
+    (prec app_prec $ do
+      { Ident "Ann" <- lexP
+      ; x <- step readPrec
+      ; m <- step readPrecF
+      ; return (Ann x m)            
+      })
+#else                                  
+  readsPrecF d r = readParen (d > app_prec)
+     (\r -> [ (Ann x m, u) 
+            | ("Ann", s) <- lex r
+            , (x,t) <- readsPrec  (app_prec+1) s]) r    
+            , (m,u) <- readsPrecF (app_prec+1) t]) r    
+#endif
+      
+--------------------------------------------------------------------------------
+
+instance Functor f => Functor (Ann f a) where
+  fmap f (Ann attr t) = Ann attr (fmap f t)
+
+instance Foldable f => Foldable (Ann f a) where
+  foldl f x (Ann _ t) = foldl f x t
+  foldr f x (Ann _ t) = foldr f x t
+
+instance Traversable f => Traversable (Ann f a) where
+  traverse f (Ann x t) = Ann x <$> traverse f t
+  mapM f (Ann x t) = liftM (Ann x) (mapM f t)
+ 
+--------------------------------------------------------------------------------
+
+-- | A newtype wrapper around @Attr f a@ so that we can make @Attr f@ 
+-- an instance of Functor, Foldable and Traversable. This is necessary
+-- since Haskell does not allow partial application of type synonyms.
+newtype Attrib f a = Attrib { unAttrib :: Attr f a }
+
+instance (ShowF f, Show a) => Show (Attrib f a) where
+  showsPrec d (Attrib x) 
+    = showParen (d>app_prec) 
+      $ showString "Attrib " 
+      . (showsPrec (app_prec+1) x) 
+
+instance Functor f => Functor (Attrib f) where
+  fmap h (Attrib y) = Attrib (go y) where
+    go (Fix (Ann x t)) = Fix $ Ann (h x) (fmap go t)
+
+instance Foldable f => Foldable (Attrib f) where
+  foldl h a (Attrib y) = go a y where go b (Fix (Ann x t)) = foldl go (h b x) t
+  foldr h a (Attrib y) = go y a where go (Fix (Ann x t)) b = h x (foldr go b t)
+
+instance Traversable f => Traversable (Attrib f) where
+  traverse h (Attrib y) = Attrib <$> go y where
+    go (Fix (Ann x t)) = Fix <$> (Ann <$> h x <*> traverse go t)
+
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Misc.hs view

@@ -0,0 +1,60 @@+
+-- | Miscellaneous utility functions
+module Data.Generics.Fixplate.Misc where
+
+--------------------------------------------------------------------------------
+
+import Data.Traversable
+
+--------------------------------------------------------------------------------
+
+mapAccumL_ :: Traversable f => (a -> b -> (a, c)) -> a -> f b -> f c
+mapAccumL_ f x t = snd (mapAccumL f x t)
+
+--------------------------------------------------------------------------------
+        
+data Two a b 
+  =  Empty 
+  |  One a
+  |  Two b
+
+--------------------------------------------------------------------------------
+
+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)
+
+--------------------------------------------------------------------------------
+
+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)
+
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Morphisms.hs view

@@ -0,0 +1,49 @@+
+-- | Scary named folds...
+
+{-# LANGUAGE CPP #-}
+module Data.Generics.Fixplate.Morphisms where
+
+--------------------------------------------------------------------------------
+
+import Data.Foldable
+import Data.Generics.Fixplate.Base
+
+#ifdef WITH_QUICKCHECK
+import Test.QuickCheck
+import Data.Generics.Fixplate.Traversals
+import Data.Generics.Fixplate.Test.Tools
+#endif 
+
+--------------------------------------------------------------------------------
+
+-- | 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) 
+
+para' :: Functor f => (f (Mu f, a) -> a) -> Mu f -> a
+para' h = go where
+  go (Fix t) = h (fmap go' $ t)
+  go' t = (t, go t) 
+
+paraList :: (Functor f, Foldable f) => (Mu f -> [a] -> a) -> Mu f -> a 
+paraList f = go where
+  go t = f t (toList $ fmap go $ unFix t)
+
+-- | A /catamorphism/ is a simpler version of a paramorphism
+cata :: Functor f => (f a -> a) -> Mu f -> a
+cata h = go where
+  go = h . fmap go . unFix
+
+-- | An /anamorphism/ is simply an unfold.
+ana :: Functor f => (a -> f a) -> a -> Mu f
+ana h = go where
+  go x = Fix (fmap go (h x))
+
+-- | 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
+
+--------------------------------------------------------------------------------
+

+ Data/Generics/Fixplate/Structure.hs view

@@ -0,0 +1,47 @@+
+{-# LANGUAGE CPP #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE Rank2Types #-}
+#endif
+
+-- | Changing the structure of a tree.
+module Data.Generics.Fixplate.Structure 
+  ( NatTrafo
+  , restructure
+  , liftAnn
+  )
+  where
+--------------------------------------------------------------------------------
+
+import Data.Generics.Fixplate.Base
+
+--------------------------------------------------------------------------------
+
+#ifdef __GLASGOW_HASKELL__
+
+-- | The type of natural transformations.
+type NatTrafo f g = forall a. (f a -> g a)
+
+-- | Changing the structure of a tree.
+restructure :: Functor f => NatTrafo f g -> Mu f -> Mu g
+restructure trafo = go where
+  go = Fix . trafo . fmap go . unFix
+
+#else  
+
+data NatTrafo f g = NatTrafo (f Int) (g Int)   -- fake and opaque data type
+
+-- | Unfortunately, this function requires Rank2Types,
+-- thus we only provide it for GHC.
+restructure :: Functor f => NatTrafo f g -> Mu f -> Mu g
+restructure = error "restructure: this operation requires Rank2Types"
+
+#endif
+  
+--------------------------------------------------------------------------------
+
+-- | Lifting natural transformations to annotations.
+liftAnn :: (f e -> g e) -> Ann f a e -> Ann g a e
+liftAnn trafo (Ann a x) = Ann a (trafo x)
+
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Test/Instances.hs view

@@ -0,0 +1,129 @@+
+
+{-# 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
+  
+--------------------------------------------------------------------------------
+

+ Data/Generics/Fixplate/Test/Tools.hs view

@@ -0,0 +1,157 @@+
+{-# 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
+
+--------------------------------------------------------------------------------
+-- * 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)
+              
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Tests.hs view

@@ -0,0 +1,30 @@+
+-- | Run all the tests
+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.Structure  
+
+import Data.Generics.Fixplate.Test.Tools
+import Data.Generics.Fixplate.Test.Instances
+
+import Test.QuickCheck
+
+--------------------------------------------------------------------------------
+
+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
+
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Traversals.hs view

@@ -0,0 +1,156 @@+
+-- | Uniplate-style traversals.
+
+{-# LANGUAGE CPP #-}
+module Data.Generics.Fixplate.Traversals where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad (liftM)
+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
+
+#ifdef WITH_QUICKCHECK
+import Test.QuickCheck
+import Data.Generics.Fixplate.Test.Tools
+#endif
+
+--------------------------------------------------------------------------------
+-- * Queries
+
+-- | The list of direct descendants.
+children :: Foldable f => Mu f -> [Mu f]
+children = foldr (:) [] . unFix
+
+-- | The list of all substructures. Together with list-comprehension syntax
+-- this is a powerful query tool.
+universe :: Foldable f => Mu f -> [Mu f]
+universe x = x : concatMap universe (children x)
+
+--------------------------------------------------------------------------------
+-- * Traversals
+
+-- | Bottom-up transformation.
+transform :: Functor f => (Mu f -> Mu f) -> Mu f -> Mu f 
+transform h = go where 
+  go = h . Fix . fmap go . unFix
+
+transformM  ::  (Traversable f, Monad m) 
+            =>  (Mu f -> m (Mu f)) -> Mu f -> m (Mu f)
+transformM action = go where
+  go (Fix x) = do 
+    y <- mapM go x
+    action (Fix y)
+
+-- | Top-down transformation. This provided only for completeness;
+-- usually, it is 'transform' what you want use instead.
+topDownTransform :: Functor f => (Mu f -> Mu f) -> Mu f -> Mu f 
+topDownTransform h = go where 
+  go = Fix . fmap go . unFix . h
+
+topDownTransformM :: (Traversable f, Monad m) => (Mu f -> m (Mu f)) -> Mu f -> m (Mu f)
+topDownTransformM h = go where 
+  go x = do
+    Fix y <- h x
+    liftM Fix (mapM go y)
+  
+-- | Non-recursive top-down transformation.
+descend :: Functor f => (Mu f -> Mu f) -> Mu f -> Mu f 
+descend h = Fix . fmap h . unFix
+
+descendM :: (Traversable f, Monad m) => (Mu f -> m (Mu f)) -> Mu f -> m (Mu f)
+descendM action = liftM Fix . mapM action . unFix
+
+-- | Bottom-up transformation until a normal form is reached.
+rewrite :: Functor f => (Mu f -> Maybe (Mu f)) -> Mu f -> Mu f 
+rewrite h = transform g  where 
+  g x = maybe x (rewrite h) (h x)
+
+rewriteM :: (Traversable f, Monad m) => (Mu f -> m (Maybe (Mu f))) -> Mu f -> m (Mu f)
+rewriteM h = transformM g where 
+  g x = h x >>= \y -> maybe (return x) (rewriteM h) y
+  
+--------------------------------------------------------------------------------
+-- * Context
+
+-- | We /annotate/ the nodes of the tree with functions which replace that
+-- particular subtree.
+context :: Traversable f => Mu f -> Attr f (Mu f -> Mu f)
+context = go id where
+  go h = Fix . Ann h . fmap g . holes . unFix where
+    g (y,replace) = go (h . Fix . replace) y where 
+
+-- | Flattened version of 'context'.
+contextList :: Traversable f => Mu f -> [(Mu f, Mu f -> Mu f)]
+contextList = map h . universe . context where
+  h this@(Fix (Ann g x)) = (forget this, g)
+
+--------------------------------------------------------------------------------
+-- * Folds
+
+-- | Left fold. Since @Mu f@ is not a functor, but a type, we cannot make
+-- it an instance of the @Foldable@ type class.
+foldLeft :: Foldable f => (a -> Mu f -> a) -> a -> Mu f -> a
+foldLeft h x0 t = go x0 t where
+  go x t = foldl go (h x t) $ unFix t
+
+foldRight :: Foldable f => (Mu f -> a -> a) -> a -> Mu f -> a
+foldRight h x0 t = go t x0 where
+  go t x = h t $ foldr go x $ unFix t 
+
+--------------------------------------------------------------------------------
+-- * Open functions
+
+-- | The children together with functions replacing that particular child.    
+holes :: Traversable f => f a -> f (a, a -> f a)
+holes tree = mapAccumL_ ithHole 1 tree where
+  ithHole i x = (i+1, (x,h)) where          
+    h y = mapAccumL_ g 1 tree where         
+      g j z = (j+1, if i==j then y else z)  
+
+holesList :: Traversable f => f a -> [(a, a -> f a)]
+holesList = toList . holes
+
+-- | Apply the given function to each child in turn.
+apply :: Traversable f => (a -> a) -> f a -> f (f a)
+apply f tree = fmap g (holes tree) where
+  g (x,replace) = replace (f x)
+
+-- | Builds up a structure from a list of the children.
+builder :: Traversable f => f a -> [b] -> f b
+builder tree xs = mapAccumL_ g xs tree where
+  g (x:xs) _ = (xs,x)
+
+--------------------------------------------------------------------------------
+#ifdef WITH_QUICKCHECK
+-- * Tests
+
+universeNaive :: Foldable f => Mu f -> [Mu f]
+universeNaive x = x : concatMap universeNaive (children x)
+
+runtests_Traversals = do
+  quickCheck prop_leftFold
+  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_rightFold :: FixT Label -> Bool
+prop_rightFold tree = 
+  foldRight (\(Fix (TreeF l s)) xs -> (l:xs)) [] tree == foldr (:) [] (fromFixT tree)
+
+#endif
+--------------------------------------------------------------------------------

+ Data/Generics/Fixplate/Zipper.hs view

@@ -0,0 +1,460 @@+
+{-# LANGUAGE CPP #-}
+#ifdef WITH_QUICKCHECK
+{-# LANGUAGE TypeSynonymInstances #-}
+#endif
+
+-- | The Zipper.
+module Data.Generics.Fixplate.Zipper where
+
+--------------------------------------------------------------------------------
+
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
+import Data.Foldable
+import Data.Traversable
+import Data.Maybe
+
+import Text.Show
+import Text.Read 
+
+import Data.Generics.Fixplate.Base
+import Data.Generics.Fixplate.Misc
+
+#ifdef WITH_QUICKCHECK
+import Test.QuickCheck
+import Data.Generics.Fixplate.Traversals
+import Data.Generics.Fixplate.Attributes
+import Data.Generics.Fixplate.Test.Tools
+import Control.Monad (liftM)
+#endif 
+
+--------------------------------------------------------------------------------
+-- * Types
+
+type Node f  =  Either (Mu f) (Path f)
+
+data Path f  =  Top
+             |  Path { unPath :: f (Node f) } 
+               
+data Loc f   =  Loc { focus :: Mu f , path :: Path f } 
+
+--------------------------------------------------------------------------------
+
+instance EqF f => Eq (Path f) where               
+  Top     == Top      = True
+  Path p1 == Path p2  = equalF p1 p2
+  _       == _        = False
+  
+instance EqF f => Eq (Loc f) where               
+  Loc f1 p1 == Loc f2 p2  = f1 == f2 && p1 == p2
+  
+instance ShowF f => Show (Path f) where               
+  showsPrec d Top = showString "Top"
+  showsPrec d (Path xs) = showParen (d>10) 
+    $ showString "Path "
+    . showsPrecF 11 xs
+
+instance ShowF f => Show (Loc f) where
+  showsPrec d (Loc foc path) = showParen (d>10) 
+    $ showString "Loc "
+    . showsPrec 11 foc
+    . showChar ' '
+    . showsPrec 11 path
+
+instance ReadF f => Read (Path f) where 
+#ifdef __GLASGOW_HASKELL__
+  readPrec = parens $ 
+    (do
+      { Ident "Top" <- lexP
+      ; return Top            
+      })
+    +++
+    (prec app_prec $ do
+      { Ident "Path" <- lexP
+      ; p <- step readPrecF
+      ; return (Path p)            
+      })    
+#else                                  
+  readsPrec d r = readParen (d > app_prec)
+     (\r -> [ (Top, s) 
+            | ("Top", s) <- lex r]) r    
+     ++
+     (\r -> [ (Path p, t) 
+            | ("Path", s) <- lex r
+            , (f,t) <- readsPrecF (app_prec+1) s]) r    
+            
+#endif
+    
+instance ReadF f => Read (Loc f) where 
+#ifdef __GLASGOW_HASKELL__
+  readPrec = parens $ 
+    (prec app_prec $ do
+      { Ident "Loc" <- lexP
+      ; f <- step readPrec
+      ; p <- step readPrec
+      ; return (Loc f p)            
+      })
+#else                                  
+  readsPrec d r = readParen (d > app_prec)
+     (\r -> [ (Loc f p, u) 
+            | ("Loc", s) <- lex r
+            , (f,t) <- readsPrec (app_prec+1) s
+            , (p,u) <- readsPrec (app_prec+1) t]) r    
+#endif
+
+--------------------------------------------------------------------------------
+-- * Converting to and from zippers
+
+-- | Creates a zipper from a tree, with the focus at the root.
+root :: Mu f -> Loc f
+root t = Loc t Top
+
+-- | Restores a tree from a zipper.
+defocus :: Traversable f => Loc f -> Mu f
+defocus (Loc foc path) = go foc path where
+  go t Top = t
+  go t (Path xs)  = go (Fix s) path' where
+    (Just path', s) = mapAccumL h Nothing xs
+    h  old  (Left   y)  =  (old     , y)
+    h  _    (Right  p)  =  (Just p  , t)
+
+-- | The zipper version of 'forget'.
+locForget :: Functor f => Loc (Ann f a) -> Loc f    
+locForget (Loc foc path) = Loc (forget foc) (go path) where
+  go :: Functor f => Path (Ann f a) -> Path f    
+  go Top = Top
+  go (Path (Ann _ nodes)) = Path (fmap h nodes)
+  
+  h :: Functor f => Node (Ann f a) -> Node f    
+  h (Left  t) = Left  (forget t)
+  h (Right p) = Right (go p)
+    
+--------------------------------------------------------------------------------
+-- * Manipulating the subtree at focus
+
+extract :: Loc f -> Mu f
+extract = focus
+
+replace :: Mu f -> Loc f -> Loc f
+replace new loc = loc { focus = new }
+
+modify :: (Mu f -> Mu f) -> Loc f -> Loc f
+modify h loc = replace (h (focus loc)) loc
+
+--------------------------------------------------------------------------------
+-- * Safe movements
+
+-- | Moves down the child with the given index.
+-- The leftmost children has index @0@.
+moveDown :: Traversable f => Int -> Loc f -> Maybe (Loc f)
+moveDown pos (Loc foc path) = new where
+  new = case mfoc' of  
+     Nothing    ->  Nothing
+     Just foc'  ->  Just $ Loc foc' (Path nodes')
+  ((mfoc',_),nodes')  =  mapAccumL g (Nothing,0) (unFix foc)    
+  g (old,j) x  =  if j==pos 
+    then  ((Just x  , j+1),  Right  path  ) 
+    else  ((old     , j+1),  Left   x     )      
+
+-- | Moves down the leftmost child.
+moveDownL :: Traversable f => Loc f -> Maybe (Loc f)
+moveDownL (Loc foc path) = new where
+  new = case mfoc' of  
+     Nothing    ->  Nothing
+     Just foc'  ->  Just $ Loc foc' (Path nodes')
+  (mfoc',nodes')  =  mapAccumL g Nothing (unFix foc)    
+  g old x  = case old of
+    Nothing  -> (Just x  ,  Right  path  ) 
+    _        -> (old     ,  Left   x     )      
+
+-- | Moves down the rightmost child.
+moveDownR :: Traversable f => Loc f -> Maybe (Loc f)
+moveDownR (Loc foc path) = new where
+  new = case mfoc' of  
+     Nothing    ->  Nothing
+     Just foc'  ->  Just $ Loc foc' (Path nodes')
+  (mfoc',nodes')  =  mapAccumR g Nothing (unFix foc)    
+  g old x  = case old of
+    Nothing  -> (Just x  ,  Right  path  ) 
+    _        -> (old     ,  Left   x     )      
+    
+--------------------------------------------------------------------------------
+
+moveUp :: Traversable f => Loc f -> Maybe (Loc f)
+moveUp (Loc foc path) = case path of
+  Top         -> Nothing
+  Path nodes  -> 
+    case mpath of
+      Nothing      -> error "moveUp: shouldn't happen"
+      Just path'   -> Just $ case path' of
+        Path nodes'    -> Loc (Fix foc') (Path nodes')
+        Top            -> Loc (Fix foc') Top
+    where      
+      (mpath,foc') = mapAccumL g Nothing nodes 
+      g old ei = case ei of
+        Right  p  -> (Just p  , foc)
+        Left   x  -> (old     , x  )
+
+--------------------------------------------------------------------------------
+
+moveRight :: Traversable f => Loc f -> Maybe (Loc f)
+moveRight (Loc foc path) = case path of
+  Top         -> Nothing
+  Path nodes  -> 
+    case two of
+      Two foc' -> Just $ Loc foc' (Path nodes')
+      _        -> Nothing
+    where      
+      (two,nodes') = mapAccumL g Empty nodes 
+      g old ei = case ei of
+        Right  p  ->  (One p  , Left foc  )
+        Left   x  -> case old of
+          One p ->    (Two x  , Right p   )
+          _     ->    (old    , ei        )
+
+moveLeft :: Traversable f => Loc f -> Maybe (Loc f)
+moveLeft (Loc foc path) = case path of
+  Top         -> Nothing
+  Path nodes  -> 
+    case two of
+      Two foc' -> Just $ Loc foc' (Path nodes')
+      _        -> Nothing
+    where      
+      (two,nodes') = mapAccumR g Empty nodes 
+      g old ei = case ei of
+        Right  p  ->  (One p  , Left foc  )
+        Left   x  -> case old of
+          One p ->    (Two x  , Right p   )
+          _     ->    (old    , ei        )
+
+--------------------------------------------------------------------------------
+-- * Testing for borders
+
+-- | Checks whether we are the top.
+isTop :: Loc f -> Bool
+isTop (Loc _ p) = case p of { Top -> True ; _ -> False }
+
+-- | Checks whether we cannot move down.
+isBottom :: Traversable f => Loc f -> Bool
+isBottom = isNothing . moveDownL
+
+isLeftmost :: Traversable f => Loc f -> Bool
+isLeftmost = isNothing . moveLeft
+
+isRightmost :: Traversable f => Loc f -> Bool
+isRightmost = isNothing . moveRight
+
+--------------------------------------------------------------------------------
+-- * Compound movements
+  
+-- | Moves to the top, by repeatedly moving up.
+moveTop :: Traversable f => Loc f -> Loc f
+moveTop = tillNothing moveUp
+
+-- | Moves left until it can.
+leftmost :: Traversable f => Loc f -> Loc f
+leftmost = tillNothing moveLeft
+
+-- | Moves right until it can.
+rightmost :: Traversable f => Loc f -> Loc f
+rightmost = tillNothing moveRight
+
+--------------------------------------------------------------------------------
+-- * Unsafe movements
+
+unsafeMoveDown :: Traversable f => Int -> Loc f -> Loc f
+unsafeMoveDown i = unsafe (moveDown i) "unsafeMoveDown: cannot move down"
+  
+unsafeMoveDownL :: Traversable f => Loc f -> Loc f
+unsafeMoveDownR :: Traversable f => Loc f -> Loc f
+unsafeMoveUp    :: Traversable f => Loc f -> Loc f
+
+unsafeMoveDownL = unsafe moveDownL "unsafeMoveDownL: cannot move down"
+unsafeMoveDownR = unsafe moveDownR "unsafeMoveDownR: cannot move down"  
+unsafeMoveUp    = unsafe moveUp    "unsafeMoveUp: cannot move up"  
+
+unsafeMoveLeft, unsafeMoveRight :: Traversable f => Loc f -> Loc f
+unsafeMoveLeft  = unsafe moveLeft  "unsafeMoveLeft: cannot move left"  
+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) = numberNodes 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 = do
+  quickCheck prop_ReadShowLoc
+  quickCheck prop_findLoc
+  quickCheck prop_contextList
+  quickCheck prop_Top
+  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
+
+----------------------------------------
+
+prop_ReadShowLoc :: LocT Label -> Bool
+prop_ReadShowLoc loc = read (show loc) == loc
+
+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) = numberNodes 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) = numberNodes tree
+    h (Label xs) = Label ('_':xs)
+  
+prop_Top :: LocT Label -> Bool
+prop_Top loc = root (defocus loc) == moveTop 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 
+

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright (c) 2011, Balazs Komuves+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither names of the copyright holders nor the names of the contributors+may be used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ Setup.lhs view

@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ fixplate.cabal view

@@ -0,0 +1,61 @@+
+Name:                fixplate
+Version:             0.1
+Synopsis:            Uniplate-style generic traversals for fixed-point types, with some extras.
+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.
+License:             BSD3
+License-file:        LICENSE
+Author:              Balazs Komuves
+Copyright:           (c) 2011 Balazs Komuves
+Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com
+Homepage:            http://code.haskell.org/~bkomuves/
+Stability:           Experimental
+Category:            Generics
+Tested-With:         GHC == 7.0.3
+Cabal-Version:       >= 1.2
+Build-Type:          Simple
+
+Flag withQuickCheck
+  Description: Compile with the QuickCheck tests. 
+  default: False
+
+Flag base4
+  Description: Base v4
+  
+Library
+  if flag(base4)
+    Build-Depends:       base >= 4 && < 5
+    cpp-options:         -DBASE_VERSION=4
+  else 
+    Build-Depends:       base >= 3 && < 4
+    cpp-options:         -DBASE_VERSION=3
+
+  if flag(withQuickCheck)
+    Build-Depends:       QuickCheck > 2.4
+    cpp-options:         -DWITH_QUICKCHECK
+
+  Exposed-Modules:     Data.Generics.Fixplate
+                       Data.Generics.Fixplate.Base
+                       Data.Generics.Fixplate.Traversals
+                       Data.Generics.Fixplate.Morphisms
+                       Data.Generics.Fixplate.Attributes
+                       Data.Generics.Fixplate.Zipper
+                       Data.Generics.Fixplate.Structure
+ 
+  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
+ 
+  Extensions:          CPP
+
+  Hs-Source-Dirs:      .
+
+  ghc-options:         -Wall -fno-warn-unused-matches
+
+