85 lines
2.7 KiB
Haskell
85 lines
2.7 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Yesod.Core.Handler.Class where
|
|
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Trans.Class (lift)
|
|
import Control.Monad.Trans.Class (MonadTrans)
|
|
import Data.IORef.Lifted (atomicModifyIORef)
|
|
import Control.Exception.Lifted (throwIO)
|
|
|
|
class Monad m => HandlerReader m where
|
|
type HandlerReaderSub m
|
|
type HandlerReaderMaster m
|
|
|
|
askYesodRequest :: m YesodRequest
|
|
askHandlerEnv :: m (RunHandlerEnv (HandlerReaderSub m) (HandlerReaderMaster m))
|
|
|
|
instance HandlerReader (GHandler sub master) where
|
|
type HandlerReaderSub (GHandler sub master) = sub
|
|
type HandlerReaderMaster (GHandler sub master) = master
|
|
|
|
askYesodRequest = GHandler $ return . handlerRequest
|
|
askHandlerEnv = GHandler $ return . handlerEnv
|
|
|
|
instance HandlerReader (GWidget sub master) where
|
|
type HandlerReaderSub (GWidget sub master) = sub
|
|
type HandlerReaderMaster (GWidget sub master) = master
|
|
|
|
askYesodRequest = lift askYesodRequest
|
|
askHandlerEnv = lift askHandlerEnv
|
|
|
|
instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where
|
|
type HandlerReaderSub (t m) = HandlerReaderSub m
|
|
type HandlerReaderMaster (t m) = HandlerReaderMaster m
|
|
|
|
askYesodRequest = lift askYesodRequest
|
|
askHandlerEnv = lift askHandlerEnv
|
|
|
|
class HandlerReader m => HandlerState m where
|
|
type HandlerStateSub m
|
|
type HandlerStateMaster m
|
|
|
|
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 sub master) where
|
|
type HandlerStateSub (GHandler sub master) = sub
|
|
type HandlerStateMaster (GHandler sub master) = master
|
|
|
|
stateGHState f =
|
|
GHandler $ flip atomicModifyIORef f' . handlerState
|
|
where
|
|
f' z = let (x, y) = f z in (y, x)
|
|
|
|
instance HandlerState (GWidget sub master) where
|
|
type HandlerStateSub (GWidget sub master) = sub
|
|
type HandlerStateMaster (GWidget sub master) = master
|
|
|
|
stateGHState = lift . stateGHState
|
|
|
|
instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where
|
|
type HandlerStateSub (t m) = HandlerStateSub m
|
|
type HandlerStateMaster (t m) = HandlerStateMaster m
|
|
|
|
stateGHState = lift . stateGHState
|
|
|
|
class Monad m => HandlerError m where
|
|
handlerError :: ErrorResponse -> m a
|
|
|
|
instance HandlerError (GHandler sub master) where
|
|
handlerError = throwIO . HCError
|
|
|
|
instance HandlerError (GWidget sub master) where
|
|
handlerError = lift . handlerError
|
|
|
|
instance (HandlerError m, MonadTrans t, Monad (t m)) => HandlerError (t m) where
|
|
handlerError = lift . handlerError
|