module Control.Effects (module Control.Effects) where
import Import hiding (liftThrough)
import Control.Monad.Runnable
import Control.Effects.Generic
import GHC.Generics
class Effect e where
data EffMethods e (m :: * -> *) :: *
type CanLift e (t :: (* -> *) -> * -> *) :: Constraint
type CanLift e t = MonadTrans t
liftThrough ::
forall t m. (CanLift e t, Monad m, Monad (t m))
=> EffMethods e m -> EffMethods e (t m)
default liftThrough ::
forall t m.
( Generic (EffMethods e m), MonadTrans t, Monad m, Monad (t m)
, SimpleMethods (EffMethods e) m t )
=> EffMethods e m -> EffMethods e (t m)
liftThrough = genericLiftThrough
mergeContext :: Monad m => m (EffMethods e m) -> EffMethods e m
default mergeContext ::
(Generic (EffMethods e m), MonadicMethods (EffMethods e) m)
=> m (EffMethods e m) -> EffMethods e m
mergeContext = genericMergeContext
class (Effect e, Monad m) => MonadEffect e m where
effect :: EffMethods e m
instance
(MonadEffect e m, Monad (t m), CanLift e t)
=> MonadEffect e (t m) where
effect = liftThrough effect
newtype RuntimeImplemented e m a = RuntimeImplemented
{ getRuntimeImplemented :: ReaderT (EffMethods e m) m a }
deriving
(Functor, Applicative, Monad, MonadPlus, Alternative, MonadState s, MonadIO, MonadCatch
, MonadThrow, MonadRandom )
instance MonadTrans (RuntimeImplemented e) where
lift = RuntimeImplemented . lift
instance MonadReader r m => MonadReader r (RuntimeImplemented e m) where
ask = RuntimeImplemented (lift ask)
local f (RuntimeImplemented rdr) = RuntimeImplemented (ReaderT (local f . runReaderT rdr))
deriving instance MonadBase b m => MonadBase b (RuntimeImplemented e m)
instance MonadBaseControl b m => MonadBaseControl b (RuntimeImplemented e m) where
type StM (RuntimeImplemented e m) a = StM (ReaderT (EffMethods e m) m) a
liftBaseWith f = RuntimeImplemented $ liftBaseWith $ \q -> f (q . getRuntimeImplemented)
restoreM = RuntimeImplemented . restoreM
instance RunnableTrans (RuntimeImplemented e) where
type TransformerResult (RuntimeImplemented e) m a = a
type TransformerState (RuntimeImplemented e) m = EffMethods e m
currentTransState = RuntimeImplemented ask
restoreTransState = return
runTransformer (RuntimeImplemented m) = runReaderT m
instance (Effect e, Monad m, CanLift e (RuntimeImplemented e))
=> MonadEffect e (RuntimeImplemented e m) where
effect = mergeContext $ RuntimeImplemented (liftThrough <$> ask)
implement :: forall e m a. EffMethods e m -> RuntimeImplemented e m a -> m a
implement em (RuntimeImplemented r) = runReaderT r em
type family MonadEffects effs m :: Constraint where
MonadEffects '[] m = ()
MonadEffects (eff ': effs) m = (MonadEffect eff m, MonadEffects effs m)