Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Code cleanup in HTML writer to eliminate -Wall warnings.

Browse source 
git-svn-id: https://pandoc.googlecode.com/svn/trunk@1308 788f1e2b-df1e-0410-8736-df70ead52e1b
This commit is contained in:
fiddlosopher 2008-07-13 17:08:55 +00:00
parent a76b920f03
commit b973bc9e3e
1 changed files with 72 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

123
Text/Pandoc/Writers/HTML.hs
View file

@ -36,7 +36,7 @@ import Text.Pandoc.Readers.TeXMath
import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss ) import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss )
import Numeric ( showHex ) import Numeric ( showHex )
import Data.Char ( ord, toLower, isAlpha ) import Data.Char ( ord, toLower, isAlpha )
import Data.List ( isPrefixOf, intersperse, find ) import Data.List ( isPrefixOf, intersperse )
import qualified Data.Set as S import qualified Data.Set as S
import Control.Monad.State import Control.Monad.State
import Text.XHtml.Transitional import Text.XHtml.Transitional
@ -53,7 +53,11 @@ defaultWriterState = WriterState {stNotes= [], stIds = [],
stMath = False, stCSS = S.empty} stMath = False, stCSS = S.empty}
-- Helpers to render HTML with the appropriate function. -- Helpers to render HTML with the appropriate function.
render opts = if writerWrapText opts then renderHtml else showHtml
render :: (HTML html) => WriterOptions -> html -> String
render opts = if writerWrapText opts then renderHtml else showHtml
renderFragment :: (HTML html) => WriterOptions -> html -> String
renderFragment opts = if writerWrapText opts renderFragment opts = if writerWrapText opts
then renderHtmlFragment then renderHtmlFragment
else showHtmlFragment else showHtmlFragment
@ -112,15 +116,15 @@ writeHtml opts (Pandoc (Meta tit authors date) blocks) =
noHtml noHtml
_ -> noHtml _ -> noHtml
else noHtml else noHtml
head = header $ metadata +++ math +++ css +++ head' = header $ metadata +++ math +++ css +++
primHtml (writerHeader opts) primHtml (writerHeader opts)
notes = reverse (stNotes newstate) notes = reverse (stNotes newstate)
before = primHtml $ writerIncludeBefore opts before = primHtml $ writerIncludeBefore opts
after = primHtml $ writerIncludeAfter opts after = primHtml $ writerIncludeAfter opts
thebody = before +++ titleHeader +++ toc +++ blocks' +++ thebody = before +++ titleHeader +++ toc +++ blocks' +++
footnoteSection opts notes +++ after footnoteSection notes +++ after
in if writerStandalone opts in if writerStandalone opts
then head +++ body thebody then head' +++ body thebody
else thebody else thebody
-- | Construct table of contents from list of header blocks and identifiers. -- | Construct table of contents from list of header blocks and identifiers.
@ -137,11 +141,11 @@ tableOfContents opts headers ids =
-- | Converts an Element to a list item for a table of contents, -- | Converts an Element to a list item for a table of contents,
-- retrieving the appropriate identifier from state. -- retrieving the appropriate identifier from state.
elementToListItem :: WriterOptions -> Element -> State WriterState Html elementToListItem :: WriterOptions -> Element -> State WriterState Html
elementToListItem opts (Blk _) = return noHtml elementToListItem _ (Blk _) = return noHtml
elementToListItem opts (Sec headerText subsecs) = do elementToListItem opts (Sec headerText subsecs) = do
st <- get st <- get
let ids = stIds st let ids = stIds st
let (id, rest) = if null ids let (id', rest) = if null ids
then ("", []) then ("", [])
else (head ids, tail ids) else (head ids, tail ids)
put $ st {stIds = rest} put $ st {stIds = rest}
@ -150,13 +154,13 @@ elementToListItem opts (Sec headerText subsecs) = do
let subList = if null subHeads let subList = if null subHeads
then noHtml then noHtml
else unordList subHeads else unordList subHeads
return $ (anchor ! [href ("#" ++ id), identifier ("TOC-" ++ id)] $ txt) +++ return $ (anchor ! [href ("#" ++ id'), identifier ("TOC-" ++ id')] $ txt) +++
subList subList
-- | Convert list of Note blocks to a footnote <div>. -- | Convert list of Note blocks to a footnote <div>.
-- Assumes notes are sorted. -- Assumes notes are sorted.
footnoteSection :: WriterOptions -> [Html] -> Html footnoteSection :: [Html] -> Html
footnoteSection opts notes = footnoteSection notes =
if null notes if null notes
then noHtml then noHtml
else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes) else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes)
@ -164,37 +168,37 @@ footnoteSection opts notes =
-- | Parse a mailto link; return Just (name, domain) or Nothing. -- | Parse a mailto link; return Just (name, domain) or Nothing.
parseMailto :: String -> Maybe (String, String) parseMailto :: String -> Maybe (String, String)
parseMailto ('m':'a':'i':'l':'t':'o':':':address) = parseMailto ('m':'a':'i':'l':'t':'o':':':addr) =
let (name, rest) = span (/='@') address let (name', rest) = span (/='@') addr
domain = drop 1 rest domain = drop 1 rest
in Just (name, domain) in Just (name', domain)
parseMailto _ = Nothing parseMailto _ = Nothing
-- | Obfuscate a "mailto:" link using Javascript. -- | Obfuscate a "mailto:" link using Javascript.
obfuscateLink :: WriterOptions -> String -> String -> Html obfuscateLink :: WriterOptions -> String -> String -> Html
obfuscateLink opts text src = obfuscateLink opts txt s =
let src' = map toLower src let s' = map toLower s
in case parseMailto src' of in case parseMailto s' of
(Just (name, domain)) -> (Just (name', domain)) ->
let domain' = substitute "." " dot " domain let domain' = substitute "." " dot " domain
at' = obfuscateChar '@' at' = obfuscateChar '@'
(linkText, altText) = (linkText, altText) =
if text == drop 7 src' -- autolink if txt == drop 7 s' -- autolink
then ("'<code>'+e+'</code>'", name ++ " at " ++ domain') then ("'<code>'+e+'</code>'", name' ++ " at " ++ domain')
else ("'" ++ text ++ "'", text ++ " (" ++ name ++ " at " ++ else ("'" ++ txt ++ "'", txt ++ " (" ++ name' ++ " at " ++
domain' ++ ")") domain' ++ ")")
in if writerStrictMarkdown opts in if writerStrictMarkdown opts
then -- need to use primHtml or &'s are escaped to &amp; in URL then -- need to use primHtml or &'s are escaped to &amp; in URL
primHtml $ "<a href=\"" ++ (obfuscateString src') primHtml $ "<a href=\"" ++ (obfuscateString s')
++ "\">" ++ (obfuscateString text) ++ "</a>" ++ "\">" ++ (obfuscateString txt) ++ "</a>"
else (script ! [thetype "text/javascript"] $ else (script ! [thetype "text/javascript"] $
primHtml ("\n<!--\nh='" ++ primHtml ("\n<!--\nh='" ++
obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++ obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++
obfuscateString name ++ "';e=n+a+h;\n" ++ obfuscateString name' ++ "';e=n+a+h;\n" ++
"document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++ "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++
linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++ linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++
noscript (primHtml $ obfuscateString altText) noscript (primHtml $ obfuscateString altText)
_ -> anchor ! [href src] $ primHtml text -- malformed email _ -> anchor ! [href s] $ primHtml txt -- malformed email
-- | Obfuscate character as entity. -- | Obfuscate character as entity.
obfuscateChar :: Char -> String obfuscateChar :: Char -> String
@ -227,6 +231,7 @@ addToCSS item = do
inlineListToIdentifier :: [Inline] -> String inlineListToIdentifier :: [Inline] -> String
inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier' inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier'
inlineListToIdentifier' :: [Inline] -> [Char]
inlineListToIdentifier' [] = "" inlineListToIdentifier' [] = ""
inlineListToIdentifier' (x:xs) = inlineListToIdentifier' (x:xs) =
xAsText ++ inlineListToIdentifier' xs xAsText ++ inlineListToIdentifier' xs
@ -266,12 +271,12 @@ uniqueIdentifiers ls =
-- | Convert Pandoc block element to HTML. -- | Convert Pandoc block element to HTML.
blockToHtml :: WriterOptions -> Block -> State WriterState Html blockToHtml :: WriterOptions -> Block -> State WriterState Html
blockToHtml opts Null = return $ noHtml blockToHtml _ Null = return $ noHtml
blockToHtml opts (Plain lst) = inlineListToHtml opts lst blockToHtml opts (Plain lst) = inlineListToHtml opts lst
blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph) blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph)
blockToHtml opts (RawHtml str) = return $ primHtml str blockToHtml _ (RawHtml str) = return $ primHtml str
blockToHtml opts (HorizontalRule) = return $ hr blockToHtml _ (HorizontalRule) = return $ hr
blockToHtml opts (CodeBlock attr@(_,classes,_) rawCode) = do blockToHtml _ (CodeBlock attr@(_,classes,_) rawCode) = do
case highlightHtml attr rawCode of case highlightHtml attr rawCode of
Left _ -> -- change leading newlines into <br /> tags, because some Left _ -> -- change leading newlines into <br /> tags, because some
-- browsers ignore leading newlines in pre blocks -- browsers ignore leading newlines in pre blocks
@ -294,22 +299,22 @@ blockToHtml opts (BlockQuote blocks) =
[OrderedList attribs lst] -> [OrderedList attribs lst] ->
blockToHtml (opts {writerIncremental = inc}) blockToHtml (opts {writerIncremental = inc})
(OrderedList attribs lst) (OrderedList attribs lst)
otherwise -> blockListToHtml opts blocks >>= _ -> blockListToHtml opts blocks >>=
(return . blockquote) (return . blockquote)
else blockListToHtml opts blocks >>= (return . blockquote) else blockListToHtml opts blocks >>= (return . blockquote)
blockToHtml opts (Header level lst) = do blockToHtml opts (Header level lst) = do
contents <- inlineListToHtml opts lst contents <- inlineListToHtml opts lst
st <- get st <- get
let ids = stIds st let ids = stIds st
let (id, rest) = if null ids let (id', rest) = if null ids
then ("", []) then ("", [])
else (head ids, tail ids) else (head ids, tail ids)
put $ st {stIds = rest} put $ st {stIds = rest}
let attribs = if writerStrictMarkdown opts && not (writerTableOfContents opts) let attribs = if writerStrictMarkdown opts && not (writerTableOfContents opts)
then [] then []
else [identifier id] else [identifier id']
let contents' = if writerTableOfContents opts let contents' = if writerTableOfContents opts
then anchor ! [href ("#TOC-" ++ id)] $ contents then anchor ! [href ("#TOC-" ++ id')] $ contents
else contents else contents
return $ case level of return $ case level of
1 -> h1 contents' ! attribs 1 -> h1 contents' ! attribs
@ -346,40 +351,56 @@ blockToHtml opts (DefinitionList lst) = do
then [theclass "incremental"] then [theclass "incremental"]
else [] else []
return $ defList ! attribs $ contents return $ defList ! attribs $ contents
blockToHtml opts (Table capt aligns widths headers rows) = do blockToHtml opts (Table capt aligns widths headers rows') = do
let alignStrings = map alignmentToString aligns let alignStrings = map alignmentToString aligns
captionDoc <- if null capt captionDoc <- if null capt
then return noHtml then return noHtml
else inlineListToHtml opts capt >>= return . caption else inlineListToHtml opts capt >>= return . caption
colHeads <- colHeadsToHtml opts alignStrings colHeads <- colHeadsToHtml opts alignStrings
widths headers widths headers
rows' <- mapM (tableRowToHtml opts alignStrings) rows rows'' <- mapM (tableRowToHtml opts alignStrings) rows'
return $ table $ captionDoc +++ colHeads +++ rows' return $ table $ captionDoc +++ colHeads +++ rows''
colHeadsToHtml :: WriterOptions
-> [[Char]]
-> [Float]
-> [[Block]]
-> State WriterState Html
colHeadsToHtml opts alignStrings widths headers = do colHeadsToHtml opts alignStrings widths headers = do
heads <- sequence $ zipWith3 heads <- sequence $ zipWith3
(\align width item -> tableItemToHtml opts th align width item) (\alignment columnwidth item -> tableItemToHtml opts th alignment columnwidth item)
alignStrings widths headers alignStrings widths headers
return $ tr $ toHtmlFromList heads return $ tr $ toHtmlFromList heads
alignmentToString :: Alignment -> [Char]
alignmentToString alignment = case alignment of alignmentToString alignment = case alignment of
AlignLeft -> "left" AlignLeft -> "left"
AlignRight -> "right" AlignRight -> "right"
AlignCenter -> "center" AlignCenter -> "center"
AlignDefault -> "left" AlignDefault -> "left"
tableRowToHtml opts aligns cols = tableRowToHtml :: WriterOptions
(sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) cols) >>= -> [[Char]]
-> [[Block]]
-> State WriterState Html
tableRowToHtml opts aligns columns =
(sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) columns) >>=
return . tr . toHtmlFromList return . tr . toHtmlFromList
tableItemToHtml opts tag align' width item = do tableItemToHtml :: WriterOptions
-> (Html -> Html)
-> [Char]
-> Float
-> [Block]
-> State WriterState Html
tableItemToHtml opts tag' align' width' item = do
contents <- blockListToHtml opts item contents <- blockListToHtml opts item
let attrib = [align align'] ++ let attrib = [align align'] ++
if width /= 0 if width' /= 0
then [thestyle ("width: " ++ show (truncate (100*width)) ++ then [thestyle ("width: " ++ show (truncate (100*width')) ++
"%;")] "%;")]
else [] else []
return $ tag ! attrib $ contents return $ tag' ! attrib $ contents
blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html
blockListToHtml opts lst = blockListToHtml opts lst =
@ -428,22 +449,22 @@ inlineToHtml opts inline =
PlainMath -> PlainMath ->
inlineListToHtml opts (readTeXMath str) >>= inlineListToHtml opts (readTeXMath str) >>=
return . (thespan ! [theclass "math"])) return . (thespan ! [theclass "math"]))
(TeX str) -> return noHtml (TeX _) -> return noHtml
(HtmlInline str) -> return $ primHtml str (HtmlInline str) -> return $ primHtml str
(Link [Code str] (src,tit)) | "mailto:" `isPrefixOf` src -> (Link [Code str] (s,_)) | "mailto:" `isPrefixOf` s ->
return $ obfuscateLink opts str src return $ obfuscateLink opts str s
(Link txt (src,tit)) | "mailto:" `isPrefixOf` src -> do (Link txt (s,_)) | "mailto:" `isPrefixOf` s -> do
linkText <- inlineListToHtml opts txt linkText <- inlineListToHtml opts txt
return $ obfuscateLink opts (show linkText) src return $ obfuscateLink opts (show linkText) s
(Link txt (src,tit)) -> do (Link txt (s,tit)) -> do
linkText <- inlineListToHtml opts txt linkText <- inlineListToHtml opts txt
return $ anchor ! ([href src] ++ return $ anchor ! ([href s] ++
if null tit then [] else [title tit]) $ if null tit then [] else [title tit]) $
linkText linkText
(Image txt (source,tit)) -> do (Image txt (s,tit)) -> do
alternate <- inlineListToHtml opts txt alternate <- inlineListToHtml opts txt
let alternate' = renderFragment opts alternate let alternate' = renderFragment opts alternate
let attributes = [src source] ++ let attributes = [src s] ++
(if null tit (if null tit
then [] then []
else [title tit]) ++ else [title tit]) ++