diff --git a/Yesod.hs b/Yesod.hs index 6d8406eb..73c3f733 100644 --- a/Yesod.hs +++ b/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 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index fb8d340a..01e82cd5 100644 --- a/Yesod/Dispatch.hs +++ b/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" diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs new file mode 100644 index 00000000..354df21a --- /dev/null +++ b/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) diff --git a/hellowidget.hs b/hellowidget.hs new file mode 100644 index 00000000..c3099586 --- /dev/null +++ b/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 diff --git a/static/script.js b/static/script.js new file mode 100644 index 00000000..43c21a53 --- /dev/null +++ b/static/script.js @@ -0,0 +1,3 @@ +$(function(){ + $("p.noscript").hide(); +}); diff --git a/static/style.css b/static/style.css new file mode 100644 index 00000000..39895bcc --- /dev/null +++ b/static/style.css @@ -0,0 +1,3 @@ +body { + background-color: #ffd; +} diff --git a/static/style2.css b/static/style2.css new file mode 100644 index 00000000..853ac29a --- /dev/null +++ b/static/style2.css @@ -0,0 +1,3 @@ +body { + font-family: sans-serif; +} diff --git a/yesod.cabal b/yesod.cabal index 00670ad8..5ff38b18 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,6 +53,7 @@ library Yesod.Internal Yesod.Json Yesod.Request + Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth