From 76cff2ab237821479e230c862daee9c2e99f67f2 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 28 Mar 2014 13:15:51 +0300
Subject: [PATCH] MonadReader instance for HandlerT and WidgetT

---
 yesod-core/Yesod/Core/Types.hs | 23 +++++++++++++++++++----
 yesod-core/yesod-core.cabal    |  3 ++-
 2 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs
index a2aea777..b0e2c79e 100644
--- a/yesod-core/Yesod/Core/Types.hs
+++ b/yesod-core/Yesod/Core/Types.hs
@@ -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
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index e7d86fee..d56b4356 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -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