module Text.Hamlet
(
Html
, shamlet
, shamletFile
, xshamlet
, xshamletFile
, HtmlUrl
, hamlet
, hamletFile
, xhamlet
, xhamletFile
, HtmlUrlI18n
, ihamlet
, ihamletFile
, ToAttributes (..)
, HamletSettings (..)
, hamletWithSettings
, hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
, Env (..)
, HamletRules (..)
, hamletRules
, htmlRules
) 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
#if MIN_VERSION_blaze_html(0,5,0)
import Text.Blaze.Html (Html, toHtml)
import Text.Blaze.Internal (preEscapedText)
#else
import Text.Blaze (Html, preEscapedText, toHtml)
#endif
import qualified Data.Foldable as F
import Control.Monad (mplus)
import Data.Monoid (mempty, mappend)
import Control.Arrow ((***))
class ToAttributes a where
toAttributes :: a -> [(Text, Text)]
instance ToAttributes (Text, Text) where
toAttributes = return
instance ToAttributes (String, String) where
toAttributes (k, v) = [(pack k, pack v)]
instance ToAttributes [(Text, Text)] where
toAttributes = id
instance ToAttributes [(String, String)] where
toAttributes = map (pack *** pack)
attrsToHtml :: [(Text, Text)] -> Html
attrsToHtml =
foldr go mempty
where
go (k, v) rest =
toHtml " "
`mappend` preEscapedText k
`mappend` preEscapedText (pack "=\"")
`mappend` toHtml v
`mappend` preEscapedText (pack "\"")
`mappend` rest
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
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern (BindVar i@(Ident s)) = do
name <- newName s
return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple is) = do
names <- mapM (newName . unIdent) is
return (TupP $ map VarP names, zip is $ map VarE names)
bindingPattern (BindConstr (Ident con) is) = do
names <- mapM (newName . unIdent) is
return (ConP (mkName con) (map VarP names), zip is $ map VarE names)
docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp env hr scope (DocForall list idents inside) = do
let list' = derefToExp scope list
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
mh <- [|F.mapM_|]
inside' <- docsToExp env hr scope' inside
let lam = LamE [pat] inside'
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
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
inside' <- docToExp env hr scope' (DocWith dis inside)
let lam = LamE [pat] inside'
return $ lam `AppE` deref'
docToExp env hr scope (DocMaybe val idents inside mno) = do
let val' = derefToExp scope val
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
inside' <- docsToExp env hr scope' inside
let inside'' = LamE [pat] inside'
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 scope (DocCase deref cases) = do
let exp_ = derefToExp scope deref
matches <- mapM toMatch cases
return $ CaseE exp_ matches
where
toMatch (idents, inside) = do
let pat = case map unIdent idents of
["_"] -> WildP
strs -> let (constr:fields) = map mkName strs
in ConP constr (map VarP fields)
insideExp <- docsToExp env hr scope inside
return $ Match pat (NormalB insideExp) []
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)
contentToExp _ hr scope (ContentAttrs d) = do
html <- [|attrsToHtml . toAttributes|]
return $ hrFromHtml hr `AppE` (html `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
hamlet' :: QuasiQuoter
hamlet' = hamletWithSettings hamletRules defaultHamletSettings{hamletNewlines=True}
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
#ifdef GHC_7_4
qAddDependentFile fp
#endif
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