module Text.Hamlet.RT
(
HamletRT (..)
, HamletData (..)
, HamletException (..)
, parseHamletRT
, renderHamletRT
, SimpleDoc (..)
) where
import Data.Monoid (mconcat)
import Control.Monad (liftM, forM)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Control.Failure
import Text.Blaze
import Text.Hamlet.Parse
import Text.Hamlet.Quasi (showParams)
import Data.List (intercalate)
data HamletData url = HDHtml (Html ())
| HDUrl url
| HDUrlParams url [(String, String)]
| HDTemplate HamletRT
| HDBool Bool
| HDMaybe (Maybe (HamletData url))
| HDList [HamletData url]
| HDMap [(String, HamletData url)]
data SimpleDoc = SDRaw String
| SDVar [String]
| SDUrl Bool [String]
| SDTemplate [String]
| SDForall [String] String [SimpleDoc]
| SDMaybe [String] String [SimpleDoc] [SimpleDoc]
| SDCond [([String], [SimpleDoc])] [SimpleDoc]
newtype HamletRT = HamletRT [SimpleDoc]
data HamletException = HamletParseException String
| HamletUnsupportedDocException Doc
| HamletRenderException String
deriving (Show, Typeable)
instance Exception HamletException
parseHamletRT :: Failure HamletException m
=> HamletSettings -> String -> m HamletRT
parseHamletRT set s =
case parseDoc set s of
Error s' -> failure $ HamletParseException s'
Ok x -> liftM HamletRT $ mapM convert x
where
convert x@(DocForall deref (Ident ident) docs) = do
deref' <- flattenDeref x deref
docs' <- mapM convert docs
return $ SDForall deref' ident docs'
convert x@(DocMaybe deref (Ident ident) jdocs ndocs) = do
deref' <- flattenDeref x deref
jdocs' <- mapM convert jdocs
ndocs' <- maybe (return []) (mapM convert) ndocs
return $ SDMaybe deref' ident jdocs' ndocs'
convert (DocContent (ContentRaw s')) = return $ SDRaw s'
convert x@(DocContent (ContentVar deref)) = do
y <- flattenDeref x deref
return $ SDVar y
convert x@(DocContent (ContentUrl p deref)) = do
y <- flattenDeref x deref
return $ SDUrl p y
convert x@(DocContent (ContentEmbed deref)) = do
y <- flattenDeref x deref
return $ SDTemplate y
convert x@(DocCond conds els) = do
conds' <- mapM go conds
els' <- maybe (return []) (mapM convert) els
return $ SDCond conds' els'
where
go (deref, docs') = do
deref' <- flattenDeref x deref
docs'' <- mapM convert docs'
return (deref', docs'')
flattenDeref _ (DerefLeaf (Ident x)) = return [x]
flattenDeref orig (DerefBranch (DerefLeaf (Ident x)) y) = do
y' <- flattenDeref orig y
return $ x : y'
flattenDeref orig _ = failure $ HamletUnsupportedDocException orig
renderHamletRT :: Failure HamletException m
=> HamletRT
-> HamletData url
-> (url -> String)
-> m (Html ())
renderHamletRT (HamletRT docs) (HDMap scope0) renderUrl =
liftM mconcat $ mapM (go scope0) docs
where
go _ (SDRaw s) = return $ preEscapedString s
go scope (SDVar n) = do
v <- lookup' n n $ HDMap scope
case v of
HDHtml h -> return h
_ -> fa $ intercalate "." n ++ ": expected HDHtml"
go scope (SDUrl p n) = do
v <- lookup' n n $ HDMap scope
case (p, v) of
(False, HDUrl u) -> return $ preEscapedString $ renderUrl u
(True, HDUrlParams u q) ->
return $ preEscapedString $ renderUrl u ++ showParams q
(False, _) -> fa $ intercalate "." n ++ ": expected HDUrl"
(True, _) -> fa $ intercalate "." n ++ ": expected HDUrlParams"
go scope (SDTemplate n) = do
v <- lookup' n n $ HDMap scope
case v of
HDTemplate h -> renderHamletRT h (HDMap scope) renderUrl
_ -> fa $ intercalate "." n ++ ": expected HDTemplate"
go scope (SDForall n ident docs') = do
v <- lookup' n n $ HDMap scope
case v of
HDList os -> do
liftM mconcat $ forM os $ \o -> do
let scope' = HDMap $ (ident, o) : scope
renderHamletRT (HamletRT docs') scope' renderUrl
_ -> fa $ intercalate "." n ++ ": expected HDList"
go scope (SDMaybe n ident jdocs ndocs) = do
v <- lookup' n n $ HDMap scope
(scope', docs') <-
case v of
HDMaybe Nothing -> return (scope, ndocs)
HDMaybe (Just o) -> return ((ident, o) : scope, jdocs)
_ -> fa $ intercalate "." n ++ ": expected HDMaybe"
renderHamletRT (HamletRT docs') (HDMap scope') renderUrl
go scope (SDCond [] docs') =
renderHamletRT (HamletRT docs') (HDMap scope) renderUrl
go scope (SDCond ((b, docs'):cs) els) = do
v <- lookup' b b $ HDMap scope
case v of
HDBool True ->
renderHamletRT (HamletRT docs') (HDMap scope) renderUrl
HDBool False -> go scope (SDCond cs els)
_ -> fa $ intercalate "." b ++ ": expected HDBool"
lookup' _ [] x = return x
lookup' orig (n:ns) (HDMap m) =
case lookup n m of
Nothing -> fa $ intercalate "." orig ++ " not found"
Just o -> lookup' orig ns o
lookup' orig _ _ = fa $ intercalate "." orig ++ ": unexpected type"
fa = failure . HamletRenderException
renderHamletRT _ _ _ =
failure $ HamletRenderException "renderHamletRT must be given a HDMap"