MonadHandler/MonadWidget

yesod-core/Yesod/Core.hs

@@ -48,9 +48,8 @@ module Yesod.Core
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
       -- * Subsites
-    , HandlerReader (..)
+    , MonadHandler (..)
-    , HandlerState (..)
+    , MonadWidget (..)
-    , HandlerError (..)
     , getRouteToParent
       -- * Misc
     , yesodVersion
@@ -89,7 +88,7 @@ import Data.Version (showVersion)
 import Yesod.Routes.Class (RenderRoute (..))
 
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI :: (Monad m, RenderMessage site msg) => msg -> HandlerT site m AuthResult
+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
 unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg

yesod-core/Yesod/Core/Class/Handler.hs

@@ -1,60 +1,48 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
-module Yesod.Core.Class.Handler where
+module Yesod.Core.Class.Handler
+    ( MonadHandler (..)
+    , MonadWidget (..)
+    ) where
 
 import Yesod.Core.Types
 import Data.IORef.Lifted (atomicModifyIORef)
 import Control.Exception.Lifted (throwIO)
 import Control.Monad.Base
 import Data.Monoid (mempty)
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..))
+import Control.Monad.Trans.Class (lift)
 
-class Monad m => HandlerReader m where
+class MonadResource m => MonadHandler m where
     type HandlerSite m
+    liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
 
-    askYesodRequest :: m YesodRequest
+replaceToParent :: HandlerData site route -> HandlerData site ()
-    askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
+replaceToParent hd = hd { handlerToParent = const () }
 
-instance Monad m => HandlerReader (HandlerT site m) where
+instance MonadResourceBase m => MonadHandler (HandlerT site m) where
     type HandlerSite (HandlerT site m) = site
+    liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
+{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}
 
-    askYesodRequest = HandlerT $ return . handlerRequest
+instance MonadResourceBase m => MonadHandler (WidgetT site m) where
-    askHandlerEnv = HandlerT $ return . handlerEnv
-
-instance Monad m => HandlerReader (WidgetT site m) where
     type HandlerSite (WidgetT site m) = site
+    liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
+{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
 
-    askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest
+instance MonadHandler m => MonadHandler (ExceptionT m) where
-    askHandlerEnv = WidgetT $ return . (, mempty) . handlerEnv
+    type HandlerSite (ExceptionT m) = HandlerSite m
+    liftHandlerT = lift . liftHandlerT
+-- FIXME add a bunch of transformer instances
 
-class HandlerReader m => HandlerState m where
+class MonadHandler m => MonadWidget m where
-    stateGHState :: (GHState -> (a, GHState)) -> m a
+    liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
-
+instance MonadResourceBase m => MonadWidget (WidgetT site m) where
-    getGHState :: m GHState
+    liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
-    getGHState = stateGHState $ \s -> (s, s)
+-- FIXME add a bunch of transformer instances
-
-    putGHState :: GHState -> m ()
-    putGHState s = stateGHState $ const ((), s)
-
-instance MonadBase IO m => HandlerState (HandlerT site m) where
-    stateGHState f =
-        HandlerT $ flip atomicModifyIORef f' . handlerState
-      where
-        f' z = let (x, y) = f z in (y, x)
-
-instance MonadBase IO m => HandlerState (WidgetT site m) where
-    stateGHState f =
-        WidgetT $ fmap (, mempty) . flip atomicModifyIORef f' . handlerState
-      where
-        f' z = let (x, y) = f z in (y, x)
-
-class HandlerReader m => HandlerError m where
-    handlerError :: HandlerContents -> m a
-
-instance MonadBase IO m => HandlerError (HandlerT site m) where
-    handlerError = throwIO
-
-instance MonadBase IO m => HandlerError (WidgetT site m) where
-    handlerError = throwIO

yesod-core/Yesod/Core/Content.hs

@@ -244,6 +244,8 @@ instance ToTypedContent Html where
     toTypedContent h = TypedContent typeHtml (toContent h)
 instance ToTypedContent T.Text where
     toTypedContent t = TypedContent typePlain (toContent t)
+instance ToTypedContent [Char] where
+    toTypedContent = toTypedContent . pack
 instance ToTypedContent Text where
     toTypedContent t = TypedContent typePlain (toContent t)
 instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where

yesod-core/Yesod/Core/Dispatch.hs

@@ -114,9 +114,8 @@ mkYesodGeneral name args clazzes isSub resS = do
      return (renderRouteDec ++ masterTypeSyns, dispatchDec)
   where sub     = foldl appT subCons subArgs
         master  = if isSub then (varT $ mkName "m") else sub
-        context = if isSub then cxt $ yesod : map return clazzes
+        context = if isSub then cxt $ map return clazzes
                            else return []
-        yesod   = classP ''HandlerReader [master]
         handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO    |]
         widget  = tySynD (mkName "Widget")  [] [t| WidgetT  $master IO () |]
         res     = map (fmap parseType) resS

yesod-core/Yesod/Core/Handler.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -165,36 +166,41 @@ import           Text.Blaze.Html               (preEscapedToMarkup, toHtml)
 
 import           Control.Monad.Trans.Resource  (ResourceT)
 import           Data.Dynamic                  (fromDynamic, toDyn)
-import qualified Data.IORef                    as I
+import qualified Data.IORef.Lifted             as I
 import           Data.Maybe                    (listToMaybe)
 import           Data.Typeable                 (Typeable, typeOf)
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
+import Control.Failure (failure)
 
-get :: HandlerState m => m GHState
+get :: MonadHandler m => m GHState
-get = getGHState
+get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
 
-put :: HandlerState m => GHState -> m ()
+put :: MonadHandler m => GHState -> m ()
-put = putGHState
+put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState
 
-modify :: HandlerState m => (GHState -> GHState) -> m ()
+modify :: MonadHandler m => (GHState -> GHState) -> m ()
-modify = stateGHState . (((), ) .)
+modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState
 
-tell :: HandlerState m => Endo [Header] -> m ()
+tell :: MonadHandler m => Endo [Header] -> m ()
 tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
 
-hcError :: HandlerError m => ErrorResponse -> m a
+handlerError :: MonadHandler m => HandlerContents -> m a
+handlerError = liftHandlerT . failure
+
+hcError :: MonadHandler m => ErrorResponse -> m a
 hcError = handlerError . HCError
 
-getRequest :: HandlerReader m => m YesodRequest
+getRequest :: MonadHandler m => m YesodRequest
-getRequest = askYesodRequest
+getRequest = liftHandlerT $ HandlerT $ return . handlerRequest
 
-runRequestBody :: (MonadResource m, HandlerReader m, HandlerState m)
+runRequestBody :: MonadHandler m => m RequestBodyContents
-               => m RequestBodyContents
 runRequestBody = do
-    RunHandlerEnv {..} <- askHandlerEnv
+    HandlerData
-    req <- askYesodRequest
+        { handlerEnv = RunHandlerEnv {..}
+        , handlerRequest = req
+        } <- liftHandlerT $ HandlerT return
     let len = W.requestBodyLength $ reqWaiRequest req
         upload = rheUpload len
     x <- get
@@ -232,25 +238,28 @@ rbHelper' backend mkFI req =
             | otherwise = a'
     go = decodeUtf8With lenientDecode
 
+askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
+askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
+
 -- | Get the master site appliation argument.
-getYesod :: HandlerReader m => m (HandlerSite m)
+getYesod :: MonadHandler m => m (HandlerSite m)
 getYesod = rheSite `liftM` askHandlerEnv
 
 -- | Get the URL rendering function.
-getUrlRender :: HandlerReader m => m (Route (HandlerSite m) -> Text)
+getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
 getUrlRender = do
     x <- rheRender `liftM` askHandlerEnv
     return $ flip x []
 
 -- | The URL rendering function with query-string parameters.
 getUrlRenderParams
-    :: HandlerReader m
+    :: MonadHandler m
     => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
 getUrlRenderParams = rheRender `liftM` askHandlerEnv
 
 -- | Get the route requested by the user. If this is a 404 response- where the
 -- user requested an invalid route- this function will return 'Nothing'.
-getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m)))
+getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
 getCurrentRoute = rheRoute `liftM` askHandlerEnv
 
 -- | Returns a function that runs 'HandlerT' actions inside @IO@.
@@ -332,7 +341,7 @@ handlerToIO =
 --
 -- If you want direct control of the final status code, or need a different
 -- status code, please use 'redirectWith'.
-redirect :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
+redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
          => url -> m a
 redirect url = do
     req <- waiRequest
@@ -343,7 +352,7 @@ redirect url = do
     redirectWith status url
 
 -- | Redirect to the given URL with the specified status code.
-redirectWith :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
+redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
              => H.Status
              -> url
              -> m a
@@ -358,7 +367,7 @@ ultDestKey = "_ULT"
 --
 -- An ultimate destination is stored in the user session and can be loaded
 -- later by 'redirectUltDest'.
-setUltDest :: (HandlerState m, RedirectUrl (HandlerSite m) url)
+setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
            => url
            -> m ()
 setUltDest url = do
@@ -369,19 +378,19 @@ setUltDest url = do
 --
 -- If this is a 404 handler, there is no current page, and then this call does
 -- nothing.
-setUltDestCurrent :: HandlerState m => m ()
+setUltDestCurrent :: MonadHandler m => m ()
 setUltDestCurrent = do
     route <- getCurrentRoute
     case route of
         Nothing -> return ()
         Just r -> do
-            gets' <- reqGetParams `liftM` askYesodRequest
+            gets' <- reqGetParams `liftM` getRequest
             setUltDest (r, gets')
 
 -- | Sets the ultimate destination to the referer request header, if present.
 --
 -- This function will not overwrite an existing ultdest.
-setUltDestReferer :: HandlerState m => m ()
+setUltDestReferer :: MonadHandler m => m ()
 setUltDestReferer = do
     mdest <- lookupSession ultDestKey
     maybe
@@ -398,7 +407,7 @@ setUltDestReferer = do
 --
 -- This function uses 'redirect', and thus will perform a temporary redirect to
 -- a GET request.
-redirectUltDest :: (RedirectUrl (HandlerSite m) url, HandlerState m, HandlerError m)
+redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)
                 => url -- ^ default destination if nothing in session
                 -> m a
 redirectUltDest def = do
@@ -407,7 +416,7 @@ redirectUltDest def = do
     maybe (redirect def) redirect mdest
 
 -- | Remove a previously set ultimate destination. See 'setUltDest'.
-clearUltDest :: HandlerState m => m ()
+clearUltDest :: MonadHandler m => m ()
 clearUltDest = deleteSession ultDestKey
 
 msgKey :: Text
@@ -416,13 +425,13 @@ msgKey = "_MSG"
 -- | Sets a message in the user's session.
 --
 -- See 'getMessage'.
-setMessage :: HandlerState m => Html -> m ()
+setMessage :: MonadHandler m => Html -> m ()
 setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
 
 -- | Sets a message in the user's session.
 --
 -- See 'getMessage'.
-setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg)
+setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
             => msg -> m ()
 setMessageI msg = do
     mr <- getMessageRender
@@ -432,7 +441,7 @@ setMessageI msg = do
 -- variable.
 --
 -- See 'setMessage'.
-getMessage :: HandlerState m => m (Maybe Html)
+getMessage :: MonadHandler m => m (Maybe Html)
 getMessage = do
     mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey
     deleteSession msgKey
@@ -442,11 +451,11 @@ getMessage = do
 --
 -- For some backends, this is more efficient than reading in the file to
 -- memory, since they can optimize file sending via a system call to sendfile.
-sendFile :: HandlerError m => ContentType -> FilePath -> m a
+sendFile :: MonadHandler m => ContentType -> FilePath -> m a
 sendFile ct fp = handlerError $ HCSendFile ct fp Nothing
 
 -- | Same as 'sendFile', but only sends part of a file.
-sendFilePart :: HandlerError m
+sendFilePart :: MonadHandler m
              => ContentType
              -> FilePath
              -> Integer -- ^ offset
@@ -457,17 +466,17 @@ sendFilePart ct fp off count =
 
 -- | Bypass remaining handler code and output the given content with a 200
 -- status code.
-sendResponse :: (HandlerError m, ToTypedContent c) => c -> m a
+sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a
 sendResponse = handlerError . HCContent H.status200 . toTypedContent
 
 -- | Bypass remaining handler code and output the given content with the given
 -- status code.
-sendResponseStatus :: (HandlerError m, ToTypedContent c) => H.Status -> c -> m a
+sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a
 sendResponseStatus s = handlerError . HCContent s . toTypedContent
 
 -- | Send a 201 "Created" response with the given route as the Location
 -- response header.
-sendResponseCreated :: HandlerError m => Route (HandlerSite m) -> m a
+sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a
 sendResponseCreated url = do
     r <- getUrlRender
     handlerError $ HCCreated $ r url
@@ -477,25 +486,25 @@ sendResponseCreated url = do
 -- that you have already specified. This function short-circuits. It should be
 -- considered only for very specific needs. If you are not sure if you need it,
 -- you don't.
-sendWaiResponse :: HandlerError m => W.Response -> m b
+sendWaiResponse :: MonadHandler m => W.Response -> m b
 sendWaiResponse = handlerError . HCWai
 
 -- | Return a 404 not found page. Also denotes no handler available.
-notFound :: HandlerError m => m a
+notFound :: MonadHandler m => m a
 notFound = hcError NotFound
 
 -- | Return a 405 method not supported page.
-badMethod :: HandlerError m => m a
+badMethod :: MonadHandler m => m a
 badMethod = do
     w <- waiRequest
     hcError $ BadMethod $ W.requestMethod w
 
 -- | Return a 403 permission denied page.
-permissionDenied :: HandlerError m => Text -> m a
+permissionDenied :: MonadHandler m => Text -> m a
 permissionDenied = hcError . PermissionDenied
 
 -- | Return a 403 permission denied page.
-permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m)
+permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
                   => msg
                   -> m a
 permissionDeniedI msg = do
@@ -503,11 +512,11 @@ permissionDeniedI msg = do
     permissionDenied $ mr msg
 
 -- | Return a 400 invalid arguments page.
-invalidArgs :: HandlerError m => [Text] -> m a
+invalidArgs :: MonadHandler m => [Text] -> m a
 invalidArgs = hcError . InvalidArgs
 
 -- | Return a 400 invalid arguments page.
-invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
+invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
 invalidArgsI msg = do
     mr <- getMessageRender
     invalidArgs $ map mr msg
@@ -515,7 +524,7 @@ invalidArgsI msg = do
 ------- Headers
 -- | Set the cookie on the client.
 
-setCookie :: HandlerState m => SetCookie -> m ()
+setCookie :: MonadHandler m => SetCookie -> m ()
 setCookie = addHeader . AddCookie
 
 -- | Helper function for setCookieExpires value
@@ -531,7 +540,7 @@ getExpires m = do
 --
 -- Note: although the value used for key and path is 'Text', you should only
 -- use ASCII values to be HTTP compliant.
-deleteCookie :: HandlerState m
+deleteCookie :: MonadHandler m
              => Text -- ^ key
              -> Text -- ^ path
              -> m ()
@@ -540,19 +549,19 @@ deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
 
 -- | Set the language in the user session. Will show up in 'languages' on the
 -- next request.
-setLanguage :: HandlerState m => Text -> m ()
+setLanguage :: MonadHandler m => Text -> m ()
 setLanguage = setSession langKey
 
 -- | Set an arbitrary response header.
 --
 -- Note that, while the data type used here is 'Text', you must provide only
 -- ASCII value to be HTTP compliant.
-setHeader :: HandlerState m => Text -> Text -> m ()
+setHeader :: MonadHandler m => Text -> Text -> m ()
 setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
 
 -- | Set the Cache-Control header to indicate this response should be cached
 -- for the given number of seconds.
-cacheSeconds :: HandlerState m => Int -> m ()
+cacheSeconds :: MonadHandler m => Int -> m ()
 cacheSeconds i = setHeader "Cache-Control" $ T.concat
     [ "max-age="
     , T.pack $ show i
@@ -561,16 +570,16 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
 
 -- | Set the Expires header to some date in 2037. In other words, this content
 -- is never (realistically) expired.
-neverExpires :: HandlerState m => m ()
+neverExpires :: MonadHandler m => m ()
 neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
 
 -- | Set an Expires header in the past, meaning this content should not be
 -- cached.
-alreadyExpired :: HandlerState m => m ()
+alreadyExpired :: MonadHandler m => m ()
 alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
 
 -- | Set an Expires header to the given date.
-expiresAt :: HandlerState m => UTCTime -> m ()
+expiresAt :: MonadHandler m => UTCTime -> m ()
 expiresAt = setHeader "Expires" . formatRFC1123
 
 -- | Set a variable in the user's session.
@@ -578,40 +587,40 @@ expiresAt = setHeader "Expires" . formatRFC1123
 -- The session is handled by the clientsession package: it sets an encrypted
 -- and hashed cookie on the client. This ensures that all data is secure and
 -- not tampered with.
-setSession :: HandlerState m
+setSession :: MonadHandler m
            => Text -- ^ key
            -> Text -- ^ value
            -> m ()
 setSession k = setSessionBS k . encodeUtf8
 
 -- | Same as 'setSession', but uses binary data for the value.
-setSessionBS :: HandlerState m
+setSessionBS :: MonadHandler m
              => Text
              -> S.ByteString
              -> m ()
 setSessionBS k = modify . modSession . Map.insert k
 
 -- | Unsets a session variable. See 'setSession'.
-deleteSession :: HandlerState m => Text -> m ()
+deleteSession :: MonadHandler m => Text -> m ()
 deleteSession = modify . modSession . Map.delete
 
 -- | Clear all session variables.
 --
 -- Since: 1.0.1
-clearSession :: HandlerState m => m ()
+clearSession :: MonadHandler m => m ()
 clearSession = modify $ \x -> x { ghsSession = Map.empty }
 
 modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
 modSession f x = x { ghsSession = f $ ghsSession x }
 
 -- | Internal use only, not to be confused with 'setHeader'.
-addHeader :: HandlerState m => Header -> m ()
+addHeader :: MonadHandler m => Header -> m ()
 addHeader = tell . Endo . (:)
 
 -- | Some value which can be turned into a URL for redirects.
 class RedirectUrl master a where
     -- | Converts the value to the URL and a list of query-string parameters.
-    toTextUrl :: (HandlerReader m, HandlerSite m ~ master) => a -> m Text
+    toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text
 
 instance RedirectUrl master Text where
     toTextUrl = return
@@ -633,21 +642,21 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k
     toTextUrl (url, params) = toTextUrl (url, Map.toList params)
 
 -- | Lookup for session data.
-lookupSession :: HandlerState m => Text -> m (Maybe Text)
+lookupSession :: MonadHandler m => Text -> m (Maybe Text)
 lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
 
 -- | Lookup for session data in binary format.
-lookupSessionBS :: HandlerState m => Text -> m (Maybe S.ByteString)
+lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
 lookupSessionBS n = do
     m <- liftM ghsSession get
     return $ Map.lookup n m
 
 -- | Get all session variables.
-getSession :: HandlerState m => m SessionMap
+getSession :: MonadHandler m => m SessionMap
 getSession = liftM ghsSession get
 
 -- | Get a unique identifier.
-newIdent :: HandlerState m => m Text
+newIdent :: MonadHandler m => m Text
 newIdent = do
     x <- get
     let i' = ghsIdent x + 1
@@ -660,7 +669,7 @@ newIdent = do
 -- POST form, and some Javascript to automatically submit the form. This can be
 -- useful when you need to post a plain link somewhere that needs to cause
 -- changes on the server.
-redirectToPost :: (HandlerError m, RedirectUrl (HandlerSite m) url)
+redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
                => url
                -> m a
 redirectToPost url = do
@@ -680,14 +689,14 @@ $doctype 5
 |] >>= sendResponse
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
-hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerSite m)) -> m Html
+hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
 hamletToRepHtml = giveUrlRenderer
 
 -- | Provide a URL rendering function to the given function and return the
 -- result. Useful for processing Shakespearean templates.
 --
 -- Since 1.2.0
-giveUrlRenderer :: HandlerReader m
+giveUrlRenderer :: MonadHandler m
                 => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
                 -> m output
 giveUrlRenderer f = do
@@ -695,10 +704,10 @@ giveUrlRenderer f = do
     return $ f render
 
 -- | Get the request\'s 'W.Request' value.
-waiRequest :: HandlerReader m => m W.Request
+waiRequest :: MonadHandler m => m W.Request
 waiRequest = reqWaiRequest `liftM` getRequest
 
-getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message)
+getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
                  => m (message -> Text)
 getMessageRender = do
     env <- askHandlerEnv
@@ -710,7 +719,7 @@ getMessageRender = do
 -- newtype wrappers to distinguish logically different types.
 --
 -- Since 1.2.0
-cached :: (HandlerState m, Typeable a)
+cached :: (MonadHandler m, Typeable a)
        => m a
        -> m a
 cached f = do
@@ -751,41 +760,41 @@ cached f = do
 -- If a matching language is not found the default language will be used.
 --
 -- This is handled by parseWaiRequest (not exposed).
-languages :: HandlerReader m => m [Text]
+languages :: MonadHandler m => m [Text]
 languages = reqLangs `liftM` getRequest
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)
 
 -- | Lookup for GET parameters.
-lookupGetParams :: HandlerReader m => Text -> m [Text]
+lookupGetParams :: MonadHandler m => Text -> m [Text]
 lookupGetParams pn = do
     rr <- getRequest
     return $ lookup' pn $ reqGetParams rr
 
 -- | Lookup for GET parameters.
-lookupGetParam :: HandlerReader m => Text -> m (Maybe Text)
+lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
 lookupGetParam = liftM listToMaybe . lookupGetParams
 
 -- | Lookup for POST parameters.
-lookupPostParams :: (MonadResource m, HandlerState m) => Text -> m [Text]
+lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
 lookupPostParams pn = do
     (pp, _) <- runRequestBody
     return $ lookup' pn pp
 
-lookupPostParam :: (MonadResource m, HandlerState m)
+lookupPostParam :: (MonadResource m, MonadHandler m)
                 => Text
                 -> m (Maybe Text)
 lookupPostParam = liftM listToMaybe . lookupPostParams
 
 -- | Lookup for POSTed files.
-lookupFile :: (HandlerState m, MonadResource m)
+lookupFile :: (MonadHandler m, MonadResource m)
            => Text
            -> m (Maybe FileInfo)
 lookupFile = liftM listToMaybe . lookupFiles
 
 -- | Lookup for POSTed files.
-lookupFiles :: (HandlerState m, MonadResource m)
+lookupFiles :: (MonadHandler m, MonadResource m)
             => Text
             -> m [FileInfo]
 lookupFiles pn = do
@@ -793,11 +802,11 @@ lookupFiles pn = do
     return $ lookup' pn files
 
 -- | Lookup for cookie data.
-lookupCookie :: HandlerReader m => Text -> m (Maybe Text)
+lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
 lookupCookie = liftM listToMaybe . lookupCookies
 
 -- | Lookup for cookie data.
-lookupCookies :: HandlerReader m => Text -> m [Text]
+lookupCookies :: MonadHandler m => Text -> m [Text]
 lookupCookies pn = do
     rr <- getRequest
     return $ lookup' pn $ reqCookies rr
@@ -823,11 +832,11 @@ lookupCookies pn = do
 -- provided inside this do-block. Should be used together with 'provideRep'.
 --
 -- Since 1.2.0
-selectRep :: HandlerReader m
+selectRep :: MonadHandler m
           => Writer.Writer (Endo [ProvidedRep m]) ()
           -> m TypedContent
 selectRep w = do
-    cts <- liftM reqAccept askYesodRequest
+    cts <- liftM reqAccept getRequest
     case mapMaybe tryAccept cts of
         [] ->
             case reps of
@@ -885,7 +894,7 @@ provideRepType ct handler =
 -- | Stream in the raw request body without any parsing.
 --
 -- Since 1.2.0
-rawRequestBody :: (HandlerReader m, MonadResource m) => Source m S.ByteString
+rawRequestBody :: (MonadHandler m, MonadResource m) => Source m S.ByteString
 rawRequestBody = do
     req <- lift waiRequest
     transPipe liftResourceT $ W.requestBody req

yesod-core/Yesod/Core/Json.hs

@@ -20,8 +20,9 @@ module Yesod.Core.Json
     , acceptsJson
     ) where
 
-import Yesod.Core.Handler (HandlerT, waiRequest, invalidArgs, redirect, selectRep, provideRep)
+import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody)
 import Yesod.Core.Content (TypedContent)
+import Yesod.Core.Types (reqAccept)
 import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
 import Yesod.Core.Class.Handler
 import Yesod.Core.Widget (WidgetT)
@@ -67,19 +68,16 @@ jsonToRepJson = return . J.toJSON
 -- 'J.Value'@.
 --
 -- /Since: 0.3.0/
-parseJsonBody :: (MonadResource m, HandlerReader m, J.FromJSON a) => m (J.Result a)
+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseJsonBody = do
-    req <- waiRequest
+    eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
-    eValue <- runExceptionT
-            $ transPipe liftResourceT (requestBody req)
-           $$ sinkParser JP.value'
     return $ case eValue of
         Left e -> J.Error $ show e
         Right value -> J.fromJSON value
 
 -- | Same as 'parseJsonBody', but return an invalid args response on a parse
 -- error.
-parseJsonBody_ :: (HandlerError m, J.FromJSON a, MonadResource m) => m a
+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
 parseJsonBody_ = do
     ra <- parseJsonBody
     case ra of
@@ -97,8 +95,7 @@ array = J.Array . V.fromList . map J.toJSON
 --     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
 --
 --     2. 3xx otherwise, following the PRG pattern.
-jsonOrRedirect :: HandlerError m
+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
-               => J.ToJSON a
                => Route (HandlerSite m) -- ^ Redirect target
                -> a            -- ^ Data to send via JSON
                -> m J.Value
@@ -109,9 +106,8 @@ jsonOrRedirect r j = do
 
 -- | Returns @True@ if the client prefers @application\/json@ as
 -- indicated by the @Accept@ HTTP header.
-acceptsJson :: HandlerReader m => m Bool
+acceptsJson :: MonadHandler m => m Bool
 acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
-            .  join
+            .  listToMaybe
-            .  liftM (listToMaybe . parseHttpAccept)
+            .  reqAccept)
-            .  lookup "Accept" . requestHeaders)
+           `liftM` getRequest
-           `liftM` waiRequest

yesod-core/Yesod/Core/Types.hs

@@ -13,7 +13,6 @@ import           Control.Applicative                (Applicative (..))
 import           Control.Applicative                ((<$>))
 import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
-import           Control.Failure                    (Failure (..))
 import           Control.Monad                      (liftM, ap)
 import           Control.Monad.Base                 (MonadBase (liftBase))
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
@@ -424,9 +423,6 @@ instance MonadIO m => MonadLogger (HandlerT site m) where
     monadLoggerLog a b c d = HandlerT $ \hd ->
         liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
 
-instance Failure e m => Failure e (HandlerT site m) where
-    failure = lift . failure
-
 instance Monoid (UniqueList x) where
     mempty = UniqueList id
     UniqueList x `mappend` UniqueList y = UniqueList $ x . y

yesod-core/Yesod/Core/Widget.hs

@@ -70,24 +70,25 @@ import qualified Data.Text.Lazy as TL
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
+import           Text.Shakespeare.I18N         (renderMessage)
 
 preEscapedLazyText :: TL.Text -> Html
 preEscapedLazyText = preEscapedToMarkup
 
-class Monad m => ToWidget site m a where
+class ToWidget site a where
-    toWidget :: a -> WidgetT site m ()
+    toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
-instance (Monad m, render ~ RY site) => ToWidget site m (render -> Html) where
+instance render ~ RY site => ToWidget site (render -> Html) where
     toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
-instance (Monad m, render ~ RY site) => ToWidget site m (render -> Css) where
+instance render ~ RY site => ToWidget site (render -> Css) where
     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
-instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) where
+instance render ~ RY site => ToWidget site (render -> CssBuilder) where
     toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
-instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where
+instance render ~ RY site => ToWidget site (render -> Javascript) where
     toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
-instance (site' ~ site, Monad m, m' ~ m) => ToWidget site' m' (WidgetT site m ()) where
+instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
-    toWidget = id
+    toWidget = liftWidgetT
-instance Monad m => ToWidget site m Html where
+instance ToWidget site Html where
     toWidget = toWidget . const
 
 -- | Allows adding some CSS to the page with a specific media type.
@@ -97,17 +98,17 @@ class ToWidgetMedia site a where
     -- | Add the given content to the page, but only for the given media type.
     --
     -- Since 1.2
-    toWidgetMedia :: Monad m
+    toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
                   => Text -- ^ media value
                   -> a
-                  -> WidgetT site m ()
+                  -> m ()
 instance render ~ RY site => ToWidgetMedia site (render -> Css) where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
     toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
 
 class ToWidgetBody site a where
-    toWidgetBody :: Monad m => a -> WidgetT site m ()
+    toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidgetBody site (render -> Html) where
     toWidgetBody = toWidget
@@ -117,7 +118,7 @@ instance ToWidgetBody site Html where
     toWidgetBody = toWidget
 
 class ToWidgetHead site a where
-    toWidgetHead :: Monad m => a -> WidgetT site m ()
+    toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
 
 instance render ~ RY site => ToWidgetHead site (render -> Html) where
     toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
@@ -132,52 +133,59 @@ instance ToWidgetHead site Html where
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
-setTitle :: Monad m => Html -> WidgetT site m ()
+setTitle :: MonadWidget m => Html -> m ()
 setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
-setTitleI :: (Monad m, RenderMessage site msg) => msg -> WidgetT site m ()
+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
 setTitleI msg = do
     mr <- getMessageRender
     setTitle $ toHtml $ mr msg
 
 -- | Link to the specified local stylesheet.
-addStylesheet :: Monad m => Route site -> WidgetT site m ()
+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
 addStylesheet = flip addStylesheetAttrs []
 
 -- | Link to the specified local stylesheet.
-addStylesheetAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
+addStylesheetAttrs :: MonadWidget m
+                   => Route (HandlerSite m)
+                   -> [(Text, Text)]
+                   -> m ()
 addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemote :: Monad m => Text -> WidgetT site m ()
+addStylesheetRemote :: MonadWidget m => Text -> m ()
 addStylesheetRemote = flip addStylesheetRemoteAttrs []
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
 addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
 
-addStylesheetEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
+addStylesheetEither :: MonadWidget m
+                    => Either (Route (HandlerSite m)) Text
+                    -> m ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
 
-addScriptEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
+addScriptEither :: MonadWidget m
+                => Either (Route (HandlerSite m)) Text
+                -> m ()
 addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
-addScript :: Monad m => Route site -> WidgetT site m ()
+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
 addScript = flip addScriptAttrs []
 
 -- | Link to the specified local script.
-addScriptAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
 addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
-addScriptRemote :: Monad m => Text -> WidgetT site m ()
+addScriptRemote :: MonadWidget m => Text -> m ()
 addScriptRemote = flip addScriptRemoteAttrs []
 
 -- | Link to the specified remote script.
-addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
 addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
 
 whamlet :: QuasiQuoter
@@ -207,7 +215,7 @@ rules = do
     return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
 
 -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
-ihamletToRepHtml :: (HandlerReader m, RenderMessage (HandlerSite m) message)
+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
                  => HtmlUrlI18n message (Route (HandlerSite m))
                  -> m Html
 ihamletToRepHtml ih = do
@@ -215,8 +223,8 @@ ihamletToRepHtml ih = do
     mrender <- getMessageRender
     return $ ih (toHtml . mrender) urender
 
-tell :: Monad m => GWData (Route site) -> WidgetT site m ()
+tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
-tell w = WidgetT $ const $ return ((), w)
+tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)

yesod-core/helloworld.hs

@@ -17,17 +17,16 @@ mkYesodSub "Subsite" [] [parseRoutes|
 /multi/*Strings SubMultiR
 |]
 
-getSubRootR :: Yesod m => GHandler Subsite m RepPlain
+getSubRootR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepPlain
 getSubRootR = do
-    Subsite s <- getYesodSub
+    Subsite s <- getYesod
-    tm <- getRouteToMaster
     render <- getUrlRender
     $logDebug "I'm in SubRootR"
-    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
+    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render SubRootR)
 
-handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
+handleSubMultiR :: Yesod master => Strings -> HandlerT Subsite (HandlerT master IO) RepPlain
 handleSubMultiR x = do
-    Subsite y <- getYesodSub
+    Subsite y <- getYesod
     $logInfo "In SubMultiR"
     return . RepPlain . toContent . show $ (x, y)
 

yesod-form/Yesod/Form/Fields.hs

@@ -79,7 +79,6 @@ import qualified Data.ByteString.Lazy as L
 import Data.Text (Text, unpack, pack)
 import qualified Data.Text.Read
 
-import Control.Monad.Trans.Class
 import qualified Data.Map as Map
 import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
 import Control.Arrow ((&&&))
@@ -482,7 +481,7 @@ data Option a = Option
     , optionExternalValue :: Text
     }
 
-optionsPairs :: (HandlerReader m, RenderMessage (HandlerSite m) msg)
+optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
              => [(msg, a)] -> m (OptionList a)
 optionsPairs opts = do
   mr <- getMessageRender
@@ -493,7 +492,7 @@ optionsPairs opts = do
                  }
   return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
 
-optionsEnum :: (HandlerReader m, Show a, Enum a, Bounded a) => m (OptionList a)
+optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 optionsPersist :: ( YesodPersist site, PersistEntity a
@@ -563,7 +562,7 @@ fileField = Field
     , fieldEnctype = Multipart
     }
 
-fileAFormReq :: (HandlerState m, RenderMessage (HandlerSite m) FormMessage)
+fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
              => FieldSettings (HandlerSite m) -> AForm m FileInfo
 fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
     let (name, ints') =
@@ -595,7 +594,7 @@ $newline never
             }
     return (res, (fv :), ints', Multipart)
 
-fileAFormOpt :: HandlerState m
+fileAFormOpt :: MonadHandler m
              => RenderMessage (HandlerSite m) FormMessage
              => FieldSettings (HandlerSite m)
              -> AForm m (Maybe FileInfo)

yesod-form/Yesod/Form/Functions.hs

@@ -100,21 +100,21 @@ askFiles = do
     (x, _, _) <- ask
     return $ liftM snd x
 
-mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
+mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a
      -> FieldSettings site
      -> Maybe a
      -> MForm m (FormResult a, FieldView site)
 mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
-mopt :: (site ~ HandlerSite m, HandlerState m)
+mopt :: (site ~ HandlerSite m, MonadHandler m)
      => Field m a
      -> FieldSettings site
      -> Maybe (Maybe a)
      -> MForm m (FormResult (Maybe a), FieldView site)
 mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
-mhelper :: (site ~ HandlerSite m, HandlerState m)
+mhelper :: (site ~ HandlerSite m, MonadHandler m)
         => Field m a
         -> FieldSettings site
         -> Maybe a
@@ -156,14 +156,14 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         , fvRequired = isReq
         })
 
-areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
+areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a
      -> FieldSettings site
      -> Maybe a
      -> AForm m a
 areq a b = formToAForm . liftM (second return) . mreq a b
 
-aopt :: HandlerState m
+aopt :: MonadHandler m
      => Field m a
      -> FieldSettings (HandlerSite m)
      -> Maybe (Maybe a)
@@ -187,14 +187,14 @@ runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle
 -- For example, a common case is displaying a form on a GET request and having
 -- the form submit to a POST page. In such a case, both the GET and POST
 -- handlers should use 'runFormPost'.
-runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, HandlerState m)
+runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)
             => (Html -> MForm m (FormResult a, xml))
             -> m ((FormResult a, xml), Enctype)
 runFormPost form = do
     env <- postEnv
     postHelper form env
 
-postHelper  :: (HandlerReader m, RenderMessage (HandlerSite m) FormMessage)
+postHelper  :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
             => (Html -> MForm m (FormResult a, xml))
             -> Maybe (Env, FileEnv)
             -> m ((FormResult a, xml), Enctype)
@@ -224,12 +224,12 @@ postHelper form env = do
 -- page will both receive and incoming form and produce a new, blank form. For
 -- general usage, you can stick with @runFormPost@.
 generateFormPost
-    :: (RenderMessage (HandlerSite m) FormMessage, HandlerReader m)
+    :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
     => (Html -> MForm m (FormResult a, xml))
     -> m (xml, Enctype)
 generateFormPost form = first snd `liftM` postHelper form Nothing
 
-postEnv :: (HandlerState m, MonadResource m)
+postEnv :: (MonadHandler m, MonadResource m)
         => m (Maybe (Env, FileEnv))
 postEnv = do
     req <- getRequest
@@ -240,7 +240,7 @@ postEnv = do
             let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
             return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
 
-runFormPostNoToken :: (HandlerState m, MonadResource m)
+runFormPostNoToken :: MonadHandler m
                    => (Html -> MForm m (FormResult a, xml))
                    -> m ((FormResult a, xml), Enctype)
 runFormPostNoToken form = do
@@ -249,7 +249,7 @@ runFormPostNoToken form = do
     env <- postEnv
     runFormGeneric (form mempty) m langs env
 
-runFormGet :: HandlerReader m
+runFormGet :: MonadHandler m
            => (Html -> MForm m a)
            -> m (a, Enctype)
 runFormGet form = do
@@ -260,7 +260,7 @@ runFormGet form = do
                 Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
     getHelper form env
 
-generateFormGet :: HandlerReader m
+generateFormGet :: MonadHandler m
                 => (Html -> MForm m a)
                 -> m (a, Enctype)
 generateFormGet form = getHelper form Nothing
@@ -268,7 +268,7 @@ generateFormGet form = getHelper form Nothing
 getKey :: Text
 getKey = "_hasdata"
 
-getHelper :: HandlerReader m
+getHelper :: MonadHandler m
           => (Html -> MForm m a)
           -> Maybe (Env, FileEnv)
           -> m (a, Enctype)

yesod-form/Yesod/Form/Input.hs

@@ -13,7 +13,6 @@ import Data.Text (Text)
 import Control.Applicative (Applicative (..))
 import Yesod.Core
 import Control.Monad (liftM)
-import Control.Monad.Trans.Resource
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Control.Arrow ((***))
@@ -53,7 +52,7 @@ iopt field name = FormInput $ \m l env fenv -> do
         Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
         Right x -> Right x
 
-runInputGet :: HandlerError m => FormInput m a -> m a
+runInputGet :: MonadHandler m => FormInput m a -> m a
 runInputGet (FormInput f) = do
     env <- liftM (toMap . reqGetParams) getRequest
     m <- getYesod
@@ -66,7 +65,7 @@ runInputGet (FormInput f) = do
 toMap :: [(Text, a)] -> Map.Map Text [a]
 toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
 
-runInputPost :: (HandlerState m, HandlerError m, MonadResource m) => FormInput m a -> m a
+runInputPost :: MonadHandler m => FormInput m a -> m a
 runInputPost (FormInput f) = do
     (env, fenv) <- liftM (toMap *** toMap) runRequestBody
     m <- getYesod

yesod-form/Yesod/Form/Jquery.hs

@@ -115,12 +115,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});
     , fieldEnctype = UrlEncoded
     }
 
-addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
+addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m ()
 addScript' f = do
     y <- getYesod
     addScriptEither $ f y
 
-addStylesheet' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
+addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)
+               => (site -> Either (Route site) Text)
+               -> m ()
 addStylesheet' f = do
     y <- getYesod
     addStylesheetEither $ f y

yesod-form/Yesod/Form/Nic.hs

@@ -47,7 +47,9 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
   where
     showVal = either id (pack . renderHtml)
 
-addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
+addScript' :: (MonadWidget m, HandlerSite m ~ site)
+           => (site -> Either (Route site) Text)
+           -> m ()
 addScript' f = do
     y <- getYesod
     addScriptEither $ f y

yesod-newsfeed/Yesod/AtomFeed.hs

@@ -42,7 +42,7 @@ instance HasContentType RepAtom where
 instance ToTypedContent RepAtom where
     toTypedContent = TypedContent typeAtom . toContent
 
-atomFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepAtom
+atomFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepAtom
 atomFeed feed = do
     render <- getUrlRender
     return $ RepAtom $ toContent $ renderLBS def $ template feed render
@@ -75,10 +75,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
     ]
 
 -- | Generates a link tag in the head of a widget.
-atomLink :: Monad m
+atomLink :: MonadWidget m
-         => Route site
+         => Route (HandlerSite m)
          -> Text -- ^ title
-         -> WidgetT site m ()
+         -> m ()
 atomLink r title = toWidgetHead [hamlet|
     <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
     |]

yesod-newsfeed/Yesod/Feed.hs

@@ -25,7 +25,7 @@ import Yesod.AtomFeed
 import Yesod.RssFeed
 import Yesod.Core
 
-newsFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m TypedContent
+newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
 newsFeed f = selectRep $ do
     provideRep $ atomFeed f
     provideRep $ rssFeed f

yesod-newsfeed/Yesod/RssFeed.hs

@@ -39,7 +39,7 @@ instance ToTypedContent RepRss where
     toTypedContent = TypedContent typeRss . toContent
 
 -- | Generate the feed
-rssFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepRss
+rssFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m RepRss
 rssFeed feed = do
     render <- getUrlRender
     return $ RepRss $ toContent $ renderLBS def $ template feed render
@@ -71,10 +71,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
     ]
 
 -- | Generates a link tag in the head of a widget.
-rssLink :: Monad m
+rssLink :: MonadWidget m
-        => Route site
+        => Route (HandlerSite m)
         -> Text -- ^ title
-        -> WidgetT site m ()
+        -> m ()
 rssLink r title = toWidgetHead [hamlet|
     <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
     |]

yesod-sitemap/Yesod/Sitemap.hs

@@ -75,14 +75,14 @@ template urls render =
         , Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
         ]
 
-sitemap :: HandlerReader m => [SitemapUrl (Route (HandlerSite m))] -> m RepXml
+sitemap :: MonadHandler m => [SitemapUrl (Route (HandlerSite m))] -> m RepXml
 sitemap urls = do
     render <- getUrlRender
     let doc = template urls render
     return $ RepXml $ toContent $ renderLBS def doc
 
 -- | A basic robots file which just lists the "Sitemap: " line.
-robots :: HandlerReader m
+robots :: MonadHandler m
        => Route (HandlerSite m) -- ^ sitemap url
        -> m RepPlain
 robots smurl = do

yesod/Yesod/Default/Handlers.hs

@@ -6,8 +6,8 @@ module Yesod.Default.Handlers
 
 import Yesod.Core
 
-getFaviconR :: HandlerError m => m ()
+getFaviconR :: MonadHandler m => m ()
 getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
 
-getRobotsR :: HandlerError m => m ()
+getRobotsR :: MonadHandler m => m ()
 getRobotsR = sendFile "text/plain" "config/robots.txt"