module Yesod.Widget
(
GWidget (..)
, Widget
, liftHandler
, newIdent
, setTitle
, addStyle
, addStylesheet
, addStylesheetRemote
, addStylesheetEither
, addScript
, addScriptRemote
, addScriptEither
, addHead
, addBody
, addJavascript
, wrapWidget
, 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)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
import Yesod.Internal
newtype GWidget sub master a = GWidget (
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 (
GHandler sub master
)))))))) a)
deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
instance Monoid (GWidget sub master ()) where
mempty = return ()
mappend x y = x >> y
type Widget y = GWidget y y
instance HamletValue (GWidget s m ()) where
newtype HamletMonad (GWidget s m ()) a =
GWidget' { runGWidget' :: GWidget s m a }
type HamletUrl (GWidget s m ()) = Route m
toHamletValue = runGWidget'
htmlToHamletMonad = GWidget' . addBody . const
urlToHamletMonad url params = GWidget' $
addBody $ \r -> preEscapedString (r url params)
fromHamletValue = GWidget'
instance Monad (HamletMonad (GWidget s m ())) where
return = GWidget' . return
x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y
liftHandler :: GHandler sub master a -> GWidget sub master a
liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift
setTitle :: Html -> GWidget sub master ()
setTitle = GWidget . lift . tell . Last . Just . Title
addHead :: Hamlet (Route master) -> GWidget sub master ()
addHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
addBody :: Hamlet (Route master) -> GWidget sub master ()
addBody = GWidget . tell . Body
newIdent :: GWidget sub master String
newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do
i <- get
let i' = i + 1
put i'
return $ "w" ++ show i'
addStyle :: Cassius (Route master) -> GWidget sub master ()
addStyle = GWidget . lift . lift . lift . lift . tell . Just
addStylesheet :: Route master -> GWidget sub master ()
addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
addStylesheetRemote :: String -> GWidget sub master ()
addStylesheetRemote =
GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
addStylesheetEither :: Either (Route master) String -> GWidget sub master ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Either (Route master) String -> GWidget sub master ()
addScriptEither = either addScript addScriptRemote
addScript :: Route master -> GWidget sub master ()
addScript = GWidget . lift . lift . tell . toUnique . Script . Local
addScriptRemote :: String -> GWidget sub master ()
addScriptRemote =
GWidget . lift . lift . tell . toUnique . Script . Remote
addJavascript :: Julius (Route master) -> GWidget sub master ()
addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just
wrapWidget :: GWidget s m a
-> (Hamlet (Route m) -> Hamlet (Route m))
-> GWidget s m a
wrapWidget (GWidget w) wrap =
GWidget $ mapWriterT (fmap go) w
where
go (a, Body h) = (a, Body $ wrap h)
extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m))
extractBody (GWidget w) =
GWidget $ mapWriterT (fmap go) w
where
go ((), Body h) = (h, Body mempty)