From f96b71e6f1e3b1e32f2d35b8b3b6708f4b7da2ed Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 31 Jan 2011 13:26:31 +0200
Subject: [PATCH] liftIOHandler

---
 Yesod/Dispatch.hs |  3 ---
 Yesod/Handler.hs  | 18 ++++++++++++++++--
 yesod-core.cabal  |  2 +-
 3 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
index 31ea35b3..096ebf02 100644
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@@ -46,8 +46,6 @@ import Data.Char (isUpper)
 
 import Web.Routes (decodePathInfo)
 
-import Control.Monad.IO.Class (liftIO)
-
 #if TEST
 import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
@@ -187,7 +185,6 @@ toWaiApp' y key' env = do
             case decodePathInfo $ B.unpack $ W.pathInfo env of
                 "":x -> x
                 x -> x
-    liftIO $ print (W.pathInfo env, segments)
     case yesodDispatch y key' segments y id of
         Just app -> app env
         Nothing ->
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index d099f37c..0490c92b 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -83,6 +83,7 @@ module Yesod.Handler
     , hamletToRepHtml
       -- ** Misc
     , newIdent
+    , liftIOHandler
       -- * Internal Yesod
     , runHandler
     , YesodApp (..)
@@ -111,14 +112,14 @@ import Control.Exception hiding (Handler, catch, finally)
 import qualified Control.Exception as E
 import Control.Applicative
 
-import Control.Monad (liftM)
+import Control.Monad (liftM, join)
 
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.State
-import Control.Monad.Trans.Error (throwError, ErrorT (runErrorT), Error (..))
+import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
 
 import System.IO
 import qualified Network.Wai as W
@@ -127,6 +128,7 @@ import Control.Failure (Failure (failure))
 import Text.Hamlet
 
 import Control.Monad.IO.Peel (MonadPeelIO)
+import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
 import qualified Data.Map as Map
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -740,6 +742,18 @@ newIdent = GHandler $ lift $ lift $ lift $ do
     put x { ghsIdent = i' }
     return $ "h" ++ show i'
 
+liftIOHandler :: MonadIO mo
+              => GGHandler sub master IO a
+              -> GGHandler sub master mo a
+liftIOHandler x = do
+    k <- peel
+    join $ liftIO $ k x
+
+instance MonadTransPeel (GGHandler s m) where
+    peel = GHandler $ do
+        k <- liftPeel $ liftPeel $ liftPeel peel
+        return $ liftM GHandler . k . unGHandler
+
 -- | Redirect to a POST resource.
 --
 -- This is not technically a redirect; instead, it returns an HTML page with a
diff --git a/yesod-core.cabal b/yesod-core.cabal
index 776f190e..6b4001a4 100644
--- a/yesod-core.cabal
+++ b/yesod-core.cabal
@@ -59,7 +59,7 @@ library
                      Yesod.Internal.Request
                      Yesod.Internal.Dispatch
                      Paths_yesod_core
-    ghc-options:     -Wall -Werror
+    ghc-options:     -Wall
 
 executable             runtests
     if flag(ghc7)