module Yesod.Widget
(
GWidget
, PageContent (..)
, whamlet
, whamletFile
, ihamletToRepHtml
, ToWidget (..)
, ToWidgetHead (..)
, ToWidgetBody (..)
, setTitle
, setTitleI
, addHamletHead
, addHtmlHead
, addHamlet
, addHtml
, addWidget
, addSubWidget
, addCassius
, addCassiusMedia
, addLucius
, addLuciusMedia
, addStylesheet
, addStylesheetAttrs
, addStylesheetRemote
, addStylesheetRemoteAttrs
, addStylesheetEither
, addJulius
, addJuliusBody
, addScript
, addScriptAttrs
, addScriptRemote
, addScriptRemoteAttrs
, addScriptEither
, unGWidget
) where
import Data.Monoid
import qualified Text.Blaze.Html5 as H
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Yesod.Routes.Class
import Yesod.Handler
( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams, MonadLift (..)
)
import Yesod.Message (RenderMessage)
import Yesod.Content (RepHtml (..), toContent)
import Control.Applicative (Applicative (..), (<$>))
import Control.Monad.IO.Class (MonadIO (liftIO))
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.Trans.Control (MonadBaseControl (..), control)
import Control.Monad.Trans.Resource
import Control.Exception (throwIO)
import qualified Text.Hamlet as NP
import Data.Text.Lazy.Builder (fromLazyText)
import Text.Blaze (toHtml, preEscapedLazyText)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Arrow (first)
newtype GWidget sub master a = GWidget
{ unGWidget :: GHandler sub master (a, GWData (Route master))
}
instance (a ~ ()) => Monoid (GWidget sub master a) where
mempty = return ()
mappend x y = x >> 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
(a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w
tell w'
return a
class ToWidget sub master a where
toWidget :: a -> GWidget sub master ()
type RY master = Route master -> [(Text, Text)] -> Text
instance render ~ RY master => ToWidget sub master (render -> Html) where
toWidget = addHamlet
instance render ~ RY master => ToWidget sub master (render -> Css) where
toWidget = addCassius
instance render ~ RY master => ToWidget sub master (render -> Javascript) where
toWidget = addJulius
instance ToWidget sub master (GWidget sub master ()) where
toWidget = id
instance ToWidget sub master Html where
toWidget = addHtml
class ToWidgetBody sub master a where
toWidgetBody :: a -> GWidget sub master ()
instance render ~ RY master => ToWidgetBody sub master (render -> Html) where
toWidgetBody = addHamlet
instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where
toWidgetBody = addJuliusBody
instance ToWidgetBody sub master Html where
toWidgetBody = addHtml
class ToWidgetHead sub master a where
toWidgetHead :: a -> GWidget sub master ()
instance render ~ RY master => ToWidgetHead sub master (render -> Html) where
toWidgetHead = addHamletHead
instance render ~ RY master => ToWidgetHead sub master (render -> Css) where
toWidgetHead = addCassius
instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
toWidgetHead = addJulius
instance ToWidgetHead sub master Html where
toWidgetHead = addHtmlHead
setTitle :: Html -> GWidget sub master ()
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
setTitleI msg = do
mr <- lift getMessageRender
setTitle $ toHtml $ mr msg
addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()
addHamletHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
addHtmlHead :: Html -> GWidget sub master ()
addHtmlHead = addHamletHead . const
addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()
addHamlet x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
addHtml :: Html -> GWidget sub master ()
addHtml = addHamlet . const
addWidget :: GWidget sub master () -> GWidget sub master ()
addWidget = id
addCassius :: CssUrl (Route master) -> GWidget sub master ()
addCassius x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
addLucius :: CssUrl (Route master) -> GWidget sub master ()
addLucius = addCassius
addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
addLuciusMedia = addCassiusMedia
addStylesheet :: Route master -> GWidget sub master ()
addStylesheet = flip addStylesheetAttrs []
addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
addStylesheetRemote :: Text -> GWidget sub master ()
addStylesheetRemote = flip addStylesheetRemoteAttrs []
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Either (Route master) Text -> GWidget sub master ()
addScriptEither = either addScript addScriptRemote
addScript :: Route master -> GWidget sub master ()
addScript = flip addScriptAttrs []
addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
addScriptRemote :: Text -> GWidget sub master ()
addScriptRemote = flip addScriptRemoteAttrs []
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()
addJulius x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()
addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
data PageContent url = PageContent
{ pageTitle :: Html
, pageHead :: HtmlUrl url
, pageBody :: HtmlUrl 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 [|liftW getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
f env
return $ NP.HamletRules ah ur $ \_ b -> return b
ihamletToRepHtml :: RenderMessage master message
=> HtmlUrlI18n message (Route master)
-> GHandler sub master RepHtml
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
mrender <- getMessageRender
return $ RepHtml $ toContent $ ih (toHtml . mrender) urender
tell :: GWData (Route master) -> GWidget sub master ()
tell w = GWidget $ return ((), w)
instance MonadLift (GHandler sub master) (GWidget sub master) where
lift = GWidget . fmap (\x -> (x, mempty))
liftW :: GHandler sub master a -> GWidget sub master a
liftW = lift
instance Functor (GWidget sub master) where
fmap f (GWidget x) = GWidget (fmap (first f) x)
instance Applicative (GWidget sub master) where
pure a = GWidget $ pure (a, mempty)
GWidget f <*> GWidget v =
GWidget $ k <$> f <*> v
where
k (a, wa) (b, wb) = (a b, wa `mappend` wb)
instance Monad (GWidget sub master) where
return = pure
GWidget x >>= f = GWidget $ do
(a, wa) <- x
(b, wb) <- unGWidget (f a)
return (b, wa `mappend` wb)
instance MonadIO (GWidget sub master) where
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
instance MonadBase IO (GWidget sub master) where
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl IO (GWidget sub master) where
data StM (GWidget sub master) a =
StW (StM (GHandler sub master) (a, GWData (Route master)))
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unGWidget)
restoreM (StW base) = GWidget $ restoreM base
instance Resource (GWidget sub master) where
type Base (GWidget sub master) = IO
resourceLiftBase = liftIO
resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)
instance ResourceUnsafeIO (GWidget sub master) where
unsafeFromIO = liftIO
instance ResourceThrow (GWidget sub master) where
resourceThrow = liftIO . throwIO
instance ResourceIO (GWidget sub master)