{-# LANGUAGE Safe #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Object.Mortal
-- Copyright   :  (c) Fumiaki Kinoshita 2015
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-----------------------------------------------------------------------------
module Control.Object.Mortal (
    Mortal(..),
    mortal,
    mortal_,
    runMortal,
    immortal,
    apprises,
    apprise
    ) where

import Control.Object.Object
import Control.Monad.Trans.Except
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.Strict
import Data.Bifunctor
import Data.Monoid
import Witherable
import Data.Tuple (swap)

-- | A 'Mortal' is an object that may die.
-- A mortal yields a final result upon death.
-- @'Mortal' f g@ forms a 'Monad':
-- 'return' is a dead object and ('>>=') prolongs the life of the left object.
--
-- @Object f g ≡ Mortal f g Void@
--
newtype Mortal f g a = Mortal { Mortal f g a -> Object f (ExceptT a g)
unMortal :: Object f (ExceptT a g) }

instance Monad m => Functor (Mortal f m) where
  fmap :: (a -> b) -> Mortal f m a -> Mortal f m b
fmap a -> b
f (Mortal Object f (ExceptT a m)
obj) = Object f (ExceptT b m) -> Mortal f m b
forall (f :: * -> *) (g :: * -> *) a.
Object f (ExceptT a g) -> Mortal f g a
Mortal (Object f (ExceptT a m)
obj Object f (ExceptT a m)
-> (forall x. ExceptT a m x -> ExceptT b m x)
-> Object f (ExceptT b m)
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f g -> (forall x. g x -> h x) -> Object f h
@>>^ (m (Either a x) -> m (Either b x))
-> ExceptT a m x -> ExceptT b m x
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((Either a x -> Either b x) -> m (Either a x) -> m (Either b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either a x -> Either b x
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)))
  {-# INLINE fmap #-}

instance Monad m => Applicative (Mortal f m) where
  pure :: a -> Mortal f m a
pure a
a = (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
mortal ((forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a)
-> (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
forall a b. (a -> b) -> a -> b
$ ExceptT a m (x, Mortal f m a)
-> f x -> ExceptT a m (x, Mortal f m a)
forall a b. a -> b -> a
const (ExceptT a m (x, Mortal f m a)
 -> f x -> ExceptT a m (x, Mortal f m a))
-> ExceptT a m (x, Mortal f m a)
-> f x
-> ExceptT a m (x, Mortal f m a)
forall a b. (a -> b) -> a -> b
$ a -> ExceptT a m (x, Mortal f m a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE a
a
  {-# INLINE pure #-}
  <*> :: Mortal f m (a -> b) -> Mortal f m a -> Mortal f m b
(<*>) = Mortal f m (a -> b) -> Mortal f m a -> Mortal f m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance Monad m => Monad (Mortal f m) where
  Mortal f m a
m >>= :: Mortal f m a -> (a -> Mortal f m b) -> Mortal f m b
>>= a -> Mortal f m b
k = (forall x. f x -> ExceptT b m (x, Mortal f m b)) -> Mortal f m b
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
mortal ((forall x. f x -> ExceptT b m (x, Mortal f m b)) -> Mortal f m b)
-> (forall x. f x -> ExceptT b m (x, Mortal f m b)) -> Mortal f m b
forall a b. (a -> b) -> a -> b
$ \f x
f -> m (Either a (x, Mortal f m a))
-> ExceptT b m (Either a (x, Mortal f m a))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT a m (x, Mortal f m a) -> m (Either a (x, Mortal f m a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT a m (x, Mortal f m a) -> m (Either a (x, Mortal f m a)))
-> ExceptT a m (x, Mortal f m a) -> m (Either a (x, Mortal f m a))
forall a b. (a -> b) -> a -> b
$ Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
forall (m :: * -> *) (f :: * -> *) a x.
Monad m =>
Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
runMortal Mortal f m a
m f x
f) ExceptT b m (Either a (x, Mortal f m a))
-> (Either a (x, Mortal f m a) -> ExceptT b m (x, Mortal f m b))
-> ExceptT b m (x, Mortal f m b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left a
a -> Mortal f m b -> f x -> ExceptT b m (x, Mortal f m b)
forall (m :: * -> *) (f :: * -> *) a x.
Monad m =>
Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
runMortal (a -> Mortal f m b
k a
a) f x
f
    Right (x
x, Mortal f m a
m') -> (x, Mortal f m b) -> ExceptT b m (x, Mortal f m b)
forall (m :: * -> *) a. Monad m => a -> m a
return (x
x, Mortal f m a
m' Mortal f m a -> (a -> Mortal f m b) -> Mortal f m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Mortal f m b
k)

instance MonadTrans (Mortal f) where
  lift :: m a -> Mortal f m a
lift m a
m = (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
mortal ((forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a)
-> (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
forall a b. (a -> b) -> a -> b
$ ExceptT a m (x, Mortal f m a)
-> f x -> ExceptT a m (x, Mortal f m a)
forall a b. a -> b -> a
const (ExceptT a m (x, Mortal f m a)
 -> f x -> ExceptT a m (x, Mortal f m a))
-> ExceptT a m (x, Mortal f m a)
-> f x
-> ExceptT a m (x, Mortal f m a)
forall a b. (a -> b) -> a -> b
$ m (Either a (x, Mortal f m a)) -> ExceptT a m (x, Mortal f m a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either a (x, Mortal f m a)) -> ExceptT a m (x, Mortal f m a))
-> m (Either a (x, Mortal f m a)) -> ExceptT a m (x, Mortal f m a)
forall a b. (a -> b) -> a -> b
$ (a -> Either a (x, Mortal f m a))
-> m a -> m (Either a (x, Mortal f m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a (x, Mortal f m a)
forall a b. a -> Either a b
Left m a
m
  {-# INLINE lift #-}

-- | Construct a mortal in a 'Object' construction manner.
mortal :: Monad m => (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
mortal :: (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a
mortal forall x. f x -> ExceptT a m (x, Mortal f m a)
f = Object f (ExceptT a m) -> Mortal f m a
forall (f :: * -> *) (g :: * -> *) a.
Object f (ExceptT a g) -> Mortal f g a
Mortal ((forall x. f x -> ExceptT a m (x, Object f (ExceptT a m)))
-> Object f (ExceptT a m)
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object (((x, Mortal f m a) -> (x, Object f (ExceptT a m)))
-> ExceptT a m (x, Mortal f m a)
-> ExceptT a m (x, Object f (ExceptT a m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Mortal f m a -> Object f (ExceptT a m))
-> (x, Mortal f m a) -> (x, Object f (ExceptT a m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mortal f m a -> Object f (ExceptT a m)
forall (f :: * -> *) (g :: * -> *) a.
Mortal f g a -> Object f (ExceptT a g)
unMortal) (ExceptT a m (x, Mortal f m a)
 -> ExceptT a m (x, Object f (ExceptT a m)))
-> (f x -> ExceptT a m (x, Mortal f m a))
-> f x
-> ExceptT a m (x, Object f (ExceptT a m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> ExceptT a m (x, Mortal f m a)
forall x. f x -> ExceptT a m (x, Mortal f m a)
f))
{-# INLINE mortal #-}

-- | Send a message to a mortal.
runMortal :: Monad m => Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
runMortal :: Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
runMortal Mortal f m a
m f x
f = (Object f (ExceptT a m) -> Mortal f m a)
-> (x, Object f (ExceptT a m)) -> (x, Mortal f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object f (ExceptT a m) -> Mortal f m a
forall (f :: * -> *) (g :: * -> *) a.
Object f (ExceptT a g) -> Mortal f g a
Mortal ((x, Object f (ExceptT a m)) -> (x, Mortal f m a))
-> ExceptT a m (x, Object f (ExceptT a m))
-> ExceptT a m (x, Mortal f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object f (ExceptT a m)
-> f x -> ExceptT a m (x, Object f (ExceptT a m))
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject (Mortal f m a -> Object f (ExceptT a m)
forall (f :: * -> *) (g :: * -> *) a.
Mortal f g a -> Object f (ExceptT a g)
unMortal Mortal f m a
m) f x
f
{-# INLINE runMortal #-}

-- | A smart constructor of 'Mortal' where the result type is restricted to ()
mortal_ :: Object f (ExceptT () g) -> Mortal f g ()
mortal_ :: Object f (ExceptT () g) -> Mortal f g ()
mortal_ = Object f (ExceptT () g) -> Mortal f g ()
forall (f :: * -> *) (g :: * -> *) a.
Object f (ExceptT a g) -> Mortal f g a
Mortal
{-# INLINE mortal_ #-}

-- | Turn an object into a mortal without death.
immortal :: Monad m => Object f m -> Mortal f m x
immortal :: Object f m -> Mortal f m x
immortal Object f m
obj = Object f (ExceptT x m) -> Mortal f m x
forall (f :: * -> *) (g :: * -> *) a.
Object f (ExceptT a g) -> Mortal f g a
Mortal (Object f m
obj Object f m
-> (forall x. m x -> ExceptT x m x) -> Object f (ExceptT x m)
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f g -> (forall x. g x -> h x) -> Object f h
@>>^ forall x. m x -> ExceptT x m x
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift)
{-# INLINE immortal #-}

-- | Send a message to mortals in a 'Witherable' container.
apprises :: (Witherable t, Monad m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r
apprises :: f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r
apprises f a
f a -> r
p b -> r
q = (t (Mortal f m b) -> m (r, t (Mortal f m b)))
-> StateT (t (Mortal f m b)) m r
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((t (Mortal f m b) -> m (r, t (Mortal f m b)))
 -> StateT (t (Mortal f m b)) m r)
-> (t (Mortal f m b) -> m (r, t (Mortal f m b)))
-> StateT (t (Mortal f m b)) m r
forall a b. (a -> b) -> a -> b
$ \t (Mortal f m b)
t -> ((t (Mortal f m b), r) -> (r, t (Mortal f m b)))
-> m (t (Mortal f m b), r) -> m (r, t (Mortal f m b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t (Mortal f m b), r) -> (r, t (Mortal f m b))
forall a b. (a, b) -> (b, a)
swap (m (t (Mortal f m b), r) -> m (r, t (Mortal f m b)))
-> m (t (Mortal f m b), r) -> m (r, t (Mortal f m b))
forall a b. (a -> b) -> a -> b
$ WriterT r m (t (Mortal f m b)) -> m (t (Mortal f m b), r)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT r m (t (Mortal f m b)) -> m (t (Mortal f m b), r))
-> WriterT r m (t (Mortal f m b)) -> m (t (Mortal f m b), r)
forall a b. (a -> b) -> a -> b
$ ((Mortal f m b -> WriterT r m (Maybe (Mortal f m b)))
 -> t (Mortal f m b) -> WriterT r m (t (Mortal f m b)))
-> t (Mortal f m b)
-> (Mortal f m b -> WriterT r m (Maybe (Mortal f m b)))
-> WriterT r m (t (Mortal f m b))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Mortal f m b -> WriterT r m (Maybe (Mortal f m b)))
-> t (Mortal f m b) -> WriterT r m (t (Mortal f m b))
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither t (Mortal f m b)
t
  ((Mortal f m b -> WriterT r m (Maybe (Mortal f m b)))
 -> WriterT r m (t (Mortal f m b)))
-> (Mortal f m b -> WriterT r m (Maybe (Mortal f m b)))
-> WriterT r m (t (Mortal f m b))
forall a b. (a -> b) -> a -> b
$ \Mortal f m b
obj -> m (Maybe (Mortal f m b), r) -> WriterT r m (Maybe (Mortal f m b))
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (Maybe (Mortal f m b), r) -> WriterT r m (Maybe (Mortal f m b)))
-> m (Maybe (Mortal f m b), r)
-> WriterT r m (Maybe (Mortal f m b))
forall a b. (a -> b) -> a -> b
$ ExceptT b m (a, Mortal f m b) -> m (Either b (a, Mortal f m b))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Mortal f m b -> f a -> ExceptT b m (a, Mortal f m b)
forall (m :: * -> *) (f :: * -> *) a x.
Monad m =>
Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)
runMortal Mortal f m b
obj f a
f) m (Either b (a, Mortal f m b))
-> (Either b (a, Mortal f m b) -> m (Maybe (Mortal f m b), r))
-> m (Maybe (Mortal f m b), r)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left b
r -> (Maybe (Mortal f m b), r) -> m (Maybe (Mortal f m b), r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Mortal f m b)
forall a. Maybe a
Nothing, b -> r
q b
r)
    Right (a
x, Mortal f m b
obj') -> (Maybe (Mortal f m b), r) -> m (Maybe (Mortal f m b), r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mortal f m b -> Maybe (Mortal f m b)
forall a. a -> Maybe a
Just Mortal f m b
obj', a -> r
p a
x)
{-# INLINE apprises #-}

-- | Send a message to mortals in a container.
apprise :: (Witherable t, Monad m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])
apprise :: f a -> StateT (t (Mortal f m r)) m ([a], [r])
apprise f a
f = (Endo [a] -> [a])
-> (Endo [r] -> [r]) -> (Endo [a], Endo [r]) -> ([a], [r])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Endo [a] -> [a] -> [a]
forall a. Endo a -> a -> a
`appEndo` []) (Endo [r] -> [r] -> [r]
forall a. Endo a -> a -> a
`appEndo` [])
  ((Endo [a], Endo [r]) -> ([a], [r]))
-> StateT (t (Mortal f m r)) m (Endo [a], Endo [r])
-> StateT (t (Mortal f m r)) m ([a], [r])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
-> (a -> (Endo [a], Endo [r]))
-> (r -> (Endo [a], Endo [r]))
-> StateT (t (Mortal f m r)) m (Endo [a], Endo [r])
forall (t :: * -> *) (m :: * -> *) r (f :: * -> *) a b.
(Witherable t, Monad m, Monoid r) =>
f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r
apprises f a
f (\a
a -> (([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:), Endo [r]
forall a. Monoid a => a
mempty)) (\r
b -> (Endo [a]
forall a. Monoid a => a
mempty, ([r] -> [r]) -> Endo [r]
forall a. (a -> a) -> Endo a
Endo (r
br -> [r] -> [r]
forall a. a -> [a] -> [a]
:)))
{-# INLINE apprise #-}