80 lines
2.3 KiB
Haskell
80 lines
2.3 KiB
Haskell
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Yesod.Hamlet
|
|
( hamletToContent
|
|
, hamletToRepHtml
|
|
, PageContent (..)
|
|
, Hamlet
|
|
, hamlet
|
|
, HtmlContent (..)
|
|
, HtmlObject
|
|
)
|
|
where
|
|
|
|
import Text.Hamlet
|
|
import Text.Hamlet.Monad (outputHtml)
|
|
import Yesod.Response
|
|
import Yesod.Handler
|
|
import Data.Convertible.Text
|
|
import Data.Object
|
|
import Control.Arrow ((***))
|
|
|
|
data PageContent url = PageContent
|
|
{ pageTitle :: HtmlContent
|
|
, pageHead :: Hamlet url IO ()
|
|
, pageBody :: Hamlet url IO ()
|
|
}
|
|
|
|
hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content
|
|
hamletToContent h = do
|
|
render <- getUrlRender
|
|
return $ ContentEnum $ go render
|
|
where
|
|
go render iter seed = do
|
|
res <- runHamlet h render seed $ iter' iter
|
|
case res of
|
|
Left x -> return $ Left x
|
|
Right ((), x) -> return $ Right x
|
|
iter' iter seed text = iter seed $ cs text
|
|
|
|
hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml
|
|
hamletToRepHtml h = do
|
|
c <- hamletToContent h
|
|
return $ RepHtml c
|
|
|
|
-- FIXME some type of JSON combined output...
|
|
--hamletToRepHtmlJson :: x
|
|
-- -> (x -> Hamlet (Routes y) IO ())
|
|
-- -> (x -> Json)
|
|
-- -> Handler y RepHtmlJson
|
|
|
|
instance Monad m => ConvertSuccess String (Hamlet url m ()) where
|
|
convertSuccess = outputHtml . Unencoded . cs
|
|
instance Monad m
|
|
=> ConvertSuccess (Object String HtmlContent) (Hamlet url m ()) where
|
|
convertSuccess (Scalar h) = outputHtml h
|
|
convertSuccess (Sequence s) = template () where
|
|
template = [$hamlet|
|
|
%ul
|
|
$forall s' s
|
|
%li ^s^|]
|
|
s' _ = map cs s
|
|
convertSuccess (Mapping m) = template () where
|
|
template :: Monad m => () -> Hamlet url m ()
|
|
template = [$hamlet|
|
|
%dl
|
|
$forall pairs pair
|
|
%dt $pair.fst$
|
|
%dd ^pair.snd^|]
|
|
pairs _ = map (cs *** cs) m
|
|
instance ConvertSuccess String HtmlContent where
|
|
convertSuccess = Unencoded . cs
|
|
|
|
type HtmlObject = Object String HtmlContent
|
|
|
|
instance ConvertSuccess (Object String String) HtmlObject where
|
|
convertSuccess = fmap cs
|