2008-08-01 21:00:50 +00:00
|
|
|
|
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
2007-11-03 23:27:58 +00:00
|
|
|
|
{-
|
2010-03-23 13:31:09 -07:00
|
|
|
|
Copyright (C) 2006-2010 John MacFarlane <jgm@berkeley.edu>
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
|
|
|
it under the terms of the GNU General Public License as published by
|
|
|
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
|
|
|
(at your option) any later version.
|
|
|
|
|
|
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
|
along with this program; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
|
-}
|
|
|
|
|
|
|
|
|
|
{- |
|
|
|
|
|
Module : Text.Pandoc.Writers.HTML
|
2010-03-23 13:31:09 -07:00
|
|
|
|
Copyright : Copyright (C) 2006-2010 John MacFarlane
|
2007-11-03 23:27:58 +00:00
|
|
|
|
License : GNU GPL, version 2 or above
|
|
|
|
|
|
|
|
|
|
Maintainer : John MacFarlane <jgm@berkeley.edu>
|
|
|
|
|
Stability : alpha
|
|
|
|
|
Portability : portable
|
|
|
|
|
|
|
|
|
|
Conversion of 'Pandoc' documents to HTML.
|
|
|
|
|
-}
|
|
|
|
|
module Text.Pandoc.Writers.HTML ( writeHtml , writeHtmlString ) where
|
|
|
|
|
import Text.Pandoc.Definition
|
|
|
|
|
import Text.Pandoc.CharacterReferences ( decodeCharacterReferences )
|
|
|
|
|
import Text.Pandoc.Shared
|
2009-12-31 01:08:46 +00:00
|
|
|
|
import Text.Pandoc.Templates
|
2007-12-02 00:36:32 +00:00
|
|
|
|
import Text.Pandoc.Readers.TeXMath
|
2010-07-16 00:23:13 -07:00
|
|
|
|
import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss )
|
2010-01-01 04:11:54 +00:00
|
|
|
|
import Text.Pandoc.XML (stripTags, escapeStringForXML)
|
2010-07-15 19:01:00 -07:00
|
|
|
|
import Network.HTTP ( urlEncode )
|
2007-11-03 23:27:58 +00:00
|
|
|
|
import Numeric ( showHex )
|
2009-04-25 00:29:58 +00:00
|
|
|
|
import Data.Char ( ord, toLower )
|
2009-12-31 01:15:42 +00:00
|
|
|
|
import Data.List ( isPrefixOf, intersperse )
|
2009-04-25 00:29:58 +00:00
|
|
|
|
import Data.Maybe ( catMaybes )
|
2007-11-03 23:27:58 +00:00
|
|
|
|
import Control.Monad.State
|
2008-07-27 03:54:07 +00:00
|
|
|
|
import Text.XHtml.Transitional hiding ( stringToHtml )
|
2010-03-18 06:45:56 +00:00
|
|
|
|
import Text.TeXMath
|
|
|
|
|
import Text.XML.Light.Output
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
data WriterState = WriterState
|
2009-12-31 01:13:26 +00:00
|
|
|
|
{ stNotes :: [Html] -- ^ List of notes
|
|
|
|
|
, stMath :: Bool -- ^ Math is used in document
|
|
|
|
|
, stHighlighting :: Bool -- ^ Syntax highlighting is used
|
|
|
|
|
, stSecNum :: [Int] -- ^ Number of current section
|
2007-11-03 23:27:58 +00:00
|
|
|
|
} deriving Show
|
|
|
|
|
|
|
|
|
|
defaultWriterState :: WriterState
|
2009-12-31 01:13:26 +00:00
|
|
|
|
defaultWriterState = WriterState {stNotes= [], stMath = False, stHighlighting = False, stSecNum = []}
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
-- Helpers to render HTML with the appropriate function.
|
2008-07-13 17:08:55 +00:00
|
|
|
|
|
|
|
|
|
renderFragment :: (HTML html) => WriterOptions -> html -> String
|
2007-11-03 23:27:58 +00:00
|
|
|
|
renderFragment opts = if writerWrapText opts
|
|
|
|
|
then renderHtmlFragment
|
|
|
|
|
else showHtmlFragment
|
|
|
|
|
|
2010-01-01 04:11:48 +00:00
|
|
|
|
-- | Modified version of Text.XHtml's stringToHtml.
|
|
|
|
|
-- Use unicode characters wherever possible.
|
2008-07-27 03:54:07 +00:00
|
|
|
|
stringToHtml :: String -> Html
|
2010-01-01 04:11:54 +00:00
|
|
|
|
stringToHtml = primHtml . escapeStringForXML
|
2008-07-27 03:54:07 +00:00
|
|
|
|
|
2007-11-03 23:27:58 +00:00
|
|
|
|
-- | Convert Pandoc document to Html string.
|
|
|
|
|
writeHtmlString :: WriterOptions -> Pandoc -> String
|
2009-12-31 01:13:26 +00:00
|
|
|
|
writeHtmlString opts d =
|
|
|
|
|
let (tit, auths, date, toc, body', newvars) = evalState (pandocToHtml opts d)
|
|
|
|
|
defaultWriterState
|
|
|
|
|
in if writerStandalone opts
|
|
|
|
|
then inTemplate opts tit auths date toc body' newvars
|
|
|
|
|
else renderFragment opts body'
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
-- | Convert Pandoc document to Html structure.
|
|
|
|
|
writeHtml :: WriterOptions -> Pandoc -> Html
|
2009-12-31 01:13:26 +00:00
|
|
|
|
writeHtml opts d =
|
|
|
|
|
let (tit, auths, date, toc, body', newvars) = evalState (pandocToHtml opts d)
|
|
|
|
|
defaultWriterState
|
|
|
|
|
in if writerStandalone opts
|
2009-12-31 01:14:35 +00:00
|
|
|
|
then inTemplate opts tit auths date toc body' newvars
|
2009-12-31 01:13:26 +00:00
|
|
|
|
else body'
|
|
|
|
|
|
|
|
|
|
-- result is (title, authors, date, toc, body, new variables)
|
|
|
|
|
pandocToHtml :: WriterOptions
|
|
|
|
|
-> Pandoc
|
2010-03-20 17:14:18 +00:00
|
|
|
|
-> State WriterState (Html, [Html], Html, Maybe Html, Html, [(String,String)])
|
2009-12-31 01:13:26 +00:00
|
|
|
|
pandocToHtml opts (Pandoc (Meta title' authors' date') blocks) = do
|
|
|
|
|
let standalone = writerStandalone opts
|
|
|
|
|
tit <- if standalone
|
|
|
|
|
then inlineListToHtml opts title'
|
|
|
|
|
else return noHtml
|
|
|
|
|
auths <- if standalone
|
|
|
|
|
then mapM (inlineListToHtml opts) authors'
|
|
|
|
|
else return []
|
|
|
|
|
date <- if standalone
|
|
|
|
|
then inlineListToHtml opts date'
|
|
|
|
|
else return noHtml
|
|
|
|
|
let sects = hierarchicalize blocks
|
|
|
|
|
toc <- if writerTableOfContents opts
|
|
|
|
|
then tableOfContents opts sects
|
2010-03-20 17:14:18 +00:00
|
|
|
|
else return Nothing
|
2010-07-22 23:23:47 -07:00
|
|
|
|
let startSlide = RawHtml "<div class=\"slide\">\n"
|
|
|
|
|
endSlide = RawHtml "</div>\n"
|
2010-07-18 23:05:48 -07:00
|
|
|
|
let cutUp (HorizontalRule : Header 1 ys : xs) = cutUp (Header 1 ys : xs)
|
2010-07-22 23:23:47 -07:00
|
|
|
|
cutUp (HorizontalRule : xs) = [endSlide, startSlide] ++ cutUp xs
|
|
|
|
|
cutUp (Header 1 ys : xs) = [endSlide, startSlide] ++
|
|
|
|
|
(Header 1 ys : cutUp xs)
|
2010-07-13 23:41:18 -07:00
|
|
|
|
cutUp (x:xs) = x : cutUp xs
|
|
|
|
|
cutUp [] = []
|
2010-07-22 23:23:47 -07:00
|
|
|
|
let slides = case blocks of
|
|
|
|
|
(HorizontalRule : xs) -> [startSlide] ++ cutUp xs ++ [endSlide]
|
|
|
|
|
(Header 1 ys : xs) -> [startSlide, Header 1 ys] ++
|
|
|
|
|
cutUp xs ++ [endSlide]
|
|
|
|
|
_ -> [startSlide] ++ cutUp blocks ++
|
|
|
|
|
[endSlide]
|
2010-07-13 23:41:18 -07:00
|
|
|
|
blocks' <- liftM toHtmlFromList $
|
2010-07-22 22:58:48 -07:00
|
|
|
|
if writerSlideVariant opts `elem` [SlidySlides, S5Slides]
|
2010-07-22 23:23:47 -07:00
|
|
|
|
then mapM (blockToHtml opts) slides
|
2010-07-22 22:58:48 -07:00
|
|
|
|
else mapM (elementToHtml opts) sects
|
2009-12-31 01:13:26 +00:00
|
|
|
|
st <- get
|
|
|
|
|
let notes = reverse (stNotes st)
|
2010-03-13 04:11:24 +00:00
|
|
|
|
let thebody = blocks' +++ footnoteSection notes
|
2009-12-31 01:13:26 +00:00
|
|
|
|
let math = if stMath st
|
|
|
|
|
then case writerHTMLMathMethod opts of
|
|
|
|
|
LaTeXMathML (Just url) ->
|
|
|
|
|
script !
|
2010-03-23 14:02:37 -07:00
|
|
|
|
[src url, thetype "text/javascript"] $ noHtml
|
2010-03-18 06:45:56 +00:00
|
|
|
|
MathML (Just url) ->
|
|
|
|
|
script !
|
2010-03-23 14:02:37 -07:00
|
|
|
|
[src url, thetype "text/javascript"] $ noHtml
|
2010-10-26 21:06:51 -07:00
|
|
|
|
MathJax url ->
|
|
|
|
|
script ! [src url, thetype "text/javascript"] $ noHtml
|
2009-12-31 01:13:26 +00:00
|
|
|
|
JsMath (Just url) ->
|
|
|
|
|
script !
|
2010-03-23 14:02:37 -07:00
|
|
|
|
[src url, thetype "text/javascript"] $ noHtml
|
2010-03-18 06:45:56 +00:00
|
|
|
|
_ -> case lookup "mathml-script" (writerVariables opts) of
|
2009-12-31 01:13:26 +00:00
|
|
|
|
Just s ->
|
|
|
|
|
script ! [thetype "text/javascript"] <<
|
|
|
|
|
primHtml s
|
|
|
|
|
Nothing -> noHtml
|
|
|
|
|
else noHtml
|
2010-07-16 00:23:13 -07:00
|
|
|
|
let newvars = [("highlighting-css", defaultHighlightingCss) |
|
|
|
|
|
stHighlighting st] ++
|
2010-03-18 06:45:56 +00:00
|
|
|
|
[("math", renderHtmlFragment math) | stMath st]
|
2009-12-31 01:13:26 +00:00
|
|
|
|
return (tit, auths, date, toc, thebody, newvars)
|
|
|
|
|
|
2009-12-31 01:14:35 +00:00
|
|
|
|
inTemplate :: TemplateTarget a
|
|
|
|
|
=> WriterOptions
|
2009-12-31 01:13:26 +00:00
|
|
|
|
-> Html
|
|
|
|
|
-> [Html]
|
|
|
|
|
-> Html
|
2010-03-20 17:14:18 +00:00
|
|
|
|
-> Maybe Html
|
2009-12-31 01:13:26 +00:00
|
|
|
|
-> Html
|
|
|
|
|
-> [(String,String)]
|
2009-12-31 01:14:35 +00:00
|
|
|
|
-> a
|
2009-12-31 01:13:26 +00:00
|
|
|
|
inTemplate opts tit auths date toc body' newvars =
|
|
|
|
|
let renderedTit = showHtmlFragment tit
|
|
|
|
|
topTitle' = stripTags renderedTit
|
|
|
|
|
authors = map (stripTags . showHtmlFragment) auths
|
|
|
|
|
date' = stripTags $ showHtmlFragment date
|
|
|
|
|
variables = writerVariables opts ++ newvars
|
|
|
|
|
context = variables ++
|
|
|
|
|
[ ("body", renderHtmlFragment body')
|
|
|
|
|
, ("pagetitle", topTitle')
|
|
|
|
|
, ("title", renderHtmlFragment tit)
|
2009-12-31 01:15:42 +00:00
|
|
|
|
, ("date", date') ] ++
|
2010-03-20 17:14:18 +00:00
|
|
|
|
(case toc of
|
|
|
|
|
Just t -> [ ("toc", renderHtmlFragment t)]
|
|
|
|
|
Nothing -> []) ++
|
2009-12-31 01:15:42 +00:00
|
|
|
|
[ ("author", a) | a <- authors ]
|
2009-12-31 01:13:26 +00:00
|
|
|
|
in renderTemplate context $ writerTemplate opts
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
2009-12-05 17:56:02 +00:00
|
|
|
|
-- | Like Text.XHtml's identifier, but adds the writerIdentifierPrefix
|
|
|
|
|
prefixedId :: WriterOptions -> String -> HtmlAttr
|
|
|
|
|
prefixedId opts s = identifier $ writerIdentifierPrefix opts ++ s
|
|
|
|
|
|
2009-04-25 00:29:58 +00:00
|
|
|
|
-- | Construct table of contents from list of elements.
|
2010-03-20 17:14:18 +00:00
|
|
|
|
tableOfContents :: WriterOptions -> [Element] -> State WriterState (Maybe Html)
|
|
|
|
|
tableOfContents _ [] = return Nothing
|
2009-04-25 00:29:58 +00:00
|
|
|
|
tableOfContents opts sects = do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
let opts' = opts { writerIgnoreNotes = True }
|
2009-04-25 00:29:58 +00:00
|
|
|
|
contents <- mapM (elementToListItem opts') sects
|
2010-01-09 03:13:08 +00:00
|
|
|
|
let tocList = catMaybes contents
|
2010-03-20 17:14:18 +00:00
|
|
|
|
return $ if null tocList
|
|
|
|
|
then Nothing
|
|
|
|
|
else Just $ thediv ! [prefixedId opts' "TOC"] $ unordList tocList
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
2009-12-09 04:58:29 +00:00
|
|
|
|
-- | Convert section number to string
|
|
|
|
|
showSecNum :: [Int] -> String
|
|
|
|
|
showSecNum = concat . intersperse "." . map show
|
2009-12-08 02:36:16 +00:00
|
|
|
|
|
2007-11-03 23:27:58 +00:00
|
|
|
|
-- | Converts an Element to a list item for a table of contents,
|
|
|
|
|
-- retrieving the appropriate identifier from state.
|
2009-04-25 00:29:58 +00:00
|
|
|
|
elementToListItem :: WriterOptions -> Element -> State WriterState (Maybe Html)
|
|
|
|
|
elementToListItem _ (Blk _) = return Nothing
|
2009-12-08 02:36:16 +00:00
|
|
|
|
elementToListItem opts (Sec _ num id' headerText subsecs) = do
|
2009-12-09 04:58:29 +00:00
|
|
|
|
let sectnum = if writerNumberSections opts
|
|
|
|
|
then (thespan ! [theclass "toc-section-number"] << showSecNum num) +++
|
|
|
|
|
stringToHtml " "
|
|
|
|
|
else noHtml
|
|
|
|
|
txt <- liftM (sectnum +++) $ inlineListToHtml opts headerText
|
2009-04-25 00:29:58 +00:00
|
|
|
|
subHeads <- mapM (elementToListItem opts) subsecs >>= return . catMaybes
|
2007-11-03 23:27:58 +00:00
|
|
|
|
let subList = if null subHeads
|
|
|
|
|
then noHtml
|
2009-04-25 00:29:58 +00:00
|
|
|
|
else unordList subHeads
|
2010-03-23 14:02:37 -07:00
|
|
|
|
return $ Just $ (anchor ! [href ("#" ++ writerIdentifierPrefix opts ++ id')] $ txt) +++ subList
|
2009-04-25 00:29:58 +00:00
|
|
|
|
|
|
|
|
|
-- | Convert an Element to Html.
|
|
|
|
|
elementToHtml :: WriterOptions -> Element -> State WriterState Html
|
|
|
|
|
elementToHtml opts (Blk block) = blockToHtml opts block
|
2009-12-08 02:36:16 +00:00
|
|
|
|
elementToHtml opts (Sec level num id' title' elements) = do
|
2009-04-25 00:29:58 +00:00
|
|
|
|
innerContents <- mapM (elementToHtml opts) elements
|
2009-12-09 04:58:29 +00:00
|
|
|
|
modify $ \st -> st{stSecNum = num} -- update section number
|
|
|
|
|
header' <- blockToHtml opts (Header level title')
|
2010-07-15 19:01:00 -07:00
|
|
|
|
let slides = writerSlideVariant opts `elem` [SlidySlides, S5Slides]
|
|
|
|
|
let header'' = header' ! [prefixedId opts id' |
|
|
|
|
|
not (writerStrictMarkdown opts ||
|
|
|
|
|
writerSectionDivs opts || slides)]
|
|
|
|
|
let stuff = header'' : innerContents
|
|
|
|
|
return $ if slides -- S5 gets confused by the extra divs around sections
|
|
|
|
|
then toHtmlFromList stuff
|
|
|
|
|
else if writerSectionDivs opts
|
|
|
|
|
then thediv ! [prefixedId opts id'] << stuff
|
|
|
|
|
else toHtmlFromList stuff
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
-- | Convert list of Note blocks to a footnote <div>.
|
|
|
|
|
-- Assumes notes are sorted.
|
2008-07-13 17:08:55 +00:00
|
|
|
|
footnoteSection :: [Html] -> Html
|
|
|
|
|
footnoteSection notes =
|
2007-11-03 23:27:58 +00:00
|
|
|
|
if null notes
|
|
|
|
|
then noHtml
|
|
|
|
|
else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes)
|
|
|
|
|
|
2008-02-09 03:21:04 +00:00
|
|
|
|
|
|
|
|
|
-- | Parse a mailto link; return Just (name, domain) or Nothing.
|
|
|
|
|
parseMailto :: String -> Maybe (String, String)
|
2008-07-13 17:08:55 +00:00
|
|
|
|
parseMailto ('m':'a':'i':'l':'t':'o':':':addr) =
|
|
|
|
|
let (name', rest) = span (/='@') addr
|
2008-02-09 03:21:04 +00:00
|
|
|
|
domain = drop 1 rest
|
2008-07-13 17:08:55 +00:00
|
|
|
|
in Just (name', domain)
|
2008-02-09 03:21:04 +00:00
|
|
|
|
parseMailto _ = Nothing
|
|
|
|
|
|
2009-01-24 19:58:48 +00:00
|
|
|
|
-- | Obfuscate a "mailto:" link.
|
2007-11-03 23:27:58 +00:00
|
|
|
|
obfuscateLink :: WriterOptions -> String -> String -> Html
|
2009-01-24 19:58:48 +00:00
|
|
|
|
obfuscateLink opts txt s | writerEmailObfuscation opts == NoObfuscation =
|
2010-03-23 14:02:37 -07:00
|
|
|
|
anchor ! [href s] << txt
|
2008-07-13 17:08:55 +00:00
|
|
|
|
obfuscateLink opts txt s =
|
2009-01-24 19:58:48 +00:00
|
|
|
|
let meth = writerEmailObfuscation opts
|
|
|
|
|
s' = map toLower s
|
2008-07-13 17:08:55 +00:00
|
|
|
|
in case parseMailto s' of
|
|
|
|
|
(Just (name', domain)) ->
|
2007-11-03 23:27:58 +00:00
|
|
|
|
let domain' = substitute "." " dot " domain
|
|
|
|
|
at' = obfuscateChar '@'
|
|
|
|
|
(linkText, altText) =
|
2008-07-13 17:08:55 +00:00
|
|
|
|
if txt == drop 7 s' -- autolink
|
|
|
|
|
then ("'<code>'+e+'</code>'", name' ++ " at " ++ domain')
|
|
|
|
|
else ("'" ++ txt ++ "'", txt ++ " (" ++ name' ++ " at " ++
|
2007-11-03 23:27:58 +00:00
|
|
|
|
domain' ++ ")")
|
2009-01-24 19:58:48 +00:00
|
|
|
|
in case meth of
|
|
|
|
|
ReferenceObfuscation ->
|
|
|
|
|
-- need to use primHtml or &'s are escaped to & in URL
|
2008-07-13 17:08:55 +00:00
|
|
|
|
primHtml $ "<a href=\"" ++ (obfuscateString s')
|
|
|
|
|
++ "\">" ++ (obfuscateString txt) ++ "</a>"
|
2009-01-24 19:58:48 +00:00
|
|
|
|
JavascriptObfuscation ->
|
|
|
|
|
(script ! [thetype "text/javascript"] $
|
2007-11-03 23:27:58 +00:00
|
|
|
|
primHtml ("\n<!--\nh='" ++
|
|
|
|
|
obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++
|
2008-07-13 17:08:55 +00:00
|
|
|
|
obfuscateString name' ++ "';e=n+a+h;\n" ++
|
2007-11-03 23:27:58 +00:00
|
|
|
|
"document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++
|
|
|
|
|
linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++
|
|
|
|
|
noscript (primHtml $ obfuscateString altText)
|
2009-01-24 19:58:48 +00:00
|
|
|
|
_ -> error $ "Unknown obfuscation method: " ++ show meth
|
2010-03-23 14:02:37 -07:00
|
|
|
|
_ -> anchor ! [href s] $ stringToHtml txt -- malformed email
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
-- | Obfuscate character as entity.
|
|
|
|
|
obfuscateChar :: Char -> String
|
|
|
|
|
obfuscateChar char =
|
|
|
|
|
let num = ord char
|
|
|
|
|
numstr = if even num then show num else "x" ++ showHex num ""
|
|
|
|
|
in "&#" ++ numstr ++ ";"
|
|
|
|
|
|
|
|
|
|
-- | Obfuscate string using entities.
|
|
|
|
|
obfuscateString :: String -> String
|
|
|
|
|
obfuscateString = concatMap obfuscateChar . decodeCharacterReferences
|
|
|
|
|
|
|
|
|
|
-- | Convert Pandoc block element to HTML.
|
|
|
|
|
blockToHtml :: WriterOptions -> Block -> State WriterState Html
|
2008-07-13 17:08:55 +00:00
|
|
|
|
blockToHtml _ Null = return $ noHtml
|
2007-11-03 23:27:58 +00:00
|
|
|
|
blockToHtml opts (Plain lst) = inlineListToHtml opts lst
|
2010-03-16 04:06:25 +00:00
|
|
|
|
blockToHtml opts (Para [Image txt (s,tit)]) = do
|
|
|
|
|
img <- inlineToHtml opts (Image txt (s,tit))
|
|
|
|
|
capt <- inlineListToHtml opts txt
|
|
|
|
|
return $ thediv ! [theclass "figure"] <<
|
2010-03-18 02:39:06 +00:00
|
|
|
|
[img, paragraph ! [theclass "caption"] << capt]
|
2007-11-03 23:27:58 +00:00
|
|
|
|
blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph)
|
2008-07-13 17:08:55 +00:00
|
|
|
|
blockToHtml _ (RawHtml str) = return $ primHtml str
|
|
|
|
|
blockToHtml _ (HorizontalRule) = return $ hr
|
2009-11-21 04:40:59 +00:00
|
|
|
|
blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do
|
|
|
|
|
let classes' = if writerLiterateHaskell opts
|
|
|
|
|
then classes
|
|
|
|
|
else filter (/= "literate") classes
|
|
|
|
|
case highlightHtml (id',classes',keyvals) rawCode of
|
2008-05-15 00:54:33 +00:00
|
|
|
|
Left _ -> -- change leading newlines into <br /> tags, because some
|
|
|
|
|
-- browsers ignore leading newlines in pre blocks
|
|
|
|
|
let (leadingBreaks, rawCode') = span (=='\n') rawCode
|
2009-11-21 04:40:59 +00:00
|
|
|
|
attrs = [theclass (unwords classes') | not (null classes')] ++
|
2009-12-05 17:56:02 +00:00
|
|
|
|
[prefixedId opts id' | not (null id')] ++
|
2009-11-21 04:40:59 +00:00
|
|
|
|
map (\(x,y) -> strAttr x y) keyvals
|
2010-07-07 10:28:25 -07:00
|
|
|
|
addBird = if "literate" `elem` classes'
|
2010-06-28 19:47:29 -07:00
|
|
|
|
then unlines . map ("> " ++) . lines
|
|
|
|
|
else unlines . lines
|
2009-11-21 04:40:59 +00:00
|
|
|
|
in return $ pre ! attrs $ thecode <<
|
|
|
|
|
(replicate (length leadingBreaks) br +++
|
2010-06-28 19:47:29 -07:00
|
|
|
|
[stringToHtml $ addBird rawCode'])
|
2009-12-31 01:13:26 +00:00
|
|
|
|
Right h -> modify (\st -> st{ stHighlighting = True }) >> return h
|
2007-11-03 23:27:58 +00:00
|
|
|
|
blockToHtml opts (BlockQuote blocks) =
|
|
|
|
|
-- in S5, treat list in blockquote specially
|
|
|
|
|
-- if default is incremental, make it nonincremental;
|
|
|
|
|
-- otherwise incremental
|
2010-07-13 20:44:56 -07:00
|
|
|
|
if writerSlideVariant opts /= NoSlides
|
2007-11-03 23:27:58 +00:00
|
|
|
|
then let inc = not (writerIncremental opts) in
|
|
|
|
|
case blocks of
|
|
|
|
|
[BulletList lst] -> blockToHtml (opts {writerIncremental = inc})
|
|
|
|
|
(BulletList lst)
|
|
|
|
|
[OrderedList attribs lst] ->
|
|
|
|
|
blockToHtml (opts {writerIncremental = inc})
|
|
|
|
|
(OrderedList attribs lst)
|
2008-07-13 17:08:55 +00:00
|
|
|
|
_ -> blockListToHtml opts blocks >>=
|
2007-11-03 23:27:58 +00:00
|
|
|
|
(return . blockquote)
|
|
|
|
|
else blockListToHtml opts blocks >>= (return . blockquote)
|
|
|
|
|
blockToHtml opts (Header level lst) = do
|
|
|
|
|
contents <- inlineListToHtml opts lst
|
2009-12-09 04:58:29 +00:00
|
|
|
|
secnum <- liftM stSecNum get
|
|
|
|
|
let contents' = if writerNumberSections opts
|
|
|
|
|
then (thespan ! [theclass "header-section-number"] << showSecNum secnum) +++
|
|
|
|
|
stringToHtml " " +++ contents
|
|
|
|
|
else contents
|
|
|
|
|
let contents'' = if writerTableOfContents opts
|
2010-03-23 14:02:37 -07:00
|
|
|
|
then anchor ! [href $ "#" ++ writerIdentifierPrefix opts ++ "TOC"] $ contents'
|
2009-12-09 04:58:29 +00:00
|
|
|
|
else contents'
|
2007-11-03 23:27:58 +00:00
|
|
|
|
return $ case level of
|
2009-12-09 04:58:29 +00:00
|
|
|
|
1 -> h1 contents''
|
|
|
|
|
2 -> h2 contents''
|
|
|
|
|
3 -> h3 contents''
|
|
|
|
|
4 -> h4 contents''
|
|
|
|
|
5 -> h5 contents''
|
|
|
|
|
6 -> h6 contents''
|
|
|
|
|
_ -> paragraph contents''
|
2007-11-03 23:27:58 +00:00
|
|
|
|
blockToHtml opts (BulletList lst) = do
|
|
|
|
|
contents <- mapM (blockListToHtml opts) lst
|
|
|
|
|
let attribs = if writerIncremental opts
|
|
|
|
|
then [theclass "incremental"]
|
|
|
|
|
else []
|
|
|
|
|
return $ unordList ! attribs $ contents
|
|
|
|
|
blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do
|
|
|
|
|
contents <- mapM (blockListToHtml opts) lst
|
|
|
|
|
let numstyle' = camelCaseToHyphenated $ show numstyle
|
|
|
|
|
let attribs = (if writerIncremental opts
|
|
|
|
|
then [theclass "incremental"]
|
|
|
|
|
else []) ++
|
|
|
|
|
(if startnum /= 1
|
|
|
|
|
then [start startnum]
|
|
|
|
|
else []) ++
|
|
|
|
|
(if numstyle /= DefaultStyle
|
2008-02-24 18:15:36 +00:00
|
|
|
|
then [thestyle $ "list-style-type: " ++ numstyle' ++ ";"]
|
2007-11-03 23:27:58 +00:00
|
|
|
|
else [])
|
|
|
|
|
return $ ordList ! attribs $ contents
|
|
|
|
|
blockToHtml opts (DefinitionList lst) = do
|
2009-12-07 08:26:53 +00:00
|
|
|
|
contents <- mapM (\(term, defs) ->
|
|
|
|
|
do term' <- liftM (dterm <<) $ inlineListToHtml opts term
|
|
|
|
|
defs' <- mapM (liftM (ddef <<) . blockListToHtml opts) defs
|
|
|
|
|
return $ term' : defs') lst
|
2007-11-03 23:27:58 +00:00
|
|
|
|
let attribs = if writerIncremental opts
|
|
|
|
|
then [theclass "incremental"]
|
|
|
|
|
else []
|
2009-12-07 08:26:53 +00:00
|
|
|
|
return $ dlist ! attribs << concat contents
|
2008-07-13 17:08:55 +00:00
|
|
|
|
blockToHtml opts (Table capt aligns widths headers rows') = do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
let alignStrings = map alignmentToString aligns
|
|
|
|
|
captionDoc <- if null capt
|
|
|
|
|
then return noHtml
|
|
|
|
|
else inlineListToHtml opts capt >>= return . caption
|
2010-03-10 06:19:53 +00:00
|
|
|
|
let percent w = show (truncate (100*w) :: Integer) ++ "%"
|
|
|
|
|
let coltags = if all (== 0.0) widths
|
|
|
|
|
then noHtml
|
|
|
|
|
else concatHtml $ map
|
|
|
|
|
(\w -> col ! [width $ percent w] $ noHtml) widths
|
|
|
|
|
head' <- if all null headers
|
|
|
|
|
then return noHtml
|
|
|
|
|
else liftM (thead <<) $ tableRowToHtml opts alignStrings 0 headers
|
|
|
|
|
body' <- liftM (tbody <<) $
|
|
|
|
|
zipWithM (tableRowToHtml opts alignStrings) [1..] rows'
|
|
|
|
|
return $ table $ captionDoc +++ coltags +++ head' +++ body'
|
2008-07-13 17:08:55 +00:00
|
|
|
|
|
2010-03-07 19:35:14 +00:00
|
|
|
|
tableRowToHtml :: WriterOptions
|
|
|
|
|
-> [String]
|
2010-03-10 06:19:53 +00:00
|
|
|
|
-> Int
|
|
|
|
|
-> [[Block]]
|
2008-07-13 17:08:55 +00:00
|
|
|
|
-> State WriterState Html
|
2010-03-10 06:19:53 +00:00
|
|
|
|
tableRowToHtml opts alignStrings rownum cols' = do
|
2010-03-07 19:35:14 +00:00
|
|
|
|
let mkcell = if rownum == 0 then th else td
|
|
|
|
|
let rowclass = case rownum of
|
|
|
|
|
0 -> "header"
|
|
|
|
|
x | x `rem` 2 == 1 -> "odd"
|
|
|
|
|
_ -> "even"
|
2010-03-10 06:19:53 +00:00
|
|
|
|
cols'' <- sequence $ zipWith
|
|
|
|
|
(\alignment item -> tableItemToHtml opts mkcell alignment item)
|
|
|
|
|
alignStrings cols'
|
2010-03-07 19:35:14 +00:00
|
|
|
|
return $ tr ! [theclass rowclass] $ toHtmlFromList cols''
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
2008-07-13 17:08:55 +00:00
|
|
|
|
alignmentToString :: Alignment -> [Char]
|
2007-11-03 23:27:58 +00:00
|
|
|
|
alignmentToString alignment = case alignment of
|
|
|
|
|
AlignLeft -> "left"
|
|
|
|
|
AlignRight -> "right"
|
|
|
|
|
AlignCenter -> "center"
|
|
|
|
|
AlignDefault -> "left"
|
|
|
|
|
|
2008-07-13 17:08:55 +00:00
|
|
|
|
tableItemToHtml :: WriterOptions
|
|
|
|
|
-> (Html -> Html)
|
|
|
|
|
-> [Char]
|
|
|
|
|
-> [Block]
|
|
|
|
|
-> State WriterState Html
|
2010-03-10 06:19:53 +00:00
|
|
|
|
tableItemToHtml opts tag' align' item = do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
contents <- blockListToHtml opts item
|
2010-03-10 06:19:53 +00:00
|
|
|
|
return $ tag' ! [align align'] $ contents
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html
|
|
|
|
|
blockListToHtml opts lst =
|
|
|
|
|
mapM (blockToHtml opts) lst >>= return . toHtmlFromList
|
|
|
|
|
|
|
|
|
|
-- | Convert list of Pandoc inline elements to HTML.
|
|
|
|
|
inlineListToHtml :: WriterOptions -> [Inline] -> State WriterState Html
|
|
|
|
|
inlineListToHtml opts lst =
|
|
|
|
|
mapM (inlineToHtml opts) lst >>= return . toHtmlFromList
|
|
|
|
|
|
|
|
|
|
-- | Convert Pandoc inline element to HTML.
|
|
|
|
|
inlineToHtml :: WriterOptions -> Inline -> State WriterState Html
|
|
|
|
|
inlineToHtml opts inline =
|
|
|
|
|
case inline of
|
|
|
|
|
(Str str) -> return $ stringToHtml str
|
|
|
|
|
(Space) -> return $ stringToHtml " "
|
2010-01-01 04:11:48 +00:00
|
|
|
|
(LineBreak) -> return br
|
|
|
|
|
(EmDash) -> return $ stringToHtml "—"
|
|
|
|
|
(EnDash) -> return $ stringToHtml "–"
|
|
|
|
|
(Ellipses) -> return $ stringToHtml "…"
|
|
|
|
|
(Apostrophe) -> return $ stringToHtml "’"
|
2007-11-03 23:27:58 +00:00
|
|
|
|
(Emph lst) -> inlineListToHtml opts lst >>= return . emphasize
|
|
|
|
|
(Strong lst) -> inlineListToHtml opts lst >>= return . strong
|
|
|
|
|
(Code str) -> return $ thecode << str
|
2008-02-24 18:15:36 +00:00
|
|
|
|
(Strikeout lst) -> inlineListToHtml opts lst >>=
|
|
|
|
|
return . (thespan ! [thestyle "text-decoration: line-through;"])
|
2008-07-15 23:25:49 +00:00
|
|
|
|
(SmallCaps lst) -> inlineListToHtml opts lst >>=
|
|
|
|
|
return . (thespan ! [thestyle "font-variant: small-caps;"])
|
2007-11-03 23:27:58 +00:00
|
|
|
|
(Superscript lst) -> inlineListToHtml opts lst >>= return . sup
|
|
|
|
|
(Subscript lst) -> inlineListToHtml opts lst >>= return . sub
|
|
|
|
|
(Quoted quoteType lst) ->
|
|
|
|
|
let (leftQuote, rightQuote) = case quoteType of
|
2010-01-01 04:11:48 +00:00
|
|
|
|
SingleQuote -> (stringToHtml "‘",
|
|
|
|
|
stringToHtml "’")
|
|
|
|
|
DoubleQuote -> (stringToHtml "“",
|
|
|
|
|
stringToHtml "”")
|
2007-11-03 23:27:58 +00:00
|
|
|
|
in do contents <- inlineListToHtml opts lst
|
|
|
|
|
return $ leftQuote +++ contents +++ rightQuote
|
2010-10-26 21:06:51 -07:00
|
|
|
|
(Math t str) -> modify (\st -> st {stMath = True}) >>
|
2007-12-02 00:36:32 +00:00
|
|
|
|
(case writerHTMLMathMethod opts of
|
2008-08-13 03:02:42 +00:00
|
|
|
|
LaTeXMathML _ ->
|
2008-09-15 22:43:21 +00:00
|
|
|
|
-- putting LaTeXMathML in container with class "LaTeX" prevents
|
|
|
|
|
-- non-math elements on the page from being treated as math by
|
|
|
|
|
-- the javascript
|
|
|
|
|
return $ thespan ! [theclass "LaTeX"] $
|
2010-07-15 19:01:00 -07:00
|
|
|
|
case t of
|
|
|
|
|
InlineMath -> primHtml ("$" ++ str ++ "$")
|
|
|
|
|
DisplayMath -> primHtml ("$$" ++ str ++ "$$")
|
|
|
|
|
JsMath _ -> do
|
|
|
|
|
let m = primHtml str
|
|
|
|
|
return $ case t of
|
|
|
|
|
InlineMath -> thespan ! [theclass "math"] $ m
|
|
|
|
|
DisplayMath -> thediv ! [theclass "math"] $ m
|
|
|
|
|
WebTeX url -> do
|
|
|
|
|
let m = image ! [src (url ++ urlEncode str),
|
|
|
|
|
alt str, title str]
|
|
|
|
|
return $ case t of
|
|
|
|
|
InlineMath -> m
|
|
|
|
|
DisplayMath -> br +++ m +++ br
|
2007-12-02 00:36:32 +00:00
|
|
|
|
GladTeX ->
|
2010-08-01 08:30:04 -07:00
|
|
|
|
return $ case t of
|
|
|
|
|
InlineMath -> primHtml $ "<EQ ENV=\"math\">" ++ str ++ "</EQ>"
|
|
|
|
|
DisplayMath -> primHtml $ "<EQ ENV=\"displaymath\">" ++ str ++ "</EQ>"
|
2010-03-18 06:45:56 +00:00
|
|
|
|
MathML _ -> do
|
|
|
|
|
let dt = if t == InlineMath
|
|
|
|
|
then DisplayInline
|
|
|
|
|
else DisplayBlock
|
|
|
|
|
let conf = useShortEmptyTags (const False)
|
|
|
|
|
defaultConfigPP
|
|
|
|
|
case texMathToMathML dt str of
|
|
|
|
|
Right r -> return $ primHtml $
|
|
|
|
|
ppcElement conf r
|
2010-03-21 22:48:47 -07:00
|
|
|
|
Left _ -> inlineListToHtml opts
|
2010-07-15 19:01:00 -07:00
|
|
|
|
(readTeXMath str) >>= return .
|
2010-10-26 21:06:51 -07:00
|
|
|
|
(thespan ! [theclass "math"])
|
|
|
|
|
MathJax _ -> do
|
|
|
|
|
let dt = if t == InlineMath
|
|
|
|
|
then DisplayInline
|
|
|
|
|
else DisplayBlock
|
|
|
|
|
let conf = useShortEmptyTags (const False)
|
|
|
|
|
defaultConfigPP
|
|
|
|
|
case texMathToMathML dt str of
|
|
|
|
|
Right r -> return $ primHtml $
|
|
|
|
|
ppcElement conf r
|
|
|
|
|
Left _ -> inlineListToHtml opts
|
|
|
|
|
(readTeXMath str) >>= return .
|
2010-07-15 19:01:00 -07:00
|
|
|
|
(thespan ! [theclass "math"])
|
|
|
|
|
PlainMath -> do
|
|
|
|
|
x <- inlineListToHtml opts (readTeXMath str)
|
|
|
|
|
let m = thespan ! [theclass "math"] $ x
|
|
|
|
|
return $ case t of
|
|
|
|
|
InlineMath -> m
|
|
|
|
|
DisplayMath -> br +++ m +++ br )
|
2008-08-13 03:02:42 +00:00
|
|
|
|
(TeX str) -> case writerHTMLMathMethod opts of
|
|
|
|
|
LaTeXMathML _ -> do modify (\st -> st {stMath = True})
|
|
|
|
|
return $ primHtml str
|
|
|
|
|
_ -> return noHtml
|
2007-11-03 23:27:58 +00:00
|
|
|
|
(HtmlInline str) -> return $ primHtml str
|
2008-07-13 17:08:55 +00:00
|
|
|
|
(Link [Code str] (s,_)) | "mailto:" `isPrefixOf` s ->
|
|
|
|
|
return $ obfuscateLink opts str s
|
|
|
|
|
(Link txt (s,_)) | "mailto:" `isPrefixOf` s -> do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
linkText <- inlineListToHtml opts txt
|
2008-07-13 17:08:55 +00:00
|
|
|
|
return $ obfuscateLink opts (show linkText) s
|
|
|
|
|
(Link txt (s,tit)) -> do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
linkText <- inlineListToHtml opts txt
|
2010-03-23 14:02:37 -07:00
|
|
|
|
return $ anchor ! ([href s] ++
|
2007-11-03 23:27:58 +00:00
|
|
|
|
if null tit then [] else [title tit]) $
|
|
|
|
|
linkText
|
2008-07-13 17:08:55 +00:00
|
|
|
|
(Image txt (s,tit)) -> do
|
2007-11-03 23:27:58 +00:00
|
|
|
|
alternate <- inlineListToHtml opts txt
|
|
|
|
|
let alternate' = renderFragment opts alternate
|
2010-03-23 14:02:37 -07:00
|
|
|
|
let attributes = [src s] ++
|
2007-11-03 23:27:58 +00:00
|
|
|
|
(if null tit
|
|
|
|
|
then []
|
|
|
|
|
else [title tit]) ++
|
|
|
|
|
if null txt
|
|
|
|
|
then []
|
|
|
|
|
else [alt alternate']
|
|
|
|
|
return $ image ! attributes
|
|
|
|
|
-- note: null title included, as in Markdown.pl
|
|
|
|
|
(Note contents) -> do
|
|
|
|
|
st <- get
|
|
|
|
|
let notes = stNotes st
|
|
|
|
|
let number = (length notes) + 1
|
|
|
|
|
let ref = show number
|
|
|
|
|
htmlContents <- blockListToNote opts ref contents
|
|
|
|
|
-- push contents onto front of notes
|
|
|
|
|
put $ st {stNotes = (htmlContents:notes)}
|
2009-12-31 01:47:08 +00:00
|
|
|
|
return $ sup <<
|
2010-03-23 14:02:37 -07:00
|
|
|
|
anchor ! [href ("#" ++ writerIdentifierPrefix opts ++ "fn" ++ ref),
|
2009-12-31 01:47:08 +00:00
|
|
|
|
theclass "footnoteRef",
|
|
|
|
|
prefixedId opts ("fnref" ++ ref)] << ref
|
2008-08-04 03:15:12 +00:00
|
|
|
|
(Cite _ il) -> inlineListToHtml opts il
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|
|
|
|
|
blockListToNote :: WriterOptions -> String -> [Block] -> State WriterState Html
|
|
|
|
|
blockListToNote opts ref blocks =
|
|
|
|
|
-- If last block is Para or Plain, include the backlink at the end of
|
|
|
|
|
-- that block. Otherwise, insert a new Plain block with the backlink.
|
2010-03-23 14:02:37 -07:00
|
|
|
|
let backlink = [HtmlInline $ " <a href=\"#" ++ writerIdentifierPrefix opts ++ "fnref" ++ ref ++
|
2007-11-03 23:27:58 +00:00
|
|
|
|
"\" class=\"footnoteBackLink\"" ++
|
2010-01-01 04:11:48 +00:00
|
|
|
|
" title=\"Jump back to footnote " ++ ref ++ "\">↩</a>"]
|
2007-11-03 23:27:58 +00:00
|
|
|
|
blocks' = if null blocks
|
|
|
|
|
then []
|
|
|
|
|
else let lastBlock = last blocks
|
|
|
|
|
otherBlocks = init blocks
|
|
|
|
|
in case lastBlock of
|
|
|
|
|
(Para lst) -> otherBlocks ++
|
|
|
|
|
[Para (lst ++ backlink)]
|
|
|
|
|
(Plain lst) -> otherBlocks ++
|
|
|
|
|
[Plain (lst ++ backlink)]
|
|
|
|
|
_ -> otherBlocks ++ [lastBlock,
|
|
|
|
|
Plain backlink]
|
|
|
|
|
in do contents <- blockListToHtml opts blocks'
|
2009-12-05 17:56:02 +00:00
|
|
|
|
return $ li ! [prefixedId opts ("fn" ++ ref)] $ contents
|
2007-11-03 23:27:58 +00:00
|
|
|
|
|