MonadInvertIO

Yesod.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE PackageImports #-}
 module Yesod
     ( module Yesod.Request
     , module Yesod.Content
@@ -13,7 +12,7 @@ module Yesod
     , Application
     , lift
     , liftIO
-    , MonadCatchIO
+    , MonadInvertIO
     , mempty
     ) where
 
@@ -36,7 +35,7 @@ import Yesod.Form
 import Yesod.Widget
 import Network.Wai (Application)
 import Yesod.Hamlet
-import "transformers" Control.Monad.Trans.Class (lift)
-import "transformers" Control.Monad.IO.Class (liftIO)
-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.IO.Class (liftIO)
 import Data.Monoid (mempty)
+import Control.Monad.Invert (MonadInvertIO)

Yesod/Handler.hs

@@ -73,7 +73,7 @@ module Yesod.Handler
     , YesodApp (..)
     , toMasterHandler
     , localNoCurrent
-    , finallyHandler
+    , HandlerData
 #if TEST
     , testSuite
 #endif
@@ -94,17 +94,18 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
-import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C
 
 import System.IO
 import qualified Network.Wai as W
-import Control.Monad.Attempt
+import Control.Failure (Failure (failure))
 import Data.ByteString.UTF8 (toString)
 import qualified Data.ByteString.Lazy.UTF8 as L
 
 import Text.Hamlet
 
+import Control.Monad.Invert (MonadInvertIO (..))
+import Control.Monad (liftM)
+
 #if TEST
 import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.HUnit (testCase)
@@ -153,15 +154,28 @@ toMasterHandler tm ts route (GHandler h) =
 -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
 -- special responses. It is declared as a newtype to make compiler errors more
 -- readable.
-newtype GHandler sub master a = GHandler { unGHandler ::
-    ReaderT (HandlerData sub master) (
+newtype GHandler sub master a =
+    GHandler
+        { unGHandler :: GHInner sub master a
+        }
+    deriving (Functor, Applicative, Monad, MonadIO)
+
+type GHInner s m =
+    ReaderT (HandlerData s m) (
     MEitherT HandlerContents (
     WriterT (Endo [Header]) (
     WriterT (Endo [(String, Maybe String)]) (
     IO
-    )))) a
-}
-    deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
+    ))))
+
+instance MonadInvertIO (GHandler s m) where
+    newtype InvertedIO (GHandler s m) a =
+        InvGHandlerIO
+            { runInvGHandlerIO :: InvertedIO (GHInner s m) a
+            }
+    type InvertedArg (GHandler s m) = (HandlerData s m, ())
+    invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler
+    revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f
 
 type Endo a = a -> a
 
@@ -475,24 +489,7 @@ localNoCurrent =
 
 testSuite :: Test
 testSuite = testGroup "Yesod.Handler"
-    [ testCase "finally" caseFinally
+    [
     ]
 
-caseFinally :: Assertion
-caseFinally = do
-    i <- newIORef (1 :: Int)
-    let h = finallyHandler (do
-                liftIO $ writeIORef i 2
-                () <- redirectString RedirectTemporary ""
-                return ()) $ liftIO $ writeIORef i 3
-    let y = runHandler h undefined undefined undefined undefined undefined
-    _ <- unYesodApp y undefined undefined undefined
-    j <- readIORef i
-    j @?= 3
-
 #endif
-
--- | A version of 'finally' which works correctly with short-circuiting.
-finallyHandler :: GHandler s m a -> GHandler s m b -> GHandler s m a
-finallyHandler (GHandler (ReaderT thing)) (GHandler (ReaderT after)) =
-    GHandler $ ReaderT $ \hd -> mapMEitherT (`C.finally` runMEitherT (after hd)) (thing hd)

Yesod/Widget.hs

@@ -33,17 +33,21 @@ import Control.Monad.Trans.State
 import Text.Hamlet
 import Text.Cassius
 import Text.Julius
-import Yesod.Handler (Route, GHandler)
+import Yesod.Handler (Route, GHandler, HandlerData)
 import Control.Applicative (Applicative)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (lift)
-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
 import Yesod.Internal
 
+import Control.Monad.Invert (MonadInvertIO (..))
+import Control.Monad (liftM)
+
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
 -- dependencies along with a 'StateT' to track unique identifiers.
-newtype GWidget sub master a = GWidget (
+newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a }
+    deriving (Functor, Applicative, Monad, MonadIO)
+type GWInner sub master =
     WriterT (Body (Route master)) (
     WriterT (Last Title) (
     WriterT (UniqueList (Script (Route master))) (
@@ -53,11 +57,19 @@ newtype GWidget sub master a = GWidget (
     WriterT (Head (Route master)) (
     StateT Int (
     GHandler sub master
-    )))))))) a)
-    deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
+    ))))))))
 instance Monoid (GWidget sub master ()) where
     mempty = return ()
     mappend x y = x >> y
+instance MonadInvertIO (GWidget s m) where
+    newtype InvertedIO (GWidget s m) a =
+        InvGWidgetIO
+            { runInvGWidgetIO :: InvertedIO (GWInner s m) a
+            }
+    type InvertedArg (GWidget s m) =
+        (Int, (HandlerData s m, ()))
+    invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget
+    revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f
 
 instance HamletValue (GWidget s m ()) where
     newtype HamletMonad (GWidget s m ()) a =

Yesod/Yesod.hs

@@ -52,7 +52,7 @@ import qualified Web.ClientSession as CS
 import qualified Data.ByteString.UTF8 as BSU
 import Database.Persist
 import Control.Monad.Trans.Class (MonadTrans (..))
-import Control.Monad.Attempt (Failure)
+import Control.Failure (Failure)
 import qualified Data.ByteString as S
 import qualified Network.Wai.Middleware.CleanPath
 import qualified Data.ByteString.Lazy as L

yesod.cabal

@@ -37,13 +37,11 @@ library
                    , clientsession             >= 0.4.0    && < 0.5
                    , pureMD5                   >= 1.1.0.0  && < 2.2
                    , random                    >= 1.0.0.2  && < 1.1
-                   , control-monad-attempt     >= 0.3      && < 0.4
                    , cereal                    >= 0.2      && < 0.4
                    , dataenc                   >= 0.13.0.2 && < 0.14
                    , old-locale                >= 1.0.0.2  && < 1.1
-                   , persistent                >= 0.2.2    && < 0.3
-                   , neither                   >= 0.0.0    && < 0.1
-                   , MonadCatchIO-transformers >= 0.2.2.0  && < 0.3
+                   , persistent                >= 0.3.0    && < 0.4
+                   , neither                   >= 0.1.0    && < 0.2
                    , data-object               >= 0.3.1    && < 0.4
                    , network                   >= 2.2.1.5  && < 2.3
                    , email-validate            >= 0.2.5    && < 0.3
@@ -51,6 +49,7 @@ library
                    , web-routes                >= 0.23     && < 0.24
                    , xss-sanitize              >= 0.2      && < 0.3
                    , data-default              >= 0.2      && < 0.3
+                   , failure                   >= 0.1      && < 0.2
     exposed-modules: Yesod
                      Yesod.Content
                      Yesod.Dispatch