{-# LANGUAGE CPP #-}
module Boots.Factory(
Factory
, running
, boot
, withFactory
, within
, polish
, natTrans
, wrap
, bracket
, offer
, delay
, (C.>>>)
, (C.<<<)
, (<>)
, MonadThrow(..)
, MonadCatch
, MonadReader(..)
, asks
, MonadIO(..)
, lift
) where
import qualified Control.Category as C
import Control.Monad.Catch hiding (bracket)
import Control.Monad.Cont
import Control.Monad.Reader
import Unsafe.Coerce (unsafeCoerce)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
newtype Factory m env component
= Factory { unFactory :: ReaderT env (ContT () m) component }
deriving (Functor, Applicative, Monad, MonadReader env, MonadIO)
instance MonadThrow m => MonadThrow (Factory m env) where
{-# INLINE throwM #-}
throwM = offer . throwM
instance Monad m => MonadCont (Factory m env) where
{-# INLINE callCC #-}
callCC a = do
env <- ask
wrap . running env $ callCC a
instance Semigroup (Factory m env env) where
{-# INLINE (<>) #-}
a <> b = a >>= (`within` b)
instance Monoid (Factory m env env) where
{-# INLINE mempty #-}
mempty = ask
{-# INLINE mappend #-}
mappend = (<>)
instance C.Category (Factory m) where
{-# INLINE id #-}
id = ask
{-# INLINE (.) #-}
a . b = b >>= (`within` a)
running :: env -> Factory m env c -> (c -> m ()) -> m ()
running env pma = runContT (runReaderT (unFactory pma) env)
{-# INLINE running #-}
boot :: Monad m => Factory m () (m ()) -> m ()
boot factory = running () factory id
withFactory :: (env' -> env) -> Factory m env component -> Factory m env' component
withFactory = unsafeCoerce withReaderT
{-# INLINE withFactory #-}
within :: env -> Factory m env component -> Factory m env' component
within = withFactory . const
{-# INLINE within #-}
polish :: component -> [Factory m component component] -> Factory m env' component
polish env = within env . mconcat
{-# INLINE polish #-}
natTrans :: (n () -> m ()) -> (m () -> n ()) -> Factory n env component -> Factory m env component
natTrans fnm fmn fac = do
env <- ask
wrap $ \fm -> fnm $ running env fac (fmn . fm)
{-# INLINE natTrans #-}
wrap :: ((c -> m ()) -> m ()) -> Factory m env c
wrap = Factory . lift . ContT
{-# INLINE wrap #-}
bracket :: MonadCatch m => m res -> (res -> m ()) -> Factory m env res
bracket open close = wrap $ \f -> do
res <- open
a <- try $ f res
b <- try $ close res
go a b
where
go (Left e) _ = throwM (e :: SomeException)
go _ (Left e) = throwM (e :: SomeException)
go _ _ = return ()
{-# INLINE go #-}
{-# INLINE bracket #-}
offer :: Monad m => m a -> Factory m env a
offer ma = wrap (ma >>=)
{-# INLINE offer #-}
delay :: MonadCatch m => m () -> Factory m env ()
delay ma = bracket (return ()) (const ma)
{-# INLINE delay #-}