{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}
-- explicit dictionary higher-kind instances are defined in
-- - base-4.9
-- - transformers >= 0.5
-- - transformes-compat >= 0.5 when transformers aren't 0.4
#define EXPLICIT_DICT_FUNCTOR_CLASSES (MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) || (MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)))
#define HAS_GENERIC (__GLASGOW_HASKELL__ >= 702)
#define HAS_GENERIC1 (__GLASGOW_HASKELL__ >= 706)
-- Polymorphic typeable
#define HAS_POLY_TYPEABLE MIN_VERSION_base(4,7,0)
#ifdef __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE ConstrainedClassMethods #-}
#endif
#if HAS_GENERIC
{-# LANGUAGE DeriveGeneric #-}
#endif
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright : (C) 2008-2015 Edward Kmett
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : experimental
-- Portability : non-portable
--
----------------------------------------------------------------------------
module Data.Functor.Foldable
(
-- * Base functors for fixed points
Base
, ListF(..)
-- * Fixed points
, Fix(..), unfix
, Mu(..)
, Nu(..)
-- * Folding
, Recursive(..)
-- ** Combinators
, gapo
, gcata
, zygo
, gzygo
, histo
, ghisto
, futu
, chrono
, gchrono
-- ** Distributive laws
, distCata
, distPara
, distParaT
, distZygo
, distZygoT
, distHisto
, distGHisto
, distFutu
, distGFutu
-- * Unfolding
, Corecursive(..)
-- ** Combinators
, gana
-- ** Distributive laws
, distAna
, distApo
, distGApo
, distGApoT
-- * Refolding
, hylo
, ghylo
-- ** Changing representation
, refix
-- * Common names
, fold, gfold
, unfold, gunfold
, refold, grefold
-- * Mendler-style
, mcata
, mhisto
-- * Elgot (co)algebras
, elgot
, coelgot
-- * Zygohistomorphic prepromorphisms
, zygoHistoPrepro
) where
import Control.Applicative
import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Trans.Env
import qualified Control.Comonad.Cofree as Cofree
import Control.Comonad.Cofree (Cofree(..))
import Control.Monad (liftM, join)
import Control.Monad.Free (Free(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Data.Functor.Identity
import Control.Arrow
import Data.Function (on)
import Data.Functor.Classes
import Text.Read
import Text.Show
#ifdef __GLASGOW_HASKELL__
import Data.Data hiding (gunfold)
#if HAS_POLY_TYPEABLE
#else
import qualified Data.Data as Data
#endif
#if HAS_GENERIC
import GHC.Generics (Generic)
#endif
#if HAS_GENERIC1
import GHC.Generics (Generic1)
#endif
#endif
import Data.Monoid (Monoid (..))
import Prelude
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Bifunctor as Bi
import qualified Data.Bifoldable as Bi
import qualified Data.Bitraversable as Bi
type family Base t :: * -> *
class Functor (Base t) => Recursive t where
project :: t -> Base t t
cata :: (Base t a -> a) -- ^ a (Base t)-algebra
-> t -- ^ fixed point
-> a -- ^ result
cata f = c where c = f . fmap c . project
para :: (Base t (t, a) -> a) -> t -> a
para t = p where p x = t . fmap ((,) <*> p) $ project x
gpara :: (Corecursive 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
-- | Fokkinga's prepromorphism
prepro
:: Corecursive t
=> (forall b. Base t b -> Base t b)
-> (Base t a -> a)
-> t
-> a
prepro e f = c where c = f . fmap (c . cata (embed . e)) . project
--- | A generalized prepromorphism
gprepro
:: (Corecursive t, Comonad w)
=> (forall b. Base t (w b) -> w (Base t b))
-> (forall c. Base t c -> Base t c)
-> (Base t (w a) -> a)
-> t
-> a
gprepro k e f = extract . c where c = fmap f . k . fmap (duplicate . c . cata (embed . e)) . project
distPara :: Corecursive t => Base t (t, a) -> (t, Base t a)
distPara = distZygo embed
distParaT :: (Corecursive 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) => Corecursive t where
embed :: Base t t -> t
ana
:: (a -> Base t a) -- ^ a (Base t)-coalgebra
-> a -- ^ seed
-> t -- ^ resulting fixed point
ana g = a where a = embed . fmap a . g
apo :: (a -> Base t (Either t a)) -> a -> t
apo g = a where a = embed . (fmap (either id a)) . g
-- | Fokkinga's postpromorphism
postpro
:: Recursive t
=> (forall b. Base t b -> Base t b) -- natural transformation
-> (a -> Base t a) -- a (Base t)-coalgebra
-> a -- seed
-> t
postpro e g = a where a = embed . fmap (ana (e . project) . a) . g
-- | A generalized postpromorphism
gpostpro
:: (Recursive t, Monad m)
=> (forall b. m (Base t b) -> Base t (m b)) -- distributive law
-> (forall c. Base t c -> Base t c) -- natural transformation
-> (a -> Base t (m a)) -- a (Base t)-m-coalgebra
-> a -- seed
-> t
gpostpro k e g = a . return where a = embed . fmap (ana (e . project) . a . join) . k . liftM g
hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g = h where h = f . fmap h . g
fold :: Recursive t => (Base t a -> a) -> t -> a
fold = cata
unfold :: Corecursive t => (a -> Base t a) -> a -> t
unfold = ana
refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
refold = hylo
-- | Base functor of @[]@.
data ListF a b = Nil | Cons a b
deriving (Eq,Ord,Show,Read,Typeable
#if HAS_GENERIC
, Generic
#endif
#if HAS_GENERIC1
, Generic1
#endif
)
#if EXPLICIT_DICT_FUNCTOR_CLASSES
instance Eq2 ListF where
liftEq2 _ _ Nil Nil = True
liftEq2 f g (Cons a b) (Cons a' b') = f a a' && g b b'
liftEq2 _ _ _ _ = False
instance Eq a => Eq1 (ListF a) where
liftEq = liftEq2 (==)
instance Ord2 ListF where
liftCompare2 _ _ Nil Nil = EQ
liftCompare2 _ _ Nil _ = LT
liftCompare2 _ _ _ Nil = GT
liftCompare2 f g (Cons a b) (Cons a' b') = f a a' `mappend` g b b'
instance Ord a => Ord1 (ListF a) where
liftCompare = liftCompare2 compare
instance Show a => Show1 (ListF a) where
liftShowsPrec = liftShowsPrec2 showsPrec showList
instance Show2 ListF where
liftShowsPrec2 _ _ _ _ _ Nil = showString "Nil"
liftShowsPrec2 sa _ sb _ d (Cons a b) = showParen (d > 10)
$ showString "Cons "
. sa 11 a
. showString " "
. sb 11 b
instance Read2 ListF where
liftReadsPrec2 ra _ rb _ d = readParen (d > 10) $ \s -> nil s ++ cons s
where
nil s0 = do
("Nil", s1) <- lex s0
return (Nil, s1)
cons s0 = do
("Cons", s1) <- lex s0
(a, s2) <- ra 11 s1
(b, s3) <- rb 11 s2
return (Cons a b, s3)
instance Read a => Read1 (ListF a) where
liftReadsPrec = liftReadsPrec2 readsPrec readList
#else
instance Eq a => Eq1 (ListF a) where eq1 = (==)
instance Ord a => Ord1 (ListF a) where compare1 = compare
instance Show a => Show1 (ListF a) where showsPrec1 = showsPrec
instance Read a => Read1 (ListF a) where readsPrec1 = readsPrec
#endif
-- These instances cannot be auto-derived on with GHC <= 7.6
instance Functor (ListF a) where
fmap _ Nil = Nil
fmap f (Cons a b) = Cons a (f b)
instance F.Foldable (ListF a) where
foldMap _ Nil = Data.Monoid.mempty
foldMap f (Cons _ b) = f b
instance T.Traversable (ListF a) where
traverse _ Nil = pure Nil
traverse f (Cons a b) = Cons a <$> f b
instance Bi.Bifunctor ListF where
bimap _ _ Nil = Nil
bimap f g (Cons a b) = Cons (f a) (g b)
instance Bi.Bifoldable ListF where
bifoldMap _ _ Nil = mempty
bifoldMap f g (Cons a b) = mappend (f a) (g b)
instance Bi.Bitraversable ListF where
bitraverse _ _ Nil = pure Nil
bitraverse f g (Cons a b) = Cons <$> f a <*> g b
type instance Base [a] = ListF a
instance Recursive [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 Corecursive [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 -> []
-- | Example boring stub for non-recursive data types
type instance Base (Maybe a) = Const (Maybe a)
instance Recursive (Maybe a) where project = Const
instance Corecursive (Maybe a) where embed = getConst
-- | Example boring stub for non-recursive data types
type instance Base (Either a b) = Const (Either a b)
instance Recursive (Either a b) where project = Const
instance Corecursive (Either a b) where embed = getConst
-- | A generalized catamorphism
gfold, gcata
:: (Recursive t, Comonad w)
=> (forall b. Base t (w b) -> w (Base t b)) -- ^ a distributive law
-> (Base t (w a) -> a) -- ^ a (Base t)-w-algebra
-> t -- ^ fixed point
-> 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
-- | A generalized anamorphism
gunfold, gana
:: (Corecursive t, Monad m)
=> (forall b. m (Base t b) -> Base t (m b)) -- ^ a distributive law
-> (a -> Base t (m a)) -- ^ a (Base t)-m-coalgebra
-> a -- ^ seed
-> 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
-- | A generalized hylomorphism
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
futu :: Corecursive t => (a -> Base t (Free (Base t) a)) -> a -> t
futu = gana distFutu
distFutu :: Functor f => Free f (f a) -> f (Free f a)
distFutu = distGFutu id
distGFutu :: (Functor f, Functor h) => (forall b. h (f b) -> f (h b)) -> Free h (f a) -> f (Free h a)
distGFutu _ (Pure fa) = Pure <$> fa
distGFutu k (Free as) = Free <$> k (distGFutu k <$> as)
-------------------------------------------------------------------------------
-- Fix
-------------------------------------------------------------------------------
newtype Fix f = Fix (f (Fix f))
unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f
instance Eq1 f => Eq (Fix f) where
Fix a == Fix b = eq1 a b
instance Ord1 f => Ord (Fix f) where
compare (Fix a) (Fix b) = compare1 a b
instance Show1 f => Show (Fix f) where
showsPrec d (Fix a) =
showParen (d >= 11)
$ showString "Fix "
. showsPrec1 11 a
instance Read1 f => Read (Fix f) where
readPrec = parens $ prec 10 $ do
Ident "Fix" <- lexP
Fix <$> step (readS_to_Prec readsPrec1)
#ifdef __GLASGOW_HASKELL__
#if HAS_POLY_TYPEABLE
deriving instance Typeable Fix
deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)
#else
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
#if MIN_VERSION_base(4,4,0)
fixTyCon = mkTyCon3 "recursion-schemes" "Data.Functor.Foldable" "Fix"
#else
fixTyCon = mkTyCon "Data.Functor.Foldable.Fix"
#endif
{-# NOINLINE fixTyCon #-}
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
#endif
type instance Base (Fix f) = f
instance Functor f => Recursive (Fix f) where
project (Fix a) = a
instance Functor f => Corecursive (Fix f) where
embed = Fix
refix :: (Recursive s, Corecursive t, Base s ~ Base t) => s -> t
refix = cata embed
toFix :: Recursive t => t -> Fix (Base t)
toFix = refix
fromFix :: Corecursive t => Fix (Base t) -> t
fromFix = refix
-------------------------------------------------------------------------------
-- Lambek
-------------------------------------------------------------------------------
-- | Lambek's lemma provides a default definition for 'project' in terms of 'cata' and 'embed'
lambek :: (Recursive t, Corecursive t) => (t -> Base t t)
lambek = cata (fmap embed)
-- | The dual of Lambek's lemma, provides a default definition for 'embed' in terms of 'ana' and 'project'
colambek :: (Recursive t, Corecursive 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 => Recursive (Mu f) where
project = lambek
cata f (Mu g) = g f
instance Functor f => Corecursive (Mu f) where
embed m = Mu (\f -> f (fmap (fold f) m))
instance (Functor f, Eq1 f) => Eq (Mu f) where
(==) = (==) `on` toFix
instance (Functor f, Ord1 f) => Ord (Mu f) where
compare = compare `on` toFix
instance (Functor f, Show1 f) => Show (Mu f) where
showsPrec d f = showParen (d > 10) $
showString "fromFix " . showsPrec 11 (toFix f)
#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 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 => Corecursive (Nu f) where
embed = colambek
ana = Nu
instance Functor f => Recursive (Nu f) where
project (Nu f a) = Nu f <$> f a
instance (Functor f, Eq1 f) => Eq (Nu f) where
(==) = (==) `on` toFix
instance (Functor f, Ord1 f) => Ord (Nu f) where
compare = compare `on` toFix
instance (Functor f, Show1 f) => Show (Nu f) where
showsPrec d f = showParen (d > 10) $
showString "fromFix " . showsPrec 11 (toFix f)
#ifdef __GLASGOW_HASKELL__
instance (Functor f, Read1 f) => Read (Nu f) where
readPrec = parens $ prec 10 $ do
Ident "fromFix" <- lexP
fromFix <$> step readPrec
#endif
zygo :: Recursive t => (Base t b -> b) -> (Base t (b, a) -> a) -> t -> a
zygo f = gfold (distZygo f)
distZygo
:: Functor f
=> (f b -> b) -- An f-algebra
-> (f (b, a) -> (b, f a)) -- ^ A distributive for semi-mutual recursion
distZygo g m = (g (fmap fst m), fmap snd m)
gzygo
:: (Recursive 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) -- An f-w-algebra to use for semi-mutual recursion
-> (forall c. f (w c) -> w (f c)) -- A base Distributive law
-> f (EnvT b w a) -> EnvT b w (f a) -- A new distributive law that adds semi-mutual recursion
distZygoT g k fe = EnvT (g (getEnv <$> fe)) (k (lower <$> fe))
where getEnv (EnvT e _) = e
gapo :: Corecursive t => (b -> Base t b) -> (a -> Base t (Either b a)) -> a -> t
gapo g = gunfold (distGApo g)
distApo :: Recursive 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)
distGApoT
:: (Functor f, Functor m)
=> (b -> f b)
-> (forall c. m (f c) -> f (m c))
-> ExceptT b m (f a)
-> f (ExceptT b m a)
distGApoT g k = fmap ExceptT . k . fmap (distGApo g) . runExceptT
-- | Course-of-value iteration
histo :: Recursive t => (Base t (Cofree (Base t) a) -> a) -> t -> a
histo = gcata distHisto
ghisto :: (Recursive t, Functor h) => (forall b. Base t (h b) -> h (Base t b)) -> (Base t (Cofree h a) -> a) -> t -> a
ghisto g = gcata (distGHisto g)
distHisto :: Functor f => f (Cofree f a) -> Cofree f (f a)
distHisto = distGHisto id
distGHisto :: (Functor f, Functor h) => (forall b. f (h b) -> h (f b)) -> f (Cofree h a) -> Cofree h (f a)
distGHisto k = Cofree.unfold (\as -> (extract <$> as, k (Cofree.unwrap <$> as)))
chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> (a -> b)
chrono = ghylo distHisto distFutu
gchrono :: (Functor f, Functor w, Functor m) =>
(forall c. f (w c) -> w (f c)) ->
(forall c. m (f c) -> f (m c)) ->
(f (Cofree w b) -> b) -> (a -> f (Free m a)) ->
(a -> b)
gchrono w m = ghylo (distGHisto w) (distGFutu m)
-- | Mendler-style iteration
mcata :: (forall y. (y -> c) -> f y -> c) -> Fix f -> c
mcata psi = psi (mcata psi) . unfix
-- | Mendler-style course-of-value iteration
mhisto :: (forall y. (y -> c) -> (y -> f y) -> f y -> c) -> Fix f -> c
mhisto psi = psi (mhisto psi) unfix . unfix
-- | Elgot algebras
elgot :: Functor f => (f a -> a) -> (b -> Either a (f b)) -> b -> a
elgot phi psi = h where h = (id ||| phi . fmap h) . psi
-- | Elgot coalgebras: <http://comonad.com/reader/2008/elgot-coalgebras/>
coelgot :: Functor f => ((a, f b) -> b) -> (a -> f a) -> a -> b
coelgot phi psi = h where h = phi . (id &&& fmap h . psi)
-- | Zygohistomorphic prepromorphisms:
--
-- A corrected and modernized version of <http://www.haskell.org/haskellwiki/Zygohistomorphic_prepromorphisms>
zygoHistoPrepro
:: (Corecursive t, Recursive t)
=> (Base t b -> b)
-> (forall c. Base t c -> Base t c)
-> (Base t (EnvT b (Cofree (Base t)) a) -> a)
-> t
-> a
zygoHistoPrepro f g t = gprepro (distZygoT f distHisto) g t
-------------------------------------------------------------------------------
-- Not exposed anywhere
-------------------------------------------------------------------------------
-- | Read a list (using square brackets and commas), given a function
-- for reading elements.
_readListWith :: ReadS a -> ReadS [a]
_readListWith rp =
readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
where
readl s = [([],t) | ("]",t) <- lex s] ++
[(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]
readl' s = [([],t) | ("]",t) <- lex s] ++
[(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]