61 lines
1.9 KiB
Haskell
61 lines
1.9 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
module Yesod.Core.Class.Handler where
|
|
|
|
import Yesod.Core.Types
|
|
import Data.IORef.Lifted (atomicModifyIORef)
|
|
import Control.Exception.Lifted (throwIO)
|
|
import Control.Monad.Base
|
|
import Data.Monoid (mempty)
|
|
|
|
class Monad m => HandlerReader m where
|
|
type HandlerSite m
|
|
|
|
askYesodRequest :: m YesodRequest
|
|
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
|
|
|
|
instance Monad m => HandlerReader (HandlerT site m) where
|
|
type HandlerSite (HandlerT site m) = site
|
|
|
|
askYesodRequest = HandlerT $ return . handlerRequest
|
|
askHandlerEnv = HandlerT $ return . handlerEnv
|
|
|
|
instance Monad m => HandlerReader (WidgetT site m) where
|
|
type HandlerSite (WidgetT site m) = site
|
|
|
|
askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest
|
|
askHandlerEnv = WidgetT $ return . (, mempty) . handlerEnv
|
|
|
|
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 MonadBase IO m => HandlerState (HandlerT site m) where
|
|
stateGHState f =
|
|
HandlerT $ flip atomicModifyIORef f' . handlerState
|
|
where
|
|
f' z = let (x, y) = f z in (y, x)
|
|
|
|
instance MonadBase IO m => HandlerState (WidgetT site m) where
|
|
stateGHState f =
|
|
WidgetT $ fmap (, mempty) . flip atomicModifyIORef f' . handlerState
|
|
where
|
|
f' z = let (x, y) = f z in (y, x)
|
|
|
|
class HandlerReader m => HandlerError m where
|
|
handlerError :: HandlerContents -> m a
|
|
|
|
instance MonadBase IO m => HandlerError (HandlerT site m) where
|
|
handlerError = throwIO
|
|
|
|
instance MonadBase IO m => HandlerError (WidgetT site m) where
|
|
handlerError = throwIO
|