haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added extractBody

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-01 17:19:42 +03:00
parent e76f380cb5
commit 5568530a5d
1 changed files with 9 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Yesod/Widget.hs
View File

@ -20,6 +20,7 @@ module Yesod.Widget
, addBody , addBody
-- * Manipulating -- * Manipulating
, wrapWidget , wrapWidget
, extractBody
) where ) where
import Data.List (nub) import Data.List (nub)
@ -30,7 +31,6 @@ import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string)
import Yesod.Handler (Routes, GHandler) import Yesod.Handler (Routes, GHandler)
import Yesod.Yesod (Yesod, defaultLayout) import Yesod.Yesod (Yesod, defaultLayout)
import Yesod.Content (RepHtml (..)) import Yesod.Content (RepHtml (..))
import Data.Maybe (fromMaybe)
import Control.Applicative (Applicative) import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -63,7 +63,7 @@ newtype Head url = Head (Hamlet url)
newtype Body url = Body (Hamlet url) newtype Body url = Body (Hamlet url)
deriving Monoid deriving Monoid
newtype Widget sub master a = Widget { unWidget :: newtype Widget sub master a = Widget (
WriterT (Body (Routes master)) ( WriterT (Body (Routes master)) (
WriterT (Last Title) ( WriterT (Last Title) (
WriterT (UniqueList (Script (Routes master))) ( WriterT (UniqueList (Script (Routes master))) (
@ -72,8 +72,7 @@ newtype Widget sub master a = Widget { unWidget ::
WriterT (Head (Routes master)) ( WriterT (Head (Routes master)) (
StateT Int ( StateT Int (
GHandler sub master GHandler sub master
))))))) a ))))))) a)
}
deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
setTitle :: Html () -> Widget sub master () setTitle :: Html () -> Widget sub master ()
@ -148,3 +147,9 @@ wrapWidget wrap (Widget w) =
Widget $ mapWriterT (fmap go) w Widget $ mapWriterT (fmap go) w
where where
go (a, Body h) = (a, Body $ wrap h) go (a, Body h) = (a, Body $ wrap h)
extractBody :: Widget s m () -> Widget s m (Hamlet (Routes m))
extractBody (Widget w) =
Widget $ mapWriterT (fmap go) w
where
go ((), Body h) = (h, Body mempty)