{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}

module Yesod.Core.Types.Instances
  ( CachedMemoT
  , runCachedMemoT
  ) where

import ClassyPrelude.Yesod
import Yesod.Core.Types

import Control.Monad.Fix

import Control.Monad.Memo

import Data.Binary (Binary)

import Control.Monad.Logger (MonadLoggerIO)

import Utils

import Language.Haskell.TH

import Control.Monad.Reader (MonadReader(..))
import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT)
  

instance MonadFix m => MonadFix (HandlerT site m) where
  mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
  
instance MonadFix m => MonadFix (WidgetT site m) where
  mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r


-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
  deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
                   , MonadIO
                   , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
                   , MonadResource, MonadHandler, MonadWidget
                   )

deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)

instance MonadReader r m => MonadReader r (CachedMemoT k v m) where
  reader = CachedMemoT . lift . reader
  local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act

instance MonadTrans (CachedMemoT k v) where
  lift = CachedMemoT . lift


-- | Uses `cachedBy` with a `Binary`-encoded @k@
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
  memo act key = do
    loc <- CachedMemoT ask
    cachedByBinary (loc, key) $ act key

runCachedMemoT :: Q Exp
runCachedMemoT = do
  loc <- location
  [e| flip runReaderT loc . runCachedMemoT' |]
