Migrated Widget to RWS transformer

Yesod/Core.hs

@@ -41,8 +41,7 @@ import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
 import Data.Monoid
-import Control.Monad.Trans.Writer
+import Control.Monad.Trans.RWS
-import Control.Monad.Trans.State hiding (get, put)
 import Text.Hamlet
 import Text.Cassius
 import Text.Julius
@@ -393,17 +392,7 @@ widgetToPageContent :: (Eq (Route master), Yesod master)
                     => GWidget sub master ()
                     -> GHandler sub master (PageContent (Route master))
 widgetToPageContent (GWidget w) = do
-    w' <- flip evalStateT 0
+    ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 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)

Yesod/Internal.hs

@@ -12,6 +12,7 @@ module Yesod.Internal
       -- * Cookie names
     , langKey
       -- * Widgets
+    , GWData (..)
     , Location (..)
     , UniqueList (..)
     , Script (..)
@@ -32,7 +33,9 @@ module Yesod.Internal
     ) where
 
 import Text.Hamlet (Hamlet, hamlet, Html)
-import Data.Monoid (Monoid (..))
+import Text.Cassius (Cassius)
+import Text.Julius (Julius)
+import Data.Monoid (Monoid (..), Last)
 import Data.List (nub)
 
 import Data.ByteString (ByteString)
@@ -120,3 +123,23 @@ nonceKey = "_NONCE"
 
 sessionName :: ByteString
 sessionName = "_SESSION"
+
+data GWData a = GWData
+    (Body a)
+    (Last Title)
+    (UniqueList (Script a))
+    (UniqueList (Stylesheet a))
+    (Maybe (Cassius a))
+    (Maybe (Julius a))
+    (Head a)
+instance Monoid (GWData a) where
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
+    mappend (GWData a1 a2 a3 a4 a5 a6 a7)
+            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData
+        (a1 `mappend` b1)
+        (a2 `mappend` b2)
+        (a3 `mappend` b3)
+        (a4 `mappend` b4)
+        (a5 `mappend` b5)
+        (a6 `mappend` b6)
+        (a7 `mappend` b7)

Yesod/Widget.hs

@@ -33,8 +33,7 @@ module Yesod.Widget
     ) where
 
 import Data.Monoid
-import Control.Monad.Trans.Writer
+import Control.Monad.Trans.RWS
-import Control.Monad.Trans.State
 import Text.Hamlet
 import Text.Cassius
 import Text.Julius
@@ -51,24 +50,15 @@ import Control.Monad.IO.Peel (MonadPeelIO)
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
 -- dependencies along with a 'StateT' to track unique identifiers.
-newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a }
+newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner m monad a } -- FIXME remove s
     deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
 
 instance MonadTrans (GGWidget s m) where
-    lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift
+    lift = GWidget . lift
 
 type GWidget s m = GGWidget s m (GHandler s m)
-type GWInner sub master monad =
+type GWInner master = RWST () (GWData (Route master)) Int
-    WriterT (Body (Route master)) (
+
-    WriterT (Last Title) (
-    WriterT (UniqueList (Script (Route master))) (
-    WriterT (UniqueList (Stylesheet (Route master))) (
-    WriterT (Maybe (Cassius (Route master))) (
-    WriterT (Maybe (Julius (Route master))) (
-    WriterT (Head (Route master)) (
-    StateT Int (
-    monad
-    ))))))))
 instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where
     mempty = return ()
     mappend x y = x >> y
@@ -87,53 +77,35 @@ instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) whe
     x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y
 
 addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
-addSubWidget sub w = do master <- lift getYesod
+addSubWidget sub (GWidget w) = do
-                        let sr = fromSubRoute sub master
+    master <- lift getYesod
-                        i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get
+    let sr = fromSubRoute sub master
-                        w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i
+    s <- GWidget get
-                              $ runWriterT $ runWriterT $ runWriterT $ runWriterT
+    (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s
-                              $ runWriterT $ runWriterT $ runWriterT 
+    GWidget $ put s'
-                              $ unGWidget w
+    GWidget $ tell w'
-                        let ((((((((a,
+    return a
-                                    body),
-                                   title),
-                                  scripts),
-                                 stylesheets),
-                                style),
-                               jscript),
-                              h),
-                             i') = w'
-                        GWidget $ do
-                          tell body
-                          lift $ tell title
-                          lift $ lift $ tell scripts
-                          lift $ lift $ lift $ tell stylesheets
-                          lift $ lift $ lift $ lift $ tell style
-                          lift $ lift $ lift $ lift $ lift $ tell jscript
-                          lift $ lift $ lift $ lift $ lift $ lift $ tell h
-                          lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i'
-                          return a
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
 setTitle :: Monad m => Html -> GGWidget sub master m ()
-setTitle = GWidget . lift . tell . Last . Just . Title
+setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
 
 -- | Add a 'Hamlet' to the head tag.
 addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
-addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
+addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
 
 -- | Add a 'Html' to the head tag.
 addHtmlHead :: Monad m => Html -> GGWidget sub master m ()
-addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
+addHtmlHead = addHamletHead . const
 
 -- | Add a 'Hamlet' to the body tag.
 addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
-addHamlet = GWidget . tell . Body
+addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
 
 -- | Add a 'Html' to the body tag.
 addHtml :: Monad m => Html -> GGWidget sub master m ()
-addHtml = GWidget . tell . Body . const
+addHtml = addHamlet . const
 
 -- | Add another widget. This is defined as 'id', by can help with types, and
 -- makes widget blocks look more consistent.
@@ -142,16 +114,15 @@ addWidget = id
 
 -- | Add some raw CSS to the style tag.
 addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()
-addCassius = GWidget . lift . lift . lift . lift . tell . Just
+addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty
 
 -- | Link to the specified local stylesheet.
 addStylesheet :: Monad m => Route master -> GGWidget sub master m ()
-addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
+addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty
 
 -- | Link to the specified remote stylesheet.
 addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()
-addStylesheetRemote =
+addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty
-    GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
 
 addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
@@ -161,24 +132,23 @@ addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
 addScript :: Monad m => Route master -> GGWidget sub master m ()
-addScript = GWidget . lift . lift . tell . toUnique . Script . Local
+addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty
 
 -- | Link to the specified remote script.
 addScriptRemote :: Monad m => String -> GGWidget sub master m ()
-addScriptRemote =
+addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty
-    GWidget . lift . lift . tell . toUnique . Script . Remote
 
 -- | Include raw Javascript in the page's script tag.
 addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()
-addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
+addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
 
 -- | Pull out the HTML tag contents and return it. Useful for performing some
 -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
 extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m))
 extractBody (GWidget w) =
-    GWidget $ mapWriterT (liftM go) w
+    GWidget $ mapRWST (liftM go) w
   where
-    go ((), Body h) = (h, Body mempty)
+    go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g)
 
 -- | Content for a web page. By providing this datatype, we can easily create
 -- generic site templates, which would have the type signature:

yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         0.7.0.1
+version:         0.7.0.2
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>