module Text.Hamlet
(
Html
, shamlet
, shamletFile
, xshamlet
, xshamletFile
, HtmlUrl
, hamlet
, hamletFile
, xhamlet
, xhamletFile
, HtmlUrlI18n
, ihamlet
, ihamletFile
, HamletSettings
, hamletWithSettings
, hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
, Env (..)
, HamletRules (..)
) where
import Text.Shakespeare.Base
import Text.Hamlet.Parse
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Char (isUpper, isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Text.Blaze (Html, preEscapedText, toHtml)
import qualified Data.Foldable as F
import Control.Monad (mplus)
type Render url = url -> [(Text, Text)] -> Text
type Translate msg = msg -> Html
type HtmlUrl url = Render url -> Html
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp env hr scope docs = do
exps <- mapM (docToExp env hr scope) docs
case exps of
[] -> [|return ()|]
[x] -> return x
_ -> return $ DoE $ map NoBindS exps
unIdent :: Ident -> String
unIdent (Ident s) = s
docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp env hr scope (DocForall list idents inside) = do
let list' = derefToExp scope list
names <- mapM (newName . unIdent) idents
let pairs = zip idents (map VarE names)
let scope' = pairs ++ scope
mh <- [|F.mapM_|]
inside' <- docsToExp env hr scope' inside
let lam = flip LamE inside' $ case names of
[x] -> [VarP x]
_ -> [TupP $ map VarP names]
return $ mh `AppE` lam `AppE` list'
docToExp env hr scope (DocWith [] inside) = do
inside' <- docsToExp env hr scope inside
return $ inside'
docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do
let deref' = derefToExp scope deref
names <- mapM (newName . unIdent) idents
let pairs = zip idents (map VarE names)
let scope' = pairs ++ scope
inside' <- docToExp env hr scope' (DocWith dis inside)
let lam = flip LamE inside' $ case names of
[x] -> [VarP x]
_ -> [TupP $ map VarP names]
return $ lam `AppE` deref'
docToExp env hr scope (DocMaybe val idents inside mno) = do
let val' = derefToExp scope val
names <- mapM (newName . unIdent) idents
let pairs = zip idents (map VarE names)
let scope' = pairs ++ scope
inside' <- docsToExp env hr scope' inside
let inside'' = flip LamE inside' $ case names of
[x] -> [VarP x]
_ -> [TupP $ map VarP names]
ninside' <- case mno of
Nothing -> [|Nothing|]
Just no -> do
no' <- docsToExp env hr scope no
j <- [|Just|]
return $ j `AppE` no'
mh <- [|maybeH|]
return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
docToExp env hr scope (DocCond conds final) = do
conds' <- mapM go conds
final' <- case final of
Nothing -> [|Nothing|]
Just f -> do
f' <- docsToExp env hr scope f
j <- [|Just|]
return $ j `AppE` f'
ch <- [|condH|]
return $ ch `AppE` ListE conds' `AppE` final'
where
go :: (Deref, [Doc]) -> Q Exp
go (d, docs) = do
let d' = derefToExp scope d
docs' <- docsToExp env hr scope docs
return $ TupE [d', docs']
docToExp env hr v (DocContent c) = contentToExp env hr v c
contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
contentToExp _ hr _ (ContentRaw s) = do
os <- [|preEscapedText . pack|]
let s' = LitE $ StringL s
return $ hrFromHtml hr `AppE` (os `AppE` s')
contentToExp _ hr scope (ContentVar d) = do
str <- [|toHtml|]
return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
contentToExp env hr scope (ContentUrl hasParams d) =
case urlRender env of
Nothing -> error "URL interpolation used, but no URL renderer provided"
Just wrender -> wrender $ \render -> do
let render' = return render
ou <- if hasParams
then [|\(u, p) -> $(render') u p|]
else [|\u -> $(render') u []|]
let d' = derefToExp scope d
pet <- [|toHtml|]
return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
contentToExp env hr scope (ContentMsg d) =
case msgRender env of
Nothing -> error "Message interpolation used, but no message renderer provided"
Just wrender -> wrender $ \render ->
return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
shamlet :: QuasiQuoter
shamlet = hamletWithSettings htmlRules defaultHamletSettings
xshamlet :: QuasiQuoter
xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings
htmlRules :: Q HamletRules
htmlRules = do
i <- [|id|]
return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)
hamlet :: QuasiQuoter
hamlet = hamletWithSettings hamletRules defaultHamletSettings
xhamlet :: QuasiQuoter
xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
hamletRules :: Q HamletRules
hamletRules = do
i <- [|id|]
let ur f = do
r <- newName "_render"
let env = Env
{ urlRender = Just ($ (VarE r))
, msgRender = Nothing
}
h <- f env
return $ LamE [VarP r] h
return $ HamletRules i ur em
where
em (Env (Just urender) Nothing) e =
urender $ \ur' -> return (e `AppE` ur')
em _ _ = error "bad Env"
ihamlet :: QuasiQuoter
ihamlet = hamletWithSettings ihamletRules defaultHamletSettings
ihamletRules :: Q HamletRules
ihamletRules = do
i <- [|id|]
let ur f = do
u <- newName "_urender"
m <- newName "_mrender"
let env = Env
{ urlRender = Just ($ (VarE u))
, msgRender = Just ($ (VarE m))
}
h <- f env
return $ LamE [VarP m, VarP u] h
return $ HamletRules i ur em
where
em (Env (Just urender) (Just mrender)) e =
urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')
em _ _ = error "bad Env"
hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings hr set =
QuasiQuoter
{ quoteExp = hamletFromString hr set
}
data HamletRules = HamletRules
{ hrFromHtml :: Exp
, hrWithEnv :: (Env -> Q Exp) -> Q Exp
, hrEmbed :: Env -> Exp -> Q Exp
}
data Env = Env
{ urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
, msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
}
hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
hamletFromString qhr set s = do
hr <- qhr
case parseDoc set s of
Error s' -> error s'
Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d
hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings qhr set fp = do
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
hamletFromString qhr set contents
hamletFile :: FilePath -> Q Exp
hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
xhamletFile :: FilePath -> Q Exp
xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
shamletFile :: FilePath -> Q Exp
shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
xshamletFile :: FilePath -> Q Exp
xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
ihamletFile :: FilePath -> Q Exp
ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
varName :: Scope -> String -> Exp
varName _ "" = error "Illegal empty varName"
varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
strToExp :: String -> Exp
strToExp s@(c:_)
| all isDigit s = LitE $ IntegerL $ read s
| isUpper c = ConE $ mkName s
| otherwise = VarE $ mkName s
strToExp "" = error "strToExp on empty string"
condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()
condH bms mm = fromMaybe (return ()) $ lookup True bms `mplus` mm
maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()
maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm