{-# Language
        FlexibleContexts,
        UndecidableInstances,
        TypeSynonymInstances,
        DeriveGeneric,
        DeriveDataTypeable,
        StandaloneDeriving #-}
-- | Fix-point type. It allows to define generic recursion schemes.
--
-- > Fix f = f (Fix f)
--
-- Type @f@ should be a 'Functor' if you want to use
-- simple recursion schemes or 'Traversable' if you want to
-- use monadic recursion schemes. This style allows you to express
-- recursive functions in non-recursive manner.
-- You can imagine that a non-recursive function
-- holds values of the previous iteration.
--
-- Little example:
--
-- > type List a = Fix (L a)
-- >
-- > data L a b = Nil | Cons a b
-- >
-- > instance Functor (L a) where
-- >    fmap f x = case x of
-- >        Nil      -> Nil
-- >        Cons a b -> Cons a (f b)
-- >
-- > length :: List a -> Int
-- > length = cata $ \x -> case x of
-- >    Nil      -> 0
-- >    Cons _ n -> n + 1
-- >
-- > sum :: Num a => List a -> a
-- > sum = cata $ \x -> case x of
-- >    Nil      -> 0
-- >    Cons a s -> a + s

module Data.Fix (
    Fix(..)
    -- * Simple recursion
    -- | Type @f@ should be a 'Functor'. They transform
    -- non-recursive functions to recursive ones.
    , cata
    , ana
    , hylo
    , (~>)
    -- * Monadic recursion
    -- | Type @f@ should be a 'Traversable'.
    , cataM
    , anaM
    , hyloM
    )
where

import GHC.Generics
import Data.Data
import Data.Function (on)

-- | A fix-point type.
newtype Fix f = Fix { Fix f -> f (Fix f)
unFix :: f (Fix f) } deriving ((forall x. Fix f -> Rep (Fix f) x)
-> (forall x. Rep (Fix f) x -> Fix f) -> Generic (Fix f)
forall x. Rep (Fix f) x -> Fix f
forall x. Fix f -> Rep (Fix f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
$cto :: forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
$cfrom :: forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
Generic, Typeable)
deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)

-- standard instances

instance Show (f (Fix f)) => Show (Fix f) where
    showsPrec :: Int -> Fix f -> ShowS
showsPrec n :: Int
n x :: Fix f
x = Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ \s :: String
s ->
        "Fix " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> f (Fix f) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 (Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Fix f
x) String
s

instance Read (f (Fix f)) => Read (Fix f) where
    readsPrec :: Int -> ReadS (Fix f)
readsPrec d :: Int
d = Bool -> ReadS (Fix f) -> ReadS (Fix f)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (ReadS (Fix f) -> ReadS (Fix f)) -> ReadS (Fix f) -> ReadS (Fix f)
forall a b. (a -> b) -> a -> b
$ \r :: String
r ->
        [(f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix f (Fix f)
m, String
t) | ("Fix", s :: String
s) <- ReadS String
lex String
r, (m :: f (Fix f)
m, t :: String
t) <- Int -> ReadS (f (Fix f))
forall a. Read a => Int -> ReadS a
readsPrec 11 String
s]

instance Eq (f (Fix f)) => Eq (Fix f) where
    == :: Fix f -> Fix f -> Bool
(==) = f (Fix f) -> f (Fix f) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (f (Fix f) -> f (Fix f) -> Bool)
-> (Fix f -> f (Fix f)) -> Fix f -> Fix f -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

instance Ord (f (Fix f)) => Ord (Fix f) where
    compare :: Fix f -> Fix f -> Ordering
compare = f (Fix f) -> f (Fix f) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (f (Fix f) -> f (Fix f) -> Ordering)
-> (Fix f -> f (Fix f)) -> Fix f -> Fix f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix


-- recursion

-- | Catamorphism or generic function fold.
cata :: Functor f => (f a -> a) -> (Fix f -> a)
cata :: (f a -> a) -> Fix f -> a
cata f :: f a -> a
f = f a -> a
f (f a -> a) -> (Fix f -> f a) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> a) -> f (Fix f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> a) -> Fix f -> a
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f a -> a
f) (f (Fix f) -> f a) -> (Fix f -> f (Fix f)) -> Fix f -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | Anamorphism or generic function unfold.
ana :: Functor f => (a -> f a) -> (a -> Fix f)
ana :: (a -> f a) -> a -> Fix f
ana f :: a -> f a
f = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f) -> (a -> f (Fix f)) -> a -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Fix f) -> f a -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> f a) -> a -> Fix f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
f) (f a -> f (Fix f)) -> (a -> f a) -> a -> f (Fix f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
f

-- | Hylomorphism is anamorphism followed by catamorphism.
hylo :: Functor f => (f b -> b) -> (a -> f a) -> (a -> b)
hylo :: (f b -> b) -> (a -> f a) -> a -> b
hylo phi :: f b -> b
phi psi :: a -> f a
psi = (f b -> b) -> Fix f -> b
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f b -> b
phi (Fix f -> b) -> (a -> Fix f) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> a -> Fix f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Fix f
ana a -> f a
psi

-- | Infix version of @hylo@.
(~>) :: Functor f => (a -> f a) -> (f b -> b) -> (a -> b)
psi :: a -> f a
psi ~> :: (a -> f a) -> (f b -> b) -> a -> b
~> phi :: f b -> b
phi = f b -> b
phi (f b -> b) -> (a -> f b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f b -> b) -> (a -> f a) -> a -> b
forall (f :: * -> *) b a.
Functor f =>
(f b -> b) -> (a -> f a) -> a -> b
hylo f b -> b
phi a -> f a
psi) (f a -> f b) -> (a -> f a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
psi

-- monadic recursion

-- | Monadic catamorphism.
cataM :: (Applicative m, Monad m, Traversable t)
    => (t a -> m a) -> Fix t -> m a
cataM :: (t a -> m a) -> Fix t -> m a
cataM f :: t a -> m a
f = (t a -> m a
f (t a -> m a) -> m (t a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t a) -> m a) -> (Fix t -> m (t a)) -> Fix t -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix t -> m a) -> t (Fix t) -> m (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((t a -> m a) -> Fix t -> m a
forall (m :: * -> *) (t :: * -> *) a.
(Applicative m, Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
cataM t a -> m a
f) (t (Fix t) -> m (t a)) -> (Fix t -> t (Fix t)) -> Fix t -> m (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix t -> t (Fix t)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix

-- | Monadic anamorphism.
anaM :: (Applicative m, Monad m, Traversable t)
    => (a -> m (t a)) -> (a -> m (Fix t))
anaM :: (a -> m (t a)) -> a -> m (Fix t)
anaM f :: a -> m (t a)
f = (t (Fix t) -> Fix t) -> m (t (Fix t)) -> m (Fix t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t (Fix t) -> Fix t
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (m (t (Fix t)) -> m (Fix t))
-> (a -> m (t (Fix t))) -> a -> m (Fix t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> m (Fix t)) -> t a -> m (t (Fix t))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> m (t a)) -> a -> m (Fix t)
forall (m :: * -> *) (t :: * -> *) a.
(Applicative m, Monad m, Traversable t) =>
(a -> m (t a)) -> a -> m (Fix t)
anaM a -> m (t a)
f) (t a -> m (t (Fix t))) -> m (t a) -> m (t (Fix t))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (t a) -> m (t (Fix t))) -> (a -> m (t a)) -> a -> m (t (Fix t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (t a)
f

-- | Monadic hylomorphism.
hyloM :: (Applicative m, Monad m, Traversable t)
    => (t b -> m b) -> (a -> m (t a)) -> (a -> m b)
hyloM :: (t b -> m b) -> (a -> m (t a)) -> a -> m b
hyloM phi :: t b -> m b
phi psi :: a -> m (t a)
psi = ((t b -> m b) -> Fix t -> m b
forall (m :: * -> *) (t :: * -> *) a.
(Applicative m, Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
cataM t b -> m b
phi (Fix t -> m b) -> m (Fix t) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (Fix t) -> m b) -> (a -> m (Fix t)) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (t a)) -> a -> m (Fix t)
forall (m :: * -> *) (t :: * -> *) a.
(Applicative m, Monad m, Traversable t) =>
(a -> m (t a)) -> a -> m (Fix t)
anaM a -> m (t a)
psi