module Control.Monad.Levels.Writer
( writer
, tell
, HasWriter
, listen
, CanListen
, ListenFn
, pass
, CanPass
, PassFn
, IsWriter
) where
import Control.Monad.Levels
import Control.Monad.Levels.Constraints
import Control.Arrow (second)
import Data.Monoid (Endo (..), Monoid (..))
import qualified Control.Monad.Trans.RWS.Lazy as LRWS
import qualified Control.Monad.Trans.RWS.Strict as SRWS
import qualified Control.Monad.Trans.Writer.Lazy as LW
import qualified Control.Monad.Trans.Writer.Strict as SW
class (Monoid w, MonadTower m) => IsWriter w m where
_writer :: (a,w) -> m a
_listen :: m a -> m (a,w)
_pass :: m (a, w -> w) -> m a
instance (Monoid w, MonadTower m) => IsWriter w (LW.WriterT w m) where
_writer = LW.writer
_listen = LW.listen
_pass = LW.pass
instance (Monoid w, MonadTower m) => IsWriter w (SW.WriterT w m) where
_writer = SW.writer
_listen = SW.listen
_pass = SW.pass
instance (Monoid w, MonadTower m) => IsWriter w (LRWS.RWST r w s m) where
_writer = LRWS.writer
_listen = LRWS.listen
_pass = LRWS.pass
instance (Monoid w, MonadTower m) => IsWriter w (SRWS.RWST r w s m) where
_writer = SRWS.writer
_listen = SRWS.listen
_pass = SRWS.pass
instance (Monoid w) => ValidConstraint (IsWriter w) where
type ConstraintSatisfied (IsWriter w) m = SameWriter w m
type family SameWriter w m where
SameWriter w (LW.WriterT w m) = True
SameWriter w (SW.WriterT w m) = True
SameWriter w (LRWS.RWST r w s m) = True
SameWriter w (SRWS.RWST r w s m) = True
SameWriter w m = False
type HasWriter w m = (Monoid w, SatisfyConstraint (IsWriter w) m)
writer :: forall w m a. (HasWriter w m) => (a,w) -> m a
writer = liftSat (Proxy :: Proxy (IsWriter w)) . _writer
tell :: (HasWriter w m) => w -> m ()
tell = writer . ((),)
type CanListen w m a = SatisfyConstraintF (IsWriter w) m a (ListenFn w)
type ListenFn w = Func MonadicValue (MkVarFnFrom (MonadicTuple w))
listen :: forall w m a. (CanListen w m a) => m a -> m (a,w)
listen = lowerSat c f m a _listen
where
c :: Proxy (IsWriter w)
c = Proxy
f :: Proxy (ListenFn w)
f = Proxy
m :: Proxy m
m = Proxy
a :: Proxy a
a = Proxy
type CanPass w m a = SatisfyConstraintF (IsWriter w) m a (PassFn w)
type PassFn w = MkVarFn (MonadicTuple (Endo w))
pass :: forall w m a. (CanPass w m a) => m (a, w -> w) -> m a
pass = lowerSat c f m a (_pass . fmap (second appEndo)) . fmap (second Endo)
where
c :: Proxy (IsWriter w)
c = Proxy
f :: Proxy (PassFn w)
f = Proxy
m :: Proxy m
m = Proxy
a :: Proxy a
a = Proxy