module Yesod.Widget
(
GWidget
, GGWidget (..)
, PageContent (..)
, setTitle
, addHamletHead
, addHtmlHead
, addHamlet
, addHtml
, addWidget
, addSubWidget
, addCassius
, addStylesheet
, addStylesheetRemote
, addStylesheetEither
, addJulius
, addScript
, addScriptRemote
, addScriptEither
, extractBody
) where
import Data.Monoid
import Control.Monad.Trans.Writer
import Control.Monad.Trans.State
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod.Handler
(Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Yesod.Internal
import Control.Monad (liftM)
import Control.Monad.IO.Peel (MonadPeelIO)
newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a }
deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
instance MonadTrans (GGWidget s m) where
lift = GWidget . lift . lift . lift . lift . lift . lift . lift . 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
))))))))
instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where
mempty = return ()
mappend x y = x >> y
instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where
newtype HamletMonad (GGWidget s m monad a) b =
GWidget' { runGWidget' :: GGWidget s m monad b }
type HamletUrl (GGWidget s m monad a) = Route m
toHamletValue = runGWidget'
htmlToHamletMonad = GWidget' . addHtml
urlToHamletMonad url params = GWidget' $
addHamlet $ \r -> preEscapedString (r url params)
fromHamletValue = GWidget'
instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where
return = GWidget' . return
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
setTitle :: Monad m => Html -> GGWidget sub master m ()
setTitle = GWidget . lift . tell . Last . Just . Title
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
addHtmlHead :: Monad m => Html -> GGWidget sub master m ()
addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
addHamlet = GWidget . tell . Body
addHtml :: Monad m => Html -> GGWidget sub master m ()
addHtml = GWidget . tell . Body . const
addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo ()
addWidget = id
addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()
addCassius = GWidget . lift . lift . lift . lift . tell . Just
addStylesheet :: Monad m => Route master -> GGWidget sub master m ()
addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()
addStylesheetRemote =
GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
addScriptEither = either addScript addScriptRemote
addScript :: Monad m => Route master -> GGWidget sub master m ()
addScript = GWidget . lift . lift . tell . toUnique . Script . Local
addScriptRemote :: Monad m => String -> GGWidget sub master m ()
addScriptRemote =
GWidget . lift . lift . tell . toUnique . Script . Remote
addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()
addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m))
extractBody (GWidget w) =
GWidget $ mapWriterT (liftM go) w
where
go ((), Body h) = (h, Body mempty)
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: Hamlet url
, pageBody :: Hamlet url
}