57 lines
2.3 KiB
Haskell
57 lines
2.3 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Blog
|
|
( runBlogT
|
|
) where
|
|
|
|
-------------------------------------------------------------------------------
|
|
import Control.Monad.Base (MonadBase (..))
|
|
import Control.Monad.Logger (MonadLogger, NoLoggingT (..))
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
|
|
MonadTransControl (..),
|
|
defaultLiftBaseWith,
|
|
defaultRestoreM)
|
|
import Database.Persist.Postgresql (ConnectionString)
|
|
-------------------------------------------------------------------------------
|
|
|
|
|
|
newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a }
|
|
deriving (Functor, Applicative, Monad, MonadLogger, MonadReader ConnectionString, MonadIO)
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
instance MonadTrans BlogT where
|
|
lift = BlogT . lift . lift
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
deriving instance (MonadBase b m) => MonadBase b (BlogT m)
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where
|
|
type StM (BlogT m) a = ComposeSt BlogT m a
|
|
liftBaseWith = defaultLiftBaseWith
|
|
restoreM = defaultRestoreM
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
instance MonadTransControl BlogT where
|
|
type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a)
|
|
liftWith f = BlogT $ liftWith $ \run ->
|
|
liftWith $ \run' ->
|
|
f (run' . run . unBlogT)
|
|
restoreT = BlogT . restoreT . restoreT
|
|
|
|
|
|
-------------------------------------------------------------------------------
|
|
runBlogT :: ConnectionString -> BlogT m a -> m a
|
|
runBlogT backend (BlogT m) =
|
|
runReaderT (runNoLoggingT m) backend
|