module Algebra.Monad.Free where
import Algebra.Monad.Base
import Unsafe.Coerce (unsafeCoerce)
data Free f a = Join (f (Free f a))
| Pure a
deriving instance (Show (f (Free f a)),Show a) => Show (Free f a)
instance Functor f => Functor (Free f) where
map f (Join fa) = Join (map2 f fa)
map f (Pure a) = Pure (f a)
instance Unit (Free f) where pure = Pure
instance Functor f => Applicative (Free f)
instance Functor f => Monad (Free f) where
join (Join f) = Join (map join f)
join (Pure f) = f
instance Counit f => Counit (Free f) where
extract (Join f) = extract (extract f)
extract (Pure a) = a
instance Comonad f => Comonad (Free f) where
duplicate (Pure a) = Pure (Pure a)
duplicate (Join f) = Join (f =>> liftF)
instance (Ord (f (Free f a)),Ord a,Unit f) => Eq (Free f a) where
a == b = compare a b == EQ
instance (Ord (f (Free f a)),Ord a,Unit f) => Ord (Free f a) where
compare (Join fa) (Join fb) = compare fa fb
compare (Pure a) (Pure b) = compare a b
compare (Pure a) x = compare (Join (pure (Pure a))) x
compare x (Pure a) = compare x (Join (pure (Pure a)))
instance MonadFix f => MonadFix (Free f) where
mfix f = Join (Pure<$>mfix (\a -> perform (f a)))
instance Foldable f => Foldable (Free f) where
fold (Join f) = foldMap fold f
fold (Pure a) = a
instance Traversable f => Traversable (Free f) where
sequence (Join f) = Join<$>(traverse sequence f)
sequence (Pure a) = Pure<$>a
instance MonadTrans Free where lift = liftF
instance ConcreteMonad Free where
generalize (Join f) = Join ((pure . generalize . getId) f)
generalize (Pure a) = Pure a
instance MonadState s m => MonadState s (Free m) where
get = lift get
put a = lift (put a)
modify f = lift (modify f)
instance MonadReader r m => MonadReader r (Free m) where
ask = lift ask
local f (Join m) = Join (local f m)
local _ (Pure a) = Pure a
instance MonadWriter w m => MonadWriter w (Free m) where
tell w = lift (tell w)
listen m = lift (listen (perform m))
censor m = lift (censor (perform m))
instance MonadCounter w a m => MonadCounter w a (Free m) where
getCounter = lift getCounter
instance MonadIO m => MonadIO (Free m) where
liftIO = lift . liftIO
instance MonadList m => MonadList (Free m) where
fork l = lift (fork l)
instance MonadFuture m t => MonadFuture m (Free t) where
future = lift . future
instance MonadError e m => MonadError e (Free m) where
throw e = lift (throw e)
catch k m = lift (catch (map perform k) (perform m))
concrete :: Monad m => Free m a -> m (Free Id a)
concrete = map Pure . perform
unliftF :: Monad m => Free m a -> Free m (m a)
unliftF = Pure . perform
mapF :: (Functor f,Functor g) => (forall a. f a -> g a) -> Free f b -> Free g b
mapF f (Join a) = Join (f (map (mapF f) a))
mapF _ (Pure a) = Pure a
class MonadFree m f | f -> m where
step :: Monad m => f a -> m (f a)
perform :: Monad m => f a -> m a
liftF :: Functor m => m a -> f a
instance MonadFree m (Free m) where
step (Join j) = j
step (Pure a) = pure (Pure a)
perform (Join fa) = fa >>= perform
perform (Pure a) = pure a
liftF = Join . map Pure
coerceStep :: forall m f g a. (Monad m,MonadFree m f) => (f a -> g a) -> (g a -> m (g a))
coerceStep _ = unsafeCoerce (step :: f a -> m (f a))
coercePerform :: forall m f g a. (Monad m,MonadFree m f) => (f a -> g a) -> (g a -> m a)
coercePerform _ = unsafeCoerce (perform :: f a -> m a)
coerceLiftF :: forall m f g a. (Functor m,MonadFree m f) => (f a -> g a) -> (m a -> g a)
coerceLiftF _ = unsafeCoerce (liftF :: m a -> f a)
data Cofree w a = Step a (w (Cofree w a))
type Infinite a = Cofree Id a
type Colist a = Cofree Maybe a
instance Functor w => Functor (Cofree w) where
map f (Step a wca) = Step (f a) (map2 f wca)
instance Counit (Cofree w) where
extract (Step a _) = a
instance Functor w => Comonad (Cofree w) where
duplicate d@(Step _ wca) = Step d (map duplicate wca)
instance Foldable w => Foldable (Cofree w) where
fold (Step a wca) = a + foldMap fold wca
instance Traversable w => Traversable (Cofree w) where
sequence (Step fa wcfa) = Step<$>fa<*>traverse sequence wcfa
instance Unit m => Unit (Cofree m) where
pure a = Step a (pure (pure a))
instance Applicative m => Applicative (Cofree m) where
instance Applicative m => Monad (Cofree m) where
join (Step (Step a _) ww) = Step a (map join ww)
type Bifree f a = Cofree (Free f) a
newtype ContC k a b = ContC { runContC :: forall c. k b c -> k a c }
contC :: (Category k,Category k') => Iso (ContC k a b) (ContC k' a' b') (k a b) (k' a' b')
contC = iso (\x -> ContC (x >>>)) (($id) . runContC)
instance Deductive (ContC k) where
ContC cxbx . ContC bxax = ContC (\kcx -> bxax (cxbx kcx))
instance Category (ContC k) where
id = ContC id