module Data.Generics.Fixplate.Morphisms where
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
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)
cata :: Functor f => (f a -> a) -> Mu f -> a
cata h = go where
go = h . fmap go . unFix
ana :: Functor f => (a -> f a) -> a -> Mu f
ana h = go where
go = Fix . fmap go . h
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
hylo :: Functor f => (f a -> a) -> (b -> f b) -> (b -> a)
hylo g h = cata g . ana h
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)
a = h ba
ba = fmap go t
newtype Free f a = Free { unFree :: Either a (f (Free f a)) }
newtype CoFree f a = CoFree { unCoFree :: (a , f (CoFree f a)) }
futu :: Functor f => (a -> f (Free f a)) -> a -> Mu f
futu h = go where
go = Fix . fmap worker . h
worker (Free ei) = case ei of
Left x -> go x
Right t -> Fix (fmap worker t)
histo :: Functor f => (f (CoFree f a) -> a) -> Mu f -> a
histo h = go where
go = h . fmap worker . unFix
worker t@(Fix s) = CoFree ( go t , fmap worker s )
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 () }
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
runtests_Morphisms :: IO ()
runtests_Morphisms = do
quickCheck prop_para
quickCheck prop_paraList
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