{-# 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'