diff --git a/HTML5Slide.hs b/HTML5Slide.hs
new file mode 100644
--- /dev/null
+++ b/HTML5Slide.hs
@@ -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
+
+
+ #{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"
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Monitor.hs b/Monitor.hs
new file mode 100644
--- /dev/null
+++ b/Monitor.hs
@@ -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 ()
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/google-html5-slide.cabal b/google-html5-slide.cabal
new file mode 100644
--- /dev/null
+++ b/google-html5-slide.cabal
@@ -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
diff --git a/main.hs b/main.hs
new file mode 100644
--- /dev/null
+++ b/main.hs
@@ -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