haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

MonadReader instance for HandlerT and WidgetT

Browse Source
This commit is contained in:
Michael Snoyman 2014-03-28 13:15:51 +03:00
parent 03d86646a6
commit 76cff2ab23
2 changed files with 21 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
yesod-core/Yesod/Core/Types.hs
View File

@ -61,6 +61,7 @@ import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..))
-- Sessions
type SessionMap = Map Text ByteString
@ -386,11 +387,18 @@ instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader ->
liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader)
(f $ liftM StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base
instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
local f (WidgetT g) = WidgetT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty)
@ -428,6 +436,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase
instance Monad m => MonadReader site (HandlerT site m) where
ask = HandlerT $ return . rheSite . handlerEnv
local f (HandlerT g) = HandlerT $ \hd -> g hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use
@ -438,9 +453,9 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader ->
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')
restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadThrow m => MonadThrow (HandlerT site m) where

3
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.9.2
version: 1.2.10
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -39,6 +39,7 @@ library
, shakespeare-i18n >= 1.0
, blaze-builder >= 0.2.1.4 && < 0.4
, transformers >= 0.2.2 && < 0.4
, mtl
, clientsession >= 0.9 && < 0.10
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.3