51 lines
1.6 KiB
Haskell
51 lines
1.6 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Control.Monad.Trans.Memo.StateCache.Instances
|
|
( hoistStateCache
|
|
) where
|
|
|
|
import ClassyPrelude hiding (handle)
|
|
import Yesod.Core
|
|
import Control.Monad.Logger (MonadLoggerIO)
|
|
import Control.Monad.Trans.Memo.StateCache
|
|
import Control.Monad.Catch
|
|
|
|
|
|
instance MonadResource m => MonadResource (StateCache c m) where
|
|
liftResourceT = lift . liftResourceT
|
|
|
|
instance MonadLogger m => MonadLogger (StateCache c m)
|
|
instance MonadLoggerIO m => MonadLoggerIO (StateCache c m)
|
|
|
|
instance MonadHandler m => MonadHandler (StateCache c m) where
|
|
type HandlerSite (StateCache c m) = HandlerSite m
|
|
type SubHandlerSite (StateCache c m) = SubHandlerSite m
|
|
|
|
liftHandler = lift . liftHandler
|
|
liftSubHandler = lift . liftSubHandler
|
|
|
|
instance MonadWidget m => MonadWidget (StateCache c m) where
|
|
liftWidget = lift . liftWidget
|
|
|
|
instance MonadThrow m => MonadThrow (StateCache c m) where
|
|
throwM = lift . throwM
|
|
|
|
-- | Rolls back modifications to state in failing section
|
|
instance MonadCatch m => MonadCatch (StateCache c m) where
|
|
catch m h = do
|
|
s <- container
|
|
(x, s') <- lift . handle (flip runStateCache s . h) $ runStateCache m s
|
|
x <$ setContainer s'
|
|
|
|
hoistStateCache :: forall m n c b.
|
|
Monad n
|
|
=> (forall a. m a -> n a)
|
|
-> (StateCache c m b -> StateCache c n b)
|
|
-- ^ Morally identical to `Control.Monad.Morph.hoist`
|
|
--
|
|
-- Due to limited exports from `Control.Monad.Trans.Memo.StateCache` we incur a @Monad n@ constraint which `Control.Monad.Morph.hoist` does not account for
|
|
hoistStateCache nat m = do
|
|
s <- container
|
|
(x, s') <- lift . nat $ runStateCache m s
|
|
x <$ setContainer s'
|