Fix

Fix.hs

{-# LANGUAGE RankNTypes, ScopedTypeVariables, DeriveTraversable, PatternSynonyms, UndecidableInstances, FlexibleInstances, ViewPatterns, InstanceSigs #-}

module Fix where

import Control.Monad (ap, join, (<=<))
import Control.Applicative (empty, Alternative, (<|>))
import Control.Arrow
import Data.Functor.Compose

-- Free f a = Mu x. a + f x
-- Cofree f a = Nu x. a * f x
-- Mu < Fix  < Nu

newtype Fix f = Fix (f (Fix f))

unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f

cata :: Functor f => (f b -> b) -> Fix f -> b
cata alg = alg . fmap (cata alg) . unfix

cataM :: (Traversable t, Monad f) => (t b -> f b) -> Fix t -> f b
cataM alg = alg <=< traverse (cataM' alg) . unfix

ana :: Functor f => (a -> f a) -> a -> Fix f
ana coalg = Fix . fmap (ana coalg) . coalg

anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f)
anaM f = fmap Fix . traverse (anaM f) <=< f

futu :: Functor f => (a -> f (Free f a)) -> a -> Fix f
futu coalg t = ana go (Free(Fix(ReturnF t))) where
    go (Free(Fix(ReturnF a))) = coalg a
    go (Free(Fix(BindF fa))) = fmap Free fa

futuM :: (Traversable f, Monad m) => (a -> m (f (Free f a))) -> a -> m (Fix f)
futuM coalg t = anaM go (Free(Fix(ReturnF t))) where
    go (Free(Fix(ReturnF a)))  = coalg a
    go (Free(Fix(BindF fa))) = return (fmap Free fa)

histo :: Functor f => (f (Cofree f a) -> a) -> Fix f -> a
histo h = unfix >>> fmap worker >>> h where  
    worker t = Cofree(Fix(CoBindF (histo h t) (fmap (uncofree . worker) (unfix t))))

histoM :: (Traversable f, Comonad m, Monad m) => (f (Cofree f a) -> m a) -> Fix f -> m a
histoM f = ?

chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b
chrono f g = histo f . futu g

chronoM :: (Traversable f, Comonad m, Monad m) => (f (Cofree f b) -> m b) -> (a -> m (f (Free f a))) -> a -> m b
chronoM f g = histoM f <=< futuM g

hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
hylo f g = h where h = f . fmap h . g

hyloM :: (Traversable t, Monad m) => (t b -> m b) -> (a -> m (t a)) -> a -> m b
hyloM f g = f <=< traverse (hyloM f g) <=< g
    
data CofreeF f a r = CoBindF a (f r) deriving (Functor, Foldable, Traversable)

data FreeF f a r = ReturnF a | BindF (f r) deriving (Functor, Foldable, Traversable)

newtype Free f a = Free(Fix(FreeF f a))

newtype Cofree f a = Cofree(Fix(CofreeF f a))

unfree :: Free f a -> Fix (FreeF f a)
unfree (Free v) = v

uncofree :: Cofree f a -> Fix (CofreeF f a)
uncofree (Cofree v) = v

_unwrap :: Cofree a b -> a (Fix (CofreeF a b))
_unwrap (Cofree(Fix(CoBindF _ as))) = as

unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a
unfold f c = case f c of
  (x, d) -> Cofree(Fix(CoBindF x (fmap (uncofree . unfold f) d)))

instance Functor f => Functor (Cofree f) where
    fmap :: (a -> b) -> Cofree f a -> Cofree f b
    fmap f = Cofree . go . uncofree where
        go (Fix (CoBindF a as)) = Fix (CoBindF (f a) (fmap go as))

instance Alternative f => Monad (Cofree f) where
    return a = Cofree (Fix (CoBindF a empty))
    (Cofree(Fix(CoBindF a m))) >>= f = case f a of
        (Cofree(Fix(CoBindF b n))) -> Cofree(Fix(CoBindF b (fmap uncofree ((fmap Cofree n) <|> (fmap ((>>= f) . Cofree) m)))))   

instance Alternative f => Applicative(Cofree f) where
    pure = return
    (<*>) = ap  

instance Functor f => Comonad (Cofree f) where
    duplicate :: Cofree f a -> Cofree f (Cofree f a)
    duplicate w = Cofree(Fix(CoBindF w (fmap (uncofree . duplicate . Cofree) (_unwrap w))))
    extract (Cofree(Fix(CoBindF a _))) = a

instance Foldable f => Foldable (Cofree f) where
    foldMap f = go . uncofree where
        go (Fix(CoBindF a as)) = f a `mappend` foldMap go as

instance Traversable f => Traversable (Cofree f) where
    traverse f = fmap Cofree . go . uncofree where
        go (Fix (CoBindF a as)) = (\x y -> Fix(CoBindF x y)) <$> f a <*> traverse go as

liftF :: Functor f => f a -> Free f a
liftF c = Free (Fix (BindF $ fmap (unfree . Free . Fix . ReturnF) c))

instance Functor f => Functor (Free f) where
    fmap :: (a -> b) -> Free f a -> Free f b
    fmap f = Free . cata go . unfree where
        go (ReturnF a) = Fix (ReturnF (f a))
        go (BindF   a) = Fix (BindF a)

instance Functor f => Applicative(Free f) where
    pure = return
    (<*>) = ap    

instance Functor f => Monad (Free f) where
    return a = Free (Fix (ReturnF a))
    x >>= f = Free $ go $ unfree x where
                go (Fix (ReturnF a)) = unfree $ f a
                go (Fix (BindF a)) = Fix . BindF $ fmap go a
  
retract :: (Monad f, Traversable f) => Free f b -> f b
retract = cataM alg . unfree where
    alg (ReturnF a) = return a
    alg (BindF as) = as