module Text.Pandoc.Writers.HTML ( writeHtml , writeHtmlString ) where
import Text.Pandoc.Definition
import Text.Pandoc.LaTeXMathML
import Text.Pandoc.CharacterReferences ( decodeCharacterReferences )
import Text.Pandoc.Shared
import Text.Pandoc.Readers.TeXMath
import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss )
import Numeric ( showHex )
import Data.Char ( ord, toLower )
import Data.List ( isPrefixOf, intercalate )
import Data.Maybe ( catMaybes )
import qualified Data.Set as S
import Control.Monad.State
import Text.XHtml.Transitional hiding ( stringToHtml )
data WriterState = WriterState
{ stNotes :: [Html]
, stMath :: Bool
, stCSS :: S.Set String
} deriving Show
defaultWriterState :: WriterState
defaultWriterState = WriterState {stNotes= [], stMath = False, stCSS = S.empty}
render :: (HTML html) => WriterOptions -> html -> String
render opts = if writerWrapText opts then renderHtml else showHtml
renderFragment :: (HTML html) => WriterOptions -> html -> String
renderFragment opts = if writerWrapText opts
then renderHtmlFragment
else showHtmlFragment
stringToHtml :: String -> Html
stringToHtml = primHtml . concatMap fixChar
where
fixChar '<' = "<"
fixChar '>' = ">"
fixChar '&' = "&"
fixChar '"' = """
fixChar '\160' = " "
fixChar c | ord c < 0xff = [c]
fixChar c = "&#" ++ show (ord c) ++ ";"
writeHtmlString :: WriterOptions -> Pandoc -> String
writeHtmlString opts =
if writerStandalone opts
then render opts . writeHtml opts
else renderFragment opts . writeHtml opts
writeHtml :: WriterOptions -> Pandoc -> Html
writeHtml opts (Pandoc (Meta tit authors date) blocks) =
let titlePrefix = writerTitlePrefix opts
topTitle = evalState (inlineListToHtml opts tit) defaultWriterState
topTitle' = if null titlePrefix
then topTitle
else if null tit
then stringToHtml titlePrefix
else titlePrefix +++ " - " +++ topTitle
metadata = thetitle topTitle' +++
meta ! [httpequiv "Content-Type",
content "text/html; charset=UTF-8"] +++
meta ! [name "generator", content "pandoc"] +++
(toHtmlFromList $
map (\a -> meta ! [name "author", content a]) authors) +++
(if null date
then noHtml
else meta ! [name "date", content date])
titleHeader = if writerStandalone opts && not (null tit) &&
not (writerS5 opts)
then h1 ! [theclass "title"] $ topTitle
else noHtml
sects = hierarchicalize blocks
toc = if writerTableOfContents opts
then evalState (tableOfContents opts sects) defaultWriterState
else noHtml
(blocks', newstate) = runState
(mapM (elementToHtml opts) sects >>= return . toHtmlFromList)
defaultWriterState
cssLines = stCSS newstate
css = if S.null cssLines
then noHtml
else style ! [thetype "text/css"] $ primHtml $
'\n':(unlines $ S.toList cssLines)
math = if stMath newstate
then case writerHTMLMathMethod opts of
LaTeXMathML Nothing ->
primHtml latexMathMLScript
LaTeXMathML (Just url) ->
script !
[src url, thetype "text/javascript"] $
noHtml
JsMath (Just url) ->
script !
[src url, thetype "text/javascript"] $
noHtml
_ -> noHtml
else noHtml
head' = header $ metadata +++ math +++ css +++
primHtml (writerHeader opts)
notes = reverse (stNotes newstate)
before = primHtml $ writerIncludeBefore opts
after = primHtml $ writerIncludeAfter opts
thebody = before +++ titleHeader +++ toc +++ blocks' +++
footnoteSection notes +++ after
in if writerStandalone opts
then head' +++ body thebody
else thebody
tableOfContents :: WriterOptions -> [Element] -> State WriterState Html
tableOfContents _ [] = return noHtml
tableOfContents opts sects = do
let opts' = opts { writerIgnoreNotes = True }
contents <- mapM (elementToListItem opts') sects
return $ thediv ! [identifier "TOC"] $ unordList $ catMaybes contents
elementToListItem :: WriterOptions -> Element -> State WriterState (Maybe Html)
elementToListItem _ (Blk _) = return Nothing
elementToListItem opts (Sec _ id' headerText subsecs) = do
txt <- inlineListToHtml opts headerText
subHeads <- mapM (elementToListItem opts) subsecs >>= return . catMaybes
let subList = if null subHeads
then noHtml
else unordList subHeads
return $ Just $ (anchor ! [href ("#" ++ id')] $ txt) +++ subList
elementToHtml :: WriterOptions -> Element -> State WriterState Html
elementToHtml opts (Blk block) = blockToHtml opts block
elementToHtml opts (Sec level id' title' elements) = do
innerContents <- mapM (elementToHtml opts) elements
header' <- blockToHtml opts (Header level title')
return $ if writerS5 opts || (writerStrictMarkdown opts && not (writerTableOfContents opts))
then toHtmlFromList (header' : innerContents)
else thediv ! [identifier id'] << (header' : innerContents)
footnoteSection :: [Html] -> Html
footnoteSection notes =
if null notes
then noHtml
else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes)
parseMailto :: String -> Maybe (String, String)
parseMailto ('m':'a':'i':'l':'t':'o':':':addr) =
let (name', rest) = span (/='@') addr
domain = drop 1 rest
in Just (name', domain)
parseMailto _ = Nothing
obfuscateLink :: WriterOptions -> String -> String -> Html
obfuscateLink opts txt s | writerEmailObfuscation opts == NoObfuscation =
anchor ! [href s] << txt
obfuscateLink opts txt s =
let meth = writerEmailObfuscation opts
s' = map toLower s
in case parseMailto s' of
(Just (name', domain)) ->
let domain' = substitute "." " dot " domain
at' = obfuscateChar '@'
(linkText, altText) =
if txt == drop 7 s'
then ("'<code>'+e+'</code>'", name' ++ " at " ++ domain')
else ("'" ++ txt ++ "'", txt ++ " (" ++ name' ++ " at " ++
domain' ++ ")")
in case meth of
ReferenceObfuscation ->
primHtml $ "<a href=\"" ++ (obfuscateString s')
++ "\">" ++ (obfuscateString txt) ++ "</a>"
JavascriptObfuscation ->
(script ! [thetype "text/javascript"] $
primHtml ("\n<!--\nh='" ++
obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++
obfuscateString name' ++ "';e=n+a+h;\n" ++
"document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++
linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++
noscript (primHtml $ obfuscateString altText)
_ -> error $ "Unknown obfuscation method: " ++ show meth
_ -> anchor ! [href s] $ primHtml txt
obfuscateChar :: Char -> String
obfuscateChar char =
let num = ord char
numstr = if even num then show num else "x" ++ showHex num ""
in "&#" ++ numstr ++ ";"
obfuscateString :: String -> String
obfuscateString = concatMap obfuscateChar . decodeCharacterReferences
addToCSS :: String -> State WriterState ()
addToCSS item = do
st <- get
let current = stCSS st
put $ st {stCSS = S.insert item current}
blockToHtml :: WriterOptions -> Block -> State WriterState Html
blockToHtml _ Null = return $ noHtml
blockToHtml opts (Plain lst) = inlineListToHtml opts lst
blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph)
blockToHtml _ (RawHtml str) = return $ primHtml str
blockToHtml _ (HorizontalRule) = return $ hr
blockToHtml opts (CodeBlock (_,classes,_) rawCode) | "haskell" `elem` classes &&
writerLiterateHaskell opts =
let classes' = map (\c -> if c == "haskell" then "literatehaskell" else c) classes
in blockToHtml opts $ CodeBlock ("",classes',[]) $ intercalate "\n" $ map ("> " ++) $ lines rawCode
blockToHtml _ (CodeBlock attr@(_,classes,_) rawCode) = do
case highlightHtml attr rawCode of
Left _ ->
let (leadingBreaks, rawCode') = span (=='\n') rawCode
in return $ pre ! (if null classes
then []
else [theclass $ unwords classes]) $ thecode <<
(replicate (length leadingBreaks) br +++
[stringToHtml $ rawCode' ++ "\n"])
Right h -> addToCSS defaultHighlightingCss >> return h
blockToHtml opts (BlockQuote blocks) =
if writerS5 opts
then let inc = not (writerIncremental opts) in
case blocks of
[BulletList lst] -> blockToHtml (opts {writerIncremental = inc})
(BulletList lst)
[OrderedList attribs lst] ->
blockToHtml (opts {writerIncremental = inc})
(OrderedList attribs lst)
_ -> blockListToHtml opts blocks >>=
(return . blockquote)
else blockListToHtml opts blocks >>= (return . blockquote)
blockToHtml opts (Header level lst) = do
contents <- inlineListToHtml opts lst
let contents' = if writerTableOfContents opts
then anchor ! [href "#TOC"] $ contents
else contents
return $ case level of
1 -> h1 contents'
2 -> h2 contents'
3 -> h3 contents'
4 -> h4 contents'
5 -> h5 contents'
6 -> h6 contents'
_ -> paragraph contents'
blockToHtml opts (BulletList lst) = do
contents <- mapM (blockListToHtml opts) lst
let attribs = if writerIncremental opts
then [theclass "incremental"]
else []
return $ unordList ! attribs $ contents
blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do
contents <- mapM (blockListToHtml opts) lst
let numstyle' = camelCaseToHyphenated $ show numstyle
let attribs = (if writerIncremental opts
then [theclass "incremental"]
else []) ++
(if startnum /= 1
then [start startnum]
else []) ++
(if numstyle /= DefaultStyle
then [thestyle $ "list-style-type: " ++ numstyle' ++ ";"]
else [])
return $ ordList ! attribs $ contents
blockToHtml opts (DefinitionList lst) = do
contents <- mapM (\(term, def) -> do term' <- inlineListToHtml opts term
def' <- blockListToHtml opts def
return $ (term', def')) lst
let attribs = if writerIncremental opts
then [theclass "incremental"]
else []
return $ defList ! attribs $ contents
blockToHtml opts (Table capt aligns widths headers rows') = do
let alignStrings = map alignmentToString aligns
captionDoc <- if null capt
then return noHtml
else inlineListToHtml opts capt >>= return . caption
colHeads <- colHeadsToHtml opts alignStrings
widths headers
rows'' <- zipWithM (tableRowToHtml opts alignStrings) (cycle ["odd", "even"]) rows'
return $ table $ captionDoc +++ colHeads +++ rows''
colHeadsToHtml :: WriterOptions
-> [[Char]]
-> [Double]
-> [[Block]]
-> State WriterState Html
colHeadsToHtml opts alignStrings widths headers = do
heads <- sequence $ zipWith3
(\alignment columnwidth item -> tableItemToHtml opts th alignment columnwidth item)
alignStrings widths headers
return $ tr ! [theclass "header"] $ toHtmlFromList heads
alignmentToString :: Alignment -> [Char]
alignmentToString alignment = case alignment of
AlignLeft -> "left"
AlignRight -> "right"
AlignCenter -> "center"
AlignDefault -> "left"
tableRowToHtml :: WriterOptions
-> [[Char]]
-> String
-> [[Block]]
-> State WriterState Html
tableRowToHtml opts aligns rowclass columns =
(sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) columns) >>=
return . (tr ! [theclass rowclass]) . toHtmlFromList
tableItemToHtml :: WriterOptions
-> (Html -> Html)
-> [Char]
-> Double
-> [Block]
-> State WriterState Html
tableItemToHtml opts tag' align' width' item = do
contents <- blockListToHtml opts item
let attrib = [align align'] ++
if width' /= 0
then [thestyle ("width: " ++ (show (truncate (100 * width') :: Integer)) ++ "%;")]
else []
return $ tag' ! attrib $ contents
blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html
blockListToHtml opts lst =
mapM (blockToHtml opts) lst >>= return . toHtmlFromList
inlineListToHtml :: WriterOptions -> [Inline] -> State WriterState Html
inlineListToHtml opts lst =
mapM (inlineToHtml opts) lst >>= return . toHtmlFromList
inlineToHtml :: WriterOptions -> Inline -> State WriterState Html
inlineToHtml opts inline =
case inline of
(Str str) -> return $ stringToHtml str
(Space) -> return $ stringToHtml " "
(LineBreak) -> return $ br
(EmDash) -> return $ primHtmlChar "mdash"
(EnDash) -> return $ primHtmlChar "ndash"
(Ellipses) -> return $ primHtmlChar "hellip"
(Apostrophe) -> return $ primHtmlChar "rsquo"
(Emph lst) -> inlineListToHtml opts lst >>= return . emphasize
(Strong lst) -> inlineListToHtml opts lst >>= return . strong
(Code str) -> return $ thecode << str
(Strikeout lst) -> inlineListToHtml opts lst >>=
return . (thespan ! [thestyle "text-decoration: line-through;"])
(SmallCaps lst) -> inlineListToHtml opts lst >>=
return . (thespan ! [thestyle "font-variant: small-caps;"])
(Superscript lst) -> inlineListToHtml opts lst >>= return . sup
(Subscript lst) -> inlineListToHtml opts lst >>= return . sub
(Quoted quoteType lst) ->
let (leftQuote, rightQuote) = case quoteType of
SingleQuote -> (primHtmlChar "lsquo",
primHtmlChar "rsquo")
DoubleQuote -> (primHtmlChar "ldquo",
primHtmlChar "rdquo")
in do contents <- inlineListToHtml opts lst
return $ leftQuote +++ contents +++ rightQuote
(Math t str) ->
modify (\st -> st {stMath = True}) >>
(case writerHTMLMathMethod opts of
LaTeXMathML _ ->
return $ thespan ! [theclass "LaTeX"] $
if t == InlineMath
then primHtml ("$" ++ str ++ "$")
else primHtml ("$$" ++ str ++ "$$")
JsMath _ ->
return $ if t == InlineMath
then thespan ! [theclass "math"] $ primHtml str
else thediv ! [theclass "math"] $ primHtml str
MimeTeX url ->
return $ image ! [src (url ++ "?" ++ str),
alt str, title str]
GladTeX ->
return $ primHtml $ "<EQ>" ++ str ++ "</EQ>"
PlainMath ->
inlineListToHtml opts (readTeXMath str) >>=
return . (thespan ! [theclass "math"]) )
(TeX str) -> case writerHTMLMathMethod opts of
LaTeXMathML _ -> do modify (\st -> st {stMath = True})
return $ primHtml str
_ -> return noHtml
(HtmlInline str) -> return $ primHtml str
(Link [Code str] (s,_)) | "mailto:" `isPrefixOf` s ->
return $ obfuscateLink opts str s
(Link txt (s,_)) | "mailto:" `isPrefixOf` s -> do
linkText <- inlineListToHtml opts txt
return $ obfuscateLink opts (show linkText) s
(Link txt (s,tit)) -> do
linkText <- inlineListToHtml opts txt
return $ anchor ! ([href s] ++
if null tit then [] else [title tit]) $
linkText
(Image txt (s,tit)) -> do
alternate <- inlineListToHtml opts txt
let alternate' = renderFragment opts alternate
let attributes = [src s] ++
(if null tit
then []
else [title tit]) ++
if null txt
then []
else [alt alternate']
return $ image ! attributes
(Note contents) -> do
st <- get
let notes = stNotes st
let number = (length notes) + 1
let ref = show number
htmlContents <- blockListToNote opts ref contents
put $ st {stNotes = (htmlContents:notes)}
return $ anchor ! [href ("#fn" ++ ref),
theclass "footnoteRef",
identifier ("fnref" ++ ref)] <<
sup << ref
(Cite _ il) -> inlineListToHtml opts il
blockListToNote :: WriterOptions -> String -> [Block] -> State WriterState Html
blockListToNote opts ref blocks =
let backlink = [HtmlInline $ " <a href=\"#fnref" ++ ref ++
"\" class=\"footnoteBackLink\"" ++
" title=\"Jump back to footnote " ++ ref ++ "\">↩</a>"]
blocks' = if null blocks
then []
else let lastBlock = last blocks
otherBlocks = init blocks
in case lastBlock of
(Para lst) -> otherBlocks ++
[Para (lst ++ backlink)]
(Plain lst) -> otherBlocks ++
[Plain (lst ++ backlink)]
_ -> otherBlocks ++ [lastBlock,
Plain backlink]
in do contents <- blockListToHtml opts blocks'
return $ li ! [identifier ("fn" ++ ref)] $ contents