diff --git a/Yesod.hs b/Yesod.hs index f2e6916e..71d156ea 100644 --- a/Yesod.hs +++ b/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) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 4d88ef17..cf15f133 100644 --- a/Yesod/Handler.hs +++ b/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) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 6d72f44c..d89b2640 100644 --- a/Yesod/Widget.hs +++ b/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 = diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 4071d345..5762e6d1 100644 --- a/Yesod/Yesod.hs +++ b/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 diff --git a/yesod.cabal b/yesod.cabal index 7955c9d0..71f7e318 100644 --- a/yesod.cabal +++ b/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