diff options
Diffstat (limited to 'src/Text')
| -rw-r--r-- | src/Text/Pandoc/Writers/HTML.hs | 295 |
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 "↩") -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 "‘" <> (inlineListToHtml opts lst) <> text "’" + primHtmlChar "lsquo" +++ inlineListToHtml opts lst +++ primHtmlChar "rsquo" inlineToHtml opts (Quoted DoubleQuote lst) = - text "“" <> (inlineListToHtml opts lst) <> text "”" -inlineToHtml opts EmDash = text "—" -inlineToHtml opts EnDash = text "–" -inlineToHtml opts Ellipses = text "…" -inlineToHtml opts Apostrophe = text "’" -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) + |