aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Writers')
-rw-r--r--src/Text/Pandoc/Writers/HTML.hs295
1 files changed, 142 insertions, 153 deletions
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index a7ee9c0f3..06ebf2ca1 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -27,69 +27,78 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Conversion of 'Pandoc' documents to HTML.
-}
-module Text.Pandoc.Writers.HTML (
- writeHtml,
- ) where
+module Text.Pandoc.Writers.HTML ( writeHtml, writeHtmlString ) where
import Text.Pandoc.Definition
import Text.Pandoc.Shared
-import Text.Pandoc.Entities ( escapeSGMLString )
import Text.Regex ( mkRegex, matchRegex )
import Numeric ( showHex )
import Data.Char ( ord, toLower )
import Data.List ( isPrefixOf, partition )
-import Text.PrettyPrint.HughesPJ hiding ( Str )
+import Text.XHtml.Strict
--- | Convert Pandoc document to string in HTML format.
-writeHtml :: WriterOptions -> Pandoc -> String
-writeHtml opts (Pandoc (Meta title authors date) blocks) =
- let titlePrefix = writerTitlePrefix opts in
- let topTitle = if not (null titlePrefix)
- then [Str titlePrefix] ++ (if not (null title)
- then [Str " - "] ++ title
- else [])
- else title in
- let head = if (writerStandalone opts)
- then htmlHeader opts (Meta topTitle authors date)
- else empty
- titleBlocks = if (writerStandalone opts) && (not (null title)) &&
+-- | Convert Pandoc document to Html string.
+writeHtmlString :: WriterOptions -> Pandoc -> String
+writeHtmlString opts =
+ if writerStandalone opts
+ then renderHtml . (writeHtml opts)
+ else renderHtmlFragment . (writeHtml opts)
+
+-- | Convert Pandoc document to Html structure.
+writeHtml :: WriterOptions -> Pandoc -> Html
+writeHtml opts (Pandoc (Meta tit authors date) blocks) =
+ let titlePrefix = writerTitlePrefix opts
+ topTitle = inlineListToHtml opts tit
+ topTitle' = if not (null titlePrefix)
+ then stringToHtml titlePrefix +++
+ if not (null tit)
+ then '-' +++ topTitle
+ else noHtml
+ else topTitle
+ head = header $ 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]) +++
+ primHtml (writerHeader opts)
+ titleHeader = if (writerStandalone opts) && (not (null tit)) &&
(not (writerS5 opts))
- then [RawHtml "<h1 class=\"title\">", Plain title,
- RawHtml "</h1>"]
- else []
- foot = if (writerStandalone opts)
- then text "</body>\n</html>"
- else empty
- blocks' = replaceReferenceLinks (titleBlocks ++ blocks)
+ then h1 ! [theclass "title"] $ topTitle
+ else noHtml
+ blocks' = replaceReferenceLinks blocks
(noteBlocks, blocks'') = partition isNoteBlock blocks'
- before = writerIncludeBefore opts
- after = writerIncludeAfter opts
- body = (if null before then empty else text before) $$
- vcat (map (blockToHtml opts) blocks'') $$
- footnoteSection opts noteBlocks $$
- (if null after then empty else text after) in
- render $ head $$ body $$ foot $$ text ""
+ before = primHtml $ writerIncludeBefore opts
+ after = primHtml $ writerIncludeAfter opts
+ thebody = before +++ titleHeader +++
+ toHtmlFromList (map (blockToHtml opts) blocks'') +++
+ footnoteSection opts noteBlocks +++ after
+ in if writerStandalone opts
+ then head +++ (body thebody)
+ else thebody
-- | Convert list of Note blocks to a footnote <div>.
-- Assumes notes are sorted.
-footnoteSection :: WriterOptions -> [Block] -> Doc
+footnoteSection :: WriterOptions -> [Block] -> Html
footnoteSection opts notes =
if null notes
- then empty
- else inTags True "div" [("class","footnotes")] $
- selfClosingTag "hr" [] $$ (inTagsIndented "ol"
- (vcat $ map (blockToHtml opts) notes))
+ then noHtml
+ else thediv ! [theclass "footnotes"] $
+ hr +++ (olist $ toHtmlFromList $ map (blockToHtml opts) notes)
-- | Obfuscate a "mailto:" link using Javascript.
-obfuscateLink :: WriterOptions -> [Inline] -> String -> Doc
+obfuscateLink :: WriterOptions -> [Inline] -> String -> Html
obfuscateLink opts txt src =
let emailRegex = mkRegex "mailto:*([^@]*)@(.*)"
- text' = render $ inlineListToHtml opts txt
- src' = map toLower src in
+ text' = show $ inlineListToHtml opts txt
+ src' = map toLower src in
case (matchRegex emailRegex src') of
(Just [name, domain]) ->
- let domain' = substitute "." " dot " domain
- at' = obfuscateChar '@' in
- let linkText = if src' == ("mailto:" ++ text')
+ let domain' = substitute "." " dot " domain
+ at' = obfuscateChar '@'
+ linkText = if src' == ("mailto:" ++ text')
then "e"
else "'" ++ text' ++ "'"
altText = if src' == ("mailto:" ++ text')
@@ -97,16 +106,16 @@ obfuscateLink opts txt src =
else text' ++ " (" ++ name ++ " at " ++
domain' ++ ")" in
if writerStrictMarkdown opts
- then inTags False "a" [("href", obfuscateString src')] $
- text $ obfuscateString text'
- else inTags False "script" [("type", "text/javascript")]
- (text ("\n<!--\nh='" ++
+ then anchor ! [href $ obfuscateString src'] $
+ stringToHtml $ obfuscateString text'
+ else (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")) <>
- inTagsSimple "noscript" (text (obfuscateString altText))
- _ -> inTags False "a" [("href", src)] (text text') -- malformed email
+ linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++
+ noscript (stringToHtml $ obfuscateString altText)
+ _ -> anchor ! [href src] $ inlineListToHtml opts txt -- malformed email
-- | Obfuscate character as entity.
obfuscateChar :: Char -> String
@@ -119,32 +128,12 @@ obfuscateChar char =
obfuscateString :: String -> String
obfuscateString = concatMap obfuscateChar
--- | Return an HTML header with appropriate bibliographic information.
-htmlHeader :: WriterOptions -> Meta -> Doc
-htmlHeader opts (Meta title authors date) =
- let titletext = inTagsSimple "title" (wrap opts title)
- authortext = if (null authors)
- then empty
- else selfClosingTag "meta" [("name", "author"),
- ("content",
- joinWithSep ", " (map escapeSGMLString authors))]
- datetext = if (date == "")
- then empty
- else selfClosingTag "meta" [("name", "date"),
- ("content", escapeSGMLString date)] in
- text (writerHeader opts) $$ authortext $$ datetext $$ titletext $$
- text "</head>\n<body>"
-
--- | Take list of inline elements and return wrapped doc.
-wrap :: WriterOptions -> [Inline] -> Doc
-wrap opts lst = fsep $ map (inlineListToHtml opts) (splitBy Space lst)
-
-- | Convert Pandoc block element to HTML.
-blockToHtml :: WriterOptions -> Block -> Doc
-blockToHtml opts Blank = text ""
-blockToHtml opts Null = empty
-blockToHtml opts (Plain lst) = wrap opts lst
-blockToHtml opts (Para lst) = inTagsIndented "p" $ wrap opts lst
+blockToHtml :: WriterOptions -> Block -> Html
+blockToHtml opts Blank = noHtml
+blockToHtml opts Null = noHtml
+blockToHtml opts (Plain lst) = inlineListToHtml opts lst
+blockToHtml opts (Para lst) = paragraph $ inlineListToHtml opts lst
blockToHtml opts (BlockQuote blocks) =
if (writerS5 opts)
then -- in S5, treat list in blockquote specially
@@ -152,120 +141,120 @@ blockToHtml opts (BlockQuote blocks) =
-- otherwise incremental
let inc = not (writerIncremental opts) in
case blocks of
- [BulletList lst] -> blockToHtml (opts {writerIncremental =
+ [BulletList lst] -> blockToHtml (opts {writerIncremental =
inc}) (BulletList lst)
[OrderedList lst] -> blockToHtml (opts {writerIncremental =
inc}) (OrderedList lst)
- otherwise -> inTagsIndented "blockquote" $
- vcat $ map (blockToHtml opts) blocks
- else inTagsIndented "blockquote" $ vcat $ map (blockToHtml opts) blocks
+ otherwise -> blockquote $ toHtmlFromList $
+ map (blockToHtml opts) blocks
+ else blockquote $ toHtmlFromList $ map (blockToHtml opts) blocks
blockToHtml opts (Note ref lst) =
- let contents = (vcat $ map (blockToHtml opts) lst) in
- inTags True "li" [("id", "fn" ++ ref)] $
- contents <> inTags False "a" [("href", "#fnref" ++ ref),
- ("class", "footnoteBacklink"),
- ("title", "Jump back to footnote " ++ ref)]
- (text "&#8617;")
-blockToHtml opts (Key _ _) = empty
+ let contents = toHtmlFromList $ map (blockToHtml opts) lst
+ backlink = anchor ! [href ("#fnref" ++ ref), theclass "footnoteBacklink",
+ title ("Jump back to footnote " ++ ref)] $
+ (primHtmlChar "#8617") in
+ li ! [identifier ("fn" ++ ref)] $ contents +++ backlink
+blockToHtml opts (Key _ _) = noHtml
blockToHtml opts (CodeBlock str) =
- text "<pre><code>" <> text (escapeSGMLString str) <> text "\n</code></pre>"
-blockToHtml opts (RawHtml str) = text str
+ pre $ thecode $ stringToHtml (str ++ "\n") -- the final \n for consistency with Markdown.pl
+blockToHtml opts (RawHtml str) = primHtml str
blockToHtml opts (BulletList lst) =
- let attribs = if (writerIncremental opts)
- then [("class","incremental")]
+ let attribs = if writerIncremental opts
+ then [theclass "incremental"]
else [] in
- inTags True "ul" attribs $ vcat $ map (listItemToHtml opts) lst
+ ulist ! attribs $ toHtmlFromList $ map (listItemToHtml opts) lst
blockToHtml opts (OrderedList lst) =
- let attribs = if (writerIncremental opts)
- then [("class","incremental")]
+ let attribs = if writerIncremental opts
+ then [theclass "incremental"]
else [] in
- inTags True "ol" attribs $ vcat $ map (listItemToHtml opts) lst
-blockToHtml opts HorizontalRule = selfClosingTag "hr" []
+ olist ! attribs $ toHtmlFromList $ map (listItemToHtml opts) lst
+blockToHtml opts HorizontalRule = hr
blockToHtml opts (Header level lst) =
- let contents = wrap opts lst in
- if ((level > 0) && (level <= 6))
- then inTagsSimple ("h" ++ show level) contents
- else inTagsSimple "p" contents
-blockToHtml opts (Table caption aligns widths headers rows) =
+ let contents = inlineListToHtml opts lst in
+ 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 (Table capt aligns widths headers rows) =
let alignStrings = map alignmentToString aligns
- captionDoc = if null caption
- then empty
- else inTagsSimple "caption"
- (inlineListToHtml opts caption) in
- inTagsIndented "table" $ captionDoc $$
- (colHeadsToHtml opts alignStrings widths headers) $$
- (vcat $ map (tableRowToHtml opts alignStrings) rows)
+ captionDoc = if null capt
+ then noHtml
+ else caption $ inlineListToHtml opts capt in
+ table $ captionDoc +++
+ (colHeadsToHtml opts alignStrings widths headers) +++
+ (toHtmlFromList $ map (tableRowToHtml opts alignStrings) rows)
colHeadsToHtml opts alignStrings widths headers =
let heads = zipWith3
- (\align width item -> tableItemToHtml opts "th" align width item)
+ (\align width item -> tableItemToHtml opts th align width item)
alignStrings widths headers in
- inTagsIndented "tr" $ vcat heads
+ tr $ toHtmlFromList heads
alignmentToString alignment = case alignment of
- AlignLeft -> "left"
- AlignRight -> "right"
- AlignCenter -> "center"
+ AlignLeft -> "left"
+ AlignRight -> "right"
+ AlignCenter -> "center"
AlignDefault -> "left"
-
tableRowToHtml opts aligns cols =
- inTagsIndented "tr" $ vcat $ zipWith3 (tableItemToHtml opts "td") aligns (repeat 0) cols
+ tr $ toHtmlFromList $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) cols
-tableItemToHtml opts tag align width item =
- let attrib = [("align", align)] ++
+tableItemToHtml opts tag align' width item =
+ let attrib = [align align'] ++
if (width /= 0)
- then [("style", "{width: " ++
- show (truncate (100*width)) ++ "%;}")]
+ then [thestyle ("{width: " ++ show (truncate (100*width)) ++ "%;}")]
else [] in
- inTags False tag attrib $ vcat $ map (blockToHtml opts) item
+ tag ! attrib $ toHtmlFromList $ map (blockToHtml opts) item
-listItemToHtml :: WriterOptions -> [Block] -> Doc
+listItemToHtml :: WriterOptions -> [Block] -> Html
listItemToHtml opts list =
- inTagsSimple "li" $ vcat $ map (blockToHtml opts) list
+ li $ toHtmlFromList $ map (blockToHtml opts) list
-- | Convert list of Pandoc inline elements to HTML.
-inlineListToHtml :: WriterOptions -> [Inline] -> Doc
-inlineListToHtml opts lst = hcat (map (inlineToHtml opts) lst)
+inlineListToHtml :: WriterOptions -> [Inline] -> Html
+inlineListToHtml opts lst = toHtmlFromList $ map (inlineToHtml opts) lst
-- | Convert Pandoc inline element to HTML.
-inlineToHtml :: WriterOptions -> Inline -> Doc
+inlineToHtml :: WriterOptions -> Inline -> Html
inlineToHtml opts (Emph lst) =
- inTagsSimple "em" (inlineListToHtml opts lst)
+ emphasize $ inlineListToHtml opts lst
inlineToHtml opts (Strong lst) =
- inTagsSimple "strong" (inlineListToHtml opts lst)
+ strong $ inlineListToHtml opts lst
inlineToHtml opts (Code str) =
- inTagsSimple "code" $ text (escapeSGMLString str)
+ thecode $ stringToHtml $ str
inlineToHtml opts (Quoted SingleQuote lst) =
- text "&lsquo;" <> (inlineListToHtml opts lst) <> text "&rsquo;"
+ primHtmlChar "lsquo" +++ inlineListToHtml opts lst +++ primHtmlChar "rsquo"
inlineToHtml opts (Quoted DoubleQuote lst) =
- text "&ldquo;" <> (inlineListToHtml opts lst) <> text "&rdquo;"
-inlineToHtml opts EmDash = text "&mdash;"
-inlineToHtml opts EnDash = text "&ndash;"
-inlineToHtml opts Ellipses = text "&hellip;"
-inlineToHtml opts Apostrophe = text "&rsquo;"
-inlineToHtml opts (Str str) = text $ escapeSGMLString str
-inlineToHtml opts (TeX str) = text $ escapeSGMLString str
-inlineToHtml opts (HtmlInline str) = text str
-inlineToHtml opts (LineBreak) = selfClosingTag "br" []
-inlineToHtml opts Space = space
-inlineToHtml opts (Link txt (Src src title)) =
+ primHtmlChar "ldquo" +++ inlineListToHtml opts lst +++ primHtmlChar "rdquo"
+inlineToHtml opts EmDash = primHtmlChar "mdash"
+inlineToHtml opts EnDash = primHtmlChar "ndash"
+inlineToHtml opts Ellipses = primHtmlChar "hellip"
+inlineToHtml opts Apostrophe = primHtmlChar "rsquo"
+inlineToHtml opts (Str str) = stringToHtml str
+inlineToHtml opts (TeX str) = stringToHtml str
+inlineToHtml opts (HtmlInline str) = primHtml str
+inlineToHtml opts (LineBreak) = br
+inlineToHtml opts Space = stringToHtml " "
+inlineToHtml opts (Link txt (Src src tit)) =
if (isPrefixOf "mailto:" src)
then obfuscateLink opts txt src
- else inTags False "a" ([("href", src)] ++
- if null title then [] else [("title", title)])
- (inlineListToHtml opts txt)
+ else anchor ! ([href src] ++ if null tit then [] else [title tit]) $
+ inlineListToHtml opts txt
inlineToHtml opts (Link txt (Ref ref)) =
- char '[' <> (inlineListToHtml opts txt) <> text "][" <>
- (inlineListToHtml opts ref) <> char ']'
+ '[' +++ (inlineListToHtml opts txt) +++
+ ']' +++ '[' +++ (inlineListToHtml opts ref) +++
+ ']'
-- this is what markdown does, for better or worse
-inlineToHtml opts (Image alt (Src source title)) =
- let alternate = render $ inlineListToHtml opts alt in
- selfClosingTag "img" $ [("src", source)] ++
- (if null alternate then [] else [("alt", alternate)]) ++
- [("title", title)] -- note: null title is included, as in Markdown.pl
+inlineToHtml opts (Image alttext (Src source tit)) =
+ let alternate = renderHtml $ inlineListToHtml opts alttext in
+ image ! ([src source, title tit] ++ if null alttext then [] else [alt alternate])
+ -- note: null title is included, as in Markdown.pl
inlineToHtml opts (Image alternate (Ref ref)) =
- text "![" <> (inlineListToHtml opts alternate) <> text "][" <>
- (inlineListToHtml opts ref) <> char ']'
+ '!' +++ inlineToHtml opts (Link alternate (Ref ref))
inlineToHtml opts (NoteRef ref) =
- inTags False "sup" [("class", "footnoteRef"), ("id", "fnref" ++ ref)]
- (inTags False "a" [("href", "#fn" ++ ref)] $ text ref)
+ anchor ! [href ("#fn" ++ ref), theclass "footnoteRef", identifier ("fnref" ++ ref)] $
+ sup (stringToHtml ref)
+