module Yesod.Widget
(
GWidget (..)
, liftHandler
, setTitle
, addHamletHead
, addHtmlHead
, addHamlet
, addHtml
, addWidget
, addCassius
, addStylesheet
, addStylesheetRemote
, addStylesheetEither
, addJulius
, addScript
, addScriptRemote
, addScriptEither
, extractBody
, newIdent
) 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, HandlerData)
import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Yesod.Internal
import Control.Monad.Invert (MonadInvertIO (..))
import Control.Monad (liftM)
import qualified Data.Map as Map
newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a }
deriving (Functor, Applicative, Monad, MonadIO)
type GWInner sub master =
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
))))))))
instance Monoid (GWidget sub master ()) where
mempty = return ()
mappend x y = x >> y
instance MonadInvertIO (GWidget s m) where
newtype InvertedIO (GWidget s m) a =
InvGWidgetIO
{ runInvGWidgetIO :: InvertedIO (GWInner s m) a
}
type InvertedArg (GWidget s m) =
(Int, (HandlerData s m, (Map.Map String String, ())))
invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget
revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f
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' . addHtml
urlToHamletMonad url params = GWidget' $
addHamlet $ \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
addHamletHead :: Hamlet (Route master) -> GWidget sub master ()
addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
addHtmlHead :: Html -> GWidget sub master ()
addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
addHamlet :: Hamlet (Route master) -> GWidget sub master ()
addHamlet = GWidget . tell . Body
addHtml :: Html -> GWidget sub master ()
addHtml = GWidget . tell . Body . const
addWidget :: GWidget s m () -> GWidget s m ()
addWidget = id
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'
addCassius :: Cassius (Route master) -> GWidget sub master ()
addCassius = 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
addJulius :: Julius (Route master) -> GWidget sub master ()
addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
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)