91 lines
3.2 KiB
Haskell
91 lines
3.2 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Yesod.Core.Class.Handler
|
|
( MonadHandler (..)
|
|
, MonadWidget (..)
|
|
) where
|
|
|
|
import Yesod.Core.Types
|
|
import Control.Monad.IO.Unlift (liftIO, MonadIO)
|
|
import Control.Monad.Trans.Resource (MonadResource)
|
|
import Control.Monad.Trans.Class (lift)
|
|
#if __GLASGOW_HASKELL__ < 710
|
|
import Data.Monoid (Monoid)
|
|
#endif
|
|
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 )
|
|
|
|
class MonadResource m => MonadHandler m where
|
|
type HandlerSite m
|
|
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
|
|
|
|
replaceToParent :: HandlerData site route -> HandlerData site ()
|
|
replaceToParent hd = hd { handlerToParent = const () }
|
|
|
|
instance MonadIO m => MonadHandler (HandlerT site m) where
|
|
type HandlerSite (HandlerT site m) = site
|
|
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
|
|
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
|
|
|
|
instance MonadIO m => MonadHandler (WidgetT site m) where
|
|
type HandlerSite (WidgetT site m) = site
|
|
liftHandlerT (HandlerT f) = WidgetT $ \_ref env -> liftIO $ f $ replaceToParent env
|
|
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ const f #-}
|
|
|
|
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
|
|
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
|
|
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
|
|
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
|
|
instance MonadIO m => MonadWidget (WidgetT site m) where
|
|
liftWidgetT (WidgetT f) = WidgetT $ \ref env -> liftIO $ f ref $ replaceToParent env
|
|
|
|
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
|
|
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
|
|
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
|