@@ -40,7 +40,13 @@ import Text.XHtml.Strict
41type Notes = [Html]
41type Notes = [Html]
42type Ids = [String]
42type Ids = [String]
43+type ForHeader = [Html]
43−type WriterState = (Notes, Ids)
44+type WriterState = (Notes, Ids, ForHeader)
46+-- | Add some Html to be included in the document header.
47+addToHeader :: Html -> State WriterState ()
48+addToHeader item = modify (\(notes, ids, forheader) ->
49+ (notes, ids, item:forheader))
45-- | Convert Pandoc document to Html string.
51-- | Convert Pandoc document to Html string.
46writeHtmlString :: WriterOptions -> Pandoc -> String
52writeHtmlString :: WriterOptions -> Pandoc -> String
@@ -53,11 +59,11 @@ writeHtmlString opts =
53writeHtml :: WriterOptions -> Pandoc -> Html
59writeHtml :: WriterOptions -> Pandoc -> Html
54writeHtml opts (Pandoc (Meta tit authors date) blocks) =
60writeHtml opts (Pandoc (Meta tit authors date) blocks) =
55 let titlePrefix = writerTitlePrefix opts
61 let titlePrefix = writerTitlePrefix opts
56− topTitle = evalState (inlineListToHtml opts tit) ([],[])
62+ topTitle = evalState (inlineListToHtml opts tit) ([],[],[])
57 topTitle' = if null titlePrefix
63 topTitle' = if null titlePrefix
58 then topTitle
64 then topTitle
59 else titlePrefix +++ " - " +++ topTitle
65 else titlePrefix +++ " - " +++ topTitle
60− head = header $ thetitle topTitle' +++
66+ metadata = thetitle topTitle' +++
61 meta ! [httpequiv "Content-Type",
67 meta ! [httpequiv "Content-Type",
62 content "text/html; charset=UTF-8"] +++
68 content "text/html; charset=UTF-8"] +++
63 meta ! [name "generator", content "pandoc"] +++
69 meta ! [name "generator", content "pandoc"] +++
@@ -65,9 +71,7 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
65 map (\a -> meta ! [name "author", content a]) authors) +++
71 map (\a -> meta ! [name "author", content a]) authors) +++
66 (if null date
72 (if null date
67 then noHtml
73 then noHtml
68− else meta ! [name "date", content date]) +++
74+ else meta ! [name "date", content date])
69− (style ! [thetype "text/css"] $ (stringToHtml ".strikeout { text-decoration: line-through; }")) +++
70− primHtml (writerHeader opts)
71 titleHeader = if (writerStandalone opts) && (not (null tit)) &&
75 titleHeader = if (writerStandalone opts) && (not (null tit)) &&
72 (not (writerS5 opts))
76 (not (writerS5 opts))
73 then h1 ! [theclass "title"] $ topTitle
77 then h1 ! [theclass "title"] $ topTitle
@@ -77,8 +81,10 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
77 toc = if writerTableOfContents opts
81 toc = if writerTableOfContents opts
78 then tableOfContents opts headerBlocks ids
82 then tableOfContents opts headerBlocks ids
79 else noHtml
83 else noHtml
80− (blocks', (revnotes,_)) =
84+ (blocks', (revnotes,_,forhead)) =
81− runState (blockListToHtml opts blocks) ([],ids)
85+ runState (blockListToHtml opts blocks) ([],ids,[])
86+ head = header $ metadata +++ toHtmlFromList forhead +++
87+ primHtml (writerHeader opts)
82 notes = reverse revnotes
88 notes = reverse revnotes
83 before = primHtml $ writerIncludeBefore opts
89 before = primHtml $ writerIncludeBefore opts
84 after = primHtml $ writerIncludeAfter opts
90 after = primHtml $ writerIncludeAfter opts
@@ -95,7 +101,7 @@ tableOfContents opts headers ids =
95 let opts' = opts { writerIgnoreNotes = True }
101 let opts' = opts { writerIgnoreNotes = True }
96 contentsTree = hierarchicalize headers
102 contentsTree = hierarchicalize headers
97 contents = evalState (mapM (elementToListItem opts') contentsTree)
103 contents = evalState (mapM (elementToListItem opts') contentsTree)
98− ([],ids)
104+ ([],ids,[])
99 in thediv ! [identifier "toc"] $ unordList contents
105 in thediv ! [identifier "toc"] $ unordList contents
101-- | Converts an Element to a list item for a table of contents,
107-- | Converts an Element to a list item for a table of contents,
@@ -103,11 +109,11 @@ tableOfContents opts headers ids =
103elementToListItem :: WriterOptions -> Element -> State WriterState Html
109elementToListItem :: WriterOptions -> Element -> State WriterState Html
104elementToListItem opts (Blk _) = return noHtml
110elementToListItem opts (Blk _) = return noHtml
105elementToListItem opts (Sec headerText subsecs) = do
111elementToListItem opts (Sec headerText subsecs) = do
106− (notes, ids) <- get
112+ (notes, ids, forhead) <- get
107 let (id, rest) = if null ids
113 let (id, rest) = if null ids
108 then ("",[])
114 then ("",[])
109 else (head ids, tail ids)
115 else (head ids, tail ids)
110− put (notes, rest)
116+ put (notes, rest, forhead)
111 txt <- inlineListToHtml opts headerText
117 txt <- inlineListToHtml opts headerText
112 subHeads <- mapM (elementToListItem opts) subsecs
118 subHeads <- mapM (elementToListItem opts) subsecs
113 let subList = if null subHeads
119 let subList = if null subHeads
@@ -237,11 +243,11 @@ blockToHtml opts block =
237 (return . blockquote)
243 (return . blockquote)
238 else blockListToHtml opts blocks >>= (return . blockquote)
244 else blockListToHtml opts blocks >>= (return . blockquote)
239 (Header level lst) -> do contents <- inlineListToHtml opts lst
245 (Header level lst) -> do contents <- inlineListToHtml opts lst
240− (notes, ids) <- get
246+ (notes, ids, forhead) <- get
241 let (id, rest) = if null ids
247 let (id, rest) = if null ids
242 then ("", [])
248 then ("", [])
243 else (head ids, tail ids)
249 else (head ids, tail ids)
244− put (notes, rest)
250+ put (notes, rest, forhead)
245 let attribs = [identifier id]
251 let attribs = [identifier id]
246 let headerHtml = case level of
252 let headerHtml = case level of
247 1 -> h1 contents ! attribs
253 1 -> h1 contents ! attribs
@@ -331,8 +337,10 @@ inlineToHtml opts inline =
331 (Emph lst) -> inlineListToHtml opts lst >>= (return . emphasize)
337 (Emph lst) -> inlineListToHtml opts lst >>= (return . emphasize)
332 (Strong lst) -> inlineListToHtml opts lst >>= (return . strong)
338 (Strong lst) -> inlineListToHtml opts lst >>= (return . strong)
333 (Code str) -> return $ thecode << str
339 (Code str) -> return $ thecode << str
340+ (Strikeout lst) -> addToHeader (style ! [thetype "text/css"] $ (stringToHtml
341+ ".strikeout { text-decoration: line-through; }")) >>
334− (Strikeout lst) -> inlineListToHtml opts lst >>=
342+ inlineListToHtml opts lst >>=
335− (return . (thespan ! [theclass "strikeout"]))
343+ (return . (thespan ! [theclass "strikeout"]))
336 (Superscript lst) -> inlineListToHtml opts lst >>= (return . sup)
344 (Superscript lst) -> inlineListToHtml opts lst >>= (return . sup)
337 (Subscript lst) -> inlineListToHtml opts lst >>= (return . sub)
345 (Subscript lst) -> inlineListToHtml opts lst >>= (return . sub)
338 (Quoted quoteType lst) ->
346 (Quoted quoteType lst) ->
@@ -361,11 +369,11 @@ inlineToHtml opts inline =
361 if null txt then [] else [alt alternate']
369 if null txt then [] else [alt alternate']
362 return $ image ! attributes
370 return $ image ! attributes
363 -- note: null title included, as in Markdown.pl
371 -- note: null title included, as in Markdown.pl
364− (Note contents) -> do (notes, ids) <- get
372+ (Note contents) -> do (notes, ids, forhead) <- get
365 let number = (length notes) + 1
373 let number = (length notes) + 1
366 let ref = show number
374 let ref = show number
367 htmlContents <- blockListToNote opts ref contents
375 htmlContents <- blockListToNote opts ref contents
368− put (htmlContents:notes, ids) -- push contents onto front of notes
376+ put (htmlContents:notes, ids, forhead) -- push contents onto front of notes
369 return $ anchor ! [href ("#fn" ++ ref),
377 return $ anchor ! [href ("#fn" ++ ref),
370 theclass "footnoteRef",
378 theclass "footnoteRef",
371 identifier ("fnref" ++ ref)] << sup << ref
379 identifier ("fnref" ++ ref)] << sup << ref