Modified HTML writer to use the Text.XHtml library. This results

in cleaner, faster code, and it makes it easier to use Pandoc in
other projects, like wikis, that use Text.XHtml.  Two functions
are now provided, writeHtml and writeHtmlString:  the former outputs
an Html structure, the latter a rendered string.  The S5 writer is
also changed, in parallel ways (writeS5, writeS5String).  The Html
header is now written programmatically, so it has been removed from
the 'headers' directory.  The S5 header is still needed, but the
doctype and some of the meta declarations have been removed, since
they are written programatically.  The INSTALL file and cabalize
have been updated to reflect the new dependency on the xhtml package.


git-svn-id: https://pandoc.googlecode.com/svn/trunk@549 788f1e2b-df1e-0410-8736-df70ead52e1b

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)
+