#{renderInlines $ sanitizeTitle docTitle} <meta charset="utf-8"> <script src="#{slideScriptURL}"> <style>#{slideStyleCss} <style>#{slideSyntaxCss} <body style="display: none"> <section.slides.layout-regular.#{slideClass}> $if not (null docTitle) <article> <h1>#{renderInlines docTitle} <p> $forall author <- docAuthors #{renderInlines author} <p> #{renderInlines docDate} $forall sec <- sectionize blocks $if isSmaller sec <article.smaller>#{renderBlocks sec} $else <article>#{renderBlocks sec} |] sanitizeTitle :: [Inline] -> [Inline] sanitizeTitle = everywhere (mkT $ replace "<br>" " ") sectionize :: [Block] -> [[Block]] sectionize [] = [] sectionize (b:bs) | isHorizontalRule b = sectionize bs | isArticleBegin b = let (cs, d:ds) = span (not . isArticleEnd) bs in (b:cs++[d]) : sectionize ds | otherwise = let (cs, ds) = span (not . isSplitter) bs in (b:cs) : sectionize ds where isSplitter a = isHeader a || isArticleBegin a || isHorizontalRule a isHeader (Header _ _) = True isHeader _ = False isArticleBegin (Plain [RawInline "html" raw]) | "<article" `isPrefixOf` raw = True isArticleBegin _ = False isArticleEnd (Plain [RawInline "html" "</article>"]) = True isArticleEnd _ = False isHorizontalRule HorizontalRule = True isHorizontalRule _ = False isSmaller :: [Block] -> Bool isSmaller = (>0) . gcount (mkQ False f) where f (Header 3 _) = True f _ = False replace :: String -> String -> String -> String replace _ _ "" = "" replace from to ss | from `isPrefixOf` ss = to ++ drop (length from) ss | otherwise = head ss : replace from to (tail ss) renderBlocks :: [Block] -> Html renderBlocks = mapM_ renderBlock renderBlock :: Block -> Html renderBlock block = case block of Plain inls -> renderInlines inls Para inls -> [shamlet|<p>#{renderInlines inls}|] CodeBlock attr codestr -> case highlight formatHtmlInline attr codestr of Nothing -> error $ "cannot highlighter for: " ++ show attr Just html -> [shamlet|<pre>#{html}|] RawBlock format str -> -- TODO: use format preEscapedToMarkup str -- blockquoted lists are incremental list BlockQuote [OrderedList attr bss] -> [shamlet| <ol.build> $forall bs <- bss <li>#{renderBlocks bs}|] BlockQuote [BulletList bss] -> [shamlet| <ul.build> $forall bs <- bss <li>#{renderBlocks bs}|] BlockQuote blocks -> [shamlet|<blockquote>#{renderBlocks blocks}|] OrderedList attr bss -> [shamlet| <ol> $forall bs <- bss <li>#{renderBlocks bs}|] BulletList bss -> [shamlet| <ul> $forall bs <- bss <li>#{renderBlocks bs}|] DefinitionList defs -> [shamlet| <dl> $forall (t, ds) <- defs <dd>#{renderInlines t} $forall d <- ds #{renderBlocks d}|] Header level inls -> case level of 1 -> [shamlet|<h2>#{renderInlines inls}|] 2 -> [shamlet|<h3>#{renderInlines inls}|] -- Level 3 is smaller article 3 -> [shamlet|<h3>#{renderInlines inls}|] _ -> error ("unsupported header level: " ++ show level) HorizontalRule -> [shamlet|<hr>|] Table cap colAlign colWidthRatio colHeader rows -> [shamlet| <table> <caption>#{renderInlines cap} <thead> <tr> $forall co <- colHeader <td>#{renderBlocks co} <tbody> $forall row <- rows <tr> $forall co <- row <td>#{renderBlocks co}|] Null -> return () renderInlines :: [Inline] -> Html renderInlines = mapM_ renderInline renderInline :: Inline -> Html renderInline inl = case inl of Str ss -> [shamlet|#{ss}|] Emph inls -> [shamlet|<em>#{renderInlines inls}|] Strong inls -> [shamlet|<strong>#{renderInlines inls}|] Strikeout inls -> [shamlet|<del>#{renderInlines inls}|] Superscript inls -> [shamlet|<sup>#{renderInlines inls}|] Subscript inls -> [shamlet|<sub>#{renderInlines inls}|] SmallCaps inls -> [shamlet|<small>#{renderInlines inls}|] Quoted SingleQuote inls -> [shamlet|'#{renderInlines inls}'|] Quoted DoubleQuote inls -> [shamlet|"#{renderInlines inls}"|] Cite cs inls -> -- TODO: use cite info [shamlet|<cite>#{renderInlines inls}|] Code ("", [], []) code -> [shamlet|<code>#{code}|] Code ("", ["url"], []) code | '@' `elem` code -> [shamlet|<a href="mailto:#{code}"><#{code}>|] | otherwise -> [shamlet|<a href="#{code}">#{code}|] Code attr code -> -- TODO: implement error $ "unsupported inline code: " ++ show attr ++ ", " ++ code Space -> preEscapedToMarkup (" " :: String) LineBreak -> [shamlet|<br>|] Math mathType str -> -- TODO: support it error $ "unsupported math: " ++ show (mathType, str) RawInline "html" str -> preEscapedToMarkup str RawInline format str -> -- TODO: support it error $ "unsupported rawinline: " ++ format Link inls (url, title) -> [shamlet|<a href="#{url}" alt="#{title}">#{renderInlines inls}|] Image inls (url, title) -> do [shamlet|<img.centered src="#{url}" alt="#{title}">|] Note _ -> -- TODO: support it error "note not supported"

{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} module HTML5Slide ( HTML5SlideOptions(..), def, writeHTML5Slide, writeHTML5SlideString, ) where import Data.Default import Data.Generics import Data.List import qualified Data.Text.Lazy as L import Text.Blaze.Html import Text.Blaze.Html.Renderer.String import Text.Hamlet import Text.Lucius import Text.Pandoc import Text.Pandoc.Highlighting data HTML5SlideOptions = HTML5SlideOptions { slideScriptURL :: String , slideClass :: String , slideStyleCss :: String , slideSyntaxCss :: String } instance Default HTML5SlideOptions where def = HTML5SlideOptions { slideScriptURL = "http://html5slides.googlecode.com/svn/trunk/slides.js" , slideClass = "" , slideStyleCss = "" , slideSyntaxCss = L.unpack $ renderCss $ [lucius| table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode, table.sourceCode pre { margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; } td.lineNumbers { border-right: 1px solid #AAAAAA; text-align: right; color: #AAAAAA; padding-right: 5px; padding-left: 5px; } td.sourceCode { padding-left: 5px; } code.sourceCode span.kw { color: #007020; font-weight: bold; } code.sourceCode span.dt { color: #902000; } code.sourceCode span.dv { color: #40a070; } code.sourceCode span.bn { color: #40a070; } code.sourceCode span.fl { color: #40a070; } code.sourceCode span.ch { color: #4070a0; } code.sourceCode span.st { color: #4070a0; } code.sourceCode span.co { color: #60a0b0; font-style: italic; } code.sourceCode span.ot { color: #007020; } code.sourceCode span.al { color: red; font-weight: bold; } code.sourceCode span.fu { color: #06287e; } code.sourceCode span.re { } code.sourceCode span.er { color: red; font-weight: bold; } |] undefined } writeHTML5SlideString :: WriterOptions -> HTML5SlideOptions -> Pandoc -> String writeHTML5SlideString opt sopt pdoc = do renderHtml $ writeHTML5Slide opt sopt pdoc writeHTML5Slide :: WriterOptions -> HTML5SlideOptions -> Pandoc -> Html writeHTML5Slide _ HTML5SlideOptions {..} (Pandoc Meta {..} blocks) = [shamlet| $doctype 5 #{renderInlines $ sanitizeTitle docTitle} <meta charset="utf-8"> <script src="#{slideScriptURL}"> <style>#{slideStyleCss} <style>#{slideSyntaxCss} <body style="display: none"> <section.slides.layout-regular.#{slideClass}> $if not (null docTitle) <article> <h1>#{renderInlines docTitle} <p> $forall author <- docAuthors #{renderInlines author} <p> #{renderInlines docDate} $forall sec <- sectionize blocks $if isSmaller sec <article.smaller>#{renderBlocks sec} $else <article>#{renderBlocks sec} |] sanitizeTitle :: [Inline] -> [Inline] sanitizeTitle = everywhere (mkT $ replace "<br>" " ") sectionize :: [Block] -> [[Block]] sectionize [] = [] sectionize (b:bs) | isHorizontalRule b = sectionize bs | isArticleBegin b = let (cs, d:ds) = span (not . isArticleEnd) bs in (b:cs++[d]) : sectionize ds | otherwise = let (cs, ds) = span (not . isSplitter) bs in (b:cs) : sectionize ds where isSplitter a = isHeader a || isArticleBegin a || isHorizontalRule a isHeader (Header _ _) = True isHeader _ = False isArticleBegin (Plain [RawInline "html" raw]) | "<article" `isPrefixOf` raw = True isArticleBegin _ = False isArticleEnd (Plain [RawInline "html" "</article>"]) = True isArticleEnd _ = False isHorizontalRule HorizontalRule = True isHorizontalRule _ = False isSmaller :: [Block] -> Bool isSmaller = (>0) . gcount (mkQ False f) where f (Header 3 _) = True f _ = False replace :: String -> String -> String -> String replace _ _ "" = "" replace from to ss | from `isPrefixOf` ss = to ++ drop (length from) ss | otherwise = head ss : replace from to (tail ss) renderBlocks :: [Block] -> Html renderBlocks = mapM_ renderBlock renderBlock :: Block -> Html renderBlock block = case block of Plain inls -> renderInlines inls Para inls -> [shamlet|<p>#{renderInlines inls}|] CodeBlock attr codestr -> case highlight formatHtmlInline attr codestr of Nothing -> error $ "cannot highlighter for: " ++ show attr Just html -> [shamlet|<pre>#{html}|] RawBlock format str -> -- TODO: use format preEscapedToMarkup str -- blockquoted lists are incremental list BlockQuote [OrderedList attr bss] -> [shamlet| <ol.build> $forall bs <- bss <li>#{renderBlocks bs}|] BlockQuote [BulletList bss] -> [shamlet| <ul.build> $forall bs <- bss <li>#{renderBlocks bs}|] BlockQuote blocks -> [shamlet|<blockquote>#{renderBlocks blocks}|] OrderedList attr bss -> [shamlet| <ol> $forall bs <- bss <li>#{renderBlocks bs}|] BulletList bss -> [shamlet| <ul> $forall bs <- bss <li>#{renderBlocks bs}|] DefinitionList defs -> [shamlet| <dl> $forall (t, ds) <- defs <dd>#{renderInlines t} $forall d <- ds #{renderBlocks d}|] Header level inls -> case level of 1 -> [shamlet|<h2>#{renderInlines inls}|] 2 -> [shamlet|<h3>#{renderInlines inls}|] -- Level 3 is smaller article 3 -> [shamlet|<h3>#{renderInlines inls}|] _ -> error ("unsupported header level: " ++ show level) HorizontalRule -> [shamlet|<hr>|] Table cap colAlign colWidthRatio colHeader rows -> [shamlet| <table> <caption>#{renderInlines cap} <thead> <tr> $forall co <- colHeader <td>#{renderBlocks co} <tbody> $forall row <- rows <tr> $forall co <- row <td>#{renderBlocks co}|] Null -> return () renderInlines :: [Inline] -> Html renderInlines = mapM_ renderInline renderInline :: Inline -> Html renderInline inl = case inl of Str ss -> [shamlet|#{ss}|] Emph inls -> [shamlet|<em>#{renderInlines inls}|] Strong inls -> [shamlet|<strong>#{renderInlines inls}|] Strikeout inls -> [shamlet|<del>#{renderInlines inls}|] Superscript inls -> [shamlet|<sup>#{renderInlines inls}|] Subscript inls -> [shamlet|<sub>#{renderInlines inls}|] SmallCaps inls -> [shamlet|<small>#{renderInlines inls}|] Quoted SingleQuote inls -> [shamlet|'#{renderInlines inls}'|] Quoted DoubleQuote inls -> [shamlet|"#{renderInlines inls}"|] Cite cs inls -> -- TODO: use cite info [shamlet|<cite>#{renderInlines inls}|] Code ("", [], []) code -> [shamlet|<code>#{code}|] Code ("", ["url"], []) code | '@' `elem` code -> [shamlet|<a href="mailto:#{code}"><#{code}>|] | otherwise -> [shamlet|<a href="#{code}">#{code}|] Code attr code -> -- TODO: implement error $ "unsupported inline code: " ++ show attr ++ ", " ++ code Space -> preEscapedToMarkup (" " :: String) LineBreak -> [shamlet|<br>|] Math mathType str -> -- TODO: support it error $ "unsupported math: " ++ show (mathType, str) RawInline "html" str -> preEscapedToMarkup str RawInline format str -> -- TODO: support it error $ "unsupported rawinline: " ++ format Link inls (url, title) -> [shamlet|<a href="#{url}" alt="#{title}">#{renderInlines inls}|] Image inls (url, title) -> do [shamlet|<img.centered src="#{url}" alt="#{title}">|] Note _ -> -- TODO: support it error "note not supported"