From 54a0e4c3b2a518b3fa42c57450869260d02c493c Mon Sep 17 00:00:00 2001 From: fiddlosopher Date: Sat, 7 Jul 2007 19:08:11 +0000 Subject: 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 --- src/Text/Pandoc/Writers/HTML.hs | 80 +++++++++++++++++++++++++++++------------ 1 file changed, 57 insertions(+), 23 deletions(-) (limited to 'src/Text/Pandoc/Writers') 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
. -- 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 -- cgit v1.2.3