Changes to HTML writer to incorporate automatic identifiers for

headers and table of contents:
+ WriterState now includes a list of header identifiers and a table
  of contents in addition to notes.
+ The function uniqueIdentifiers creates a list of unique identifiers
  from a list of inline lists (e.g. headers).
+ This list is part of WriterState and gets consumed by blockToHtml
  each time a header is encountered.
+ Headers are now printed with unique identifiers based on their names,
  e.g. Shell_scripts for "# Shell scripts".  Fancy stuff like links,
  italics, etc. gets ignored.  A numerical index is added to the end if
  there is already an identifier by the same name, e.g. "Shell_scripts1".
+ Provision has been made for a table-of-contents block element, but this
  has not yet been added.


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

1 files changed, 66 insertions, 16 deletions

diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index f6fc0741e..15286b0ea 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -39,6 +39,9 @@ import Control.Monad.State
 import Text.XHtml.Strict
 
 type Notes = [Html]
+type Ids = [String]
+type Toc = Html
+type WriterState = (Notes, Ids, Toc)
 
 -- | Convert Pandoc document to Html string.
 writeHtmlString :: WriterOptions -> Pandoc -> String
@@ -51,7 +54,7 @@ writeHtmlString opts =
 writeHtml :: WriterOptions -> Pandoc -> Html
 writeHtml opts (Pandoc (Meta tit authors date) blocks) = 
   let titlePrefix = writerTitlePrefix opts
-      topTitle    = evalState (inlineListToHtml opts tit) []
+      topTitle    = evalState (inlineListToHtml opts tit) ([],[],noHtml)
       topTitle'   = if null titlePrefix
                         then topTitle
                         else titlePrefix +++ " - " +++ topTitle
@@ -69,7 +72,11 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
                     (not (writerS5 opts))
                         then h1 ! [theclass "title"] $ topTitle
                         else noHtml
-      (blocks', revnotes) = runState (blockListToHtml opts blocks) []
+      headerBlocks = filter isHeaderBlock blocks
+      ids = uniqueIdentifiers $ map (\(Header _ lst) -> lst) headerBlocks
+      toc = noHtml -- for debugging: tableOfContents headerBlocks ids
+      (blocks', (revnotes,_,_)) = 
+                    runState (blockListToHtml opts blocks) ([],ids,toc)
       notes       = reverse revnotes
       before      = primHtml $ writerIncludeBefore opts
       after       = primHtml $ writerIncludeAfter opts
@@ -79,6 +86,11 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
          then head +++ (body thebody)
          else thebody
 
+-- | True if block is a Header block.
+isHeaderBlock :: Block -> Bool
+isHeaderBlock (Header _ _) = True
+isHeaderBlock _ = False
+
 -- | Convert list of Note blocks to a footnote <div>.
 -- Assumes notes are sorted.
 footnoteSection :: WriterOptions -> Notes -> Html
@@ -129,8 +141,41 @@ obfuscateChar char =
 obfuscateString :: String -> String
 obfuscateString = (concatMap obfuscateChar) . decodeEntities
 
+-- | Convert Pandoc inline list to plain text identifier.
+inlineListToIdentifier :: [Inline] -> String
+inlineListToIdentifier [] = ""
+inlineListToIdentifier (x:xs) = 
+  xAsText ++ inlineListToIdentifier xs
+  where xAsText = case x of
+                       Str s        -> s
+                       Emph lst     -> inlineListToIdentifier lst
+                       Strong lst   -> inlineListToIdentifier lst
+                       Quoted _ lst -> inlineListToIdentifier lst
+                       Code s       -> s
+                       Space        -> "_"
+                       EmDash       -> "--"
+                       EnDash       -> "-"
+                       Apostrophe   -> ""
+                       Ellipses     -> "..."
+                       LineBreak    -> "_"
+                       TeX _        -> ""
+                       HtmlInline _ -> ""
+                       Link lst _   -> inlineListToIdentifier lst
+                       Image lst _  -> inlineListToIdentifier lst
+                       Note _       -> ""
+
+-- | Return unique identifiers for list of inline lists.
+uniqueIdentifiers :: [[Inline]] -> [String]
+uniqueIdentifiers ls =
+  reverse (foldl addIdentifier [] ls) where
+  addIdentifier ids l =
+        let new = inlineListToIdentifier l
+            matches = length $ filter (== new) ids
+            new' = new ++ if matches > 0 then show matches else ""
+        in  new':ids
+
 -- | Convert Pandoc block element to HTML.
-blockToHtml :: WriterOptions -> Block -> State Notes Html
+blockToHtml :: WriterOptions -> Block -> State WriterState Html
 blockToHtml opts block = 
   case block of
     (Null)            -> return $ noHtml
@@ -154,14 +199,19 @@ blockToHtml opts block =
                                        (return . blockquote)
           else blockListToHtml opts blocks >>= (return . blockquote)
     (Header level lst) -> do contents <- inlineListToHtml opts lst
+                             (notes, ids, toc) <- get
+                             let (id, rest) = if null ids
+                                                 then ("", [])
+                                                 else (head ids, tail ids)
+                             put (notes, rest, toc)
                              return $  case level of
-                                         1 -> h1 contents
-                                         2 -> h2 contents
-                                         3 -> h3 contents
-                                         4 -> h4 contents
-                                         5 -> h5 contents
-                                         6 -> h6 contents
-                                         _ -> paragraph contents
+                                         1 -> h1 contents ! [identifier id]
+                                         2 -> h2 contents ! [identifier id]
+                                         3 -> h3 contents ! [identifier id]
+                                         4 -> h4 contents ! [identifier id]
+                                         5 -> h5 contents ! [identifier id]
+                                         6 -> h6 contents ! [identifier id]
+                                         _ -> paragraph contents ! [identifier id]
     (BulletList lst)   -> do contents <- mapM (blockListToHtml opts) lst
                              let attribs = if writerIncremental opts
                                               then [theclass "incremental"]
@@ -216,15 +266,15 @@ tableItemToHtml opts tag align' width item =
                     else [] 
      return $ tag ! attrib $ contents
 
-blockListToHtml :: WriterOptions -> [Block] -> State Notes Html
+blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html
 blockListToHtml opts lst = mapM (blockToHtml opts) lst >>= (return . toHtmlFromList)
 
 -- | Convert list of Pandoc inline elements to HTML.
-inlineListToHtml :: WriterOptions -> [Inline] -> State Notes Html
+inlineListToHtml :: WriterOptions -> [Inline] -> State WriterState Html
 inlineListToHtml opts lst = mapM (inlineToHtml opts) lst >>= (return . toHtmlFromList)
 
 -- | Convert Pandoc inline element to HTML.
-inlineToHtml :: WriterOptions -> Inline -> State Notes Html
+inlineToHtml :: WriterOptions -> Inline -> State WriterState Html
 inlineToHtml opts inline =
   case inline of  
     (Str str)        -> return $ stringToHtml str
@@ -263,16 +313,16 @@ inlineToHtml opts inline =
                                             if null txt then [] else [alt alternate']
                            return $ image ! attributes 
                            -- note:  null title included, as in Markdown.pl 
-    (Note contents)  -> do notes <- get
+    (Note contents)  -> do (notes, ids, toc) <- get
                            let number = (length notes) + 1
                            let ref = show number
                            htmlContents <- blockListToNote opts ref contents 
-                           modify (htmlContents:) -- push contents onto front of notes
+                           put (htmlContents:notes, ids, toc) -- push contents onto front of notes
                            return $ anchor ! [href ("#fn" ++ ref),
                                               theclass "footnoteRef",
                                               identifier ("fnref" ++ ref)] << sup << ref
 
-blockListToNote :: WriterOptions -> String -> [Block] -> State Notes Html
+blockListToNote :: WriterOptions -> String -> [Block] -> State WriterState Html
 blockListToNote opts ref blocks =
   do contents <- blockListToHtml opts blocks
      let backlink = anchor ! [href ("#fnref" ++ ref), theclass "footnoteBacklink",