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

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

import ClassyPrelude.Yesod
import Yesod.Core.Types

import Control.Monad.Fix

import Control.Monad.Memo

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Control.Monad.Logger (MonadLoggerIO)
  

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 :: m a }
  deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
                   , MonadIO
                   , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
                   , MonadResource, MonadHandler, MonadWidget
                   , IsString, Semigroup, Monoid
                   )

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

deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)

instance MonadTrans (CachedMemoT k v) where
  lift = CachedMemoT


-- | 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 = cachedBy (toStrict $ Binary.encode key) $ act key
