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 Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..))
-- Sessions -- Sessions
type SessionMap = Map Text ByteString 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) liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site))) data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader -> liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty)) 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 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 instance MonadTrans (WidgetT site) where
lift = WidgetT . const . liftM (, mempty) lift = WidgetT . const . liftM (, mempty)
@ -428,6 +436,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase 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 -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system. -- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use -- 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.\" -- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM m a) data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader -> liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase -> 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 restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadThrow m => MonadThrow (HandlerT site m) where instance MonadThrow m => MonadThrow (HandlerT site m) where

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

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