module Yesod.Widget
(
GWidget
, GGWidget (..)
, PageContent (..)
, whamlet
, whamletFile
, ihamletToRepHtml
, setTitle
, setTitleI
, addHamletHead
, addHtmlHead
, addHamlet
, addHtml
, addWidget
, addSubWidget
, addCassius
, addCassiusMedia
, addLucius
, addLuciusMedia
, addStylesheet
, addStylesheetAttrs
, addStylesheetRemote
, addStylesheetRemoteAttrs
, addStylesheetEither
, addJulius
, addJuliusBody
, addCoffee
, addCoffeeBody
, addScript
, addScriptAttrs
, addScriptRemote
, addScriptRemoteAttrs
, addScriptEither
, extractBody
) where
import Data.Monoid
import Control.Monad.Trans.RWS
import qualified Text.Blaze.Html5 as H
import Text.Hamlet
import Text.Cassius
import Text.Lucius (Lucius)
import Text.Julius
import Text.Coffee
import Yesod.Handler
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams
)
import Yesod.Message (RenderMessage)
import Yesod.Content (RepHtml (..), toContent)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Yesod.Internal
import Control.Monad (liftM)
import Data.Text (Text)
import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
import Control.Monad.IO.Control (MonadControlIO)
import qualified Text.Hamlet.NonPoly as NP
import Data.Text.Lazy.Builder (fromLazyText)
newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }
deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO)
instance MonadTrans (GGWidget m) where
lift = GWidget . lift
type GWidget s m = GGWidget m (GHandler s m)
type GWInner master = RWST () (GWData (Route master)) Int
instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where
mempty = return ()
mappend x y = x >> y
instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where
newtype HamletMonad (GGWidget m monad a) b =
GWidget' { runGWidget' :: GGWidget m monad b }
type HamletUrl (GGWidget m monad a) = Route m
toHamletValue = runGWidget'
htmlToHamletMonad = GWidget' . addHtml
urlToHamletMonad url params = GWidget' $
addHamlet $ \r -> preEscapedText (r url params)
fromHamletValue = GWidget'
instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget 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 (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
setTitle :: Monad m => Html -> GGWidget master m ()
setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()
setTitleI msg = do
mr <- lift getMessageRender
setTitle $ toHtml $ mr msg
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
addHtmlHead :: Monad m => Html -> GGWidget master m ()
addHtmlHead = addHamletHead . const
addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m ()
addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
addHtml :: Monad m => Html -> GGWidget master m ()
addHtml = addHamlet . const
addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
addWidget = id
addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
addLucius :: Monad m => Lucius (Route master) -> GGWidget master m ()
addLucius = addCassius
addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
addLuciusMedia :: Monad m => Text -> Lucius (Route master) -> GGWidget master m ()
addLuciusMedia = addCassiusMedia
addStylesheet :: Monad m => Route master -> GGWidget master m ()
addStylesheet = flip addStylesheetAttrs []
addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
addStylesheetRemote :: Monad m => Text -> GGWidget master m ()
addStylesheetRemote = flip addStylesheetRemoteAttrs []
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
addScriptEither = either addScript addScriptRemote
addScript :: Monad m => Route master -> GGWidget master m ()
addScript = flip addScriptAttrs []
addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
addScriptRemote :: Monad m => Text -> GGWidget master m ()
addScriptRemote = flip addScriptRemoteAttrs []
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()
addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j
addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
addCoffee c = do
render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c
addJulius $ const $ Javascript $ fromLazyText t
addCoffeeBody :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
addCoffeeBody c = do
render <- lift getUrlRenderParams
t <- liftIO $ renderCoffee render c
addJuliusBody $ const $ Javascript $ fromLazyText t
extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))
extractBody (GWidget w) =
GWidget $ mapRWST (liftM go) w
where
go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g)
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: Hamlet url
, pageBody :: Hamlet url
}
whamlet :: QuasiQuoter
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
whamletFile :: FilePath -> Q Exp
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
rules :: Q NP.HamletRules
rules = do
ah <- [|addHtml|]
let helper qg f = do
x <- newName "urender"
e <- f $ VarE x
let e' = LamE [VarP x] e
g <- qg
bind <- [|(>>=)|]
return $ InfixE (Just g) bind (Just e')
let ur f = do
let env = NP.Env
(Just $ helper [|lift getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ lift getMessageRender|])
f env
return $ NP.HamletRules ah ur $ \_ b -> return b
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
=> NP.IHamlet message (Route master)
-> GGHandler sub master mo RepHtml
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
mrender <- getMessageRender
return $ RepHtml $ toContent $ ih (toHtml . mrender) urender