{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Boots.Internal.Plugin(
Plugin
, runPlugin
, promote
, withPlugin
, mapPlugin
, bracketP
) where
import Control.Monad.Catch
import Control.Monad.Cont
import Control.Monad.Reader
newtype Plugin i m u = Plugin { unPlugin :: ReaderT i (ContT () m) u }
deriving (Functor, Applicative, Monad, MonadReader i, MonadIO)
runPlugin :: i -> Plugin i m u -> (u -> m ()) -> m ()
runPlugin i pma = runContT (runReaderT (unPlugin pma) i)
instance MonadTrans (Plugin i) where
lift = Plugin . lift . lift
instance MonadThrow m => MonadThrow (Plugin i m) where
throwM = lift . throwM
instance Monad m => MonadCont (Plugin i m) where
callCC a = do
i <- ask
Plugin . lift . ContT . runPlugin i $ callCC a
promote :: i -> Plugin i m u -> Plugin x m u
promote i pimu = Plugin $ lift $ ContT (runPlugin i pimu)
withPlugin :: (i -> j) -> Plugin j m u -> Plugin i m u
withPlugin f = Plugin . withReaderT f . unPlugin
mapPlugin :: (m () -> m ()) -> Plugin i m u -> Plugin i m u
mapPlugin f = Plugin . mapReaderT (mapContT f) . unPlugin
bracketP
:: MonadCatch m
=> m u
-> (u -> m ())
-> Plugin i m u
bracketP op cl = Plugin $ lift $ withContT go (lift op)
where
{-# INLINE go #-}
go f u = do
v <- try (f u)
cl u
case v of
Left e -> throwM (e :: SomeException)
Right x -> return x