{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Class.Handler
    ( MonadHandler (..)
    , MonadWidget (..)
    , liftHandlerT
    , liftWidgetT
    ) where

import Yesod.Core.Types
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift)
import Data.Conduit.Internal (Pipe, ConduitM)

import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List     ( ListT    )
import Control.Monad.Trans.Maybe    ( MaybeT   )
import Control.Monad.Trans.Except   ( ExceptT  )
import Control.Monad.Trans.Reader   ( ReaderT  )
import Control.Monad.Trans.State    ( StateT   )
import Control.Monad.Trans.Writer   ( WriterT  )
import Control.Monad.Trans.RWS      ( RWST     )
import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )

-- FIXME should we just use MonadReader instances instead?
class (MonadResource m, MonadLogger m) => MonadHandler m where
    type HandlerSite m
    type SubHandlerSite m
    liftHandler :: HandlerFor (HandlerSite m) a -> m a
    liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a

liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
liftHandlerT :: HandlerFor (HandlerSite m) a -> m a
liftHandlerT = HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}

instance MonadHandler (HandlerFor site) where
    type HandlerSite (HandlerFor site) = site
    type SubHandlerSite (HandlerFor site) = site
    liftHandler :: HandlerFor (HandlerSite (HandlerFor site)) a -> HandlerFor site a
liftHandler = HandlerFor (HandlerSite (HandlerFor site)) a -> HandlerFor site a
forall a. a -> a
id
    {-# INLINE liftHandler #-}
    liftSubHandler :: SubHandlerFor
  (SubHandlerSite (HandlerFor site))
  (HandlerSite (HandlerFor site))
  a
-> HandlerFor site a
liftSubHandler (SubHandlerFor HandlerData
  (SubHandlerSite (HandlerFor site)) (HandlerSite (HandlerFor site))
-> IO a
f) = (HandlerData site site -> IO a) -> HandlerFor site a
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor HandlerData site site -> IO a
HandlerData
  (SubHandlerSite (HandlerFor site)) (HandlerSite (HandlerFor site))
-> IO a
f
    {-# INLINE liftSubHandler #-}

instance MonadHandler (SubHandlerFor sub master) where
    type HandlerSite (SubHandlerFor sub master) = master
    type SubHandlerSite (SubHandlerFor sub master) = sub
    liftHandler :: HandlerFor (HandlerSite (SubHandlerFor sub master)) a
-> SubHandlerFor sub master a
liftHandler (HandlerFor HandlerData
  (HandlerSite (SubHandlerFor sub master))
  (HandlerSite (SubHandlerFor sub master))
-> IO a
f) = (HandlerData sub master -> IO a) -> SubHandlerFor sub master a
forall sub master a.
(HandlerData sub master -> IO a) -> SubHandlerFor sub master a
SubHandlerFor ((HandlerData sub master -> IO a) -> SubHandlerFor sub master a)
-> (HandlerData sub master -> IO a) -> SubHandlerFor sub master a
forall a b. (a -> b) -> a -> b
$ \HandlerData sub master
hd -> HandlerData
  (HandlerSite (SubHandlerFor sub master))
  (HandlerSite (SubHandlerFor sub master))
-> IO a
f HandlerData sub master
hd
      { handlerEnv :: RunHandlerEnv master master
handlerEnv =
          let rhe :: RunHandlerEnv sub master
rhe = HandlerData sub master -> RunHandlerEnv sub master
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv HandlerData sub master
hd
           in RunHandlerEnv sub master
rhe
                { rheRoute :: Maybe (Route master)
rheRoute = (Route sub -> Route master)
-> Maybe (Route sub) -> Maybe (Route master)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RunHandlerEnv sub master -> Route sub -> Route master
forall child site.
RunHandlerEnv child site -> Route child -> Route site
rheRouteToMaster RunHandlerEnv sub master
rhe) (RunHandlerEnv sub master -> Maybe (Route sub)
forall child site. RunHandlerEnv child site -> Maybe (Route child)
rheRoute RunHandlerEnv sub master
rhe)
                , rheRouteToMaster :: Route master -> Route master
rheRouteToMaster = Route master -> Route master
forall a. a -> a
id
                , rheChild :: master
rheChild = RunHandlerEnv sub master -> master
forall child site. RunHandlerEnv child site -> site
rheSite RunHandlerEnv sub master
rhe
                }
      }
    {-# INLINE liftHandler #-}
    liftSubHandler :: SubHandlerFor
  (SubHandlerSite (SubHandlerFor sub master))
  (HandlerSite (SubHandlerFor sub master))
  a
-> SubHandlerFor sub master a
liftSubHandler = SubHandlerFor
  (SubHandlerSite (SubHandlerFor sub master))
  (HandlerSite (SubHandlerFor sub master))
  a
-> SubHandlerFor sub master a
forall a. a -> a
id
    {-# INLINE liftSubHandler #-}

instance MonadHandler (WidgetFor site) where
    type HandlerSite (WidgetFor site) = site
    type SubHandlerSite (WidgetFor site) = site
    liftHandler :: HandlerFor (HandlerSite (WidgetFor site)) a -> WidgetFor site a
liftHandler (HandlerFor HandlerData
  (HandlerSite (WidgetFor site)) (HandlerSite (WidgetFor site))
-> IO a
f) = (WidgetData site -> IO a) -> WidgetFor site a
forall site a. (WidgetData site -> IO a) -> WidgetFor site a
WidgetFor ((WidgetData site -> IO a) -> WidgetFor site a)
-> (WidgetData site -> IO a) -> WidgetFor site a
forall a b. (a -> b) -> a -> b
$ HandlerData site site -> IO a
HandlerData
  (HandlerSite (WidgetFor site)) (HandlerSite (WidgetFor site))
-> IO a
f (HandlerData site site -> IO a)
-> (WidgetData site -> HandlerData site site)
-> WidgetData site
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetData site -> HandlerData site site
forall site. WidgetData site -> HandlerData site site
wdHandler
    {-# INLINE liftHandler #-}
    liftSubHandler :: SubHandlerFor
  (SubHandlerSite (WidgetFor site)) (HandlerSite (WidgetFor site)) a
-> WidgetFor site a
liftSubHandler (SubHandlerFor HandlerData
  (SubHandlerSite (WidgetFor site)) (HandlerSite (WidgetFor site))
-> IO a
f) = (WidgetData site -> IO a) -> WidgetFor site a
forall site a. (WidgetData site -> IO a) -> WidgetFor site a
WidgetFor ((WidgetData site -> IO a) -> WidgetFor site a)
-> (WidgetData site -> IO a) -> WidgetFor site a
forall a b. (a -> b) -> a -> b
$ HandlerData site site -> IO a
HandlerData
  (SubHandlerSite (WidgetFor site)) (HandlerSite (WidgetFor site))
-> IO a
f (HandlerData site site -> IO a)
-> (WidgetData site -> HandlerData site site)
-> WidgetData site
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetData site -> HandlerData site site
forall site. WidgetData site -> HandlerData site site
wdHandler
    {-# INLINE liftSubHandler #-}

#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GO(ExceptT e)
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
#undef GOX

class MonadHandler m => MonadWidget m where
    liftWidget :: WidgetFor (HandlerSite m) a -> m a
instance MonadWidget (WidgetFor site) where
    liftWidget :: WidgetFor (HandlerSite (WidgetFor site)) a -> WidgetFor site a
liftWidget = WidgetFor (HandlerSite (WidgetFor site)) a -> WidgetFor site a
forall a. a -> a
id
    {-# INLINE liftWidget #-}

liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
liftWidgetT :: WidgetFor (HandlerSite m) a -> m a
liftWidgetT = WidgetFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadWidget m =>
WidgetFor (HandlerSite m) a -> m a
liftWidget
{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}

#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GO(ExceptT e)
GO(ReaderT r)
GO(StateT s)
GOX(Monoid w, WriterT w)
GOX(Monoid w, RWST r w s)
GOX(Monoid w, Strict.RWST r w s)
GO(Strict.StateT s)
GOX(Monoid w, Strict.WriterT w)
GO(Pipe l i o u)
GO(ConduitM i o)
#undef GO
#undef GOX