defaultLayout now works directly on widgets

2010-08-22 16:08:58 +03:00 · 2010-08-22 16:08:58 +03:00 · f102b9882b
commit f102b9882b
parent 21becc6bda
5 changed files with 163 additions and 151 deletions
--- a/Yesod/Helpers/Auth.hs
+++ b/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
--- a/Yesod/Helpers/Crud.hs
+++ b/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
--- a/Yesod/Internal.hs
+++ b/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
--- a/Yesod/Widget.hs
+++ b/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.Yesod (Yesod, defaultLayout, addStaticContent)
-import Yesod.Content (RepHtml (..))
+import Yesod.Handler (Route, GHandler)
 import Control.Applicative (Applicative)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (lift)
 import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
-
-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
+import Yesod.Internal

 -- | 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
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@ -18,10 +18,10 @@ module Yesod.Yesod
      -- ** Breadcrumbs
    , YesodBreadcrumbs (..)
    , breadcrumbs
-      -- * Convenience functions
-    , applyLayout
-    , applyLayoutJson
+      -- * Utitlities
    , 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 p = hamletToContent [$hamlet|
+    defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
+    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
-                => String -- ^ title
-                -> Hamlet (Route master) -- ^ head
-                -> Hamlet (Route master) -- ^ body
-                -> Json
-                -> GHandler sub master RepHtmlJson
-applyLayoutJson t h html json = do
-    html' <- defaultLayout PageContent
-                { pageTitle = string t
-                , pageHead = h
-                , pageBody = html
-                }
+defaultLayoutJson :: Yesod master
+                  => GWidget sub master ()
+                  -> Json
+                  -> GHandler sub master RepHtmlJson
+defaultLayoutJson w json = do
+    RepHtml html' <- defaultLayout w
    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"