{-# 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 (mapReaderT)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadMask, MonadCatch)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Random.Class (MonadRandom)
import Control.Monad.Morph (MFunctor, MMonad)
  
import Yesod.Core.Types.Instances.Catch ()


deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site)
deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site)
deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site)

deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site)
deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site)
deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site)

deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site)
deriving via (ReaderT (HandlerData sub site) IO) instance MonadRandom (SubHandlerFor sub site)
deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site)


-- | 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
                   , MonadUnliftIO
                   )
  deriving newtype ( MFunctor, MMonad, MonadTrans )

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


-- | 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' |]


instance site ~ site' => ToWidget site (SomeMessage site') where
  toWidget msg = toWidget =<< (getMessageRender <*> pure msg)


deriving instance Generic AuthResult
instance Binary AuthResult
instance NFData AuthResult
