module Data.Functor.Foldable
(
Base
, Fix(..)
, Mu(..)
, Nu(..)
, Prim(..)
, Foldable(..)
, gcata
, zygo
, gzygo
, histo
, ghisto
, distCata
, distPara
, distParaT
, distZygo
, distZygoT
, distHisto
, Unfoldable(..)
, gana
, distAna
, distApo
, distGApo
, hylo
, ghylo
, refix
, fold, gfold
, unfold, gunfold
, refold, grefold
, mcata
, mhisto
) where
import Control.Applicative
import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Trans.Env
import Control.Monad (liftM, join)
import Data.Functor.Identity
import Data.Function (on)
import qualified Data.Stream.Branching as Stream
import Data.Stream.Branching (Stream(..))
import Text.Read
import Data.Data hiding (gunfold)
import qualified Data.Data as Data
type family Base t :: * -> *
data family Prim t :: * -> *
class Functor (Base t) => Foldable t where
project :: t -> Base t t
cata :: (Base t a -> a)
-> t
-> a
cata f = c where c = f . fmap c . project
para :: Unfoldable t => (Base t (t, a) -> a) -> t -> a
para t = zygo embed t
gpara :: (Unfoldable t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> (Base t (EnvT t w a) -> a) -> t -> a
gpara t = gzygo embed t
distPara :: Unfoldable t => Base t (t, a) -> (t, Base t a)
distPara = distZygo embed
distParaT :: (Unfoldable t, Comonad w) => (forall b. Base t (w b) -> w (Base t b)) -> Base t (EnvT t w a) -> EnvT t w (Base t a)
distParaT t = distZygoT embed t
class Functor (Base t) => Unfoldable t where
embed :: Base t t -> t
ana
:: (a -> Base t a)
-> a
-> t
ana g = a where a = embed . fmap a . g
apo :: Foldable t => (a -> Base t (Either t a)) -> a -> t
apo = gapo project
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g = h where h = f . fmap h . g
fold :: Foldable t => (Base t a -> a) -> t -> a
fold = cata
unfold :: Unfoldable t => (a -> Base t a) -> a -> t
unfold = ana
refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refold = hylo
data instance Prim [a] b = Cons a b | Nil deriving (Eq,Ord,Show,Read)
instance Functor (Prim [a]) where
fmap f (Cons a b) = Cons a (f b)
fmap _ Nil = Nil
type instance Base [a] = Prim [a]
instance Foldable [a] where
project (x:xs) = Cons x xs
project [] = Nil
para f (x:xs) = f (Cons x (xs, para f xs))
para f [] = f Nil
instance Unfoldable [a] where
embed (Cons x xs) = x:xs
embed Nil = []
apo f a = case f a of
Cons x (Left xs) -> x : xs
Cons x (Right b) -> x : apo f b
Nil -> []
type instance Base (Maybe a) = Const (Maybe a)
instance Foldable (Maybe a) where project = Const
instance Unfoldable (Maybe a) where embed = getConst
type instance Base (Either a b) = Const (Either a b)
instance Foldable (Either a b) where project = Const
instance Unfoldable (Either a b) where embed = getConst
gfold, gcata
:: (Foldable t, Comonad w)
=> (forall b. Base t (w b) -> w (Base t b))
-> (Base t (w a) -> a)
-> t
-> a
gcata k g = g . extract . c where
c = k . fmap (duplicate . fmap g . c) . project
gfold k g t = gcata k g t
distCata :: Functor f => f (Identity a) -> Identity (f a)
distCata = Identity . fmap runIdentity
gunfold, gana
:: (Unfoldable t, Monad m)
=> (forall b. m (Base t b) -> Base t (m b))
-> (a -> Base t (m a))
-> a
-> t
gana k f = a . return . f where
a = embed . fmap (a . liftM f . join) . k
gunfold k f t = gana k f t
distAna :: Functor f => Identity (f a) -> f (Identity a)
distAna = fmap Identity . runIdentity
grefold, ghylo
:: (Comonad w, Functor f, Monad m)
=> (forall c. f (w c) -> w (f c))
-> (forall d. m (f d) -> f (m d))
-> (f (w b) -> b)
-> (a -> f (m a))
-> a
-> b
ghylo w m f g = extract . h . return where
h = fmap f . w . fmap (duplicate . h . join) . m . liftM g
grefold w m f g a = ghylo w m f g a
newtype Fix f = Fix (f (Fix f))
unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f
deriving instance Eq (f (Fix f)) => Eq (Fix f)
deriving instance Ord (f (Fix f)) => Ord (Fix f)
deriving instance Show (f (Fix f)) => Show (Fix f)
deriving instance Read (f (Fix f)) => Read (Fix f)
#ifdef __GLASGOW_HASKELL__
instance Typeable1 f => Typeable (Fix f) where
typeOf t = mkTyConApp fixTyCon [typeOf1 (undefined `asArgsTypeOf` t)]
where asArgsTypeOf :: f a -> Fix f -> f a
asArgsTypeOf = const
fixTyCon :: TyCon
fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"
instance (Typeable1 f, Data (f (Fix f))) => Data (Fix f) where
gfoldl f z (Fix a) = z Fix `f` a
toConstr _ = fixConstr
gunfold k z c = case constrIndex c of
1 -> k (z (Fix))
_ -> error "gunfold"
dataTypeOf _ = fixDataType
fixConstr :: Constr
fixConstr = mkConstr fixDataType "Fix" [] Prefix
fixDataType :: DataType
fixDataType = mkDataType "Data.Functor.Foldable.Fix" [fixConstr]
#endif
type instance Base (Fix f) = f
instance Functor f => Foldable (Fix f) where
project (Fix a) = a
instance Functor f => Unfoldable (Fix f) where
embed = Fix
refix :: (Foldable s, Unfoldable t, Base s ~ Base t) => s -> t
refix = cata embed
toFix :: Foldable t => t -> Fix (Base t)
toFix = refix
fromFix :: Unfoldable t => Fix (Base t) -> t
fromFix = refix
lambek :: (Foldable t, Unfoldable t) => (t -> Base t t)
lambek = cata (fmap embed)
colambek :: (Foldable t, Unfoldable t) => (Base t t -> t)
colambek = ana (fmap project)
newtype Mu f = Mu (forall a. (f a -> a) -> a)
type instance Base (Mu f) = f
instance Functor f => Foldable (Mu f) where
project = lambek
cata f (Mu g) = g f
instance Functor f => Unfoldable (Mu f) where
embed m = Mu (\f -> f (fmap (fold f) m))
instance (Functor f, Eq (f (Fix f)), Eq (Fix f)) => Eq (Mu f) where
(==) = (==) `on` toFix
instance (Functor f, Ord (f (Fix f)), Ord (Fix f)) => Ord (Mu f) where
compare = compare `on` toFix
instance (Functor f, Show (f (Fix f)), Show (Fix f)) => Show (Mu f) where
showsPrec d f = showParen (d > 10) $
showString "fromFix " . showsPrec 11 (toFix f)
#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read (f (Fix f)), Read (Fix f)) => Read (Mu f) where
readPrec = parens $ prec 10 $ do
Ident "fromFix" <- lexP
fromFix <$> step readPrec
#endif
data Nu f where Nu :: (a -> f a) -> a -> Nu f
type instance Base (Nu f) = f
instance Functor f => Unfoldable (Nu f) where
embed = colambek
ana = Nu
instance Functor f => Foldable (Nu f) where
project (Nu f a) = Nu f <$> f a
instance (Functor f, Eq (f (Fix f)), Eq (Fix f)) => Eq (Nu f) where
(==) = (==) `on` toFix
instance (Functor f, Ord (f (Fix f)), Ord (Fix f)) => Ord (Nu f) where
compare = compare `on` toFix
instance (Functor f, Show (f (Fix f)), Show (Fix f)) => Show (Nu f) where
showsPrec d f = showParen (d > 10) $
showString "fromFix " . showsPrec 11 (toFix f)
#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read (f (Fix f)), Read (Fix f)) => Read (Nu f) where
readPrec = parens $ prec 10 $ do
Ident "fromFix" <- lexP
fromFix <$> step readPrec
#endif
zygo :: Foldable t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo f = gfold (distZygo f)
distZygo
:: Functor f
=> (f b -> b)
-> (f (b, a) -> (b, f a))
distZygo g m = (g (fmap fst m), fmap snd m)
gzygo
:: (Foldable t, Comonad w)
=> (Base t b -> b)
-> (forall c. Base t (w c) -> w (Base t c))
-> (Base t (EnvT b w a) -> a)
-> t
-> a
gzygo f w = gfold (distZygoT f w)
distZygoT
:: (Functor f, Comonad w)
=> (f b -> b)
-> (forall c. f (w c) -> w (f c))
-> f (EnvT b w a) -> EnvT b w (f a)
distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe))
where getEnv (EnvT e _) = e
gapo :: Unfoldable t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t
gapo g = gunfold (distGApo g)
distApo :: Foldable t => Either t (Base t a) -> Base t (Either t a)
distApo = distGApo project
distGApo :: Functor f => (b -> f b) -> Either b (f a) -> f (Either b a)
distGApo f = either (fmap Left . f) (fmap Right)
histo :: Foldable t => (Base t (Stream (Base t) a) -> a) -> t -> a
histo = gfold (distHisto id)
ghisto :: (Foldable t, Functor h) => (forall b. Base t (h b) -> h (Base t b)) -> (Base t (Stream h a) -> a) -> t -> a
ghisto g = gfold (distHisto g)
distHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (Stream h a) -> Stream h (f a)
distHisto k = Stream.unfold (\as -> (Stream.head <$> as, k (Stream.tail <$> as)))
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata psi = psi (mcata psi) . unfix
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto psi = psi (mhisto psi) unfix . unfix