220 lines
8.4 KiB
Haskell
220 lines
8.4 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
|
-- generator, allowing you to create truly modular HTML components.
|
|
module Yesod.Widget
|
|
( -- * Datatype
|
|
GWidget
|
|
, GGWidget (..)
|
|
, liftHandler
|
|
, PageContent (..)
|
|
-- * Creating
|
|
-- ** Head of page
|
|
, setTitle
|
|
, addHamletHead
|
|
, addHtmlHead
|
|
-- ** Body
|
|
, addHamlet
|
|
, addHtml
|
|
, addWidget
|
|
, addSubWidget
|
|
-- ** CSS
|
|
, addCassius
|
|
, addStylesheet
|
|
, addStylesheetRemote
|
|
, addStylesheetEither
|
|
-- ** Javascript
|
|
, addJulius
|
|
, addScript
|
|
, addScriptRemote
|
|
, addScriptEither
|
|
-- * Utilities
|
|
, extractBody
|
|
-- * Helpers for specific content
|
|
-- ** Hamlet
|
|
, hamletToContent
|
|
, hamletToRepHtml
|
|
) 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
|
|
, getUrlRenderParams
|
|
)
|
|
import Control.Applicative (Applicative)
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Control.Monad.Trans.Class (MonadTrans (lift))
|
|
import Yesod.Internal
|
|
import Yesod.Content (RepHtml (RepHtml), Content, toContent)
|
|
import Control.Monad (liftM)
|
|
|
|
import Control.Monad.IO.Peel (MonadPeelIO)
|
|
|
|
-- | A generic widget, allowing specification of both the subsite and master
|
|
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
|
|
-- dependencies along with a 'StateT' to track unique identifiers.
|
|
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
|
|
|
|
-- | Lift an action in the 'GHandler' monad into an action in the 'GWidget'
|
|
-- monad.
|
|
liftHandler :: Monad monad => monad a -> GGWidget sub master monad a
|
|
liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift
|
|
|
|
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
|
|
addSubWidget sub w = do master <- liftHandler getYesod
|
|
let sr = fromSubRoute sub master
|
|
i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get
|
|
w' <- liftHandler $ 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
|
|
|
|
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
|
-- set values.
|
|
setTitle :: Monad m => Html -> GGWidget sub master m ()
|
|
setTitle = GWidget . lift . tell . Last . Just . Title
|
|
|
|
-- | Add a 'Hamlet' to the head tag.
|
|
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
|
|
addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
|
|
|
|
-- | Add a 'Html' to the head tag.
|
|
addHtmlHead :: Monad m => Html -> GGWidget sub master m ()
|
|
addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
|
|
|
|
-- | Add a 'Hamlet' to the body tag.
|
|
addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
|
|
addHamlet = GWidget . tell . Body
|
|
|
|
-- | Add a 'Html' to the body tag.
|
|
addHtml :: Monad m => Html -> GGWidget sub master m ()
|
|
addHtml = GWidget . tell . Body . const
|
|
|
|
-- | Add another widget. This is defined as 'id', by can help with types, and
|
|
-- makes widget blocks look more consistent.
|
|
addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo ()
|
|
addWidget = id
|
|
|
|
-- | Add some raw CSS to the style tag.
|
|
addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()
|
|
addCassius = GWidget . lift . lift . lift . lift . tell . Just
|
|
|
|
-- | Link to the specified local stylesheet.
|
|
addStylesheet :: Monad m => Route master -> GGWidget sub master m ()
|
|
addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
|
|
|
|
-- | Link to the specified remote stylesheet.
|
|
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
|
|
|
|
-- | Link to the specified local script.
|
|
addScript :: Monad m => Route master -> GGWidget sub master m ()
|
|
addScript = GWidget . lift . lift . tell . toUnique . Script . Local
|
|
|
|
-- | Link to the specified remote script.
|
|
addScriptRemote :: Monad m => String -> GGWidget sub master m ()
|
|
addScriptRemote =
|
|
GWidget . lift . lift . tell . toUnique . Script . Remote
|
|
|
|
-- | Include raw Javascript in the page's script tag.
|
|
addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()
|
|
addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
|
|
|
|
-- | Pull out the HTML tag contents and return it. Useful for performing some
|
|
-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
|
|
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)
|
|
|
|
-- | Content for a web page. By providing this datatype, we can easily create
|
|
-- generic site templates, which would have the type signature:
|
|
--
|
|
-- > PageContent url -> Hamlet url
|
|
data PageContent url = PageContent
|
|
{ pageTitle :: Html
|
|
, pageHead :: Hamlet url
|
|
, pageBody :: Hamlet url
|
|
}
|
|
|
|
-- FIXME these ideally belong somewhere else, I'm just not sure where
|
|
|
|
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
|
-- Yesod 'Response'.
|
|
hamletToContent :: Hamlet (Route master) -> GHandler sub master Content
|
|
hamletToContent h = do
|
|
render <- getUrlRenderParams
|
|
return $ toContent $ h render
|
|
|
|
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
|
hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml
|
|
hamletToRepHtml = fmap RepHtml . hamletToContent
|