160 lines
4.9 KiB
Haskell
160 lines
4.9 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Yesod.Widget
|
|
( -- * Datatype
|
|
Widget
|
|
-- * Unwrapping
|
|
, widgetToPageContent
|
|
, applyLayoutW
|
|
-- * Creating
|
|
, newIdent
|
|
, setTitle
|
|
, addStyle
|
|
, addStylesheet
|
|
, addStylesheetRemote
|
|
, addScript
|
|
, addScriptRemote
|
|
, addHead
|
|
, addBody
|
|
-- * Manipulating
|
|
, wrapWidget
|
|
, extractBody
|
|
) where
|
|
|
|
import Data.List (nub)
|
|
import Data.Monoid
|
|
import Control.Monad.Trans.Writer
|
|
import Control.Monad.Trans.State
|
|
import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string)
|
|
import Yesod.Handler (Routes, GHandler)
|
|
import Yesod.Yesod (Yesod, defaultLayout)
|
|
import Yesod.Content (RepHtml (..))
|
|
import Control.Applicative (Applicative)
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
|
|
|
|
data Location url = Local url | Remote String
|
|
deriving (Show, Eq)
|
|
locationToHamlet :: Location url -> Hamlet url
|
|
locationToHamlet (Local url) = [$hamlet|@url@|]
|
|
locationToHamlet (Remote s) = [$hamlet|$string.s$|]
|
|
|
|
newtype UniqueList x = UniqueList ([x] -> [x])
|
|
instance Monoid (UniqueList x) where
|
|
mempty = UniqueList id
|
|
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
|
|
runUniqueList :: Eq x => UniqueList x -> [x]
|
|
runUniqueList (UniqueList x) = nub $ x []
|
|
toUnique :: x -> UniqueList x
|
|
toUnique = UniqueList . (:)
|
|
|
|
newtype Script url = Script { unScript :: Location url }
|
|
deriving (Show, Eq)
|
|
newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }
|
|
deriving (Show, Eq)
|
|
newtype Title = Title { unTitle :: Html () }
|
|
newtype Style url = Style (Hamlet url)
|
|
deriving Monoid
|
|
newtype Head url = Head (Hamlet url)
|
|
deriving Monoid
|
|
newtype Body url = Body (Hamlet url)
|
|
deriving Monoid
|
|
|
|
newtype Widget sub master a = Widget (
|
|
WriterT (Body (Routes master)) (
|
|
WriterT (Last Title) (
|
|
WriterT (UniqueList (Script (Routes master))) (
|
|
WriterT (UniqueList (Stylesheet (Routes master))) (
|
|
WriterT (Style (Routes master)) (
|
|
WriterT (Head (Routes master)) (
|
|
StateT Int (
|
|
GHandler sub master
|
|
))))))) a)
|
|
deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
|
|
instance Monoid (Widget sub master ()) where
|
|
mempty = return ()
|
|
mappend x y = x >> y
|
|
|
|
setTitle :: Html () -> Widget sub master ()
|
|
setTitle = Widget . lift . tell . Last . Just . Title
|
|
|
|
addHead :: Hamlet (Routes master) -> Widget sub master ()
|
|
addHead = Widget . lift . lift . lift . lift . lift . tell . Head
|
|
|
|
addBody :: Hamlet (Routes master) -> Widget sub master ()
|
|
addBody = Widget . tell . Body
|
|
|
|
newIdent :: Widget sub master String
|
|
newIdent = Widget $ lift $ lift $ lift $ lift $ lift $ lift $ do
|
|
i <- get
|
|
let i' = i + 1
|
|
put i'
|
|
return $ "w" ++ show i'
|
|
|
|
addStyle :: Hamlet (Routes master) -> Widget sub master ()
|
|
addStyle = Widget . lift . lift . lift . lift . tell . Style
|
|
|
|
addStylesheet :: Routes master -> Widget sub master ()
|
|
addStylesheet = Widget . lift . lift . lift . tell . toUnique . Stylesheet . Local
|
|
|
|
addStylesheetRemote :: String -> Widget sub master ()
|
|
addStylesheetRemote =
|
|
Widget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
|
|
|
|
addScript :: Routes master -> Widget sub master ()
|
|
addScript = Widget . lift . lift . tell . toUnique . Script . Local
|
|
|
|
addScriptRemote :: String -> Widget sub master ()
|
|
addScriptRemote =
|
|
Widget . lift . lift . tell . toUnique . Script . Remote
|
|
|
|
applyLayoutW :: (Eq (Routes m), Yesod m)
|
|
=> Widget sub m () -> GHandler sub m RepHtml
|
|
applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout
|
|
|
|
widgetToPageContent :: Eq (Routes master)
|
|
=> Widget sub master ()
|
|
-> GHandler sub master (PageContent (Routes master))
|
|
widgetToPageContent (Widget w) = do
|
|
w' <- flip evalStateT 0
|
|
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
|
|
$ runWriterT $ runWriterT w
|
|
let (((((((),
|
|
Body body),
|
|
Last mTitle),
|
|
scripts'),
|
|
stylesheets'),
|
|
Style style),
|
|
Head head') = w'
|
|
let title = maybe mempty unTitle mTitle
|
|
let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
|
|
let stylesheets = map (locationToHamlet . unStylesheet)
|
|
$ runUniqueList stylesheets'
|
|
let head'' = [$hamlet|
|
|
$forall scripts s
|
|
%script!src=^s^
|
|
$forall stylesheets s
|
|
%link!rel=stylesheet!href=^s^
|
|
%style
|
|
^style^
|
|
^head'^
|
|
|]
|
|
return $ PageContent title head'' body
|
|
|
|
wrapWidget :: (Hamlet (Routes m) -> Hamlet (Routes m))
|
|
-> Widget s m a -> Widget s m a
|
|
wrapWidget wrap (Widget w) =
|
|
Widget $ mapWriterT (fmap go) w
|
|
where
|
|
go (a, Body h) = (a, Body $ wrap h)
|
|
|
|
extractBody :: Widget s m () -> Widget s m (Hamlet (Routes m))
|
|
extractBody (Widget w) =
|
|
Widget $ mapWriterT (fmap go) w
|
|
where
|
|
go ((), Body h) = (h, Body mempty)
|