module Text.Hamlet
(
Html
, shamlet
, shamletFile
, xshamlet
, xshamletFile
, HtmlUrl
, hamlet
, hamletFile
, xhamlet
, xhamletFile
, HtmlUrlI18n
, ihamlet
, ihamletFile
, ToAttributes (..)
, HamletSettings (..)
, NewlineStyle (..)
, hamletWithSettings
, hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
, Env (..)
, HamletRules (..)
, hamletRules
, ihamletRules
, htmlRules
, CloseStyle (..)
, condH
, maybeH
, asHtmlUrl
, attrsToHtml
) where
import Text.Shakespeare.Base
import Text.Hamlet.Parse
#if MIN_VERSION_template_haskell(2,9,0)
import Language.Haskell.TH.Syntax hiding (Module)
#else
import Language.Haskell.TH.Syntax
#endif
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 (Html, toHtml)
import Text.Blaze.Internal (preEscapedText)
import qualified Data.Foldable as F
import Control.Monad (mplus)
import Data.Monoid (mempty, mappend)
import Control.Arrow ((***))
import Data.List (intercalate)
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 (BindAs i@(Ident s) b) = do
name <- newName s
(pattern, scope) <- bindingPattern b
return (AsP name pattern, (i, VarE name):scope)
bindingPattern (BindVar i@(Ident s))
| all isDigit s = do
return (LitP $ IntegerL $ read s, [])
| otherwise = do
name <- newName s
return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (TupP patterns, concat scopes)
bindingPattern (BindList is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (ListP patterns, concat scopes)
bindingPattern (BindConstr con is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (ConP (mkConName con) patterns, concat scopes)
bindingPattern (BindRecord con fields wild) = do
let f (Ident field,b) =
do (p,s) <- bindingPattern b
return ((mkName field,p),s)
(patterns, scopes) <- fmap unzip $ mapM f fields
(patterns1, scopes1) <- if wild
then bindWildFields con $ map fst fields
else return ([],[])
return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)
mkConName :: DataConstr -> Name
mkConName = mkName . conToStr
conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident x)) = x
conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields conName fields = do
fieldNames <- recordToFieldNames conName
let available n = nameBase n `notElem` map unIdent fields
let remainingFields = filter available fieldNames
let mkPat n = do
e <- newName (nameBase n)
return ((n,VarP e), (Ident (nameBase n), VarE e))
fmap unzip $ mapM mkPat remainingFields
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames conStr = do
Just conName <- lookupValueName $ conToStr conStr
DataConI _ _ typeName _ <- reify conName
TyConI (DataD _ _ _ cons _) <- reify typeName
[fields] <- return [fields | RecC name fields <- cons, name == conName]
return [fieldName | (fieldName, _, _) <- fields]
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 ((specialOrIdent, VarE 'or):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
readMay s =
case reads s of
(x, ""):_ -> Just x
_ -> Nothing
toMatch :: (Binding, [Doc]) -> Q Match
toMatch (idents, inside) = do
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
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
xhamlet :: QuasiQuoter
xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id
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 = do
asHtmlUrl' <- [|asHtmlUrl|]
urender $ \ur' -> return ((asHtmlUrl' `AppE` 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 (_mnl, 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