From 553dff7bd2a70f6b54f581f359983ca229a3e0ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 14 Mar 2013 05:00:16 +0200 Subject: [PATCH] Incomplete change: GWidget/GHandler->WidgetT/HandlerT --- yesod-core/Yesod/Core.hs | 1 - yesod-core/Yesod/Core/Class/Breadcrumbs.hs | 4 +- yesod-core/Yesod/Core/Class/Handler.hs | 49 +++---- yesod-core/Yesod/Core/Class/MonadLift.hs | 15 --- yesod-core/Yesod/Core/Class/Yesod.hs | 96 ++++++-------- yesod-core/Yesod/Core/Handler.hs | 26 ++-- yesod-core/Yesod/Core/Json.hs | 45 ++++--- yesod-core/Yesod/Core/Types.hs | 146 +++++++++------------ yesod-core/Yesod/Core/Types/Orphan.hs | 26 ---- yesod-core/Yesod/Core/Widget.hs | 77 ++++++----- yesod-core/yesod-core.cabal | 4 +- 11 files changed, 192 insertions(+), 297 deletions(-) delete mode 100644 yesod-core/Yesod/Core/Class/MonadLift.hs delete mode 100644 yesod-core/Yesod/Core/Types/Orphan.hs diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index cab53a5c..c025060a 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -78,7 +78,6 @@ import Data.Text (Text) import Yesod.Core.Widget import Yesod.Core.Json import Yesod.Core.Types -import Yesod.Core.Class.MonadLift import Text.Shakespeare.I18N import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) diff --git a/yesod-core/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/Yesod/Core/Class/Breadcrumbs.hs index aa857241..84586055 100644 --- a/yesod-core/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/Yesod/Core/Class/Breadcrumbs.hs @@ -11,11 +11,11 @@ import Data.Text (Text) class YesodBreadcrumbs site where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Route site -> GHandler site (Text , Maybe (Route site)) + breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs site => GHandler site (Text, [(Route site, Text)]) +breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index 718e7bb6..9c109c46 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -1,49 +1,36 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Yesod.Core.Class.Handler where import Yesod.Core.Types -import Yesod.Core.Types.Orphan () -import Yesod.Core.Class.MonadLift (lift) import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Resource import Control.Monad.Trans.Control import Data.IORef.Lifted (atomicModifyIORef) import Control.Exception.Lifted (throwIO) +import Control.Monad.Base +import Data.Monoid (mempty) class Monad m => HandlerReader m where type HandlerSite m - type HandlerMaster m askYesodRequest :: m YesodRequest askHandlerEnv :: m (RunHandlerEnv (HandlerSite m)) - askHandlerEnvMaster :: m (RunHandlerEnv (HandlerMaster m)) -instance HandlerReader (GHandler site) where - type HandlerSite (GHandler site) = site - type HandlerMaster (GHandler site) = site - - askYesodRequest = GHandler $ return . handlerRequest - askHandlerEnv = GHandler $ return . handlerEnv - askHandlerEnvMaster = GHandler $ return . handlerEnv - -instance HandlerReader m => HandlerReader (HandlerT site m) where +instance Monad m => HandlerReader (HandlerT site m) where type HandlerSite (HandlerT site m) = site - type HandlerMaster (HandlerT site m) = HandlerMaster m askYesodRequest = HandlerT $ return . handlerRequest askHandlerEnv = HandlerT $ return . handlerEnv - askHandlerEnvMaster = lift askHandlerEnvMaster -instance HandlerReader (GWidget site) where - type HandlerSite (GWidget site) = site - type HandlerMaster (GWidget site) = site +instance Monad m => HandlerReader (WidgetT site m) where + type HandlerSite (WidgetT site m) = site - askYesodRequest = lift askYesodRequest - askHandlerEnv = lift askHandlerEnv - askHandlerEnvMaster = lift askHandlerEnvMaster + askYesodRequest = WidgetT $ fmap (, mempty) $ askYesodRequest + askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv class HandlerReader m => HandlerState m where stateGHState :: (GHState -> (a, GHState)) -> m a @@ -54,26 +41,20 @@ class HandlerReader m => HandlerState m where putGHState :: GHState -> m () putGHState s = stateGHState $ const ((), s) -instance HandlerState (GHandler site) where +instance MonadBase IO m => HandlerState (HandlerT site m) where stateGHState f = - GHandler $ flip atomicModifyIORef f' . handlerState + HandlerT $ flip atomicModifyIORef f' . handlerState where f' z = let (x, y) = f z in (y, x) -instance HandlerState (GWidget site) where - stateGHState = lift . stateGHState - -instance HandlerState m => HandlerState (HandlerT site m) where - stateGHState = lift . stateGHState +instance MonadBase IO m => HandlerState (WidgetT site m) where + stateGHState = WidgetT . fmap (, mempty) . stateGHState class HandlerReader m => HandlerError m where handlerError :: HandlerContents -> m a -instance HandlerError (GHandler site) where +instance MonadBase IO m => HandlerError (HandlerT site m) where handlerError = throwIO -instance HandlerError (GWidget site) where - handlerError = lift . handlerError - -instance HandlerError m => HandlerError (HandlerT site m) where - handlerError = lift . handlerError +instance MonadBase IO m => HandlerError (WidgetT site m) where + handlerError = throwIO diff --git a/yesod-core/Yesod/Core/Class/MonadLift.hs b/yesod-core/Yesod/Core/Class/MonadLift.hs deleted file mode 100644 index 62e8cb6d..00000000 --- a/yesod-core/Yesod/Core/Class/MonadLift.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -module Yesod.Core.Class.MonadLift (MonadLift (..)) where - -import Control.Monad.Trans.Class - --- | The standard @MonadTrans@ class only allows lifting for monad --- 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 diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index e86afeac..341dda0c 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -58,11 +58,10 @@ import Web.Cookie (SetCookie (..)) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget -import Yesod.Core.Class.MonadLift (lift) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. -class RenderRoute a => Yesod a where +class RenderRoute site => Yesod site where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- @@ -76,36 +75,34 @@ class RenderRoute a => Yesod a where -- -- If this is not true, you should override with a different -- implementation. - approot :: Approot a + approot :: Approot site approot = ApprootRelative -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler a TypedContent + errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget a () -> GHandler a RepHtml + defaultLayout :: WidgetT site IO () -> HandlerT site IO RepHtml defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage hamletToRepHtml [hamlet| -$newline never -$doctype 5 - - - - #{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} -|] + $doctype 5 + <html> + <head> + <title>#{pageTitle p} + ^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + ^{pageBody p} + |] -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe Builder + urlRenderOverride :: site -> Route site -> Maybe Builder urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -113,9 +110,9 @@ $doctype 5 -- Return 'Authorized' if the request is authorized, -- 'Unauthorized' a message if unauthorized. -- If authentication is required, return 'AuthenticationRequired'. - isAuthorized :: Route a + isAuthorized :: Route site -> Bool -- ^ is this a write request? - -> GHandler a AuthResult + -> HandlerT site IO AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default, @@ -125,7 +122,7 @@ $doctype 5 -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler a Bool + isWriteRequest :: Route site -> HandlerT site IO Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem` @@ -135,7 +132,7 @@ $doctype 5 -- -- Used in particular by 'isAuthorized', but library users can do whatever -- they want with it. - authRoute :: a -> Maybe (Route a) + authRoute :: site -> Maybe (Route site) authRoute _ = Nothing -- | A function used to clean up path segments. It returns 'Right' with a @@ -148,7 +145,7 @@ $doctype 5 -- -- Note that versions of Yesod prior to 0.7 used a different set of rules -- involing trailing slashes. - cleanPath :: a -> [Text] -> Either [Text] [Text] + cleanPath :: site -> [Text] -> Either [Text] [Text] cleanPath _ s = if corrected == s then Right $ map dropDash s @@ -162,7 +159,7 @@ $doctype 5 -- | Builds an absolute URL by concatenating the application root with the -- pieces of a path and a query string, if any. -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. - joinPath :: a + joinPath :: site -> T.Text -- ^ application root -> [T.Text] -- ^ path pieces -> [(T.Text, T.Text)] -- ^ query string @@ -191,7 +188,7 @@ $doctype 5 addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content - -> GHandler a (Maybe (Either Text (Route a, [(Text, Text)]))) + -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing {- Temporarily disabled until we have a better interface. @@ -208,17 +205,17 @@ $doctype 5 -- | Maximum allowed length of the request body, in bytes. -- -- Default: 2 megabytes. - maximumContentLength :: a -> Maybe (Route a) -> Word64 + maximumContentLength :: site -> Maybe (Route site) -> Word64 maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes -- | Returns a @Logger@ to use for log messages. -- -- Default: Sends to stdout and automatically flushes on each write. - getLogger :: a -> IO Logger + getLogger :: site -> IO Logger getLogger _ = mkLogger True stdout -- | Send a message to the @Logger@ provided by @getLogger@. - messageLoggerSource :: a + messageLoggerSource :: site -> Logger -> Loc -- ^ position in source code -> LogSource @@ -232,11 +229,11 @@ $doctype 5 -- | The logging level in place for this application. Any messages below -- this level will simply be ignored. - logLevel :: a -> LogLevel + logLevel :: site -> LogLevel logLevel _ = LevelInfo -- | GZIP settings. - gzipSettings :: a -> GzipSettings + gzipSettings :: site -> GzipSettings gzipSettings _ = def -- | Where to Load sripts from. We recommend the default value, @@ -245,13 +242,13 @@ $doctype 5 -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js -- -- Or write your own async js loader: see 'loadJsYepnope' - jsLoader :: a -> ScriptLoadPosition a + jsLoader :: site -> ScriptLoadPosition site jsLoader _ = BottomOfBody -- | Create a session backend. Returning `Nothing' disables sessions. -- -- Default: Uses clientsession with a 2 hour timeout. - makeSessionBackend :: a -> IO (Maybe SessionBackend) + makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend _ = fmap Just defaultClientSessionBackend -- | How to store uploaded files. @@ -259,7 +256,7 @@ $doctype 5 -- Default: When the request body is greater than 50kb, store in a temp -- file. For chunked request bodies, store in a temp file. Otherwise, store -- in memory. - fileUpload :: a -> W.RequestBodyLength -> FileUpload + fileUpload :: site -> W.RequestBodyLength -> FileUpload fileUpload _ (W.KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd @@ -267,8 +264,8 @@ $doctype 5 -- | Should we log the given log source/level combination. -- -- Default: Logs everything at or above 'logLevel' - shouldLog :: a -> LogSource -> LogLevel -> Bool - shouldLog a _ level = level >= logLevel a + shouldLog :: site -> LogSource -> LogLevel -> Bool + shouldLog site _ level = level >= logLevel site -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. @@ -277,7 +274,7 @@ $doctype 5 -- performs authorization checks. -- -- Since: 1.1.6 - yesodMiddleware :: GHandler a res -> GHandler a res + yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" route <- getCurrentRoute @@ -301,11 +298,11 @@ $doctype 5 -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route site), Yesod site) - => GWidget site () - -> GHandler site (PageContent (Route site)) + => WidgetT site IO () + -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do master <- getYesod - ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unWidgetT w let title = maybe mempty unTitle mTitle scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' @@ -396,10 +393,10 @@ $newline never runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod site => ErrorResponse -> GHandler site TypedContent +defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do - r <- lift waiRequest + r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r setTitle "Not Found" toWidget [hamlet| @@ -560,20 +557,3 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ where line = show . fst . loc_start char = show . snd . loc_start - -class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where - liftHandler :: GHandler (HandlerSite m) a -> m a - liftHandler (GHandler f) = do - hd <- askHandlerData - liftResourceT $ f hd - - liftHandlerMaster :: GHandler (HandlerMaster m) a -> m a - askHandlerData :: m (HandlerData (HandlerSite m)) - -instance Yesod site => MonadHandler (GHandler site) where - liftHandler = id - liftHandlerMaster = id - askHandlerData = GHandler return -instance MonadHandler m => MonadHandler (HandlerT site m) where - liftHandlerMaster = lift . liftHandlerMaster - askHandlerData = HandlerT return diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 38beab96..dbab8595 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -21,8 +21,7 @@ --------------------------------------------------------- module Yesod.Core.Handler ( -- * Handler monad - GHandler - , HandlerT + HandlerT -- ** Read information from handler , getYesod , getUrlRender @@ -167,7 +166,6 @@ import Data.Maybe (listToMaybe) import Data.Typeable (Typeable, typeOf) import Yesod.Core.Class.Handler import Yesod.Core.Types -import Yesod.Core.Types.Orphan () import Yesod.Routes.Class (Route) get :: HandlerState m => m GHState @@ -251,10 +249,10 @@ getUrlRenderParams = rheRender `liftM` askHandlerEnv getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m))) getCurrentRoute = rheRoute `liftM` askHandlerEnv --- | Returns a function that runs 'GHandler' actions inside @IO@. +-- | Returns a function that runs 'HandlerT' actions inside @IO@. -- --- Sometimes you want to run an inner 'GHandler' action outside --- the control flow of an HTTP request (on the outer 'GHandler' +-- Sometimes you want to run an inner 'HandlerT' action outside +-- the control flow of an HTTP request (on the outer 'HandlerT' -- action). For example, you may want to spawn a new thread: -- -- @ @@ -287,9 +285,9 @@ getCurrentRoute = rheRoute `liftM` askHandlerEnv -- This allows the inner 'GHandler' to outlive the outer -- 'GHandler' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread). -handlerToIO :: MonadIO m => GHandler site (GHandler site a -> m a) +handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a) handlerToIO = - GHandler $ \oldHandlerData -> do + HandlerT $ \oldHandlerData -> do -- Let go of the request body, cache and response headers. let oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq @@ -311,7 +309,7 @@ handlerToIO = , ghsHeaders = mempty } -- Return GHandler running function. - return $ \(GHandler f) -> liftIO $ do + return $ \(HandlerT f) -> liftIO $ do -- The state IORef needs to be created here, otherwise it -- will be shared by different invocations of this function. newStateIORef <- I.newIORef newState @@ -417,7 +415,7 @@ setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg) +setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg) => msg -> m () setMessageI msg = do mr <- getMessageRender @@ -490,7 +488,7 @@ permissionDenied :: HandlerError m => Text -> m a permissionDenied = hcError . PermissionDenied -- | Return a 403 permission denied page. -permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m) +permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m) => msg -> m a permissionDeniedI msg = do @@ -502,7 +500,7 @@ invalidArgs :: HandlerError m => [Text] -> m a invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page. -invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a +invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg @@ -693,10 +691,10 @@ giveUrlRenderer f = do waiRequest :: HandlerReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest -getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message) +getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message) => m (message -> Text) getMessageRender = do - env <- askHandlerEnvMaster + env <- askHandlerEnv l <- reqLangs `liftM` getRequest return $ renderMessage (rheSite env) l diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 272b21db..e322608b 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -19,11 +19,11 @@ module Yesod.Core.Json , acceptsJson ) where -import Yesod.Core.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep) -import Yesod.Core.Class.MonadLift (lift) +import Yesod.Core.Handler (HandlerT, waiRequest, invalidArgs, redirect, selectRep, provideRep) import Yesod.Core.Content (TypedContent) import Yesod.Core.Class.Yesod (defaultLayout, Yesod) -import Yesod.Core.Widget (GWidget) +import Yesod.Core.Class.Handler +import Yesod.Core.Widget (WidgetT) import Yesod.Routes.Class import Control.Applicative ((<$>)) import Control.Monad (join) @@ -38,6 +38,9 @@ import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) import qualified Data.ByteString.Char8 as B8 import Data.Maybe (listToMaybe) +import Control.Monad.Trans.Class (lift) +import Control.Monad (liftM) +import Control.Monad.Trans.Resource (liftResourceT) -- | Provide both an HTML and JSON representation for a piece of -- data, using the default layout for the HTML output @@ -45,9 +48,9 @@ import Data.Maybe (listToMaybe) -- -- /Since: 0.3.0/ defaultLayoutJson :: (Yesod site, J.ToJSON a) - => GWidget site () -- ^ HTML - -> GHandler site a -- ^ JSON - -> GHandler site TypedContent + => WidgetT site m () -- ^ HTML + -> HandlerT site m a -- ^ JSON + -> HandlerT site m TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w provideRep $ fmap J.toJSON json @@ -56,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do -- support conversion to JSON via 'J.ToJSON'. -- -- /Since: 0.3.0/ -jsonToRepJson :: J.ToJSON a => a -> GHandler site J.Value +jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value jsonToRepJson = return . J.toJSON -- | Parse the request body to a data type as a JSON value. The @@ -65,12 +68,11 @@ jsonToRepJson = return . J.toJSON -- 'J.Value'@. -- -- /Since: 0.3.0/ -parseJsonBody :: J.FromJSON a => GHandler site (J.Result a) +parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a) parseJsonBody = do req <- waiRequest - eValue <- lift - $ runExceptionT - $ transPipe lift (requestBody req) + eValue <- runExceptionT + $ transPipe liftResourceT (requestBody req) $$ sinkParser JP.value' return $ case eValue of Left e -> J.Error $ show e @@ -78,7 +80,7 @@ parseJsonBody = do -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. -parseJsonBody_ :: J.FromJSON a => GHandler site a +parseJsonBody_ :: (HandlerError m, J.FromJSON a, MonadResource m) => m a parseJsonBody_ = do ra <- parseJsonBody case ra of @@ -96,20 +98,21 @@ array = J.Array . V.fromList . map J.toJSON -- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. -jsonOrRedirect :: (Yesod site, J.ToJSON a) - => Route site -- ^ Redirect target +jsonOrRedirect :: HandlerError m + => J.ToJSON a + => Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON - -> GHandler site J.Value + -> m J.Value jsonOrRedirect r j = do q <- acceptsJson - if q then jsonToRepJson (J.toJSON j) + if q then return (J.toJSON j) else redirect r -- | Returns @True@ if the client prefers @application\/json@ as -- indicated by the @Accept@ HTTP header. -acceptsJson :: Yesod site => GHandler site Bool -acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) +acceptsJson :: HandlerReader m => m Bool +acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';')) . join - . fmap (listToMaybe . parseHttpAccept) - . lookup "Accept" . requestHeaders - <$> waiRequest + . liftM (listToMaybe . parseHttpAccept) + . lookup "Accept" . requestHeaders) + `liftM` waiRequest diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 8cb16cb5..5dd09657 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -54,7 +55,7 @@ import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) import Yesod.Core.Internal.Util (getTime, putTime) -import Yesod.Core.Class.MonadLift (MonadLift (..)) +import Control.Monad.Trans.Class import Yesod.Routes.Class (RenderRoute (..)) -- Sessions @@ -192,23 +193,10 @@ data YesodRunnerEnv site = YesodRunnerEnv -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. -newtype GHandler site a = GHandler - { unGHandler :: HandlerData site -> ResourceT IO a - } - newtype HandlerT site m a = HandlerT - { unHandlerT :: HandlerData site -> m a + { unHandlerT :: HandlerData site -> ResourceT m a } -instance Monad m => Monad (HandlerT sub m) where - return = HandlerT . const . return - HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd -instance Monad m => Functor (HandlerT sub m) where - fmap = liftM -instance Monad m => Applicative (HandlerT sub m) where - pure = return - (<*>) = ap - data GHState = GHState { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents @@ -219,17 +207,17 @@ data GHState = GHState -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as --- the 'GHandler' monad and template haskell code should hide it away. +-- the 'HandlerT' monad and template haskell code should hide it away. type YesodApp = YesodRequest -> ResourceT IO YesodResponse -- | 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. -newtype GWidget site a = GWidget -- FIXME change to WidgetT? - { unGWidget :: GHandler site (a, GWData (Route site)) +newtype WidgetT site m a = WidgetT + { unWidgetT :: HandlerT site m (a, GWData (Route site)) } -instance (a ~ ()) => Monoid (GWidget site a) where +instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where mempty = return () mappend x y = x >> y @@ -344,62 +332,56 @@ instance Show HandlerContents where show _ = "Cannot show a HandlerContents" instance Exception HandlerContents --- Instances for GWidget -instance Functor (GWidget site) where - fmap f (GWidget x) = GWidget (fmap (first f) x) -instance Applicative (GWidget site) where - pure a = GWidget $ pure (a, mempty) - GWidget f <*> GWidget v = - GWidget $ k <$> f <*> v - where - k (a, wa) (b, wb) = (a b, wa `mappend` wb) -instance Monad (GWidget site) where - return = pure - GWidget x >>= f = GWidget $ do +-- Instances for WidgetT +instance Monad m => Functor (WidgetT site m) where + fmap = liftM +instance Monad m => Applicative (WidgetT site m) where + pure = return + (<*>) = ap +instance Monad m => Monad (WidgetT site m) where + return a = WidgetT $ pure (a, mempty) + WidgetT x >>= f = WidgetT $ do (a, wa) <- x - (b, wb) <- unGWidget (f a) + (b, wb) <- unWidgetT (f a) return (b, wa `mappend` wb) -instance MonadIO (GWidget site) where - liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO -instance MonadBase IO (GWidget site) where - liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase -instance MonadBaseControl IO (GWidget site) where - data StM (GWidget site) a = - StW (StM (GHandler site) (a, GWData (Route site))) - liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> +instance MonadIO m => MonadIO (WidgetT site m) where + liftIO = lift . liftIO +instance MonadBase b m => MonadBase b (WidgetT site m) where + liftBase = WidgetT . fmap (\a -> (a, mempty)) . liftBase +instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where + data StM (WidgetT site m) a = + StW (StM (HandlerT site m) (a, GWData (Route site))) + liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase -> liftM (\x -> (x, mempty)) - (f $ liftM StW . runInBase . unGWidget) - restoreM (StW base) = GWidget $ restoreM base + (f $ liftM StW . runInBase . unWidgetT) + restoreM (StW base) = WidgetT $ restoreM base -instance MonadUnsafeIO (GWidget site) where - unsafeLiftIO = liftIO -instance MonadThrow (GWidget site) where - monadThrow = liftIO . throwIO -instance MonadResource (GWidget site) where - liftResourceT = lift . liftResourceT +instance MonadTrans (WidgetT site) where + lift = WidgetT . fmap (, mempty) . lift +instance MonadThrow m => MonadThrow (WidgetT site m) where + monadThrow = lift . monadThrow +instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where + liftResourceT = WidgetT . fmap (, mempty) . liftResourceT -instance MonadLogger (GWidget site) where - monadLoggerLog a b c = lift . monadLoggerLog a b c +instance MonadIO m => MonadLogger (WidgetT site m) where + monadLoggerLog a b c d = WidgetT $ fmap (, mempty) $ monadLoggerLog a b c d -instance MonadLift (GHandler site) (GWidget site) where - lift = GWidget . fmap (\x -> (x, mempty)) +instance MonadTrans (HandlerT site) where + lift = HandlerT . const . lift -instance MonadLift (ResourceT IO) (GHandler site) where - lift = GHandler . const - --- Instances for GHandler -instance Functor (GHandler site) where - fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) -instance Applicative (GHandler site) where - pure = GHandler . const . pure - GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r -instance Monad (GHandler site) where - return = pure - GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r -instance MonadIO (GHandler site) where - liftIO = GHandler . const . lift -instance MonadBase IO (GHandler site) where - liftBase = GHandler . const . lift +-- Instances for HandlerT +instance Monad m => Functor (HandlerT site m) where + fmap = liftM +instance Monad m => Applicative (HandlerT site m) where + pure = return + (<*>) = ap +instance Monad m => Monad (HandlerT site m) where + return = HandlerT . const . return + HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r +instance MonadIO m => MonadIO (HandlerT site m) where + liftIO = lift . liftIO +instance MonadBase b m => MonadBase b (HandlerT site m) where + liftBase = lift . liftBase -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- @fork@ function is incompatible with the underlying @ResourceT@ system. -- Instead, if you must fork a separate thread, you should use @@ -408,26 +390,24 @@ instance MonadBase IO (GHandler site) where -- Using fork usually leads to an exception that says -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- after cleanup. Please contact the maintainers.\" -instance MonadBaseControl IO (GHandler site) where - data StM (GHandler site) a = StH (StM (ResourceT IO) a) - liftBaseWith f = GHandler $ \reader -> +instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where + data StM (HandlerT site m) a = StH (StM (ResourceT m) a) + liftBaseWith f = HandlerT $ \reader -> liftBaseWith $ \runInBase -> - f $ liftM StH . runInBase . (\(GHandler r) -> r reader) - restoreM (StH base) = GHandler $ const $ restoreM base + f $ liftM StH . runInBase . (\(HandlerT r) -> r reader) + restoreM (StH base) = HandlerT $ const $ restoreM base -instance MonadUnsafeIO (GHandler site) where - unsafeLiftIO = liftIO -instance MonadThrow (GHandler site) where - monadThrow = liftIO . throwIO -instance MonadResource (GHandler site) where - liftResourceT = lift . liftResourceT +instance MonadThrow m => MonadThrow (HandlerT site m) where + monadThrow = lift . monadThrow +instance (MonadIO m, MonadUnsafeIO m, MonadThrow m, Applicative m) => MonadResource (HandlerT site m) where + liftResourceT = HandlerT . const . liftResourceT -instance MonadLogger (GHandler site) where - monadLoggerLog a b c d = GHandler $ \hd -> +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 Exception e => Failure e (GHandler site) where - failure = liftIO . throwIO +instance Failure e m => Failure e (HandlerT site m) where + failure = lift . failure instance Monoid (UniqueList x) where mempty = UniqueList id diff --git a/yesod-core/Yesod/Core/Types/Orphan.hs b/yesod-core/Yesod/Core/Types/Orphan.hs deleted file mode 100644 index e9c361fc..00000000 --- a/yesod-core/Yesod/Core/Types/Orphan.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Yesod.Core.Types.Orphan where - -import Yesod.Core.Types -import Control.Monad.Trans.Class -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Base (MonadBase (liftBase)) -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Resource (MonadResource (..)) -import Data.Conduit (MonadThrow (..)) - -instance MonadTrans (HandlerT sub) where - lift = HandlerT . const -instance MonadBase b m => MonadBase b (HandlerT sub m) where - liftBase = lift . liftBase -instance MonadBaseControl b m => MonadBaseControl b (HandlerT sub m) -instance MonadResource m => MonadResource (HandlerT sub m) where - liftResourceT = lift . liftResourceT -instance MonadIO m => MonadIO (HandlerT sub m) -instance MonadThrow m => MonadThrow (HandlerT sub m) where - monadThrow = lift . monadThrow diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 82d5905b..81624e3b 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,7 +11,7 @@ -- generator, allowing you to create truly modular HTML components. module Yesod.Core.Widget ( -- * Datatype - GWidget + WidgetT , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets , whamlet @@ -39,7 +40,6 @@ module Yesod.Core.Widget , addScriptRemoteAttrs , addScriptEither -- * Internal - , unGWidget , whamletFileWithSettings ) where @@ -50,7 +50,6 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) -import Yesod.Core.Class.MonadLift (lift) import Text.Shakespeare.I18N (RenderMessage) import Control.Monad (liftM) import Data.Text (Text) @@ -64,24 +63,26 @@ import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL import Yesod.Core.Types +import Yesod.Core.Class.Handler +import Control.Monad.Trans.Class preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup -class ToWidget site a where - toWidget :: a -> GWidget site () +class Monad m => ToWidget site m a where + toWidget :: a -> WidgetT site m () -instance render ~ RY site => ToWidget site (render -> Html) where +instance (Monad m, render ~ RY site) => ToWidget site m (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -instance render ~ RY site => ToWidget site (render -> Css) where +instance (Monad m, render ~ RY site) => ToWidget site m (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x -instance render ~ RY site => ToWidget site (render -> CssBuilder) where +instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty -instance render ~ RY site => ToWidget site (render -> Javascript) where +instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -instance (site' ~ site) => ToWidget site' (GWidget site ()) where +instance (site' ~ site, Monad m) => ToWidget site' m (WidgetT site m ()) where toWidget = id -instance ToWidget site Html where +instance Monad m => ToWidget site m Html where toWidget = toWidget . const -- | Allows adding some CSS to the page with a specific media type. @@ -91,16 +92,17 @@ class ToWidgetMedia site a where -- | Add the given content to the page, but only for the given media type. -- -- Since 1.2 - toWidgetMedia :: Text -- ^ media value + toWidgetMedia :: Monad m + => Text -- ^ media value -> a - -> GWidget site () + -> WidgetT site 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 :: a -> GWidget site () + toWidgetBody :: Monad m => a -> WidgetT site m () instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget @@ -110,7 +112,7 @@ instance ToWidgetBody site Html where toWidgetBody = toWidget class ToWidgetHead site a where - toWidgetHead :: a -> GWidget site () + toWidgetHead :: Monad m => a -> WidgetT site m () instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head @@ -125,52 +127,52 @@ instance ToWidgetHead site Html where -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Html -> GWidget site () +setTitle :: Monad m => Html -> WidgetT site 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 :: RenderMessage site msg => msg -> GWidget site () +setTitleI :: (Monad m, RenderMessage site msg) => msg -> WidgetT site m () setTitleI msg = do - mr <- lift getMessageRender + mr <- getMessageRender setTitle $ toHtml $ mr msg -- | Link to the specified local stylesheet. -addStylesheet :: Route site -> GWidget site () +addStylesheet :: Monad m => Route site -> WidgetT site m () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet. -addStylesheetAttrs :: Route site -> [(Text, Text)] -> GWidget site () +addStylesheetAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m () addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. -addStylesheetRemote :: Text -> GWidget site () +addStylesheetRemote :: Monad m => Text -> WidgetT site m () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. -addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () +addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m () addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Either (Route site) Text -> GWidget site () +addStylesheetEither :: Monad m => Either (Route site) Text -> WidgetT site m () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Either (Route site) Text -> GWidget site () +addScriptEither :: Monad m => Either (Route site) Text -> WidgetT site m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. -addScript :: Route site -> GWidget site () +addScript :: Monad m => Route site -> WidgetT site m () addScript = flip addScriptAttrs [] -- | Link to the specified local script. -addScriptAttrs :: Route site -> [(Text, Text)] -> GWidget site () +addScriptAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m () addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. -addScriptRemote :: Text -> GWidget site () +addScriptRemote :: Monad m => Text -> WidgetT site m () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. -addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () +addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter @@ -194,27 +196,22 @@ rules = do return $ InfixE (Just g) bind (Just e') let ur f = do let env = NP.Env - (Just $ helper [|liftW getUrlRenderParams|]) - (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) + (Just $ helper [|getUrlRenderParams|]) + (Just $ helper [|liftM (toHtml .) getMessageRender|]) f env return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -ihamletToRepHtml :: RenderMessage site message - => HtmlUrlI18n message (Route site) - -> GHandler site Html +ihamletToRepHtml :: (HandlerReader m, RenderMessage (HandlerSite m) message) + => HtmlUrlI18n message (Route (HandlerSite m)) + -> m Html ihamletToRepHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender return $ ih (toHtml . mrender) urender -tell :: GWData (Route site) -> GWidget site () -tell w = GWidget $ return ((), w) - --- | Type-restricted version of @lift@. Used internally to create better error --- messages. -liftW :: GHandler site a -> GWidget site a -liftW = lift +tell :: Monad m => GWData (Route site) -> WidgetT site m () +tell w = WidgetT $ return ((), w) toUnique :: x -> UniqueList x toUnique = UniqueList . (:) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4e0722e2..c81439bb 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -82,7 +82,7 @@ library , fast-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5 - , resourcet >= 0.4 && < 0.5 + , resourcet >= 0.4.6 && < 0.5 , lifted-base >= 0.1 , attoparsec-conduit , blaze-html >= 0.5 @@ -101,12 +101,10 @@ library Yesod.Core.Class.Handler Yesod.Core.Internal.Util Yesod.Core.Internal.Response - Yesod.Core.Class.MonadLift Yesod.Core.Internal.Run Yesod.Core.Class.Yesod Yesod.Core.Class.Dispatch Yesod.Core.Class.Breadcrumbs - Yesod.Core.Types.Orphan Paths_yesod_core ghc-options: -Wall