Migrated Widget to RWS transformer

2011-03-23 08:41:30 +02:00 · 2011-03-23 08:41:30 +02:00 · 70eba502de
commit 70eba502de
parent b899498bd2
4 changed files with 53 additions and 71 deletions
--- a/Yesod/Core.hs
+++ b/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.State hiding (get, put)
+import Control.Monad.Trans.RWS
 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
-        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-        $ runWriterT $ runWriterT $ runWriterT w
-    let ((((((((),
-         Body body),
-         Last mTitle),
-         scripts'),
-         stylesheets'),
-         style),
-         jscript),
-         Head head') = w'
+    ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0
    let title = maybe mempty unTitle mTitle
    let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
    let stylesheets = map (locationToHamlet . unStylesheet)
--- a/Yesod/Internal.hs
+++ b/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)
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@ -33,8 +33,7 @@ module Yesod.Widget
    ) where

 import Data.Monoid
-import Control.Monad.Trans.Writer
-import Control.Monad.Trans.State
+import Control.Monad.Trans.RWS
 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 =
-    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
-    ))))))))
+type GWInner master = RWST () (GWData (Route master)) Int
+
 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
-                        let sr = fromSubRoute sub master
-                        i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get
-                        w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i
-                              $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-                              $ runWriterT $ runWriterT $ runWriterT 
-                              $ unGWidget w
-                        let ((((((((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
+addSubWidget sub (GWidget w) = do
+    master <- lift getYesod
+    let sr = fromSubRoute sub master
+    s <- GWidget get
+    (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s
+    GWidget $ put s'
+    GWidget $ tell w'
+    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 =
-    GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
+addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty

 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 =
-    GWidget . lift . lift . tell . toUnique . Script . Remote
+addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty

 -- | 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:
--- a/yesod-core.cabal
+++ b/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>