fixplate 0.1.1 → 0.1.2

raw patch · 8 files changed

+327/−12 lines, 8 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Generics/Fixplate.hs +4/−4
• Data/Generics/Fixplate/Attributes.hs +85/−1
• Data/Generics/Fixplate/Misc.hs +36/−0
• Data/Generics/Fixplate/Open.hs +96/−3
• Data/Generics/Fixplate/Test/Tools.hs +25/−0
• Data/Generics/Fixplate/Traversals.hs +1/−1
• Data/Generics/Fixplate/Zipper.hs +77/−0
• fixplate.cabal +3/−3

@@ -14,7 +14,7 @@ --
 -- 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).
+-- more tedious (but there are partial solutions for the latter).
 --
 -- Consider as an example the following simple expression language,
 -- encoded by a recursive algebraic data type:
@@ -42,7 +42,7 @@ -- The functions in this library work on types like that: 'Mu'@ f@,
 -- where @f@ is a functor, and sometimes explicitely on 'Attr'@ f a@.
 -- 
--- This module re-exports all the functionality present in the library.
+-- This module re-exports most of the functionality present in the library.
 --
 -- The library should be fully Haskell98 compatible, with the exception
 -- of the module "Data.Generics.Fixplate.Structure", which needs
@@ -54,7 +54,7 @@   , module Data.Generics.Fixplate.Traversals
   , module Data.Generics.Fixplate.Morphisms
   , module Data.Generics.Fixplate.Attributes
-  , module Data.Generics.Fixplate.Zipper
+--  , module Data.Generics.Fixplate.Zipper
   , module Data.Generics.Fixplate.Structure
   , Functor(..) , Foldable(..) , Traversable(..)
   )
@@ -66,7 +66,7 @@ import Data.Generics.Fixplate.Traversals
 import Data.Generics.Fixplate.Morphisms
 import Data.Generics.Fixplate.Attributes
-import Data.Generics.Fixplate.Zipper
+-- import Data.Generics.Fixplate.Zipper
 import Data.Generics.Fixplate.Structure  
 
 import Data.Foldable

@@ -9,10 +9,16 @@   , synthetise , synthetise' , synthetiseList , synthetiseM
   -- * Inherited attributes
   , inherit , inherit'
+  , inheritM , inheritM_
+  -- * Top-down folds
+  , topDownSweepM , topDownSweepM'
   -- * Traversals
   , synthAccumL    , synthAccumR
   , synthAccumL_   , synthAccumR_
   , enumerateNodes , enumerateNodes_
+  -- * Resynthetising transformations
+  , synthTransform
+  , synthRewrite
   -- * Stacking attributes
   , annZip  , annZipWith
   , annZip3 , annZipWith3  
@@ -31,9 +37,10 @@ import Control.Monad (liftM)
 import Data.Foldable
 import Data.Traversable
-import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap,sum)
+import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap,sum,and,or)
 
 import Data.Generics.Fixplate.Base
+import Data.Generics.Fixplate.Open
 
 #ifdef WITH_QUICKCHECK
 import Test.QuickCheck
@@ -77,6 +84,7 @@ 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
   go (Fix x) = do
@@ -103,7 +111,43 @@ 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))
 
+-- | Monadic version of 'inherit'.
+inheritM :: (Traversable f, Monad m) => (Mu f -> a -> m a) -> a -> Mu f -> m (Attr f a)
+inheritM act root = go root where
+  go p s@(Fix t) = do
+    a <- act s p 
+    u <- mapM (go a) t
+    return (Fix (Ann a u))
+
+inheritM_ :: (Traversable f, Monad m) => (Mu f -> a -> m a) -> a -> Mu f -> m ()
+inheritM_ act root = go root where
+  go p s@(Fix t) = do
+    a <- act s p 
+    _ <- mapM (go a) t
+    return ()
+
 --------------------------------------------------------------------------------
+-- Top-down folds
+
+-- | Monadic top-down \"sweep\" of a tree. It's kind of a more complicated folding version of 'inheritM'.
+-- This is unsafe in the sense that the user is responsible to retain the shape of the node.
+-- TODO: better name?
+topDownSweepM :: (Traversable f, Monad m) => (f () -> a -> m (f a)) -> a -> Mu f -> m ()
+topDownSweepM act root = go root where
+  go p (Fix t) = do
+    s <- act (fmap (const ()) t) p 
+    _ <- unsafeZipWithFM go s t
+    return ()
+
+-- | An attributed version of 'topDownSweepM'. Probably more useful.
+topDownSweepM' :: (Traversable f, Monad m) => (b -> f b -> a -> m (f a)) -> a -> Attr f b -> m ()
+topDownSweepM' act root = go root where
+  go p (Fix (Ann u t)) = do
+    s <- act u (fmap attribute t) p 
+    _ <- unsafeZipWithFM go s t
+    return ()
+
+--------------------------------------------------------------------------------
 -- Traversals
 
 -- | Synthetising attributes via an accumulating map in a left-to-right fashion
@@ -140,6 +184,46 @@ enumerateNodes_ :: Traversable f => Mu f -> Attr f Int
 enumerateNodes_ = snd . enumerateNodes
 
+--------------------------------------------------------------------------------
+-- Resynthetising transformations
+
+-- | Bottom-up transformations which automatically resynthetise attributes 
+-- in case of changes.
+synthTransform :: Traversable f => (f a -> a) -> (Attr f a -> Maybe (f (Attr f a))) -> Attr f a -> Attr f a 
+synthTransform calc h0 = snd . go False where
+  synth x = Fix $ Ann (calc $ fmap attribute x) x
+  hsynth x = case h0 (synth x) of 
+    Nothing -> Nothing
+    Just y  -> Just (synth y)
+  go changed0 old@(Fix (Ann _ x)) = 
+    let (changed1,y) = mapAccumL go changed0 x
+        new = case hsynth y of
+          Nothing -> (changed1,w) where
+            w = if changed1
+              then synth y
+              else old
+          Just z -> (True, z)
+    in  new
+
+-- | Bottom-up transformations to normal form (applying transformation exhaustively)
+-- which automatically resynthetise attributes in case of changes.
+synthRewrite :: Traversable f => (f a -> a) -> (Attr f a -> Maybe (f (Attr f a))) -> Attr f a -> Attr f a 
+synthRewrite calc h0 = rewrite where
+  rewrite = snd . go False 
+  synth x = Fix $ Ann (calc $ fmap attribute x) x
+  hsynth x = case h0 (synth x) of 
+    Nothing -> Nothing
+    Just y  -> Just (synth y)
+  go changed0 old@(Fix (Ann _ x)) = 
+    let (changed1,y) = mapAccumL go changed0 x
+        new = case hsynth y of
+          Nothing -> (changed1,w) where
+            w = if changed1
+              then synth y
+              else old
+          Just z -> (True, rewrite z)
+    in  new
+    
 --------------------------------------------------------------------------------
 -- Stacking attributes
 

@@ -4,7 +4,10 @@ 
 --------------------------------------------------------------------------------
 
+import Prelude hiding (mapM,mapM_)
+import Control.Monad (liftM)
 import Data.Traversable
+--import Control.Monad.Trans.State
 
 --------------------------------------------------------------------------------
         
@@ -58,5 +61,38 @@ 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 act x0 t = runStateT (mapM (StateT . flip act) t) x0 where
+
+--------------------------------------------------------------------------------  
+
+newtype StateT s m a = StateT { runStateT :: s -> m (s,a) }
+
+instance (Monad m) => Monad (StateT s m) where
+  return a = state $ \s -> (s,a)
+  m >>= k  = StateT $ \s -> do
+    ~(s', a) <- runStateT m s
+    runStateT (k a) s'
+  fail str = StateT $ \_ -> fail str
+
+state :: Monad m => (s -> (s,a)) -> 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,())
 
 --------------------------------------------------------------------------------  

@@ -9,12 +9,20 @@   , mapAccumL  , mapAccumR
   , mapAccumL_ , mapAccumR_
   -- * Open functions
-  , holes , holesList
-  , apply , builder
+  , holes   , holesList
+  , apply   , builder
+  -- * Individual elements
+  , project , unsafeProject
+  , sizeF
   -- * Enumerations
   , enumerate
   , enumerateWith
   , enumerateWith_
+  -- * Zips
+  , Shape , shape
+  , zipF , unzipF
+  , zipWithF  , unsafeZipWithF
+  , zipWithFM , unsafeZipWithFM
   )
 where
 
@@ -56,16 +64,46 @@   g (x,replace) = replace (f x)
 
 -- | Builds up a structure from a list of the children.
+-- It is unsafe in the sense that it will throw an exception
+-- if there are not enough elements in the list.
 builder :: Traversable f => f a -> [b] -> f b
 builder tree xs = mapAccumL_ g xs tree where
   g (x:xs) _ = (xs,x)
 
 --------------------------------------------------------------------------------
+
+-- | Extracts the ith child.
+project :: Foldable f => Int -> f a -> Maybe a
+project i tree = 
+  case foldl f (Left 0) tree of
+    Right x -> Just x
+    Left  _ -> Nothing
+  where
+    f (Left j) x = if i==j then Right x else Left (j+1)
+    f old      _ = old
+    
+unsafeProject :: Foldable f => Int -> f a -> a
+unsafeProject i tree = 
+  case foldl f (Left 0) tree of
+    Right x -> x
+    Left  _ -> error "unsafePoject: invalid index"
+  where
+    f (Left j) x = if i==j then Right x else Left (j+1)
+    f old      _ = old
+
+-- | Number of children. This is the generalization of 'length' to foldable functors:
+--
+-- > sizeF x = length (toList x)
+--
+sizeF :: Foldable f => f a -> Int
+sizeF = foldl (\i _ -> i+1) 0  
+
+--------------------------------------------------------------------------------
 -- Enumerations
 
 -- | Enumerates children from the left to the right, starting with zero.
 -- Also returns the number of children. This is just a simple application
--- of @mapAccumL@.
+-- of 'mapAccumL'.
 enumerate :: Traversable f => f a -> (Int, f (Int, a))
 enumerate = mapAccumL (\i x -> (i+1,(i,x))) 0
 
@@ -76,3 +114,58 @@ enumerateWith_ h = snd . enumerateWith h
   
 --------------------------------------------------------------------------------
+-- Shapes
+
+-- | A type encoding the \"shape\" of the functor data:
+-- We ignore all the fields whose type is the parameter type,
+-- but remember the rest:
+--
+-- > newtype Shape f = Shape { unShape :: f () }
+--
+-- This can be used to decide whether two realizations are compatible.
+newtype Shape f = Shape { unShape :: f () }
+
+-- | Extracting the \"shape\" of the functor
+shape :: Functor f => f a -> Shape f
+shape = Shape . fmap (const ())
+
+instance EqF   f => Eq   (Shape f) where x == y        = equalF       (unShape x) (unShape y)
+instance OrdF  f => Ord  (Shape f) where compare x y   = compareF     (unShape x) (unShape y)
+instance ShowF f => Show (Shape f) where showsPrec d x = showsPrecF d (unShape x)
+
+-- | Zips two structures if they are compatible.
+zipF :: (Traversable f, EqF f) => f a -> f b -> Maybe (f (a,b))
+zipF = zipWithF (,)
+
+unzipF :: Functor f => f (a,b) -> (f a, f b)
+unzipF t = (fmap fst t, fmap snd t)
+
+-- | Zipping two structures using a function.
+zipWithF :: (Traversable f, EqF f) => (a -> b -> c) -> f a -> f b -> Maybe (f c)
+zipWithF f x y = 
+  if shape x == shape y
+    then Just (unsafeZipWithF f x y)
+    else Nothing
+
+-- | Unsafe version of 'zipWithF': does not check if the two structures are compatible.
+-- It is left-biased in the sense that the structure of the second argument is retained.
+unsafeZipWithF :: Traversable f => (a -> b -> c) -> f a -> f b -> f c
+unsafeZipWithF f x y = z where
+  z = mapAccumL_ g (toList y) x
+  g (b:bs) a = (bs, f a b)
+
+--------------------------------------------------------------------------------
+
+-- | Monadic version of 'zipWithF'. TODO: better name?
+zipWithFM :: (Traversable f, EqF f, Monad m) => (a -> b -> m c) -> f a -> f b -> m (Maybe (f c))
+zipWithFM f x y = 
+  if shape x == shape y
+    then liftM Just (unsafeZipWithFM f x y) 
+    else return Nothing
+
+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)
+
+--------------------------------------------------------------------------------
+

@@ -54,6 +54,31 @@ 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)

@@ -50,7 +50,7 @@   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 

@@ -265,6 +265,55 @@ isRightmost = isNothing . moveRight
 
 --------------------------------------------------------------------------------
+-- * Location queries
+
+-- | Gives back the index of the given location among the children of its parent.
+-- Indexing starts from zero. In case of root node (no parent), we also return zero.
+horizontalPos :: Foldable f => Loc f -> Int
+horizontalPos (Loc _ path) = case path of
+  Top        -> 0
+  Path nodes -> 
+    case mpos of
+      Right pos -> pos
+      Left _    -> error "horizontalPos: shouldn't happen"
+    where
+      mpos = foldl g (Left 0) nodes 
+      g old ei = case old of
+        Right _ -> old
+        Left  j -> case ei of
+          Left _  -> Left (j+1)
+          Right _ -> Right j
+
+-- | We return the full path from the root as a sequence of child indices.
+-- This means that
+-- 
+-- > loc == foldl (flip unsafeMoveDown) (moveTop loc) (fullPathDown loc)
+--
+fullPathDown :: Foldable f => Loc f -> [Int]
+fullPathDown = reverse . fullPathUp
+
+-- | The following equations hold for 'fullPathUp' and 'fullPathDown':
+-- 
+-- > fullPathUp == reverse . fullPathDown
+-- > loc == foldr unsafeMoveDown (moveTop loc) (fullPathUp loc)
+--
+fullPathUp :: Foldable f => Loc f -> [Int]
+fullPathUp (Loc _ pth) = go pth where    
+  go path = case path of
+    Top        -> []
+    Path nodes -> 
+      case mpos of
+        Right (pos,parent) -> pos : go parent
+        Left _             -> error "fullPathUp: shouldn't happen"
+      where
+        mpos = foldl g (Left 0) nodes 
+        g old ei = case old of
+          Right _ -> old
+          Left  j -> case ei of
+            Left _  -> Left (j+1)
+            Right p -> Right (j,p)    
+
+--------------------------------------------------------------------------------
 -- * Compound movements
   
 -- | Moves to the top, by repeatedly moving up.
@@ -434,6 +483,10 @@   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
@@ -454,6 +507,12 @@ 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
@@ -489,6 +548,24 @@     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

@@ -1,6 +1,6 @@  Name:                fixplate-Version:             0.1.1+Version:             0.1.2 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.@@ -9,7 +9,7 @@ License:             BSD3 License-file:        LICENSE Author:              Balazs Komuves-Copyright:           (c) 2011 Balazs Komuves+Copyright:           (c) 2011-2012 Balazs Komuves Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com Homepage:            http://code.haskell.org/~bkomuves/ Stability:           Experimental@@ -64,6 +64,6 @@    Hs-Source-Dirs:      . -  ghc-options:         -Wall -fno-warn-unused-matches+  ghc-options:         -Wall -fno-warn-unused-matches -fno-warn-name-shadowing