defaultLayout now works directly on widgets

Yesod/Helpers/Auth.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -182,7 +183,9 @@ getOpenIdR = do
     lookupGetParam "dest" >>= maybe (return ()) setUltDestString
     rtom <- getRouteToMaster
     message <- getMessage
-    applyLayout "Log in via OpenID" mempty [$hamlet|
+    defaultLayout $ do
+        setTitle "Log in via OpenID"
+        addBody [$hamlet|
 $maybe message msg
     %p.message $msg$
 %form!method=get!action=@rtom.OpenIdForwardR@
@@ -262,7 +265,9 @@ getDisplayName extra =
 getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson
 getCheckR = do
     creds <- maybeCreds
-    applyLayoutJson "Authentication Status" mempty (html creds) (json creds)
+    defaultLayoutJson (do
+        setTitle "Authentication Status"
+        addBody $ html creds) (json creds)
   where
     html creds = [$hamlet|
 %h1 Authentication Status
@@ -303,7 +308,7 @@ getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml
 getEmailRegisterR = do
     _ae <- getAuthEmailSettings
     toMaster <- getRouteToMaster
-    applyLayout "Register a new account" mempty [$hamlet|
+    defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet|
 %p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
 %form!method=post!action=@toMaster.EmailRegisterR@
     %label!for=email E-mail
@@ -333,7 +338,7 @@ postEmailRegisterR = do
     tm <- getRouteToMaster
     let verUrl = render $ tm $ EmailVerifyR lid verKey
     sendVerifyEmail ae email verKey verUrl
-    applyLayout "Confirmation e-mail sent" mempty [$hamlet|
+    defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet|
 %p A confirmation e-mail has been sent to $email$.
 |]
 
@@ -350,7 +355,9 @@ getEmailVerifyR lid key = do
                       Nothing) []
             toMaster <- getRouteToMaster
             redirect RedirectTemporary $ toMaster EmailPasswordR
-        _ -> applyLayout "Invalid verification key" mempty [$hamlet|
+        _ -> defaultLayout $ do
+            setTitle "Invalid verification key"
+            addBody [$hamlet|
 %p I'm sorry, but that was an invalid verification key.
 |]
 
@@ -359,7 +366,9 @@ getEmailLoginR = do
     _ae <- getAuthEmailSettings
     toMaster <- getRouteToMaster
     msg <- getMessage
-    applyLayout "Login" mempty [$hamlet|
+    defaultLayout $ do
+        setTitle "Login"
+        addBody [$hamlet|
 $maybe msg ms
     %p.message $ms$
 %p Please log in to your account.
@@ -414,7 +423,9 @@ getEmailPasswordR = do
             setMessage $ string "You must be logged in to set a password"
             redirect RedirectTemporary $ toMaster EmailLoginR
     msg <- getMessage
-    applyLayout "Set password" mempty [$hamlet|
+    defaultLayout $ do
+        setTitle "Set password"
+        addBody [$hamlet|
 $maybe msg ms
     %p.message $ms$
 %h3 Set a new password

Yesod/Helpers/Crud.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Yesod.Helpers.Crud
     ( Item (..)
     , Crud (..)
@@ -17,7 +18,6 @@ import Yesod.Content
 import Yesod.Handler
 import Text.Hamlet
 import Yesod.Form
-import Data.Monoid (mempty)
 import Language.Haskell.TH.Syntax
 
 -- | An entity which can be displayed by the Crud subsite.
@@ -53,7 +53,9 @@ getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
 getCrudListR = do
     items <- getYesodSub >>= crudSelect
     toMaster <- getRouteToMaster
-    applyLayout "Items" mempty [$hamlet|
+    defaultLayout $ do
+        setTitle "Items"
+        addBody [$hamlet|
 %h1 Items
 %ul
     $forall items item
@@ -111,7 +113,9 @@ getCrudDeleteR s = do
     crud <- getYesodSub
     item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
     toMaster <- getRouteToMaster
-    applyLayout "Confirm delete" mempty [$hamlet|
+    defaultLayout $ do
+        setTitle "Confirm delete"
+        addBody [$hamlet|
 %form!method=post!action=@toMaster.CrudDeleteR.s@
     %h1 Really delete?
     %p Do you really want to delete $itemTitle.item$?
@@ -151,7 +155,7 @@ crudHelper title me isPost = do
             redirect RedirectTemporary $ toMaster $ CrudEditR
                                        $ toSinglePiece eid
         _ -> return ()
-    applyLayoutW $ do
+    defaultLayout $ do
         wrapWidget form (wrapForm toMaster enctype)
         setTitle $ string title
   where

Yesod/Internal.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- | Normal users should never need access to these.
 module Yesod.Internal
     ( -- * Error responses
@@ -6,8 +8,23 @@ module Yesod.Internal
     , Header (..)
       -- * Cookie names
     , langKey
+      -- * Widgets
+    , Location (..)
+    , UniqueList (..)
+    , Script (..)
+    , Stylesheet (..)
+    , Title (..)
+    , Head (..)
+    , Body (..)
+    , locationToHamlet
+    , runUniqueList
+    , toUnique
     ) where
 
+import Text.Hamlet (Hamlet, hamlet, Html)
+import Data.Monoid (Monoid (..))
+import Data.List (nub)
+
 -- | Responses to indicate some form of an error occurred. These are different
 -- from 'SpecialResponse' in that they allow for custom error pages.
 data ErrorResponse =
@@ -28,3 +45,29 @@ data Header =
 
 langKey :: String
 langKey = "_LANG"
+
+data Location url = Local url | Remote String
+    deriving (Show, Eq)
+locationToHamlet :: Location url -> Hamlet url
+locationToHamlet (Local url) = [$hamlet|@url@|]
+locationToHamlet (Remote s) = [$hamlet|$s$|]
+
+newtype UniqueList x = UniqueList ([x] -> [x])
+instance Monoid (UniqueList x) where
+    mempty = UniqueList id
+    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
+runUniqueList :: Eq x => UniqueList x -> [x]
+runUniqueList (UniqueList x) = nub $ x []
+toUnique :: x -> UniqueList x
+toUnique = UniqueList . (:)
+
+newtype Script url = Script { unScript :: Location url }
+    deriving (Show, Eq)
+newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }
+    deriving (Show, Eq)
+newtype Title = Title { unTitle :: Html }
+
+newtype Head url = Head (Hamlet url)
+    deriving Monoid
+newtype Body url = Body (Hamlet url)
+    deriving Monoid

Yesod/Widget.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -7,12 +6,9 @@
 -- generator, allowing you to create truly modular HTML components.
 module Yesod.Widget
     ( -- * Datatype
-      GWidget
+      GWidget (..)
     , Widget
     , liftHandler
-      -- * Unwrapping
-    , widgetToPageContent
-    , applyLayoutW
       -- * Creating
     , newIdent
     , setTitle
@@ -31,46 +27,18 @@ module Yesod.Widget
     , extractBody
     ) where
 
-import Data.List (nub)
 import Data.Monoid
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.State
-import Yesod.Hamlet (PageContent (..))
 import Text.Hamlet
 import Text.Cassius
 import Text.Julius
-import Yesod.Handler (Route, GHandler, getUrlRenderParams)
+import Yesod.Handler (Route, GHandler)
-import Yesod.Yesod (Yesod, defaultLayout, addStaticContent)
-import Yesod.Content (RepHtml (..))
 import Control.Applicative (Applicative)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (lift)
 import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
-
+import Yesod.Internal
-data Location url = Local url | Remote String
-    deriving (Show, Eq)
-locationToHamlet :: Location url -> Hamlet url
-locationToHamlet (Local url) = [$hamlet|@url@|]
-locationToHamlet (Remote s) = [$hamlet|$s$|]
-
-newtype UniqueList x = UniqueList ([x] -> [x])
-instance Monoid (UniqueList x) where
-    mempty = UniqueList id
-    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
-runUniqueList :: Eq x => UniqueList x -> [x]
-runUniqueList (UniqueList x) = nub $ x []
-toUnique :: x -> UniqueList x
-toUnique = UniqueList . (:)
-
-newtype Script url = Script { unScript :: Location url }
-    deriving (Show, Eq)
-newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }
-    deriving (Show, Eq)
-newtype Title = Title { unTitle :: Html }
-newtype Head url = Head (Hamlet url)
-    deriving Monoid
-newtype Body url = Body (Hamlet url)
-    deriving Monoid
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
@@ -151,78 +119,6 @@ addScriptRemote =
 addJavascript :: Julius (Route master) -> GWidget sub master ()
 addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just
 
--- | Apply the default layout to the given widget.
-applyLayoutW :: (Eq (Route m), Yesod m)
-             => GWidget sub m () -> GHandler sub m RepHtml
-applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout
-
--- | Convert a widget to a 'PageContent'.
-widgetToPageContent :: (Eq (Route master), Yesod master)
-                    => GWidget sub master ()
-                    -> GHandler sub master (PageContent (Route master))
-widgetToPageContent (GWidget w) = do
-    w' <- flip evalStateT 0
-        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-        $ runWriterT $ runWriterT $ runWriterT w
-    let ((((((((),
-         Body body),
-         Last mTitle),
-         scripts'),
-         stylesheets'),
-         style),
-         jscript),
-         Head head') = w'
-    let title = maybe mempty unTitle mTitle
-    let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
-    let stylesheets = map (locationToHamlet . unStylesheet)
-                    $ runUniqueList stylesheets'
-    let cssToHtml (Css b) = Html b
-        celper :: Cassius url -> Hamlet url
-        celper = fmap cssToHtml
-        jsToHtml (Javascript b) = Html b
-        jelper :: Julius url -> Hamlet url
-        jelper = fmap jsToHtml
-
-    render <- getUrlRenderParams
-    let renderLoc x =
-            case x of
-                Nothing -> Nothing
-                Just (Left s) -> Just s
-                Just (Right (u, p)) -> Just $ render u p
-    cssLoc <-
-        case style of
-            Nothing -> return Nothing
-            Just s -> do
-                x <- addStaticContent "css" "text/css; charset=utf-8"
-                   $ renderCassius render s
-                return $ renderLoc x
-    jsLoc <-
-        case jscript of
-            Nothing -> return Nothing
-            Just s -> do
-                x <- addStaticContent "js" "text/javascript; charset=utf-8"
-                   $ renderJulius render s
-                return $ renderLoc x
-
-    let head'' = [$hamlet|
-$forall scripts s
-    %script!src=^s^
-$forall stylesheets s
-    %link!rel=stylesheet!href=^s^
-$maybe style s
-    $maybe cssLoc s
-        %link!rel=stylesheet!href=$s$
-    $nothing
-        %style ^celper.s^
-$maybe jscript j
-    $maybe jsLoc s
-        %script!src=$s$
-    $nothing
-        %script ^jelper.j^
-^head'^
-|]
-    return $ PageContent title head'' body
-
 -- | Modify the given 'GWidget' by wrapping the body tag HTML code with the
 -- given function. You might also consider using 'extractBody'.
 wrapWidget :: GWidget s m a

Yesod/Yesod.hs

@@ -18,10 +18,10 @@ module Yesod.Yesod
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs
-      -- * Convenience functions
+      -- * Utitlities
-    , applyLayout
-    , applyLayoutJson
     , maybeAuthorized
+    , widgetToPageContent
+    , defaultLayoutJson
       -- * Defaults
     , defaultErrorHandler
       -- * Data types
@@ -39,6 +39,7 @@ import Yesod.Content
 import Yesod.Json
 #endif
 
+import Yesod.Widget
 import Yesod.Request
 import Yesod.Hamlet
 import Yesod.Handler
@@ -46,7 +47,6 @@ import qualified Network.Wai as W
 import Yesod.Internal
 import Web.ClientSession (getKey, defaultKeyFile)
 import qualified Web.ClientSession as CS
-import Data.Monoid (mempty)
 import qualified Data.ByteString.UTF8 as BSU
 import Database.Persist
 import Control.Monad.Trans.Class (MonadTrans (..))
@@ -55,6 +55,12 @@ import qualified Data.ByteString as S
 import qualified Network.Wai.Middleware.CleanPath
 import qualified Data.ByteString.Lazy as L
 import Yesod.WebRoutes
+import Data.Monoid
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.State hiding (get)
+import Text.Hamlet
+import Text.Cassius
+import Text.Julius
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -103,8 +109,10 @@ class Eq (Route a) => Yesod a where
     errorHandler = defaultErrorHandler
 
     -- | Applies some form of layout to the contents of a page.
-    defaultLayout :: PageContent (Route a) -> GHandler sub a Content
+    defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
-    defaultLayout p = hamletToContent [$hamlet|
+    defaultLayout w = do
+        p <- widgetToPageContent w
+        hamletToRepHtml [$hamlet|
 !!!
 %html
     %head
@@ -226,41 +234,24 @@ breadcrumbs = do
         (title, next) <- breadcrumb this
         go ((this, title) : back) next
 
--- | Apply the default layout ('defaultLayout') to the given title and body.
-applyLayout :: Yesod master
-            => String -- ^ title
-            -> Hamlet (Route master) -- ^ head
-            -> Hamlet (Route master) -- ^ body
-            -> GHandler sub master RepHtml
-applyLayout t h b =
-    RepHtml `fmap` defaultLayout PageContent
-                { pageTitle = string t
-                , pageHead = h
-                , pageBody = b
-                }
-
 -- | Provide both an HTML and JSON representation for a piece of data, using
 -- the default layout for the HTML output ('defaultLayout').
-applyLayoutJson :: Yesod master
+defaultLayoutJson :: Yesod master
-                => String -- ^ title
+                  => GWidget sub master ()
-                -> Hamlet (Route master) -- ^ head
+                  -> Json
-                -> Hamlet (Route master) -- ^ body
+                  -> GHandler sub master RepHtmlJson
-                -> Json
+defaultLayoutJson w json = do
-                -> GHandler sub master RepHtmlJson
+    RepHtml html' <- defaultLayout w
-applyLayoutJson t h html json = do
-    html' <- defaultLayout PageContent
-                { pageTitle = string t
-                , pageHead = h
-                , pageBody = html
-                }
     json' <- jsonToContent json
     return $ RepHtmlJson html' json'
 
 applyLayout' :: Yesod master
-             => String -- ^ title
+             => Html -- ^ title
              -> Hamlet (Route master) -- ^ body
              -> GHandler sub master ChooseRep
-applyLayout' s = fmap chooseRep . applyLayout s mempty
+applyLayout' title body = fmap chooseRep $ defaultLayout $ do
+    setTitle title
+    addBody body
 
 -- | The default error handler for 'errorHandler'.
 defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
@@ -323,6 +314,73 @@ maybeAuthorized r isWrite = do
     x <- isAuthorized r isWrite
     return $ if x == Authorized then Just r else Nothing
 
+-- | Convert a widget to a 'PageContent'.
+widgetToPageContent :: (Eq (Route master), Yesod master)
+                    => GWidget sub master ()
+                    -> GHandler sub master (PageContent (Route master))
+widgetToPageContent (GWidget w) = do
+    w' <- flip evalStateT 0
+        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
+        $ runWriterT $ runWriterT $ runWriterT w
+    let ((((((((),
+         Body body),
+         Last mTitle),
+         scripts'),
+         stylesheets'),
+         style),
+         jscript),
+         Head head') = w'
+    let title = maybe mempty unTitle mTitle
+    let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
+    let stylesheets = map (locationToHamlet . unStylesheet)
+                    $ runUniqueList stylesheets'
+    let cssToHtml (Css b) = Html b
+        celper :: Cassius url -> Hamlet url
+        celper = fmap cssToHtml
+        jsToHtml (Javascript b) = Html b
+        jelper :: Julius url -> Hamlet url
+        jelper = fmap jsToHtml
+
+    render <- getUrlRenderParams
+    let renderLoc x =
+            case x of
+                Nothing -> Nothing
+                Just (Left s) -> Just s
+                Just (Right (u, p)) -> Just $ render u p
+    cssLoc <-
+        case style of
+            Nothing -> return Nothing
+            Just s -> do
+                x <- addStaticContent "css" "text/css; charset=utf-8"
+                   $ renderCassius render s
+                return $ renderLoc x
+    jsLoc <-
+        case jscript of
+            Nothing -> return Nothing
+            Just s -> do
+                x <- addStaticContent "js" "text/javascript; charset=utf-8"
+                   $ renderJulius render s
+                return $ renderLoc x
+
+    let head'' = [$hamlet|
+$forall scripts s
+    %script!src=^s^
+$forall stylesheets s
+    %link!rel=stylesheet!href=^s^
+$maybe style s
+    $maybe cssLoc s
+        %link!rel=stylesheet!href=$s$
+    $nothing
+        %style ^celper.s^
+$maybe jscript j
+    $maybe jsLoc s
+        %script!src=$s$
+    $nothing
+        %script ^jelper.j^
+^head'^
+|]
+    return $ PageContent title head'' body
+
 #if TEST
 testSuite :: Test
 testSuite = testGroup "Yesod.Yesod"