From 4bdd01ef580338dd75eb755c0f1cdea94ccebf78 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Mar 2013 10:59:10 +0200 Subject: [PATCH] Simplified GHandler/GWidget --- yesod-core/Yesod/Core.hs | 38 ++------ yesod-core/Yesod/Core/Class/Breadcrumbs.hs | 6 +- yesod-core/Yesod/Core/Class/Dispatch.hs | 40 ++------ yesod-core/Yesod/Core/Class/Handler.hs | 41 ++++---- yesod-core/Yesod/Core/Class/Yesod.hs | 36 ++++--- yesod-core/Yesod/Core/Dispatch.hs | 30 +++--- yesod-core/Yesod/Core/Handler.hs | 59 ++++-------- yesod-core/Yesod/Core/Internal/Run.hs | 89 +++++++---------- yesod-core/Yesod/Core/Json.hs | 22 ++--- yesod-core/Yesod/Core/Types.hs | 86 ++++++++--------- yesod-core/Yesod/Core/Widget.hs | 96 ++++++++----------- yesod-core/test/YesodCoreTest/JsLoader.hs | 2 +- .../test/YesodCoreTest/NoOverloadedStrings.hs | 6 +- yesod-core/test/YesodCoreTest/YesodTest.hs | 2 +- 14 files changed, 233 insertions(+), 320 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 8f81d438..e83e3899 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -49,7 +49,7 @@ module Yesod.Core , BottomOfHeadAsync -- * Subsites , defaultLayoutT - , MonadHandlerBase (..) + , MonadHandler (..) -- * Misc , yesodVersion , yesodRender @@ -92,8 +92,8 @@ import Data.Version (showVersion) import Yesod.Routes.Class (RenderRoute (..)) -- | Return an 'Unauthorized' value, with the given i18n message. -unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult -unauthorizedI msg =do +unauthorizedI :: RenderMessage site msg => msg -> GHandler site AuthResult +unauthorizedI msg = do mr <- getMessageRender return $ Unauthorized $ mr msg @@ -104,37 +104,19 @@ yesodVersion = showVersion Paths_yesod_core.version -- -- Built on top of 'isAuthorized'. This is useful for building page that only -- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a - => Route a +maybeAuthorized :: Yesod site + => Route site -> Bool -- ^ is this a write request? - -> GHandler s a (Maybe (Route a)) + -> GHandler site (Maybe (Route site)) maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing -class (MonadResource m, HandlerState m, Yesod (HandlerBase m)) => MonadHandlerBase m where - type HandlerBase m - type HandlerSite m - liftHandler :: GHandler (HandlerBase m) (HandlerBase m) a -> m a - askHandlerData :: m (HandlerData (HandlerSite m) (HandlerSite m)) -instance Yesod master => MonadHandlerBase (GHandler master master) where - type HandlerBase (GHandler master master) = master - type HandlerSite (GHandler master master) = master - liftHandler = id - askHandlerData = GHandler return -instance MonadHandlerBase m => MonadHandlerBase (HandlerT sub m) where - type HandlerBase (HandlerT sub m) = HandlerBase m - type HandlerSite (HandlerT sub m) = sub - liftHandler = lift . liftHandler - askHandlerData = HandlerT return - -defaultLayoutT :: ( HandlerState m - , HandlerSite m ~ sub - , Yesod (HandlerBase m) - , MonadHandlerBase m - , MonadResource m +defaultLayoutT :: ( HandlerSite m ~ sub + , Yesod (HandlerMaster m) + , MonadHandler m ) - => GWidget sub sub () + => GWidget sub () -> m RepHtml defaultLayoutT (GWidget (GHandler f)) = do hd <- askHandlerData diff --git a/yesod-core/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/Yesod/Core/Class/Breadcrumbs.hs index 246cf101..aa857241 100644 --- a/yesod-core/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/Yesod/Core/Class/Breadcrumbs.hs @@ -8,14 +8,14 @@ import Data.Text (Text) -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). -class YesodBreadcrumbs y where +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 y -> GHandler sub y (Text , Maybe (Route y)) + breadcrumb :: Route site -> GHandler site (Text , Maybe (Route site)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)]) +breadcrumbs :: YesodBreadcrumbs site => GHandler site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 6783d9a9..6c71c6ba 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -18,56 +18,36 @@ import Control.Monad.Trans.Control (MonadBaseControl) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class YesodDispatch sub master where - yesodDispatch - :: Yesod master - => YesodRunnerEnv sub master - -> W.Application - -instance YesodDispatch WaiSubsite master where - yesodDispatch YesodRunnerEnv { yreSub = WaiSubsite app } req = - app req +class Yesod site => YesodDispatch site where + yesodDispatch :: YesodRunnerEnv site -> W.Application class YesodSubDispatch sub m where yesodSubDispatch - :: (HandlerError m, HandlerState m, master ~ HandlerMaster m, Yesod master, MonadBaseControl IO m) + :: (MonadHandler m, master ~ HandlerMaster m, Yesod master) => (m TypedContent - -> YesodRunnerEnv master master + -> YesodRunnerEnv master -> Maybe (Route master) -> W.Application) -> (master -> sub) -> (Route sub -> Route master) - -> YesodRunnerEnv master master + -> YesodRunnerEnv master -> W.Application instance YesodSubDispatch WaiSubsite master where - yesodSubDispatch _ toSub _ YesodRunnerEnv { yreMaster = master } req = + yesodSubDispatch _ toSub _ YesodRunnerEnv { yreSite = site } req = app req where - WaiSubsite app = toSub master + WaiSubsite app = toSub site -{- -subHelper :: Yesod master => (YesodRunnerEnv sub master -> W.Application) - -> (forall res. ToTypedContent res - => m res - -> YesodRunnerEnv master master - -> Maybe (Route master) - -> W.Application) - -> (master -> sub) - -> (Route sub -> Route master) - -> W.Application -subHelper runBase getSub toMaster = error "subHelper" --} - -subHelper :: (HandlerMaster m ~ master, HandlerState m, MonadBaseControl IO m) +subHelper :: (HandlerSite m ~ master, MonadHandler m) => (m TypedContent - -> YesodRunnerEnv master master + -> YesodRunnerEnv master -> Maybe (Route master) -> W.Application) -> (master -> sub) -> (Route sub -> Route master) -> HandlerT sub m TypedContent - -> YesodRunnerEnv master master + -> YesodRunnerEnv master -> Maybe (Route sub) -> W.Application subHelper parentRunner getSub toMaster handlert env route = diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index da406f51..f7b2c2e7 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -5,35 +5,38 @@ 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) class Monad m => HandlerReader m where - type HandlerSub m + type HandlerSite m type HandlerMaster m askYesodRequest :: m YesodRequest - askHandlerEnv :: m (RunHandlerEnv (HandlerSub m) (HandlerMaster m)) + askHandlerEnv :: m (RunHandlerEnv (HandlerSite m)) -instance HandlerReader (GHandler sub master) where - type HandlerSub (GHandler sub master) = sub - type HandlerMaster (GHandler sub master) = master +instance HandlerReader (GHandler site) where + type HandlerSite (GHandler site) = site + type HandlerMaster (GHandler site) = site askYesodRequest = GHandler $ return . handlerRequest askHandlerEnv = GHandler $ return . handlerEnv -instance HandlerReader (GWidget sub master) where - type HandlerSub (GWidget sub master) = sub - type HandlerMaster (GWidget sub master) = master +instance HandlerReader m => HandlerReader (HandlerT site m) where + type HandlerSite (HandlerT site m) = site + type HandlerMaster (HandlerT site m) = HandlerMaster m - askYesodRequest = lift askYesodRequest - askHandlerEnv = lift askHandlerEnv + askYesodRequest = HandlerT $ return . handlerRequest + askHandlerEnv = HandlerT $ return . handlerEnv -instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where - type HandlerSub (t m) = HandlerSub m - type HandlerMaster (t m) = HandlerMaster m +instance HandlerReader (GWidget site) where + type HandlerSite (GWidget site) = site + type HandlerMaster (GWidget site) = site askYesodRequest = lift askYesodRequest askHandlerEnv = lift askHandlerEnv @@ -47,26 +50,26 @@ class HandlerReader m => HandlerState m where putGHState :: GHState -> m () putGHState s = stateGHState $ const ((), s) -instance HandlerState (GHandler sub master) where +instance HandlerState (GHandler site) where stateGHState f = GHandler $ flip atomicModifyIORef f' . handlerState where f' z = let (x, y) = f z in (y, x) -instance HandlerState (GWidget sub master) where +instance HandlerState (GWidget site) where stateGHState = lift . stateGHState -instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where +instance HandlerState m => HandlerState (HandlerT site m) where stateGHState = lift . stateGHState class HandlerReader m => HandlerError m where handlerError :: HandlerContents -> m a -instance HandlerError (GHandler sub master) where +instance HandlerError (GHandler site) where handlerError = throwIO -instance HandlerError (GWidget sub master) where +instance HandlerError (GWidget site) where handlerError = lift . handlerError -instance (HandlerError m, MonadTrans t, Monad (t m)) => HandlerError (t m) where +instance HandlerError m => HandlerError (HandlerT site m) where handlerError = lift . handlerError diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index a7428e49..6c9d1168 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -6,7 +6,8 @@ module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS) import Yesod.Core.Content -import Yesod.Core.Handler hiding (getExpires) +import Yesod.Core.Handler +import Yesod.Core.Class.Handler import Yesod.Routes.Class @@ -17,6 +18,8 @@ import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) +import Control.Monad.Trans.Resource +import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Aeson (object, (.=)) @@ -77,11 +80,11 @@ class RenderRoute a => Yesod a where approot = ApprootRelative -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a TypedContent + errorHandler :: ErrorResponse -> GHandler a TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout :: GWidget a () -> GHandler a RepHtml defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage @@ -112,7 +115,7 @@ $doctype 5 -- If authentication is required, return 'AuthenticationRequired'. isAuthorized :: Route a -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult + -> GHandler a AuthResult isAuthorized _ _ = return Authorized -- | Determines whether the current request is a write request. By default, @@ -122,7 +125,7 @@ $doctype 5 -- -- This function is used to determine if a request is authorized; see -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest :: Route a -> GHandler a Bool isWriteRequest _ = do wai <- waiRequest return $ W.requestMethod wai `notElem` @@ -188,7 +191,7 @@ $doctype 5 addStaticContent :: Text -- ^ filename extension -> Text -- ^ mime-type -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) + -> GHandler a (Maybe (Either Text (Route a, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing {- Temporarily disabled until we have a better interface. @@ -274,7 +277,7 @@ $doctype 5 -- performs authorization checks. -- -- Since: 1.1.6 - yesodMiddleware :: GHandler sub a res -> GHandler sub a res + yesodMiddleware :: GHandler a res -> GHandler a res yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" route <- getCurrentRoute @@ -297,9 +300,9 @@ $doctype 5 handler -- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) +widgetToPageContent :: (Eq (Route site), Yesod site) + => GWidget site () + -> GHandler site (PageContent (Route site)) widgetToPageContent w = do master <- getYesod ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w @@ -393,7 +396,7 @@ $newline never runUniqueList (UniqueList x) = nub $ x [] -- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent +defaultErrorHandler :: Yesod site => ErrorResponse -> GHandler site TypedContent defaultErrorHandler NotFound = selectRep $ do provideRep $ defaultLayout $ do r <- lift waiRequest @@ -557,3 +560,14 @@ 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 (HandlerMaster m) a -> m a + askHandlerData :: m (HandlerData (HandlerSite m)) + +instance Yesod site => MonadHandler (GHandler site) where + liftHandler = id + askHandlerData = GHandler return +instance MonadHandler m => MonadHandler (HandlerT site m) where + liftHandler = lift . liftHandler + askHandlerData = HandlerT return diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index b0ef6e15..af0330ec 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -122,8 +122,8 @@ mkYesodGeneral name args clazzes isSub resS = do context = if isSub then cxt $ yesod : map return clazzes else return [] yesod = classP ''HandlerReader [master] - handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |] - widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |] + handler = tySynD (mkName "Handler") [] [t| GHandler $master |] + widget = tySynD (mkName "Widget") [] [t| GWidget $master () |] res = map (fmap parseType) resS subCons = conT $ mkName name subArgs = map (varT. mkName) args @@ -139,7 +139,7 @@ mkDispatchInstance :: CxtQ -- ^ The context -> [ResourceTree a] -- ^ The resource -> DecsQ mkDispatchInstance context _sub master res = do - let yDispatch = conT ''YesodDispatch `appT` master `appT` master + let yDispatch = conT ''YesodDispatch `appT` master thisDispatch = do clause' <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|yesodRunner|] @@ -199,38 +199,30 @@ mkYesodSubDispatch res = do -- handler. This is the same as 'toWaiAppPlain', except it includes two -- middlewares: GZIP compression and autohead. This is the -- recommended approach for most users. -toWaiApp :: ( Yesod master - , YesodDispatch master master - ) => master -> IO W.Application +toWaiApp :: YesodDispatch site => site -> IO W.Application toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares. -toWaiAppPlain :: ( Yesod master - , YesodDispatch master master - ) => master -> IO W.Application +toWaiAppPlain :: YesodDispatch site => site -> IO W.Application toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a -toWaiApp' :: ( Yesod master - , YesodDispatch master master - ) - => master +toWaiApp' :: YesodDispatch site + => site -> Logger -> Maybe SessionBackend -> W.Application -toWaiApp' y logger sb req = - case cleanPath y $ W.pathInfo req of - Left pieces -> sendRedirect y pieces req +toWaiApp' site logger sb req = + case cleanPath site $ W.pathInfo req of + Left pieces -> sendRedirect site pieces req Right pieces -> yesodDispatch yre req { W.pathInfo = pieces } where yre = YesodRunnerEnv { yreLogger = logger - , yreMaster = y - , yreSub = y - , yreToMaster = id + , yreSite = site , yreSessionBackend = sb } diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index e94da292..b89a5e1e 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -25,12 +25,9 @@ module Yesod.Core.Handler , HandlerT -- ** Read information from handler , getYesod - , getYesodSub , getUrlRender , getUrlRenderParams , getCurrentRoute - , getCurrentRouteSub - , getRouteToMaster , getRequest , waiRequest , runRequestBody @@ -132,7 +129,7 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, import Control.Applicative ((<$>), (<|>)) -import Control.Monad (ap, liftM) +import Control.Monad (liftM) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad.IO.Class (MonadIO, liftIO) @@ -233,16 +230,12 @@ rbHelper' backend mkFI req = | otherwise = a' go = decodeUtf8With lenientDecode --- | Get the sub application argument. -getYesodSub :: HandlerReader m => m (HandlerSub m) -getYesodSub = rheSub `liftM` askHandlerEnv - -- | Get the master site appliation argument. -getYesod :: HandlerReader m => m (HandlerMaster m) -getYesod = rheMaster `liftM` askHandlerEnv +getYesod :: HandlerReader m => m (HandlerSite m) +getYesod = rheSite `liftM` askHandlerEnv -- | Get the URL rendering function. -getUrlRender :: HandlerReader m => m (Route (HandlerMaster m) -> Text) +getUrlRender :: HandlerReader m => m (Route (HandlerSite m) -> Text) getUrlRender = do x <- rheRender `liftM` askHandlerEnv return $ flip x [] @@ -250,23 +243,13 @@ getUrlRender = do -- | The URL rendering function with query-string parameters. getUrlRenderParams :: HandlerReader m - => m (Route (HandlerMaster m) -> [(Text, Text)] -> Text) + => 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 (HandlerMaster m))) -getCurrentRoute = fmap `liftM` getRouteToMaster `ap` getCurrentRouteSub - --- | Same as 'getCurrentRoute', but for the subsite. -getCurrentRouteSub :: HandlerReader m => m (Maybe (Route (HandlerSub m))) -getCurrentRouteSub = rheRoute `liftM` askHandlerEnv - --- | Get the function to promote a route for a subsite to a route for the --- master site. -getRouteToMaster :: HandlerReader m => m (Route (HandlerSub m) -> Route (HandlerMaster m)) -getRouteToMaster = rheToMaster `liftM` askHandlerEnv - +getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m))) +getCurrentRoute = rheRoute `liftM` askHandlerEnv -- | Returns a function that runs 'GHandler' actions inside @IO@. -- @@ -304,7 +287,7 @@ getRouteToMaster = rheToMaster `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 sub master (GHandler sub master a -> m a) +handlerToIO :: MonadIO m => GHandler site (GHandler site a -> m a) handlerToIO = GHandler $ \oldHandlerData -> do -- Let go of the request body, cache and response headers. @@ -344,7 +327,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 (HandlerMaster m) url, HandlerReader m) +redirect :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m) => url -> m a redirect url = do req <- waiRequest @@ -355,7 +338,7 @@ redirect url = do redirectWith status url -- | Redirect to the given URL with the specified status code. -redirectWith :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m) +redirectWith :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m) => H.Status -> url -> m a @@ -370,7 +353,7 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: (HandlerState m, RedirectUrl (HandlerMaster m) url) +setUltDest :: (HandlerState m, RedirectUrl (HandlerSite m) url) => url -> m () setUltDest url = do @@ -410,7 +393,7 @@ setUltDestReferer = do -- -- This function uses 'redirect', and thus will perform a temporary redirect to -- a GET request. -redirectUltDest :: (RedirectUrl (HandlerMaster m) url, HandlerState m, HandlerError m) +redirectUltDest :: (RedirectUrl (HandlerSite m) url, HandlerState m, HandlerError m) => url -- ^ default destination if nothing in session -> m a redirectUltDest def = do @@ -434,7 +417,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 @@ -479,7 +462,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: HandlerError m => Route (HandlerMaster m) -> m a +sendResponseCreated :: HandlerError m => Route (HandlerSite m) -> m a sendResponseCreated url = do r <- getUrlRender handlerError $ HCCreated $ r url @@ -507,7 +490,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 @@ -519,7 +502,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 @@ -623,7 +606,7 @@ 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, HandlerMaster m ~ master) => a -> m Text + toTextUrl :: (HandlerReader m, HandlerSite m ~ master) => a -> m Text instance RedirectUrl master Text where toTextUrl = return @@ -672,7 +655,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 (HandlerMaster m) url) +redirectToPost :: (HandlerError m, RedirectUrl (HandlerSite m) url) => url -> m a redirectToPost url = do @@ -692,7 +675,7 @@ $doctype 5 |] >>= sendResponse -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Html +hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerSite m)) -> m Html hamletToRepHtml = giveUrlRenderer -- | Provide a URL rendering function to the given function and return the @@ -700,7 +683,7 @@ hamletToRepHtml = giveUrlRenderer -- -- Since 1.2.0 giveUrlRenderer :: HandlerReader m - => ((Route (HandlerMaster m) -> [(Text, Text)] -> Text) -> output) + => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output giveUrlRenderer f = do render <- getUrlRenderParams @@ -710,7 +693,7 @@ 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 m <- getYesod diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index cb8bfdd7..a57fbd55 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -11,10 +11,9 @@ import Yesod.Core.Class.Handler import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) import Control.Exception (fromException) -import Control.Exception.Lifted (catch, finally) +import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Base (liftBase) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) import Control.Monad.Trans.Resource (runResourceT) @@ -48,8 +47,8 @@ import Yesod.Routes.Class (Route, renderRoute) -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c - => RunHandlerEnv sub master - -> GHandler sub master c + => RunHandlerEnv site + -> GHandler site c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = do let toErrorHandler e = @@ -149,25 +148,23 @@ safeEh log' er req = do -- @GHandler@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the -- @GHandler@'s return value. -runFakeHandler :: (Yesod master, MonadIO m) => +runFakeHandler :: (Yesod site, MonadIO m) => SessionMap - -> (master -> Logger) - -> master - -> GHandler master master a + -> (site -> Logger) + -> site + -> GHandler site a -> m (Either ErrorResponse a) -runFakeHandler fakeSessionMap logger master handler = liftIO $ do +runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () let yapp = runHandler RunHandlerEnv - { rheRender = yesodRender master $ resolveApproot master fakeWaiRequest + { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest , rheRoute = Nothing - , rheToMaster = id - , rheMaster = master - , rheSub = master - , rheUpload = fileUpload master - , rheLog = messageLoggerSource master $ logger master + , rheSite = site + , rheUpload = fileUpload site + , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler } handler' @@ -210,10 +207,10 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} -yesodRunner :: (ToTypedContent res, Yesod master) - => GHandler sub master res - -> YesodRunnerEnv sub master - -> Maybe (Route sub) +yesodRunner :: (ToTypedContent res, Yesod site) + => GHandler site res + -> YesodRunnerEnv site + -> Maybe (Route site) -> Application yesodRunner handler' YesodRunnerEnv {..} route req | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse @@ -226,19 +223,17 @@ yesodRunner handler' YesodRunnerEnv {..} route req case mkYesodReq of Left yreq -> return yreq Right needGen -> liftIO $ needGen <$> newStdGen - let ra = resolveApproot yreMaster req - let log' = messageLoggerSource yreMaster yreLogger + let ra = resolveApproot yreSite req + let log' = messageLoggerSource yreSite yreLogger -- We set up two environments: the first one has a "safe" error handler -- which will never throw an exception. The second one uses the -- user-provided errorHandler function. If that errorHandler function -- errors out, it will use the safeEh below to recover. rheSafe = RunHandlerEnv - { rheRender = yesodRender yreMaster ra + { rheRender = yesodRender yreSite ra , rheRoute = route - , rheToMaster = yreToMaster - , rheMaster = yreMaster - , rheSub = yreSub - , rheUpload = fileUpload yreMaster + , rheSite = yreSite + , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' } @@ -248,7 +243,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req yar <- runHandler rhe handler yreq liftIO $ yarToResponse yar saveSession yreq where - maxLen = maximumContentLength yreMaster $ fmap yreToMaster route + maxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' yesodRender :: Yesod y @@ -274,38 +269,20 @@ resolveApproot master req = ApprootMaster f -> f master ApprootRequest f -> f master req -fixEnv :: (oldSub -> newSub) - -> (Route newSub -> Route oldSub) - -> YesodRunnerEnv oldSub master - -> YesodRunnerEnv newSub master -fixEnv toNewSub toOldRoute envOld = - envOld - { yreSub = toNewSub $ yreSub envOld - , yreToMaster = yreToMaster envOld . toOldRoute - } - -stripHandlerT :: (HandlerState m, MonadBaseControl IO m) +stripHandlerT :: (MonadHandler m, MonadBaseControl IO m) => HandlerT sub m a - -> (HandlerMaster m -> sub) - -> (Route sub -> Route (HandlerMaster m)) + -> (HandlerSite m -> sub) + -> (Route sub -> Route (HandlerSite m)) -> Maybe (Route sub) -> m a stripHandlerT (HandlerT f) getSub toMaster newRoute = do - yreq <- askYesodRequest - env <- askHandlerEnv - ghs <- getGHState - ighs <- liftBase $ I.newIORef ghs + hd <- askHandlerData - let sub = getSub $ rheMaster env - hd = HandlerData - { handlerRequest = yreq - , handlerEnv = env - { rheMaster = sub - , rheSub = sub - , rheToMaster = id - , rheRoute = newRoute - , rheRender = \url params -> rheRender env (toMaster url) params - } - , handlerState = ighs + let env = handlerEnv hd + f hd + { handlerEnv = env + { rheSite = getSub $ rheSite env + , rheRoute = newRoute + , rheRender = \url params -> rheRender env (toMaster url) params } - f hd `finally` (liftBase (I.readIORef ighs) >>= putGHState) + } diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 405860ef..272b21db 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -44,10 +44,10 @@ import Data.Maybe (listToMaybe) -- ('defaultLayout'). -- -- /Since: 0.3.0/ -defaultLayoutJson :: (Yesod master, J.ToJSON a) - => GWidget sub master () -- ^ HTML - -> GHandler sub master a -- ^ JSON - -> GHandler sub master TypedContent +defaultLayoutJson :: (Yesod site, J.ToJSON a) + => GWidget site () -- ^ HTML + -> GHandler site a -- ^ JSON + -> GHandler site TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w provideRep $ fmap J.toJSON json @@ -56,7 +56,7 @@ defaultLayoutJson w json = selectRep $ do -- support conversion to JSON via 'J.ToJSON'. -- -- /Since: 0.3.0/ -jsonToRepJson :: J.ToJSON a => a -> GHandler sub master J.Value +jsonToRepJson :: J.ToJSON a => a -> GHandler site J.Value jsonToRepJson = return . J.toJSON -- | Parse the request body to a data type as a JSON value. The @@ -65,7 +65,7 @@ jsonToRepJson = return . J.toJSON -- 'J.Value'@. -- -- /Since: 0.3.0/ -parseJsonBody :: J.FromJSON a => GHandler sub master (J.Result a) +parseJsonBody :: J.FromJSON a => GHandler site (J.Result a) parseJsonBody = do req <- waiRequest eValue <- lift @@ -78,7 +78,7 @@ parseJsonBody = do -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. -parseJsonBody_ :: J.FromJSON a => GHandler sub master a +parseJsonBody_ :: J.FromJSON a => GHandler site a parseJsonBody_ = do ra <- parseJsonBody case ra of @@ -96,10 +96,10 @@ array = J.Array . V.fromList . map J.toJSON -- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. -jsonOrRedirect :: (Yesod master, J.ToJSON a) - => Route master -- ^ Redirect target +jsonOrRedirect :: (Yesod site, J.ToJSON a) + => Route site -- ^ Redirect target -> a -- ^ Data to send via JSON - -> GHandler sub master J.Value + -> GHandler site J.Value jsonOrRedirect r j = do q <- acceptsJson if q then jsonToRepJson (J.toJSON j) @@ -107,7 +107,7 @@ jsonOrRedirect r j = do -- | Returns @True@ if the client prefers @application\/json@ as -- indicated by the @Accept@ HTTP header. -acceptsJson :: Yesod master => GHandler sub master Bool +acceptsJson :: Yesod site => GHandler site Bool acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) . join . fmap (listToMaybe . parseHttpAccept) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index ce22b666..8cb16cb5 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -166,12 +166,10 @@ type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -data RunHandlerEnv sub master = RunHandlerEnv - { rheRender :: !(Route master -> [(Text, Text)] -> Text) - , rheRoute :: !(Maybe (Route sub)) - , rheToMaster :: !(Route sub -> Route master) - , rheMaster :: !master - , rheSub :: !sub +data RunHandlerEnv site = RunHandlerEnv + { rheRender :: !(Route site -> [(Text, Text)] -> Text) + , rheRoute :: !(Maybe (Route site)) + , rheSite :: !site , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheOnError :: !(ErrorResponse -> YesodApp) @@ -180,28 +178,26 @@ data RunHandlerEnv sub master = RunHandlerEnv -- Since 1.2.0 } -data HandlerData sub master = HandlerData +data HandlerData site = HandlerData { handlerRequest :: !YesodRequest - , handlerEnv :: !(RunHandlerEnv sub master) + , handlerEnv :: !(RunHandlerEnv site) , handlerState :: !(IORef GHState) } -data YesodRunnerEnv sub master = YesodRunnerEnv +data YesodRunnerEnv site = YesodRunnerEnv { yreLogger :: !Logger - , yreMaster :: !master - , yreSub :: !sub - , yreToMaster :: !(Route sub -> Route master) + , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) } -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. -newtype GHandler sub master a = GHandler - { unGHandler :: HandlerData sub master -> ResourceT IO a +newtype GHandler site a = GHandler + { unGHandler :: HandlerData site -> ResourceT IO a } -newtype HandlerT sub m a = HandlerT - { unHandlerT :: HandlerData sub sub -> m a +newtype HandlerT site m a = HandlerT + { unHandlerT :: HandlerData site -> m a } instance Monad m => Monad (HandlerT sub m) where @@ -229,11 +225,11 @@ 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 sub master a = GWidget - { unGWidget :: GHandler sub master (a, GWData (Route master)) +newtype GWidget site a = GWidget -- FIXME change to WidgetT? + { unGWidget :: GHandler site (a, GWData (Route site)) } -instance (a ~ ()) => Monoid (GWidget sub master a) where +instance (a ~ ()) => Monoid (GWidget site a) where mempty = return () mappend x y = x >> y @@ -349,60 +345,60 @@ instance Show HandlerContents where instance Exception HandlerContents -- Instances for GWidget -instance Functor (GWidget sub master) where +instance Functor (GWidget site) where fmap f (GWidget x) = GWidget (fmap (first f) x) -instance Applicative (GWidget sub master) where +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 sub master) where +instance Monad (GWidget site) where return = pure GWidget x >>= f = GWidget $ do (a, wa) <- x (b, wb) <- unGWidget (f a) return (b, wa `mappend` wb) -instance MonadIO (GWidget sub master) where +instance MonadIO (GWidget site) where liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO -instance MonadBase IO (GWidget sub master) where +instance MonadBase IO (GWidget site) where liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase -instance MonadBaseControl IO (GWidget sub master) where - data StM (GWidget sub master) a = - StW (StM (GHandler sub master) (a, GWData (Route master))) +instance MonadBaseControl IO (GWidget site) where + data StM (GWidget site) a = + StW (StM (GHandler site) (a, GWData (Route site))) liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> liftM (\x -> (x, mempty)) (f $ liftM StW . runInBase . unGWidget) restoreM (StW base) = GWidget $ restoreM base -instance MonadUnsafeIO (GWidget sub master) where +instance MonadUnsafeIO (GWidget site) where unsafeLiftIO = liftIO -instance MonadThrow (GWidget sub master) where +instance MonadThrow (GWidget site) where monadThrow = liftIO . throwIO -instance MonadResource (GWidget sub master) where +instance MonadResource (GWidget site) where liftResourceT = lift . liftResourceT -instance MonadLogger (GWidget sub master) where +instance MonadLogger (GWidget site) where monadLoggerLog a b c = lift . monadLoggerLog a b c -instance MonadLift (GHandler sub master) (GWidget sub master) where +instance MonadLift (GHandler site) (GWidget site) where lift = GWidget . fmap (\x -> (x, mempty)) -instance MonadLift (ResourceT IO) (GHandler sub master) where +instance MonadLift (ResourceT IO) (GHandler site) where lift = GHandler . const -- Instances for GHandler -instance Functor (GHandler sub master) where +instance Functor (GHandler site) where fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) -instance Applicative (GHandler sub master) where +instance Applicative (GHandler site) where pure = GHandler . const . pure GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r -instance Monad (GHandler sub master) where +instance Monad (GHandler site) where return = pure GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r -instance MonadIO (GHandler sub master) where +instance MonadIO (GHandler site) where liftIO = GHandler . const . lift -instance MonadBase IO (GHandler sub master) where +instance MonadBase IO (GHandler site) where liftBase = GHandler . const . lift -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- @fork@ function is incompatible with the underlying @ResourceT@ system. @@ -412,25 +408,25 @@ instance MonadBase IO (GHandler sub master) 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 sub master) where - data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) +instance MonadBaseControl IO (GHandler site) where + data StM (GHandler site) a = StH (StM (ResourceT IO) a) liftBaseWith f = GHandler $ \reader -> liftBaseWith $ \runInBase -> f $ liftM StH . runInBase . (\(GHandler r) -> r reader) restoreM (StH base) = GHandler $ const $ restoreM base -instance MonadUnsafeIO (GHandler sub master) where +instance MonadUnsafeIO (GHandler site) where unsafeLiftIO = liftIO -instance MonadThrow (GHandler sub master) where +instance MonadThrow (GHandler site) where monadThrow = liftIO . throwIO -instance MonadResource (GHandler sub master) where +instance MonadResource (GHandler site) where liftResourceT = lift . liftResourceT -instance MonadLogger (GHandler sub master) where +instance MonadLogger (GHandler site) where monadLoggerLog a b c d = GHandler $ \hd -> liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) -instance Exception e => Failure e (GHandler sub master) where +instance Exception e => Failure e (GHandler site) where failure = liftIO . throwIO instance Monoid (UniqueList x) where diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 39142c2f..82d5905b 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -25,8 +25,6 @@ module Yesod.Core.Widget -- ** Head of page , setTitle , setTitleI - -- ** Body - , addSubWidget -- ** CSS , addStylesheet , addStylesheetAttrs @@ -70,121 +68,109 @@ import Yesod.Core.Types preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup -addSubWidget :: (Route sub -> Route master) -> sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget toMaster sub (GWidget (GHandler f)) = - GWidget $ GHandler $ f . modHD - where - modHD hd = hd - { handlerEnv = (handlerEnv hd) - { rheRoute = Nothing - , rheSub = sub - , rheToMaster = toMaster - } - } +class ToWidget site a where + toWidget :: a -> GWidget site () -class ToWidget sub master a where - toWidget :: a -> GWidget sub master () - -instance render ~ RY master => ToWidget sub master (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 render ~ RY master => ToWidget sub master (render -> Css) where +instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x -instance render ~ RY master => ToWidget sub master (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 render ~ RY master => ToWidget sub master (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 (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where +instance (site' ~ site) => ToWidget site' (GWidget site ()) where toWidget = id -instance ToWidget sub master Html where +instance ToWidget site Html where toWidget = toWidget . const -- | Allows adding some CSS to the page with a specific media type. -- -- Since 1.2 -class ToWidgetMedia sub master a where +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 -> a - -> GWidget sub master () -instance render ~ RY master => ToWidgetMedia sub master (render -> Css) where + -> GWidget site () +instance render ~ RY site => ToWidgetMedia site (render -> Css) where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x -instance render ~ RY master => ToWidgetMedia sub master (render -> CssBuilder) where +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 sub master a where - toWidgetBody :: a -> GWidget sub master () +class ToWidgetBody site a where + toWidgetBody :: a -> GWidget site () -instance render ~ RY master => ToWidgetBody sub master (render -> Html) where +instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget -instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where +instance render ~ RY site => ToWidgetBody site (render -> Javascript) where toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j -instance ToWidgetBody sub master Html where +instance ToWidgetBody site Html where toWidgetBody = toWidget -class ToWidgetHead sub master a where - toWidgetHead :: a -> GWidget sub master () +class ToWidgetHead site a where + toWidgetHead :: a -> GWidget site () -instance render ~ RY master => ToWidgetHead sub master (render -> Html) where +instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head -instance render ~ RY master => ToWidgetHead sub master (render -> Css) where +instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget -instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where +instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where toWidgetHead = toWidget -instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where +instance render ~ RY site => ToWidgetHead site (render -> Javascript) where toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j -instance ToWidgetHead sub master Html where +instance ToWidgetHead site Html where toWidgetHead = toWidgetHead . const -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Html -> GWidget sub master () +setTitle :: Html -> GWidget site () 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 master msg => msg -> GWidget sub master () +setTitleI :: RenderMessage site msg => msg -> GWidget site () setTitleI msg = do mr <- lift getMessageRender setTitle $ toHtml $ mr msg -- | Link to the specified local stylesheet. -addStylesheet :: Route master -> GWidget sub master () +addStylesheet :: Route site -> GWidget site () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet. -addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master () +addStylesheetAttrs :: Route site -> [(Text, Text)] -> GWidget site () 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 sub master () +addStylesheetRemote :: Text -> GWidget site () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. -addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master () +addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Either (Route master) Text -> GWidget sub master () +addStylesheetEither :: Either (Route site) Text -> GWidget site () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Either (Route master) Text -> GWidget sub master () +addScriptEither :: Either (Route site) Text -> GWidget site () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. -addScript :: Route master -> GWidget sub master () +addScript :: Route site -> GWidget site () addScript = flip addScriptAttrs [] -- | Link to the specified local script. -addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master () +addScriptAttrs :: Route site -> [(Text, Text)] -> GWidget site () 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 sub master () +addScriptRemote :: Text -> GWidget site () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. -addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master () +addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter @@ -214,20 +200,20 @@ rules = do return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -ihamletToRepHtml :: RenderMessage master message - => HtmlUrlI18n message (Route master) - -> GHandler sub master Html +ihamletToRepHtml :: RenderMessage site message + => HtmlUrlI18n message (Route site) + -> GHandler site Html ihamletToRepHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender return $ ih (toHtml . mrender) urender -tell :: GWData (Route master) -> GWidget sub master () +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 sub master a -> GWidget sub master a +liftW :: GHandler site a -> GWidget site a liftW = lift toUnique :: x -> UniqueList x diff --git a/yesod-core/test/YesodCoreTest/JsLoader.hs b/yesod-core/test/YesodCoreTest/JsLoader.hs index 670bc004..c084536a 100644 --- a/yesod-core/test/YesodCoreTest/JsLoader.hs +++ b/yesod-core/test/YesodCoreTest/JsLoader.hs @@ -30,5 +30,5 @@ specs = describe "Test.JsLoader" $ do res <- request defaultRequest assertBody "\n" res -runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO () +runner :: YesodDispatch master => master -> Session () -> IO () runner app f = toWaiApp app >>= runSession f diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index b0e58953..ae698287 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -15,16 +15,16 @@ import qualified Data.ByteString.Lazy.Char8 as L8 getSubsite :: a -> Subsite getSubsite = const Subsite -instance YesodSubDispatch Subsite (GHandler master master) where +instance YesodSubDispatch Subsite (GHandler master) where yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" -getBazR :: Yesod master => HandlerT Subsite (GHandler master master) RepHtml +getBazR :: Yesod master => HandlerT Subsite (GHandler master) RepHtml getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] -getBinR :: MonadHandlerBase m => HandlerT Subsite m RepHtml +getBinR :: MonadHandler m => HandlerT Subsite m RepHtml getBinR = defaultLayoutT [whamlet|

Used defaultLayoutT diff --git a/yesod-core/test/YesodCoreTest/YesodTest.hs b/yesod-core/test/YesodCoreTest/YesodTest.hs index 85fc5142..f0b7b69b 100644 --- a/yesod-core/test/YesodCoreTest/YesodTest.hs +++ b/yesod-core/test/YesodCoreTest/YesodTest.hs @@ -14,5 +14,5 @@ import Network.Wai.Test import Network.Wai import Test.Hspec -yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a +yesod :: YesodDispatch y => y -> Session a -> IO a yesod app f = toWaiApp app >>= runSession f