module Boots.Internal.Plugin(
boot
, Plugin
, runPlugin
, promote
, combine
, withPlugin
, mapPlugin
, isoPlugin
, bracketP
, wrapP
) 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)
boot :: Monad m => Plugin () m (m ()) -> m ()
boot plugin = runPlugin () plugin id
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)
combine :: [Plugin i m i] -> Plugin i m i
combine = foldl (\b a -> b >>= \i -> promote i a) ask
withPlugin :: (i -> j) -> Plugin j m u -> Plugin i m u
withPlugin f = Plugin . withReaderT f . unPlugin
isoPlugin :: (m () -> n ()) -> (n () -> m ()) -> Plugin i n u -> Plugin i m u
isoPlugin f g = Plugin . mapReaderT go . unPlugin
where
go (ContT fnc) = ContT $ \mc -> g $ fnc (f . mc)
mapPlugin :: (m () -> m ()) -> Plugin i m u -> Plugin i m u
mapPlugin f = Plugin . mapReaderT (mapContT f) . unPlugin
wrapP :: ((u -> m ()) -> m ()) -> Plugin i m u
wrapP = Plugin . lift . ContT
bracketP
:: forall m i u. 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
_ <- try $ cl u :: m (Either SomeException ())
case v of
Left e -> throwM (e :: SomeException)
Right x -> return x