google-html5-slide (empty) → 0.1.0.0
raw patch · 6 files changed
+457/−0 lines, 6 filesdep +basedep +blaze-htmldep +cmdargssetup-changed
Dependencies added: base, blaze-html, cmdargs, data-default, hamlet, pandoc, shakespeare-css, syb, text, time
Files
- HTML5Slide.hs +277/−0
- LICENSE +30/−0
- Monitor.hs +39/−0
- Setup.hs +2/−0
- google-html5-slide.cabal +34/−0
- main.hs +75/−0
+ HTML5Slide.hs view
@@ -0,0 +1,277 @@+{-# 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+<html>+ <head>+ <title>#{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 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"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Hideyuki Tanaka + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hideyuki Tanaka nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Monitor.hs view
@@ -0,0 +1,39 @@+module Monitor ( + monitor, + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import Data.Time +import System.IO +import Text.Printf + +monitor :: FilePath -> (String -> IO a) -> IO () +monitor filename m = do + r <- newIORef "" + forever $ do + cur <- readFile filename + bef <- readIORef r + length cur `seq` writeIORef r cur + + when (cur /= bef) $ try_ $ do + _ <- m cur + + ct <- getCurrentTime + tz <- getCurrentTimeZone + printf "[%s]: update\n" (show $ utcToLocalTime tz ct) + hFlush stdout + + threadDelay $ 10^(6::Int) + +try_ :: IO a -> IO () +try_ m = do + ret <- try m + case ret of + Left (SomeException e) -> do + print e + hFlush stdout + Right _ -> + return ()
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ google-html5-slide.cabal view
@@ -0,0 +1,34 @@+name: google-html5-slide +version: 0.1.0.0 +synopsis: Google HTML5 Slide generator +description: + Google HTML5 Slide <https://code.google.com/p/html5slides/> generator + for Pandoc documents +license: BSD3 +license-file: LICENSE +author: Hideyuki Tanaka +maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> +copyright: (c) 2012, Hideyuki Tanaka +category: Web +build-type: Simple +cabal-version: >=1.8 + +source-repository head + type: git + location: https://github.com/tanakh/pandoc-html5slide.git + +executable google-html5-slide + main-is: main.hs + other-modules: HTML5Slide + Monitor + + build-depends: base ==4.5.* + , text >=0.11 + , syb ==0.3.* + , time >=1.4 + , data-default >=0.5 + , blaze-html >=0.5 + , pandoc >=1.9 + , hamlet >=1.0 + , shakespeare-css >=1.0 + , cmdargs >=0.9.5
+ main.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} + +import Data.Maybe +import System.Console.CmdArgs as CA +import Text.Pandoc + +import HTML5Slide as S +import Monitor + +data HTML5Slide + = HTML5Slide + { argSlideScriptURL :: Maybe String + , argSlideClass :: Maybe String + , argSlideStyleCss :: Maybe String + , argSlideSyntaxCss :: Maybe String + , argPoll :: Bool + , filename :: String + } + deriving (Show, Data, Typeable) + +main :: IO () +main = do + HTML5Slide {..} <- cmdArgs $ HTML5Slide + { argSlideScriptURL = + CA.def + &= explicit &= name "script-url" + &= typ "URL" + &= help "URL of Google HTML5 slide script" + , argSlideClass = + CA.def + &= explicit &= name "slide-class" + &= typ "CLASSNAME" + &= help "CSS class name of slide" + , argSlideStyleCss = + CA.def + &= explicit &= name "style-css" + &= typFile + &= help "Style CSS file" + , argSlideSyntaxCss = + CA.def + &= explicit &= name "syntax-css" + &= typFile + &= help "Syntax CSS file" + , argPoll = + CA.def + &= explicit &= name "poll" + &= help "Poll filesystem for changes" + , filename = + CA.def + &= argPos 0 &= typFile + } + + styleCss <- maybe (return $ slideStyleCss S.def) readFile argSlideStyleCss + syntaxCss <- maybe (return $ slideSyntaxCss S.def) readFile argSlideSyntaxCss + + let outname = (++".html") $ takeWhile (/='.') filename + slideOpt = S.def + { slideScriptURL = + fromMaybe (slideScriptURL S.def) argSlideScriptURL + , slideClass = + fromMaybe (slideClass S.def) argSlideClass + , slideStyleCss = + styleCss + , slideSyntaxCss = + syntaxCss + } + + let compile src = + writeFile outname + $ writeHTML5SlideString defaultWriterOptions slideOpt + $ readMarkdown defaultParserState { stateStandalone = True } src + + if argPoll + then monitor filename $ compile + else readFile filename >>= compile