@@ -40,8 +40,7 @@ import Text.XHtml.Strict
41type Notes = [Html]
41type Notes = [Html]
42type Ids = [String]
42type Ids = [String]
44−type WriterState = (Notes, Ids, Toc)
43+type WriterState = (Notes, Ids)
46-- | Convert Pandoc document to Html string.
45-- | Convert Pandoc document to Html string.
47writeHtmlString :: WriterOptions -> Pandoc -> String
46writeHtmlString :: WriterOptions -> Pandoc -> String
@@ -54,7 +53,7 @@ writeHtmlString opts =
54writeHtml :: WriterOptions -> Pandoc -> Html
53writeHtml :: WriterOptions -> Pandoc -> Html
55writeHtml opts (Pandoc (Meta tit authors date) blocks) =
54writeHtml opts (Pandoc (Meta tit authors date) blocks) =
56 let titlePrefix = writerTitlePrefix opts
55 let titlePrefix = writerTitlePrefix opts
57− topTitle = evalState (inlineListToHtml opts tit) ([],[],noHtml)
56+ topTitle = evalState (inlineListToHtml opts tit) ([],[])
58 topTitle' = if null titlePrefix
57 topTitle' = if null titlePrefix
59 then topTitle
58 then topTitle
60 else titlePrefix +++ " - " +++ topTitle
59 else titlePrefix +++ " - " +++ topTitle
@@ -74,13 +73,15 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
74 else noHtml
73 else noHtml
75 headerBlocks = filter isHeaderBlock blocks
74 headerBlocks = filter isHeaderBlock blocks
76 ids = uniqueIdentifiers $ map (\(Header _ lst) -> lst) headerBlocks
75 ids = uniqueIdentifiers $ map (\(Header _ lst) -> lst) headerBlocks
76+ toc = if writerTableOfContents opts
77− toc = noHtml -- for debugging: tableOfContents headerBlocks ids
77+ then tableOfContents opts headerBlocks ids
78− (blocks', (revnotes,_,_)) =
79+ (blocks', (revnotes,_)) =
79− runState (blockListToHtml opts blocks) ([],ids,toc)
80+ runState (blockListToHtml opts blocks) ([],ids)
80 notes = reverse revnotes
81 notes = reverse revnotes
81 before = primHtml $ writerIncludeBefore opts
82 before = primHtml $ writerIncludeBefore opts
82 after = primHtml $ writerIncludeAfter opts
83 after = primHtml $ writerIncludeAfter opts
83− thebody = before +++ titleHeader +++ blocks' +++
84+ thebody = before +++ titleHeader +++ toc +++ blocks' +++
84 footnoteSection opts notes +++ after
85 footnoteSection opts notes +++ after
85 in if writerStandalone opts
86 in if writerStandalone opts
86 then head +++ (body thebody)
87 then head +++ (body thebody)
@@ -91,6 +92,33 @@ isHeaderBlock :: Block -> Bool
91isHeaderBlock (Header _ _) = True
92isHeaderBlock (Header _ _) = True
92isHeaderBlock _ = False
93isHeaderBlock _ = False
95+-- | Construct table of contents from list of header blocks and identifiers.
96+-- Assumes there are as many identifiers as header blocks.
97+tableOfContents :: WriterOptions -> [Block] -> Ids -> Html
98+tableOfContents opts headers ids =
99+ let opts' = opts { writerIgnoreNotes = True }
100+ contentsTree = hierarchicalize headers
101+ contents = evalState (mapM (elementToListItem opts') contentsTree)
103+ in unordList ! [identifier "toc"] $ contents
105+-- | Converts an Element to a list item for a table of contents,
106+-- retrieving the appropriate identifier from state.
107+elementToListItem :: WriterOptions -> Element -> State WriterState Html
108+elementToListItem opts (Blk _) = return noHtml
109+elementToListItem opts (Sec headerText subsecs) = do
111+ let (id, rest) = if null ids
113+ else (head ids, tail ids)
115+ txt <- inlineListToHtml opts headerText
116+ subHeads <- mapM (elementToListItem opts) subsecs
117+ let subList = if null subHeads
119+ else unordList subHeads
120+ return $ (anchor ! [href ("#" ++ id)] $ txt) +++ subList
94-- | Convert list of Note blocks to a footnote <div>.
122-- | Convert list of Note blocks to a footnote <div>.
95-- Assumes notes are sorted.
123-- Assumes notes are sorted.
96footnoteSection :: WriterOptions -> Notes -> Html
124footnoteSection :: WriterOptions -> Notes -> Html
@@ -167,12 +195,12 @@ inlineListToIdentifier (x:xs) =
167-- | Return unique identifiers for list of inline lists.
195-- | Return unique identifiers for list of inline lists.
168uniqueIdentifiers :: [[Inline]] -> [String]
196uniqueIdentifiers :: [[Inline]] -> [String]
169uniqueIdentifiers ls =
197uniqueIdentifiers ls =
170− reverse (foldl addIdentifier [] ls) where
198+ let addIdentifier (nonuniqueIds, uniqueIds) l =
171− addIdentifier ids l =
172 let new = inlineListToIdentifier l
199 let new = inlineListToIdentifier l
173− matches = length $ filter (== new) ids
200+ matches = length $ filter (== new) nonuniqueIds
174 new' = new ++ if matches > 0 then show matches else ""
201 new' = new ++ if matches > 0 then show matches else ""
175− in new':ids
202+ in (new:nonuniqueIds, new':uniqueIds)
203+ in reverse $ snd (foldl addIdentifier ([],[]) $ ls)
177-- | Convert Pandoc block element to HTML.
205-- | Convert Pandoc block element to HTML.
178blockToHtml :: WriterOptions -> Block -> State WriterState Html
206blockToHtml :: WriterOptions -> Block -> State WriterState Html
@@ -199,19 +227,25 @@ blockToHtml opts block =
199 (return . blockquote)
227 (return . blockquote)
200 else blockListToHtml opts blocks >>= (return . blockquote)
228 else blockListToHtml opts blocks >>= (return . blockquote)
201 (Header level lst) -> do contents <- inlineListToHtml opts lst
229 (Header level lst) -> do contents <- inlineListToHtml opts lst
202− (notes, ids, toc) <- get
230+ (notes, ids) <- get
203 let (id, rest) = if null ids
231 let (id, rest) = if null ids
204 then ("", [])
232 then ("", [])
205 else (head ids, tail ids)
233 else (head ids, tail ids)
206− put (notes, rest, toc)
234+ put (notes, rest)
235+ let attribs = [identifier id]
207− return $ case level of
236+ let headerHtml = case level of
208− 1 -> h1 contents ! [identifier id]
237+ 1 -> h1 contents ! attribs
209− 2 -> h2 contents ! [identifier id]
238+ 2 -> h2 contents ! attribs
210− 3 -> h3 contents ! [identifier id]
239+ 3 -> h3 contents ! attribs
211− 4 -> h4 contents ! [identifier id]
240+ 4 -> h4 contents ! attribs
212− 5 -> h5 contents ! [identifier id]
241+ 5 -> h5 contents ! attribs
213− 6 -> h6 contents ! [identifier id]
242+ 6 -> h6 contents ! attribs
214− _ -> paragraph contents ! [identifier id]
243+ _ -> paragraph contents ! attribs
244+ let headerHtml' = if writerTableOfContents opts
245+ then anchor ! [href "#toc"] $
215 (BulletList lst) -> do contents <- mapM (blockListToHtml opts) lst
249 (BulletList lst) -> do contents <- mapM (blockListToHtml opts) lst
216 let attribs = if writerIncremental opts
250 let attribs = if writerIncremental opts
217 then [theclass "incremental"]
251 then [theclass "incremental"]
@@ -313,11 +347,11 @@ inlineToHtml opts inline =
313 if null txt then [] else [alt alternate']
347 if null txt then [] else [alt alternate']
314 return $ image ! attributes
348 return $ image ! attributes
315 -- note: null title included, as in Markdown.pl
349 -- note: null title included, as in Markdown.pl
316− (Note contents) -> do (notes, ids, toc) <- get
350+ (Note contents) -> do (notes, ids) <- get
317 let number = (length notes) + 1
351 let number = (length notes) + 1
318 let ref = show number
352 let ref = show number
319 htmlContents <- blockListToNote opts ref contents
353 htmlContents <- blockListToNote opts ref contents
320− put (htmlContents:notes, ids, toc) -- push contents onto front of notes
354+ put (htmlContents:notes, ids) -- push contents onto front of notes
321 return $ anchor ! [href ("#fn" ++ ref),
355 return $ anchor ! [href ("#fn" ++ ref),
322 theclass "footnoteRef",
356 theclass "footnoteRef",
323 identifier ("fnref" ++ ref)] << sup << ref
357 identifier ("fnref" ++ ref)] << sup << ref