Initial widgets support

Yesod.hs

@@ -1,8 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE PackageImports #-}
 module Yesod
-    (
+    ( module Yesod.Request
-      module Yesod.Request
     , module Yesod.Content
     , module Yesod.Yesod
     , module Yesod.Handler
@@ -10,6 +9,7 @@ module Yesod
     , module Yesod.Form
     , module Yesod.Hamlet
     , module Yesod.Json
+    , module Yesod.Widget
     , Application
     , liftIO
     , mempty
@@ -28,6 +28,7 @@ import Yesod.Dispatch
 import Yesod.Request
 import Yesod.Form
 import Yesod.Yesod
+import Yesod.Widget
 import Yesod.Handler hiding (runHandler)
 import Network.Wai (Application)
 import Yesod.Hamlet

Yesod/Dispatch.hs

@@ -141,7 +141,7 @@ mkYesodGeneral name args clazzes isSub res = do
                  $ map (\x -> (x, [])) ("master" : args) ++ clazzes
     th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites
     w' <- createRoutes th
-    let w = DataInstD [] ''Routes [arg] w' []
+    let w = DataInstD [] ''Routes [arg] w' [''Show, ''Read, ''Eq]
 
     parse' <- createParse th
     parse'' <- newName "parse"

Yesod/Widget.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PackageImports #-}
+module Yesod.Widget
+    ( -- * Datatype
+      Widget
+      -- * Unwrapping
+    , widgetToPageContent
+    , applyLayoutW
+      -- * Creating
+    , newIdent
+    , setTitle
+    , addStyle
+    , addStylesheet
+    , addStylesheetRemote
+    , addScript
+    , addScriptRemote
+    , addHead
+    , addBody
+      -- * Manipulating
+    , wrapWidget
+    ) where
+
+import Data.List (nub)
+import Data.Monoid
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.State
+import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string)
+import Yesod.Handler (Routes, GHandler)
+import Yesod.Yesod (Yesod, defaultLayout)
+import Yesod.Content (RepHtml (..))
+import Data.Maybe (fromMaybe)
+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|$string.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 Style url = Style (Hamlet url)
+    deriving Monoid
+newtype Head url = Head (Hamlet url)
+    deriving Monoid
+newtype Body url = Body (Hamlet url)
+    deriving Monoid
+
+newtype Widget sub master a = Widget { unWidget ::
+    WriterT (Body (Routes master)) (
+    WriterT (Last Title) (
+    WriterT (UniqueList (Script (Routes master))) (
+    WriterT (UniqueList (Stylesheet (Routes master))) (
+    WriterT (Style (Routes master)) (
+    WriterT (Head (Routes master)) (
+    StateT Int (
+    GHandler sub master
+    ))))))) a
+}
+    deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
+
+setTitle :: Html () -> Widget sub master ()
+setTitle = Widget . lift . tell . Last . Just . Title
+
+addHead :: Hamlet (Routes master) -> Widget sub master ()
+addHead = Widget . lift . lift . lift . lift . lift . tell . Head
+
+addBody :: Hamlet (Routes master) -> Widget sub master ()
+addBody = Widget . tell . Body
+
+newIdent :: Widget sub master String
+newIdent = Widget $ lift $ lift $ lift $ lift $ lift $ lift $ do
+    i <- get
+    let i' = i + 1
+    put i'
+    return $ "w" ++ show i'
+
+addStyle :: Hamlet (Routes master) -> Widget sub master ()
+addStyle = Widget . lift . lift . lift . lift . tell . Style
+
+addStylesheet :: Routes master -> Widget sub master ()
+addStylesheet = Widget . lift . lift . lift . tell . toUnique . Stylesheet . Local
+
+addStylesheetRemote :: String -> Widget sub master ()
+addStylesheetRemote =
+    Widget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
+
+addScript :: Routes master -> Widget sub master ()
+addScript = Widget . lift . lift . tell . toUnique . Script . Local
+
+addScriptRemote :: String -> Widget sub master ()
+addScriptRemote =
+    Widget . lift . lift . tell . toUnique . Script . Remote
+
+applyLayoutW :: (Eq (Routes m), Yesod m)
+             => Widget sub m () -> GHandler sub m RepHtml
+applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout
+
+widgetToPageContent :: Eq (Routes master)
+                    => Widget sub master ()
+                    -> GHandler sub master (PageContent (Routes master))
+widgetToPageContent (Widget w) = do
+    w' <- flip evalStateT 0
+        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
+        $ runWriterT $ runWriterT w
+    let (((((((),
+         Body body),
+         Last mTitle),
+         scripts'),
+         stylesheets'),
+         Style style),
+         Head head') = w'
+    let title = maybe mempty unTitle mTitle
+    let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
+    let stylesheets = map (locationToHamlet . unStylesheet)
+                    $ runUniqueList stylesheets'
+    let head'' = [$hamlet|
+$forall scripts s
+    %script!src=^s^
+$forall stylesheets s
+    %link!rel=stylesheet!href=^s^
+%style
+    ^style^
+^head'^
+|]
+    return $ PageContent title head'' body
+
+wrapWidget :: (Hamlet (Routes m) -> Hamlet (Routes m))
+           -> Widget s m a -> Widget s m a
+wrapWidget wrap (Widget w) =
+    Widget $ mapWriterT (fmap go) w
+  where
+    go (a, Body h) = (a, Body $ wrap h)

hellowidget.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
+import Yesod
+import Yesod.Widget
+import Yesod.Helpers.Static
+
+data HW = HW { hwStatic :: Static }
+mkYesod "HW" [$parseRoutes|
+/ RootR GET
+/static StaticR Static hwStatic
+|]
+instance Yesod HW where approot _ = ""
+wrapper h = [$hamlet|
+#wrapper ^h^
+%footer Brought to you by Yesod Widgets™
+|]
+getRootR = applyLayoutW $ wrapWidget wrapper $ do
+    i <- newIdent
+    setTitle $ string "Hello Widgets"
+    addStyle [$hamlet|\#$string.i${color:red}|]
+    addStylesheet $ StaticR $ StaticRoute ["style.css"]
+    addStylesheetRemote "http://localhost:3000/static/style2.css"
+    addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"
+    addScript $ StaticR $ StaticRoute ["script.js"]
+    addBody [$hamlet|
+%h1#$string.i$ Welcome to my first widget!!!
+%p
+    %a!href=@RootR@ Recursive link.
+%p.noscript Your script did not load. :(
+|]
+    addHead [$hamlet|%meta!keywords=haskell|]
+main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000

static/script.js

@@ -0,0 +1,3 @@
+$(function(){
+    $("p.noscript").hide();
+});

static/style.css

@@ -0,0 +1,3 @@
+body {
+    background-color: #ffd;
+}

static/style2.css

@@ -0,0 +1,3 @@
+body {
+    font-family: sans-serif;
+}

yesod.cabal

@@ -53,6 +53,7 @@ library
                      Yesod.Internal
                      Yesod.Json
                      Yesod.Request
+                     Yesod.Widget
                      Yesod.Yesod
                      Yesod.Helpers.AtomFeed
                      Yesod.Helpers.Auth