b973bc9 · typeable/pandoc

36import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss )

37import Numeric ( showHex )

38import Data.Char ( ord, toLower, isAlpha )

39−import Data.List ( isPrefixOf, intersperse, find )

39+import Data.List ( isPrefixOf, intersperse )

40import qualified Data.Set as S

41import Control.Monad.State

42import Text.XHtml.Transitional

53 stMath = False, stCSS = S.empty}

54

55-- Helpers to render HTML with the appropriate function.

56+

57+render :: (HTML html) => WriterOptions -> html -> String

56−render opts = if writerWrapText opts then renderHtml else showHtml

58+render opts = if writerWrapText opts then renderHtml else showHtml

59+

60+renderFragment :: (HTML html) => WriterOptions -> html -> String

57renderFragment opts = if writerWrapText opts

61renderFragment opts = if writerWrapText opts

58 then renderHtmlFragment

62 then renderHtmlFragment

59 else showHtmlFragment

63 else showHtmlFragment

112 noHtml

116 noHtml

113 _ -> noHtml

117 _ -> noHtml

114 else noHtml

118 else noHtml

115− head = header $ metadata +++ math +++ css +++

119+ head' = header $ metadata +++ math +++ css +++

116 primHtml (writerHeader opts)

120 primHtml (writerHeader opts)

117 notes = reverse (stNotes newstate)

121 notes = reverse (stNotes newstate)

118 before = primHtml $ writerIncludeBefore opts

122 before = primHtml $ writerIncludeBefore opts

119 after = primHtml $ writerIncludeAfter opts

123 after = primHtml $ writerIncludeAfter opts

120 thebody = before +++ titleHeader +++ toc +++ blocks' +++

124 thebody = before +++ titleHeader +++ toc +++ blocks' +++

121− footnoteSection opts notes +++ after

125+ footnoteSection notes +++ after

122 in if writerStandalone opts

126 in if writerStandalone opts

123− then head +++ body thebody

127+ then head' +++ body thebody

124 else thebody

128 else thebody

125

129

126-- | Construct table of contents from list of header blocks and identifiers.

130-- | Construct table of contents from list of header blocks and identifiers.

137-- | Converts an Element to a list item for a table of contents,

141-- | Converts an Element to a list item for a table of contents,

138-- retrieving the appropriate identifier from state.

142-- retrieving the appropriate identifier from state.

139elementToListItem :: WriterOptions -> Element -> State WriterState Html

143elementToListItem :: WriterOptions -> Element -> State WriterState Html

140−elementToListItem opts (Blk _) = return noHtml

144+elementToListItem _ (Blk _) = return noHtml

141elementToListItem opts (Sec headerText subsecs) = do

145elementToListItem opts (Sec headerText subsecs) = do

142 st <- get

146 st <- get

143 let ids = stIds st

147 let ids = stIds st

144− let (id, rest) = if null ids

148+ let (id', rest) = if null ids

145 then ("", [])

149 then ("", [])

146 else (head ids, tail ids)

150 else (head ids, tail ids)

147 put $ st {stIds = rest}

151 put $ st {stIds = rest}

150 let subList = if null subHeads

154 let subList = if null subHeads

151 then noHtml

155 then noHtml

152 else unordList subHeads

156 else unordList subHeads

153− return $ (anchor ! [href ("#" ++ id), identifier ("TOC-" ++ id)] $ txt) +++

157+ return $ (anchor ! [href ("#" ++ id'), identifier ("TOC-" ++ id')] $ txt) +++

154 subList

158 subList

155

159

156-- | Convert list of Note blocks to a footnote <div>.

160-- | Convert list of Note blocks to a footnote <div>.

157-- Assumes notes are sorted.

161-- Assumes notes are sorted.

158−footnoteSection :: WriterOptions -> [Html] -> Html

162+footnoteSection :: [Html] -> Html

159−footnoteSection opts notes =

163+footnoteSection notes =

160 if null notes

164 if null notes

161 then noHtml

165 then noHtml

162 else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes)

166 else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes)

164

168

165-- | Parse a mailto link; return Just (name, domain) or Nothing.

169-- | Parse a mailto link; return Just (name, domain) or Nothing.

166parseMailto :: String -> Maybe (String, String)

170parseMailto :: String -> Maybe (String, String)

167−parseMailto ('m':'a':'i':'l':'t':'o':':':address) =

171+parseMailto ('m':'a':'i':'l':'t':'o':':':addr) =

168− let (name, rest) = span (/='@') address

172+ let (name', rest) = span (/='@') addr

169 domain = drop 1 rest

173 domain = drop 1 rest

170− in Just (name, domain)

174+ in Just (name', domain)

171parseMailto _ = Nothing

175parseMailto _ = Nothing

172

176

173-- | Obfuscate a "mailto:" link using Javascript.

177-- | Obfuscate a "mailto:" link using Javascript.

174obfuscateLink :: WriterOptions -> String -> String -> Html

178obfuscateLink :: WriterOptions -> String -> String -> Html

175−obfuscateLink opts text src =

179+obfuscateLink opts txt s =

176− let src' = map toLower src

180+ let s' = map toLower s

177− in case parseMailto src' of

181+ in case parseMailto s' of

178− (Just (name, domain)) ->

182+ (Just (name', domain)) ->

179 let domain' = substitute "." " dot " domain

183 let domain' = substitute "." " dot " domain

180 at' = obfuscateChar '@'

184 at' = obfuscateChar '@'

181 (linkText, altText) =

185 (linkText, altText) =

182− if text == drop 7 src' -- autolink

186+ if txt == drop 7 s' -- autolink

183− then ("'<code>'+e+'</code>'", name ++ " at " ++ domain')

187+ then ("'<code>'+e+'</code>'", name' ++ " at " ++ domain')

184− else ("'" ++ text ++ "'", text ++ " (" ++ name ++ " at " ++

188+ else ("'" ++ txt ++ "'", txt ++ " (" ++ name' ++ " at " ++

185 domain' ++ ")")

189 domain' ++ ")")

186 in if writerStrictMarkdown opts

190 in if writerStrictMarkdown opts

187 then -- need to use primHtml or &'s are escaped to & in URL

191 then -- need to use primHtml or &'s are escaped to & in URL

188− primHtml $ "<a href=\"" ++ (obfuscateString src')

192+ primHtml $ "<a href=\"" ++ (obfuscateString s')

189− ++ "\">" ++ (obfuscateString text) ++ "</a>"

193+ ++ "\">" ++ (obfuscateString txt) ++ "</a>"

190 else (script ! [thetype "text/javascript"] $

194 else (script ! [thetype "text/javascript"] $

191 primHtml ("\n<!--\nh='" ++

195 primHtml ("\n<!--\nh='" ++

192 obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++

196 obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++

193− obfuscateString name ++ "';e=n+a+h;\n" ++

197+ obfuscateString name' ++ "';e=n+a+h;\n" ++

194 "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++

198 "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++

195 linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++

199 linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++

196 noscript (primHtml $ obfuscateString altText)

200 noscript (primHtml $ obfuscateString altText)

197− _ -> anchor ! [href src] $ primHtml text -- malformed email

201+ _ -> anchor ! [href s] $ primHtml txt -- malformed email

198

202

199-- | Obfuscate character as entity.

203-- | Obfuscate character as entity.

200obfuscateChar :: Char -> String

204obfuscateChar :: Char -> String

227inlineListToIdentifier :: [Inline] -> String

231inlineListToIdentifier :: [Inline] -> String

228inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier'

232inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier'

229

233

234+inlineListToIdentifier' :: [Inline] -> [Char]

230inlineListToIdentifier' [] = ""

235inlineListToIdentifier' [] = ""

231inlineListToIdentifier' (x:xs) =

236inlineListToIdentifier' (x:xs) =

232 xAsText ++ inlineListToIdentifier' xs

237 xAsText ++ inlineListToIdentifier' xs

266

271

267-- | Convert Pandoc block element to HTML.

272-- | Convert Pandoc block element to HTML.

268blockToHtml :: WriterOptions -> Block -> State WriterState Html

273blockToHtml :: WriterOptions -> Block -> State WriterState Html

269−blockToHtml opts Null = return $ noHtml

274+blockToHtml _ Null = return $ noHtml

270blockToHtml opts (Plain lst) = inlineListToHtml opts lst

275blockToHtml opts (Plain lst) = inlineListToHtml opts lst

271blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph)

276blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph)

272−blockToHtml opts (RawHtml str) = return $ primHtml str

277+blockToHtml _ (RawHtml str) = return $ primHtml str

273−blockToHtml opts (HorizontalRule) = return $ hr

278+blockToHtml _ (HorizontalRule) = return $ hr

274−blockToHtml opts (CodeBlock attr@(_,classes,_) rawCode) = do

279+blockToHtml _ (CodeBlock attr@(_,classes,_) rawCode) = do

275 case highlightHtml attr rawCode of

280 case highlightHtml attr rawCode of

276 Left _ -> -- change leading newlines into <br /> tags, because some

281 Left _ -> -- change leading newlines into <br /> tags, because some

277 -- browsers ignore leading newlines in pre blocks

282 -- browsers ignore leading newlines in pre blocks

294 [OrderedList attribs lst] ->

299 [OrderedList attribs lst] ->

295 blockToHtml (opts {writerIncremental = inc})

300 blockToHtml (opts {writerIncremental = inc})

296 (OrderedList attribs lst)

301 (OrderedList attribs lst)

297− otherwise -> blockListToHtml opts blocks >>=

302+ _ -> blockListToHtml opts blocks >>=

298 (return . blockquote)

303 (return . blockquote)

299 else blockListToHtml opts blocks >>= (return . blockquote)

304 else blockListToHtml opts blocks >>= (return . blockquote)

300blockToHtml opts (Header level lst) = do

305blockToHtml opts (Header level lst) = do

301 contents <- inlineListToHtml opts lst

306 contents <- inlineListToHtml opts lst

302 st <- get

307 st <- get

303 let ids = stIds st

308 let ids = stIds st

304− let (id, rest) = if null ids

309+ let (id', rest) = if null ids

305 then ("", [])

310 then ("", [])

306 else (head ids, tail ids)

311 else (head ids, tail ids)

307 put $ st {stIds = rest}

312 put $ st {stIds = rest}

308 let attribs = if writerStrictMarkdown opts && not (writerTableOfContents opts)

313 let attribs = if writerStrictMarkdown opts && not (writerTableOfContents opts)

309 then []

314 then []

310− else [identifier id]

315+ else [identifier id']

311 let contents' = if writerTableOfContents opts

316 let contents' = if writerTableOfContents opts

312− then anchor ! [href ("#TOC-" ++ id)] $ contents

317+ then anchor ! [href ("#TOC-" ++ id')] $ contents

313 else contents

318 else contents

314 return $ case level of

319 return $ case level of

315 1 -> h1 contents' ! attribs

320 1 -> h1 contents' ! attribs

346 then [theclass "incremental"]

351 then [theclass "incremental"]

347 else []

352 else []

348 return $ defList ! attribs $ contents

353 return $ defList ! attribs $ contents

349−blockToHtml opts (Table capt aligns widths headers rows) = do

354+blockToHtml opts (Table capt aligns widths headers rows') = do

350 let alignStrings = map alignmentToString aligns

355 let alignStrings = map alignmentToString aligns

351 captionDoc <- if null capt

356 captionDoc <- if null capt

352 then return noHtml

357 then return noHtml

353 else inlineListToHtml opts capt >>= return . caption

358 else inlineListToHtml opts capt >>= return . caption

354 colHeads <- colHeadsToHtml opts alignStrings

359 colHeads <- colHeadsToHtml opts alignStrings

355 widths headers

360 widths headers

356− rows' <- mapM (tableRowToHtml opts alignStrings) rows

361+ rows'' <- mapM (tableRowToHtml opts alignStrings) rows'

357− return $ table $ captionDoc +++ colHeads +++ rows'

362+ return $ table $ captionDoc +++ colHeads +++ rows''

358−

363+

364+colHeadsToHtml :: WriterOptions

365+ -> [[Char]]

366+ -> [Float]

367+ -> [[Block]]

368+ -> State WriterState Html

359colHeadsToHtml opts alignStrings widths headers = do

369colHeadsToHtml opts alignStrings widths headers = do

360 heads <- sequence $ zipWith3

370 heads <- sequence $ zipWith3

361− (\align width item -> tableItemToHtml opts th align width item)

371+ (\alignment columnwidth item -> tableItemToHtml opts th alignment columnwidth item)

362 alignStrings widths headers

372 alignStrings widths headers

363 return $ tr $ toHtmlFromList heads

373 return $ tr $ toHtmlFromList heads

364

374

375+alignmentToString :: Alignment -> [Char]

365alignmentToString alignment = case alignment of

376alignmentToString alignment = case alignment of

366 AlignLeft -> "left"

377 AlignLeft -> "left"

367 AlignRight -> "right"

378 AlignRight -> "right"

368 AlignCenter -> "center"

379 AlignCenter -> "center"

369 AlignDefault -> "left"

380 AlignDefault -> "left"

370

381

371−tableRowToHtml opts aligns cols =

382+tableRowToHtml :: WriterOptions

383+ -> [[Char]]

384+ -> [[Block]]

385+ -> State WriterState Html

386+tableRowToHtml opts aligns columns =

372− (sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) cols) >>=

387+ (sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) columns) >>=

373 return . tr . toHtmlFromList

388 return . tr . toHtmlFromList

374

389

390+tableItemToHtml :: WriterOptions

391+ -> (Html -> Html)

392+ -> [Char]

393+ -> Float

394+ -> [Block]

395+ -> State WriterState Html

375−tableItemToHtml opts tag align' width item = do

396+tableItemToHtml opts tag' align' width' item = do

376 contents <- blockListToHtml opts item

397 contents <- blockListToHtml opts item

377 let attrib = [align align'] ++

398 let attrib = [align align'] ++

378− if width /= 0

399+ if width' /= 0

379− then [thestyle ("width: " ++ show (truncate (100*width)) ++

400+ then [thestyle ("width: " ++ show (truncate (100*width')) ++

380 "%;")]

401 "%;")]

381 else []

402 else []

382− return $ tag ! attrib $ contents

403+ return $ tag' ! attrib $ contents

383

404

384blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html

405blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html

385blockListToHtml opts lst =

406blockListToHtml opts lst =

428 PlainMath ->

449 PlainMath ->

429 inlineListToHtml opts (readTeXMath str) >>=

450 inlineListToHtml opts (readTeXMath str) >>=

430 return . (thespan ! [theclass "math"]))

451 return . (thespan ! [theclass "math"]))

431− (TeX str) -> return noHtml

452+ (TeX _) -> return noHtml

432 (HtmlInline str) -> return $ primHtml str

453 (HtmlInline str) -> return $ primHtml str

433− (Link [Code str] (src,tit)) | "mailto:" `isPrefixOf` src ->

454+ (Link [Code str] (s,_)) | "mailto:" `isPrefixOf` s ->

434− return $ obfuscateLink opts str src

455+ return $ obfuscateLink opts str s

435− (Link txt (src,tit)) | "mailto:" `isPrefixOf` src -> do

456+ (Link txt (s,_)) | "mailto:" `isPrefixOf` s -> do

436 linkText <- inlineListToHtml opts txt

457 linkText <- inlineListToHtml opts txt

437− return $ obfuscateLink opts (show linkText) src

458+ return $ obfuscateLink opts (show linkText) s

438− (Link txt (src,tit)) -> do

459+ (Link txt (s,tit)) -> do

439 linkText <- inlineListToHtml opts txt

460 linkText <- inlineListToHtml opts txt

440− return $ anchor ! ([href src] ++

461+ return $ anchor ! ([href s] ++

441 if null tit then [] else [title tit]) $

462 if null tit then [] else [title tit]) $

442 linkText

463 linkText

443− (Image txt (source,tit)) -> do

464+ (Image txt (s,tit)) -> do

444 alternate <- inlineListToHtml opts txt

465 alternate <- inlineListToHtml opts txt

445 let alternate' = renderFragment opts alternate

466 let alternate' = renderFragment opts alternate

446− let attributes = [src source] ++

467+ let attributes = [src s] ++

447 (if null tit

468 (if null tit

448 then []

469 then []

449 else [title tit]) ++

470 else [title tit]) ++