module Data.Generics.Fixplate.Attributes
( Attrib(..)
, annMap
, synthetise , synthetise' , synthetiseList , synthetiseM
, inherit , inherit'
, synthAccumL , synthAccumR
, synthAccumL_ , synthAccumR_
, enumerateNodes , enumerateNodes_
, annZip , annZipWith
, annZip3 , annZipWith3
#ifdef WITH_QUICKCHECK
, 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
annMap :: Functor f => (a -> b) -> Attr f a -> Attr f b
annMap h = unAttrib . fmap h . Attrib
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' :: 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))
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))
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))
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'))
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)
enumerateNodes :: Traversable f => Mu f -> (Int, Attr f Int)
enumerateNodes tree = synthAccumL (\i _ -> (i+1,i)) 0 tree
enumerateNodes_ :: Traversable f => Mu f -> Attr f Int
enumerateNodes_ = snd . enumerateNodes
annZip :: Functor f => Mu (Ann (Ann f a) b) -> Attr f (a,b)
annZip (Fix (Ann y (Ann x t))) = Fix (Ann (x,y) (fmap annZip t))
annZipWith :: Functor f => (a -> b -> c) -> Mu (Ann (Ann f a) b) -> Attr f c
annZipWith h = go where
go (Fix (Ann y (Ann x t))) = Fix (Ann (h x y) (fmap go t))
annZip3 :: Functor f => Mu (Ann (Ann (Ann f a) b) c) -> Attr f (a,b,c)
annZip3 (Fix (Ann z (Ann y (Ann x t)))) = Fix (Ann (x,y,z) (fmap annZip3 t))
annZipWith3 :: Functor f => (a -> b -> c -> d) -> Mu (Ann (Ann (Ann f a) b) c) -> Attr f d
annZipWith3 h = go where
go (Fix (Ann z (Ann y (Ann x t)))) = Fix (Ann (h x y z) (fmap go t))
#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