module Control.Effects1 where
import Interlude hiding (msg)
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Base
import Control.Monad.Runnable
type family EffectMsg1 eff :: * -> *
type family EffectRes1 eff :: * -> *
type family EffectCon1 eff a :: Constraint
class Monad m => MonadEffect1 eff m where
effect1 :: EffectCon1 eff a => proxy eff -> EffectMsg1 eff a -> m (EffectRes1 eff a)
newtype EffHandling1 eff m = EffHandling1 {
getHandling1 :: forall a. EffectCon1 eff a => EffectMsg1 eff a -> m (EffectRes1 eff a) }
newtype EffectHandler1 eff m a = EffectHandler1
{ unpackEffectHandler1 :: ReaderT (EffHandling1 eff m) m a }
deriving ( Functor, Applicative, Monad, Alternative, MonadState s, MonadIO, MonadCatch
, MonadThrow, MonadRandom )
instance MonadTrans (EffectHandler1 eff) where
lift = EffectHandler1 . lift
instance RunnableTrans (EffectHandler1 eff) where
type TransformerState (EffectHandler1 eff) m = EffHandling1 eff m
type TransformerResult (EffectHandler1 eff) m a = a
currentTransState = EffectHandler1 ask
restoreTransState = return
runTransformer m = runReaderT (unpackEffectHandler1 m)
instance MonadReader s m => MonadReader s (EffectHandler1 eff m) where
ask = EffectHandler1 (lift ask)
local f (EffectHandler1 rdr) = EffectHandler1 (ReaderT $ local f . runReaderT rdr)
deriving instance MonadBase IO m => MonadBase IO (EffectHandler1 eff m)
instance MonadBaseControl IO m => MonadBaseControl IO (EffectHandler1 eff m) where
type StM (EffectHandler1 eff m) a = StM (ReaderT (EffHandling1 eff m) m) a
liftBaseWith f = EffectHandler1 $ liftBaseWith $ \q -> f (q . unpackEffectHandler1)
restoreM = EffectHandler1 . restoreM
instance (MonadEffect1 eff m, MonadTrans t, Monad (t m))
=> MonadEffect1 eff (t m) where
effect1 p msg = lift (effect1 p msg)
instance Monad m => MonadEffect1 eff (EffectHandler1 eff m) where
effect1 _ msg = EffectHandler1 (ReaderT (($ msg) . getHandling1))
handleEffect1 :: (forall a. EffectCon1 eff a => EffectMsg1 eff a -> m (EffectRes1 eff a))
-> EffectHandler1 eff m b -> m b
handleEffect1 f eh = runReaderT (unpackEffectHandler1 eh) (EffHandling1 f)