MonadLift

yesod-auth/Yesod/Auth.hs

@@ -91,7 +91,7 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth
     loginHandler :: GHandler Auth m RepHtml
     loginHandler = defaultLayout $ do
         setTitleI Msg.LoginTitle
-        tm <- liftWidget getRouteToMaster
+        tm <- lift getRouteToMaster
         mapM_ (flip apLogin tm) authPlugins
 
     renderAuthMessage :: m

yesod-auth/Yesod/Auth/Facebook.hs

@@ -99,7 +99,7 @@ authFacebook cid secret perms =
             redirectText RedirectTemporary logout
     dispatch _ _ = notFound
     login tm = do
-        render <- liftWidget getUrlRender
+        render <- lift getUrlRender
         let fb = Facebook.Facebook cid secret $ render $ tm url
         let furl = Facebook.getForwardUrl fb $ perms
         [QQ(whamlet)|

yesod-auth/Yesod/Auth/OAuth.hs

@@ -65,7 +65,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
         setCreds True creds
     dispatch _ _ = notFound
     login tm = do
-        render <- liftWidget getUrlRender
+        render <- lift getUrlRender
         let oaUrl = render $ tm $ oauthUrl name
         addHtml
           [QQ(shamlet)| <a href=#{oaUrl}>Login with #{name} |]

yesod-auth/Yesod/Auth/OpenId.hs

@@ -35,7 +35,7 @@ authOpenIdExtended extensionFields =
     complete = PluginR "openid" ["complete"]
     name = "openid_identifier"
     login tm = do
-        ident <- liftWidget newIdent
+        ident <- lift newIdent
         addCassius
             [QQ(cassius)|##{ident}
     background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;

yesod-core/Yesod/Core.hs

@@ -45,14 +45,15 @@ import Yesod.Widget
 import Yesod.Message
 
 import Language.Haskell.TH.Syntax
+import qualified Language.Haskell.TH.Syntax as TH
 import Data.Text (Text)
 
 logTH :: LogLevel -> Q Exp
 logTH level =
-    [|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|]
+    [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]
   where
     liftLoc :: Loc -> Q Exp
-    liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|]
+    liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]
 
 -- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
 --

yesod-core/Yesod/Dispatch.hs

@@ -27,7 +27,7 @@ import Data.Functor   ((<$>))
 import Data.Either    (partitionEithers)
 import Prelude hiding (exp)
 import Yesod.Internal.Core
-import Yesod.Handler
+import Yesod.Handler hiding (lift)
 import Yesod.Internal.Dispatch
 import Yesod.Widget (GWidget)
 

yesod-core/Yesod/Handler.hs

@@ -94,7 +94,8 @@ module Yesod.Handler
     , hamletToRepHtml
       -- ** Misc
     , newIdent
-    , liftHandler
+      -- * Lifting
+    , MonadLift (..)
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -130,12 +131,12 @@ import Control.Applicative
 import Control.Monad (liftM)
 
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
+import Control.Monad.Trans.Class (MonadTrans)
+import qualified Control.Monad.Trans.Class
 
 import System.IO
 import qualified Network.Wai as W
 import qualified Network.HTTP.Types as H
-import Control.Failure (Failure (failure))
 
 import Text.Hamlet
 import qualified Text.Blaze.Renderer.Text
@@ -167,7 +168,7 @@ import qualified Yesod.Internal.Cache as Cache
 import Yesod.Internal.Cache (mkCacheKey, CacheKey)
 import Data.Typeable (Typeable)
 import qualified Data.IORef as I
-import Control.Monad.Trans.Resource (ResourceT)
+import Control.Monad.Trans.Resource
 import Control.Exception.Lifted (catch)
 import Network.Wai (requestBody)
 import Data.Conduit (($$))
@@ -266,10 +267,6 @@ toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
 
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
---
--- Note that, in order to lift actions from the inner monad, you must use
--- 'liftHandler' instead of just @lift@, since @GHandler@ is not in fact a
--- monad transformer.
 newtype GHandler sub master a = GHandler
     { unGHandler :: HandlerData sub master -> ResourceT IO a
     }
@@ -316,8 +313,8 @@ instance Exception HandlerContents
 getRequest :: GHandler s m Request
 getRequest = handlerRequest `liftM` ask
 
-instance Failure ErrorResponse (GHandler sub master) where
+hcError :: ErrorResponse -> GHandler sub master a
-    failure = liftIO . throwIO . HCError
+hcError = liftIO . throwIO . HCError
 
 runRequestBody :: GHandler s m RequestBodyContents
 runRequestBody = do
@@ -326,7 +323,7 @@ runRequestBody = do
         Just rbc -> return rbc
         Nothing -> do
             rr <- waiRequest
-            rbc <- liftHandler $ rbHelper rr
+            rbc <- lift $ rbHelper rr
             put x { ghsRBC = Just rbc }
             return rbc
 
@@ -602,28 +599,28 @@ sendWaiResponse :: W.Response -> GHandler s m b
 sendWaiResponse = liftIO . throwIO . HCWai
 
 -- | Return a 404 not found page. Also denotes no handler available.
-notFound :: Failure ErrorResponse m => m a
+notFound :: GHandler sub master a
-notFound = failure NotFound
+notFound = hcError NotFound
 
 -- | Return a 405 method not supported page.
 badMethod :: GHandler s m a
 badMethod = do
     w <- waiRequest
-    failure $ BadMethod $ W.requestMethod w
+    hcError $ BadMethod $ W.requestMethod w
 
 -- | Return a 403 permission denied page.
-permissionDenied :: Failure ErrorResponse m => Text -> m a
+permissionDenied :: Text -> GHandler sub master a
-permissionDenied = failure . PermissionDenied
+permissionDenied = hcError . PermissionDenied
 
 -- | Return a 403 permission denied page.
-permissionDeniedI :: RenderMessage y msg => msg -> GHandler s y a
+permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a
 permissionDeniedI msg = do
     mr <- getMessageRender
     permissionDenied $ mr msg
 
 -- | Return a 400 invalid arguments page.
-invalidArgs :: Failure ErrorResponse m => [Text] -> m a
+invalidArgs :: [Text] -> GHandler sub master a
-invalidArgs = failure . InvalidArgs
+invalidArgs = hcError . InvalidArgs
 
 -- | Return a 400 invalid arguments page.
 invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a
@@ -902,8 +899,16 @@ local :: (HandlerData sub' master' -> HandlerData sub master)
       -> GHandler sub' master' a
 local f (GHandler x) = GHandler $ \r -> x $ f r
 
-liftHandler :: ResourceT IO a -> GHandler sub master a
+-- | The standard @MonadTrans@ class only allows lifting for monad
-liftHandler = GHandler . const
+-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
+-- types do not express that they actually are transformers. This replacement
+-- class accounts for this.
+class MonadLift base m | m -> base where
+    lift :: base a -> m a
+instance (Monad m, MonadTrans t) => MonadLift m (t m) where
+    lift = Control.Monad.Trans.Class.lift
+instance MonadLift (ResourceT IO) (GHandler sub master) where
+    lift = GHandler . const
 
 -- Instances for GHandler
 instance Functor (GHandler sub master) where
@@ -924,3 +929,13 @@ instance MonadBaseControl IO (GHandler sub master) where
         liftBaseWith $ \runInBase ->
             f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
     restoreM (StH base) = GHandler $ const $ restoreM base
+
+instance Resource (GHandler sub master) where
+    type Base (GHandler sub master) = IO
+    resourceLiftBase = liftIO
+    resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)
+instance ResourceUnsafeIO (GHandler sub master) where
+    unsafeFromIO = liftIO
+instance ResourceThrow (GHandler sub master) where
+    resourceThrow = liftIO . throwIO
+instance ResourceIO (GHandler sub master)

yesod-core/Yesod/Internal/Core.hs

@@ -31,7 +31,7 @@ module Yesod.Internal.Core
     ) where
 
 import Yesod.Content
-import Yesod.Handler
+import Yesod.Handler hiding (lift)
 
 import Control.Arrow ((***))
 import Control.Monad (forM)
@@ -46,7 +46,6 @@ import qualified Web.ClientSession as CS
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
 import Data.Monoid
-import Control.Monad.Trans.Writer (runWriterT)
 import Text.Hamlet
 import Text.Julius
 import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)

yesod-core/Yesod/Widget.hs

@@ -53,8 +53,6 @@ module Yesod.Widget
     , addScriptRemote
     , addScriptRemoteAttrs
     , addScriptEither
-      -- * Utilities
-    , liftWidget
       -- * Internal
     , unGWidget
     ) where
@@ -67,7 +65,7 @@ import Text.Julius
 import Text.Coffee
 import Yesod.Handler
     ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
-    , getMessageRender, getUrlRenderParams
+    , getMessageRender, getUrlRenderParams, MonadLift (..)
     )
 import Yesod.Message (RenderMessage)
 import Yesod.Content (RepHtml (..), toContent)
@@ -80,7 +78,9 @@ import qualified Data.Map as Map
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
 
-import Control.Monad.Trans.Control (MonadBaseControl (..))
+import Control.Monad.Trans.Control (MonadBaseControl (..), control)
+import Control.Monad.Trans.Resource
+import Control.Exception (throwIO)
 import qualified Text.Hamlet as NP
 import Data.Text.Lazy.Builder (fromLazyText)
 import Text.Blaze (toHtml, preEscapedLazyText)
@@ -89,9 +89,6 @@ import Control.Monad.Base (MonadBase (liftBase))
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
---
--- Note that you must use 'liftWidget' instead of @lift@ since this is not a
--- monad transformer.
 newtype GWidget sub master a = GWidget
     { unGWidget :: GHandler sub master (a, GWData (Route master))
     }
@@ -102,9 +99,9 @@ instance (a ~ ()) => Monoid (GWidget sub master a) where
 
 addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
 addSubWidget sub (GWidget w) = do
-    master <- liftWidget getYesod
+    master <- lift getYesod
     let sr = fromSubRoute sub master
-    (a, w') <- liftWidget $ toMasterHandlerMaybe sr (const sub) Nothing w
+    (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w
     tell w'
     return a
 
@@ -165,7 +162,7 @@ setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty m
 -- set values.
 setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
 setTitleI msg = do
-    mr <- liftWidget getMessageRender
+    mr <- lift getMessageRender
     setTitle $ toHtml $ mr msg
 
 -- | Add a 'Hamlet' to the head tag.
@@ -256,7 +253,7 @@ addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavasc
 -- executable to be present at runtime.
 addCoffee :: CoffeeUrl (Route master) -> GWidget sub master ()
 addCoffee c = do
-    render <- liftWidget getUrlRenderParams
+    render <- lift getUrlRenderParams
     t <- liftIO $ renderCoffee render c
     addJulius $ const $ Javascript $ fromLazyText t
 
@@ -264,7 +261,7 @@ addCoffee c = do
 -- template. Requires the coffeescript executable to be present at runtime.
 addCoffeeBody :: CoffeeUrl (Route master) -> GWidget sub master ()
 addCoffeeBody c = do
-    render <- liftWidget getUrlRenderParams
+    render <- lift getUrlRenderParams
     t <- liftIO $ renderCoffee render c
     addJuliusBody $ const $ Javascript $ fromLazyText t
 
@@ -296,8 +293,8 @@ rules = do
             return $ InfixE (Just g) bind (Just e')
     let ur f = do
             let env = NP.Env
-                    (Just $ helper [|liftWidget getUrlRenderParams|])
+                    (Just $ helper [|liftW getUrlRenderParams|])
-                    (Just $ helper [|liftM (toHtml .) $ liftWidget getMessageRender|])
+                    (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
             f env
     return $ NP.HamletRules ah ur $ \_ b -> return b
 
@@ -319,8 +316,12 @@ mapWriterT :: (GHandler sub master (a, GWData (Route master))
            -> GWidget sub' master' b
 mapWriterT = undefined
 
-liftWidget :: GHandler sub master a -> GWidget sub master a
+instance MonadLift (GHandler sub master) (GWidget sub master) where
-liftWidget = GWidget . fmap (\x -> (x, mempty))
+    lift = GWidget . fmap (\x -> (x, mempty))
+
+-- | Type-restricted version of @lift@
+liftW :: GHandler sub master a -> GWidget sub master a
+liftW = lift
 
 -- Instances for GWidget
 instance Functor (GWidget sub master) where
@@ -348,3 +349,13 @@ instance MonadBaseControl IO (GWidget sub master) where
         liftM (\x -> (x, mempty))
         (f $ liftM StW . runInBase . unGWidget)
     restoreM (StW base) = GWidget $ restoreM base
+
+instance Resource (GWidget sub master) where
+    type Base (GWidget sub master) = IO
+    resourceLiftBase = liftIO
+    resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)
+instance ResourceUnsafeIO (GWidget sub master) where
+    unsafeFromIO = liftIO
+instance ResourceThrow (GWidget sub master) where
+    resourceThrow = liftIO . throwIO
+instance ResourceIO (GWidget sub master)

yesod-form/Yesod/Form/Fields.hs

@@ -71,7 +71,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Read
 
 import qualified Data.Map as Map
-import Yesod.Handler (newIdent)
+import Yesod.Handler (newIdent, lift)
 import Yesod.Request (FileInfo)
 
 import Yesod.Core (toPathPiece, GHandler, PathPiece)
@@ -434,7 +434,7 @@ selectFieldHelper outside onOpt inside opts' = Field
         opts <- opts'
         return $ selectParser opts x
     , fieldView = \theId name theClass val isReq -> do
-        opts <- fmap olOptions $ liftWidget opts'
+        opts <- fmap olOptions $ lift opts'
         outside theId name $ do
             unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
             flip mapM_ opts $ \opt -> inside

yesod-form/Yesod/Form/Jquery.hs

@@ -173,12 +173,12 @@ $(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});
 
 addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()
 addScript' f = do
-    y <- liftWidget getYesod
+    y <- lift getYesod
     addScriptEither $ f y
 
 addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()
 addStylesheet' f = do
-    y <- liftWidget getYesod
+    y <- lift getYesod
     addStylesheetEither $ f y
 
 readMay :: Read a => String -> Maybe a

yesod-form/Yesod/Form/Nic.hs

@@ -54,5 +54,5 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{th
 
 addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
 addScript' f = do
-    y <- liftWidget getYesod
+    y <- lift getYesod
     addScriptEither $ f y

yesod-json/Yesod/Json.hs

@@ -13,7 +13,7 @@ module Yesod.Json
     , array
     ) where
 
-import Yesod.Handler (GHandler, waiRequest, liftHandler)
+import Yesod.Handler (GHandler, waiRequest, lift)
 import Yesod.Content
     ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml)
     , RepJson (RepJson), Content (ContentBuilder)
@@ -60,7 +60,7 @@ jsonToRepJson = return . RepJson . toContent
 parseJsonBody :: GHandler sub master J.Value
 parseJsonBody = do
     req <- waiRequest
-    liftHandler $ requestBody req $$ sinkParser J.json'
+    lift $ requestBody req $$ sinkParser J.json'
 
 instance ToJavascript J.Value where
     toJavascript = fromLazyText . decodeUtf8 . JE.encode

yesod-persistent/Yesod/Persist.hs

@@ -13,8 +13,7 @@ module Yesod.Persist
 import Database.Persist
 import Database.Persist.Query
 import Database.Persist.TH
-import Control.Monad.Trans.Class (MonadTrans (..))
+import Control.Monad.Trans.Class (MonadTrans)
-import Control.Failure (Failure)
 
 import Yesod.Handler
 
@@ -25,9 +24,13 @@ class YesodPersist master where
     runDB :: YesodDB sub master a -> GHandler sub master a
 
 -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
-get404 :: (PersistStore t m, PersistEntity val, Monad (t m),
+get404 :: ( PersistStore b m
-           Failure ErrorResponse m, MonadTrans t)
+          , PersistEntity val
-       => Key t val -> t m val
+          , Monad (b m)
+          , m ~ GHandler sub master
+          , MonadTrans b
+          )
+       => Key b val -> b m val
 get404 key = do
     mres <- get key
     case mres of
@@ -36,9 +39,13 @@ get404 key = do
 
 -- | Get the given entity by unique key, or return a 404 not found if it doesn't
 --   exist.
-getBy404 :: (PersistUnique t m, PersistEntity val, Monad (t m),
+getBy404 :: ( PersistUnique b m
-             Failure ErrorResponse m, MonadTrans t)
+            , PersistEntity val
-         => Unique val t -> t m (Key t val, val)
+            , m ~ GHandler sub master
+            , Monad (b m)
+            , MonadTrans b
+            )
+         => Unique val b -> b m (Key b val, val)
 getBy404 key = do
     mres <- getBy key
     case mres of

yesod-persistent/yesod-persistent.cabal

@@ -17,7 +17,6 @@ library
                    , yesod-core                >= 0.10     && < 0.11
                    , persistent                >= 0.7      && < 0.8
                    , persistent-template       >= 0.7      && < 0.8
-                   , failure                   >= 0.1      && < 0.2
                    , transformers              >= 0.2.2    && < 0.3
     exposed-modules: Yesod.Persist
     ghc-options:     -Wall

yesod-static/Yesod/Static.hs

@@ -45,8 +45,7 @@ import System.Directory
 import Control.Monad
 import Data.FileEmbed (embedDir)
 
-import Yesod.Handler
+import Yesod.Core hiding (lift)
-import Yesod.Core
 
 import Data.List (intercalate)
 import Language.Haskell.TH

yesod/Yesod.hs

@@ -12,7 +12,6 @@ module Yesod
     , develServer
       -- * Commonly referenced functions/datatypes
     , Application
-    , lift
     , liftIO
     , MonadBaseControl
       -- * Utilities
@@ -47,7 +46,6 @@ import Yesod.Json
 import Yesod.Persist
 import Network.Wai (Application)
 import Network.Wai.Middleware.RequestLogger
-import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Control (MonadBaseControl)
 

yesod/scaffold/project.cabal.cg

@@ -57,7 +57,7 @@ executable         ~project~
         cpp-options:   -DDEVELOPMENT
         ghc-options:   -Wall -threaded -O0
     else
-        ghc-options:   -Wall -threaded -02
+        ghc-options:   -Wall -threaded -O2
 
     main-is:       main.hs
 

yesod/scaffold/tiny/Foundation.hs.cg

@@ -8,7 +8,6 @@ module Foundation
     , module Yesod.Core
     , module Settings
     , StaticRoute (..)
-    , lift
     , liftIO
     ) where
 
@@ -21,7 +20,6 @@ import Settings.StaticFiles
 import Yesod.Logger (Logger, logMsg, formatLogText)
 import qualified Settings
 import Settings (Extra, widgetFile)
-import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (liftIO)
 import Web.ClientSession (getKey)
 import Text.Hamlet (hamletFile)