HTML writer modifications:

+ Added code to HTML Writer to generate a table of contents if the
  writerTableOfContents option is specified.  This is an unordered list
  with links to the headers.  It is constructed hierarchically, based on
  the order of the headers and their levels.
+ If a TOC is used, the headers become links back to the TOC.
+ Removed Toc from WriterState; instead, the TOC is generated at the top
  level, by the function tableOfContents.
+ Fixed a bug in uniqueIdentifiers which prevented it from handling more than
  one duplicate.


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

1 files changed, 57 insertions, 23 deletions

diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index 15286b0ea..5dcca4825 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -40,8 +40,7 @@ import Text.XHtml.Strict
 
 type Notes = [Html]
 type Ids = [String]
-type Toc = Html
-type WriterState = (Notes, Ids, Toc)
+type WriterState = (Notes, Ids)
 
 -- | Convert Pandoc document to Html string.
 writeHtmlString :: WriterOptions -> Pandoc -> String
@@ -54,7 +53,7 @@ writeHtmlString opts =
 writeHtml :: WriterOptions -> Pandoc -> Html
 writeHtml opts (Pandoc (Meta tit authors date) blocks) = 
   let titlePrefix = writerTitlePrefix opts
-      topTitle    = evalState (inlineListToHtml opts tit) ([],[],noHtml)
+      topTitle    = evalState (inlineListToHtml opts tit) ([],[])
       topTitle'   = if null titlePrefix
                         then topTitle
                         else titlePrefix +++ " - " +++ topTitle
@@ -74,13 +73,15 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
                         else noHtml
       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)
+      toc = if writerTableOfContents opts 
+               then tableOfContents opts headerBlocks ids
+               else noHtml
+      (blocks', (revnotes,_)) = 
+                    runState (blockListToHtml opts blocks) ([],ids)
       notes       = reverse revnotes
       before      = primHtml $ writerIncludeBefore opts
       after       = primHtml $ writerIncludeAfter opts
-      thebody     = before +++ titleHeader +++ blocks' +++
+      thebody     = before +++ titleHeader +++ toc +++ blocks' +++
                     footnoteSection opts notes +++ after
   in  if writerStandalone opts
          then head +++ (body thebody)
@@ -91,6 +92,33 @@ isHeaderBlock :: Block -> Bool
 isHeaderBlock (Header _ _) = True
 isHeaderBlock _ = False
 
+-- | Construct table of contents from list of header blocks and identifiers.
+-- Assumes there are as many identifiers as header blocks.
+tableOfContents :: WriterOptions -> [Block] -> Ids -> Html
+tableOfContents opts headers ids =
+  let opts' = opts { writerIgnoreNotes = True }
+      contentsTree = hierarchicalize headers
+      contents = evalState (mapM (elementToListItem opts') contentsTree) 
+                 ([],ids)
+  in  unordList ! [identifier "toc"] $ contents
+
+-- | Converts an Element to a list item for a table of contents,
+-- retrieving the appropriate identifier from state.
+elementToListItem :: WriterOptions -> Element -> State WriterState Html
+elementToListItem opts (Blk _) = return noHtml
+elementToListItem opts (Sec headerText subsecs) = do
+  (notes, ids) <- get
+  let (id, rest) = if null ids
+                      then ("",[])
+                      else (head ids, tail ids)
+  put (notes, rest)
+  txt <- inlineListToHtml opts headerText
+  subHeads <- mapM (elementToListItem opts) subsecs
+  let subList = if null subHeads
+                   then noHtml
+                   else unordList subHeads 
+  return $ (anchor ! [href ("#" ++ id)] $ txt) +++ subList
+
 -- | Convert list of Note blocks to a footnote <div>.
 -- Assumes notes are sorted.
 footnoteSection :: WriterOptions -> Notes -> Html
@@ -167,12 +195,12 @@ inlineListToIdentifier (x:xs) =
 -- | Return unique identifiers for list of inline lists.
 uniqueIdentifiers :: [[Inline]] -> [String]
 uniqueIdentifiers ls =
-  reverse (foldl addIdentifier [] ls) where
-  addIdentifier ids l =
+  let addIdentifier (nonuniqueIds, uniqueIds) l =
         let new = inlineListToIdentifier l
-            matches = length $ filter (== new) ids
+            matches = length $ filter (== new) nonuniqueIds
             new' = new ++ if matches > 0 then show matches else ""
-        in  new':ids
+        in  (new:nonuniqueIds, new':uniqueIds)
+  in  reverse $ snd (foldl addIdentifier ([],[]) $ ls)
 
 -- | Convert Pandoc block element to HTML.
 blockToHtml :: WriterOptions -> Block -> State WriterState Html
@@ -199,19 +227,25 @@ blockToHtml opts block =
                                        (return . blockquote)
           else blockListToHtml opts blocks >>= (return . blockquote)
     (Header level lst) -> do contents <- inlineListToHtml opts lst
-                             (notes, ids, toc) <- get
+                             (notes, ids) <- get
                              let (id, rest) = if null ids
                                                  then ("", [])
                                                  else (head ids, tail ids)
-                             put (notes, rest, toc)
-                             return $  case level of
-                                         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]
+                             put (notes, rest)
+                             let attribs = [identifier id]
+                             let headerHtml = case level of
+                                         1 -> h1 contents ! attribs
+                                         2 -> h2 contents ! attribs
+                                         3 -> h3 contents ! attribs
+                                         4 -> h4 contents ! attribs
+                                         5 -> h5 contents ! attribs
+                                         6 -> h6 contents ! attribs
+                                         _ -> paragraph contents ! attribs
+                             let headerHtml' = if writerTableOfContents opts
+                                                  then anchor ! [href "#toc"] $
+                                                       headerHtml
+                                                  else headerHtml
+                             return headerHtml'
     (BulletList lst)   -> do contents <- mapM (blockListToHtml opts) lst
                              let attribs = if writerIncremental opts
                                               then [theclass "incremental"]
@@ -313,11 +347,11 @@ 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, ids, toc) <- get
+    (Note contents)  -> do (notes, ids) <- get
                            let number = (length notes) + 1
                            let ref = show number
                            htmlContents <- blockListToNote opts ref contents 
-                           put (htmlContents:notes, ids, toc) -- push contents onto front of notes
+                           put (htmlContents:notes, ids) -- push contents onto front of notes
                            return $ anchor ! [href ("#fn" ++ ref),
                                               theclass "footnoteRef",
                                               identifier ("fnref" ++ ref)] << sup << ref