76 lines
2.3 KiB
Haskell
76 lines
2.3 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Yesod.Core.Class.Handler where
|
|
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Types.Orphan ()
|
|
import Yesod.Core.Class.MonadLift (lift)
|
|
import Control.Monad.Trans.Class (MonadTrans)
|
|
import Control.Monad.Trans.Resource
|
|
import Control.Monad.Trans.Control
|
|
import Data.IORef.Lifted (atomicModifyIORef)
|
|
import Control.Exception.Lifted (throwIO)
|
|
|
|
class Monad m => HandlerReader m where
|
|
type HandlerSite m
|
|
type HandlerMaster m
|
|
|
|
askYesodRequest :: m YesodRequest
|
|
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
|
|
|
|
instance HandlerReader (GHandler site) where
|
|
type HandlerSite (GHandler site) = site
|
|
type HandlerMaster (GHandler site) = site
|
|
|
|
askYesodRequest = GHandler $ return . handlerRequest
|
|
askHandlerEnv = GHandler $ return . handlerEnv
|
|
|
|
instance HandlerReader m => HandlerReader (HandlerT site m) where
|
|
type HandlerSite (HandlerT site m) = site
|
|
type HandlerMaster (HandlerT site m) = HandlerMaster m
|
|
|
|
askYesodRequest = HandlerT $ return . handlerRequest
|
|
askHandlerEnv = HandlerT $ return . handlerEnv
|
|
|
|
instance HandlerReader (GWidget site) where
|
|
type HandlerSite (GWidget site) = site
|
|
type HandlerMaster (GWidget site) = site
|
|
|
|
askYesodRequest = lift askYesodRequest
|
|
askHandlerEnv = lift askHandlerEnv
|
|
|
|
class HandlerReader m => HandlerState m where
|
|
stateGHState :: (GHState -> (a, GHState)) -> m a
|
|
|
|
getGHState :: m GHState
|
|
getGHState = stateGHState $ \s -> (s, s)
|
|
|
|
putGHState :: GHState -> m ()
|
|
putGHState s = stateGHState $ const ((), s)
|
|
|
|
instance HandlerState (GHandler site) where
|
|
stateGHState f =
|
|
GHandler $ flip atomicModifyIORef f' . handlerState
|
|
where
|
|
f' z = let (x, y) = f z in (y, x)
|
|
|
|
instance HandlerState (GWidget site) where
|
|
stateGHState = lift . stateGHState
|
|
|
|
instance HandlerState m => HandlerState (HandlerT site m) where
|
|
stateGHState = lift . stateGHState
|
|
|
|
class HandlerReader m => HandlerError m where
|
|
handlerError :: HandlerContents -> m a
|
|
|
|
instance HandlerError (GHandler site) where
|
|
handlerError = throwIO
|
|
|
|
instance HandlerError (GWidget site) where
|
|
handlerError = lift . handlerError
|
|
|
|
instance HandlerError m => HandlerError (HandlerT site m) where
|
|
handlerError = lift . handlerError
|