Inital commit

.gitignore

+.DS_Store/
+.stack-work/
+TAGS
+*.swp
+server.log
+generated-index.md
+generated-index.html
+index.html
+*-deck.html
+*-handout.html
+*-page.html
+

Setup.hs

+import Distribution.Simple
+main = defaultMain

app/decker.hs

+{-# LANGUAGE TemplateHaskell #-}
+
+import           Control.Exception
+import           Control.Monad
+import qualified Data.ByteString.Char8      as B
+import           Data.FileEmbed
+import           Data.IORef
+import           Data.List
+import           Data.Maybe
+import           Data.String
+import           Data.Yaml.Pretty
+import           Development.Shake
+import           Development.Shake.FilePath
+import           System.Directory
+import           System.Exit
+import           System.FilePath
+import           System.FilePath.Glob
+import qualified Text.Mustache              as M
+import           Text.Mustache.Types        (mFromJSON)
+import           Text.Pandoc
+import           Text.Printf
+import           Utilities
+
+-- | All observable source files that are considered. These are specified in
+-- the Action monad, such that they are revealuated on each iteration of the *watch* target.
+getDeckSources = globRelative "**/*-deck.md"
+
+getPageSources = globRelative "**/*-page.md"
+
+getAllSources = globRelative "**/*.md"
+
+-- | Calculates all plain markdown files ending just in `*.md`.
+getPlainSources =
+  do all <- getAllSources
+     decks <- getDeckSources
+     pages <- getPageSources
+     return $ all \\ (decks ++ pages)
+
+-- | Returns all YAML files.
+getMeta = globRelative "**/*.yaml"
+
+-- | Actions that generate lists of target files from the source list actions
+getDecks = getDeckSources >>= replaceSuffixWith ".md" ".html"
+getDecksPdf = getDeckSources >>= replaceSuffixWith ".md" ".pdf"
+getHandouts = getDeckSources >>= replaceSuffixWith "-deck.md" "-handout.html"
+getHandoutsPdf = getDeckSources >>= replaceSuffixWith "-deck.md" "-handout.pdf"
+getPages = getPageSources >>= replaceSuffixWith ".md" ".html"
+getPagesPdf = getPageSources >>= replaceSuffixWith ".md" ".pdf"
+getPlain = getPlainSources >>= replaceSuffixWith ".md" ".html"
+getPlainPdf = getPlainSources >>= replaceSuffixWith ".md" ".pdf"
+getEverything = getDecks <++> getHandouts <++> getPages <++> getPlain
+getEverythingPdf = getDecksPdf <++> getHandoutsPdf <++> getPagesPdf <++> getPlain
+
+-- | Stuff that will be deleted by the clean target
+getCruft = return ["index.md.generated", "index.html", "server.log"]
+
+main = do
+    contextRef <-   newIORef defaultContext
+    runShakeInContext contextRef options $ do
+
+        want ["html"]
+
+        phony "html" $ do
+            need ["index.html"]
+            getDecks <++> getHandouts <++> getPages <++> getPlain >>= need
+
+        phony "pdf" $ do
+            need ["index.html"]
+            getPagesPdf <++> getHandoutsPdf <++> getPlainPdf >>= need
+
+        phony "pdf-decks" $ do
+            need ["index.html"]
+            getDecksPdf >>= need
+
+        phony "watch" $ do
+            need ["html"]
+            getDecks <++> getHandouts <++> getPages <++> getPlain >>= markNeeded
+            sources <- getAllSources
+            meta <- getMeta
+            watchFiles (sources ++ meta) contextRef
+
+        phony "server" $ do
+            need ["watch"]
+            runHttpServer contextRef True
+
+        phony "example" writeExampleProject
+
+        priority 2 $ "//*-deck.html" %> \out -> do
+            let src = out -<.> "md"
+            meta <- getMeta
+            markdownToHtmlDeck src meta out
+
+        priority 2 $ "//*-deck.pdf" %> \out -> do
+            let src = out -<.> "html"
+            need [src]
+            runHttpServer contextRef False
+            code <- cmd "decktape.sh reveal" ("http://localhost:8888/" ++ src) out
+            case code of
+              ExitFailure _ -> do
+                 cdnBase <- getBaseUrl
+                 throw $ DecktapeException cdnBase
+              ExitSuccess ->
+                 return ()
+
+        priority 2 $ "//*-handout.html" %> \out -> do
+            let src = dropSuffix "-handout.html" out ++ "-deck.md"
+            meta <- getMeta
+            markdownToHtmlHandout src meta out
+
+        priority 2 $ "//*-handout.pdf" %> \out -> do
+            let src = dropSuffix "-handout.pdf" out ++ "-deck.md"
+            meta <- getMeta
+            markdownToPdfHandout src meta out
+
+        priority 2 $ "//*-page.html" %> \out -> do
+            let src = dropSuffix "-page.html" out ++ "-page.md"
+            meta <- getMeta
+            markdownToHtmlPage src meta out
+
+        priority 2 $ "//*-page.pdf" %> \out -> do
+            let src = dropSuffix "-page.pdf" out ++ "-page.md"
+            meta <- getMeta
+            markdownToPdfPage src meta out
+
+        priority 2 $ "index.html" %> \out -> do
+            exists <- Development.Shake.doesFileExist "index.md"
+            let src = if exists then "index.md" else "index.md.generated"
+            meta <- getMeta
+            markdownToHtmlPage src meta out
+
+        "index.md.generated" %> \out -> do
+            decks <-getDecks
+            handouts <- getHandouts
+            pages <- getPages
+            plain <- getPlain
+            need $ decks ++ handouts ++ pages ++ plain
+            writeIndex out decks handouts pages plain
+
+        "//*.html" %> \out -> do
+            let src = out -<.> "md"
+            meta <- getMeta
+            markdownToHtmlPage src meta out
+
+        "//*.pdf" %> \out -> do
+            let src = out -<.> "md"
+            meta <- getMeta
+            markdownToPdfPage src meta out
+
+        phony "clean" $
+            getEverything <++> getEverythingPdf <++> getCruft >>= removeFilesAfter "."
+
+        phony "help" $
+            liftIO $ B.putStr helpText
+
+        phony "source" $ do
+            source <- getAllSources
+            meta <- getMeta
+            liftIO $ mapM_ putStrLn $ source ++ meta
+
+        phony "meta" $ do
+            meta <- getMeta
+            value <- readMetaData meta
+            liftIO $ B.putStr $ encodePretty defConfig value
+
+        phony "publish" $ do
+            everything <- getEverything
+            need everything
+            hasResource <- Development.Shake.doesDirectoryExist resourceDir
+            let source = if hasResource then resourceDir : everything else everything
+            meta <- getMeta
+            metaData <- readMetaData meta
+            let host = metaValueAsString "rsync-destination.host" metaData
+            let path = metaValueAsString "rsync-destination.path" metaData
+            if isJust host && isJust path
+               then do
+                   cmd "ssh " (fromJust host) "mkdir -p" (fromJust path) :: Action ()
+                   cmd "rsync -a" source $ intercalate ":" [fromJust host, fromJust path] :: Action ()
+               else throw RsyncUrlException
+
+        phony "cache" $ getAllSources >>= mapM_ cacheImages
+
+        phony "clean-cache" $ do
+            need ["clean"]
+            removeFilesAfter "." ["**/cached"]
+
+-- | The help page
+helpText :: B.ByteString
+helpText = $(makeRelativeToProject "resource/help-page.md" >>= embedFile)
+
+-- | Glob for pathes below and relative to the current directory.
+globRelative :: String -> Action [FilePath]
+globRelative pat = liftIO $ glob pat >>= mapM makeRelativeToCurrentDirectory
+
+-- | Some constants that might need tweaking
+resourceDir = "img"
+options = shakeOptions{shakeFiles=".shake"}

app/dot.hs

+#!/usr/bin/env runhaskell
+{-# LANGUAGE OverloadedStrings #-}
+-- dot.hs
+
+module Main where
+
+import qualified Data.ByteString.Base64          as B64
+import qualified Data.ByteString.Char8           as B
+import qualified Data.ByteString.Lazy.Char8      as L
+import           Data.Digest.Pure.MD5
+import           Data.List
+import           Data.List.Split
+import           System.Exit
+import           System.IO
+import           System.Process
+import           Text.Pandoc.JSON
+
+-- All supported Graphviz render
+graphviz :: [String]
+graphviz = ["dot", "neato", "twopi", "circo", "fdp", "sfdp", "patchwork"]
+
+-- Searches code block attributes for the first graphviz renderer command
+parseAttribs :: Attr -> Maybe (String, String)
+
+parseAttribs (_, _, namevals) = find (((flip elem) graphviz) . fst) namevals
+
+-- Compiles an external Graphviz file to an external PDF file. Returns the name of
+-- the PDF file or an error message.
+compileExternal :: String -> String -> IO (Either String String)
+
+compileExternal cmd infile = do
+  let outfile = (Prelude.head $ splitOn "." infile) ++ ".pdf"
+  result <- readProcessWithExitCode cmd ["-Tpdf", "-o", outfile, infile] ""
+  case result of
+    (ExitSuccess, _, _) -> return (Right outfile)
+    (_, err, _) -> return (Left err)
+
+-- Compiles an external Graphviz file to an external PDF file with a generated filename.
+-- Returns the name of the PDF file or an error message.
+compileInternal :: String -> String -> IO (Either String String)
+
+compileInternal cmd contents = do
+  let outfile = cmd ++ "-" ++  (take 8 $ show $ md5 $ L.pack contents) ++ ".pdf"
+  result <- readProcessWithExitCode cmd ["-Tpdf", "-o", outfile] contents
+  case result of
+    (ExitSuccess, _, _) -> return (Right outfile)
+    (_, err, _) -> return (Left err)
+
+-- Creates a Pandoc Image block from the filename or communicates an inline error message.
+generateBlock :: (Either String String) -> IO Block
+
+generateBlock (Right filename) = do
+  return (Para [Image nullAttr [] (filename, "Generated from code block")])
+generateBlock (Left error) = do
+  hPutStrLn stderr msg
+  return (Para [Str msg])
+         where msg = "Error in filter 'graphviz': " ++ error
+
+-- Compiles graphviz code from a code block to an image block
+compileGraphviz :: Maybe Format -> Block -> IO Block
+
+compileGraphviz (Just (Format "latex")) cb@(CodeBlock attribs contents) =
+    case parseAttribs attribs of
+      Just (graphvizCmd, "")     -> compileInternal graphvizCmd contents >>= generateBlock
+      Just (graphvizCmd, infile) -> compileExternal graphvizCmd infile >>= generateBlock
+      Nothing                    -> return cb
+
+compileGraphviz (Just (Format "revealjs")) cb@(CodeBlock (id, classes, namevals) contents) =
+    -- Examine 'dot' attribute.
+    case lookup "dot" namevals of
+      -- Empty file name means 'read from code block'.
+      Just "" -> do
+        -- Pipe content to dot, include result via data url on an image tag.
+        -- Otherwise it is difficult to control the size of the resulting SVG
+        -- element with CSS.
+        (exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg"] contents
+        if exitCode == ExitSuccess
+        then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from code block")])
+        else return (Para [Str $ "Error running 'dot': " ++ err])
+
+      -- Read from file
+      Just file -> do
+        (exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg", file] ""
+        if exitCode == ExitSuccess
+        then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from file " ++ file)])
+        else return (Para [Str $ "Error running 'dot': " ++ err])
+
+      -- Do nothing
+      Nothing -> return cb
+
+compileGraphviz _ cb = return cb
+
+main :: IO ()
+main = toJSONFilter compileGraphviz
+
+-- | Encode a svg snippet into a data url for an image element
+svgDataUrl :: String -> String
+svgDataUrl svg = "data:image/svg+xml;base64," ++ B.unpack (B64.encode (B.pack svg))

app/gnuplot.hs

+#!/usr/bin/env runhaskell
+{-# LANGUAGE OverloadedStrings #-}
+-- gnuplot.hs
+
+module Main where
+
+import Text.Pandoc.JSON
+import System.Process
+import System.IO
+import System.Exit
+import System.Directory
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Digest.Pure.MD5
+import Data.List
+import Data.List.Split
+import qualified Data.ByteString.Base64 as B64
+
+-- Compiles an external Gnuplot file to an external PDF file. Returns the name of
+-- the PDF file or an error message.
+compileExternal :: String -> String -> IO (Either String String)
+
+compileExternal cmd infile = do
+  let outfile = (Prelude.head (splitOn "." infile)) ++ ".pdf"
+  let prelude = "set terminal pdfcairo; set output '" ++ outfile ++ "';"
+  (exitCode, _, err) <- readProcessWithExitCode "gnuplot" ["-d", "-e", prelude, infile] ""
+  if exitCode == ExitSuccess
+  then return (Right outfile)
+  else return (Left err)
+
+genUniqueFilename :: String -> String -> String -> FilePath
+genUniqueFilename prefix contents extension =
+    prefix ++ "-" ++ (take 8 $ show $ md5 $ L.pack contents) ++ "." ++ extension
+
+-- Compiles an embedded Gnuplot description to an external PDF file with a generated filename.
+-- Returns the name of the PDF file or an error message.
+compileInternal :: String -> String -> IO (Either String String)
+
+compileInternal cmd contents = do
+  let outfile = genUniqueFilename cmd contents "pdf"
+  exists <- doesFileExist outfile
+  if exists
+  then return (Right outfile)
+  else do
+      let prelude = "set terminal pdfcairo; set output '" ++ outfile ++ "';"
+      (exitCode, _, err) <- readProcessWithExitCode "gnuplot" ["-d"] (prelude ++ contents)
+      if exitCode == ExitSuccess
+      then return (Right outfile)
+      else return (Left err)
+
+-- Creates a Pandoc Image block from the filename or communicates an inline error message.
+generateBlock :: (Either String String) -> IO Block
+
+generateBlock (Right filename) = do
+  return (Para [Image nullAttr [] (filename, "Generated from code block")])
+
+generateBlock (Left error) = do
+  hPutStrLn stderr msg
+  return (Para [Str msg])
+         where msg = "Error in filter 'gnuplot': " ++ error
+
+-- Compiles gnuplot code from a code block to an image block
+compileGnuplot :: Maybe Format -> Block -> IO Block
+
+thrd (_, _, x) = x
+
+compileGnuplot (Just (Format "latex")) cb@(CodeBlock attribs contents) =
+    case lookup "gnuplot" (thrd attribs) of
+      Just ""     -> compileInternal "gnuplot" contents >>= generateBlock
+      Just infile -> compileExternal "gnuplot" infile >>= generateBlock
+      Nothing                    -> return cb
+
+compileGnuplot (Just (Format "revealjs")) cb@(CodeBlock (id, classes, namevals) contents) =
+    -- Examine 'dot' attribute.
+    case lookup "dot" namevals of
+      -- Empty file name means 'read from code block'.
+      Just "" -> do
+        -- Pipe content to dot, include result via data
+        -- url on an image tag. Otherwise it is difficult to control
+        -- the size if the resulting SVG element with CSS.
+        (exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg"] contents
+        if exitCode == ExitSuccess
+        then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from code block")])
+        else return (Para [Str $ "Error running 'dot': " ++ err])
+
+      -- Read from file
+      Just file -> do
+        (exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg", file] ""
+        if exitCode == ExitSuccess
+        then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from file " ++ file)])
+        else return (Para [Str $ "Error running 'dot': " ++ err])
+
+      -- Do nothing
+      Nothing -> return cb
+
+compileGnuplot _ cb = return cb
+
+main :: IO ()
+main = toJSONFilter compileGnuplot
+
+-- | Encode a svg snippet into a data url for an image element
+svgDataUrl :: String -> String
+svgDataUrl svg = "data:image/svg+xml;base64," ++ (B.unpack (B64.encode (B.pack svg)))

app/handout.hs

+#!/usr/bin/env runhaskell
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Control.Monad
+import           Data.Default           ()
+import           Data.List.Split
+import           Text.Pandoc.Definition ()
+import           Text.Pandoc.JSON
+import           Text.Pandoc.Walk
+import           Text.Printf
+import Filter
+
+main :: IO ()
+main = toJSONFilter filterNotes
+

app/include.hs

+#!/usr/bin/env runhaskell
+-- includes.hs
+import Text.Pandoc.JSON
+
+doInclude :: Block -> IO Block
+doInclude cb@(CodeBlock (id, classes, namevals) contents) =
+  case lookup "include" namevals of
+       Just f     -> return . (CodeBlock (id, classes, namevals)) =<< readFile f
+       Nothing    -> return cb
+doInclude x = return x
+
+main :: IO ()
+main = toJSONFilter doInclude
+

app/macros.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Text.Pandoc.Definition
+import Text.Pandoc.JSON
+import Text.Pandoc.Walk
+import Filter
+
+main :: IO ()
+main = toJSONFilter expandMacros
+

app/pandoc.hs

+module Pandoc (pandoc) where
+
+import Text.Pandoc
+import Control.Exception
+
+pandoc :: WriterOptions -> FilePath -> FilePath -> IO ()
+pandoc options inPath outPath = do
+  pandoc <- readFile inPath >>= readMarkdown def
+  writeHtmlString options pandoc >>= writeFile outPath
+

app/slideset-filter.hs

+#!/usr/bin/env runhaskell
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Filter
+import Text.Pandoc.JSON
+
+main :: IO ()
+main = toJSONFilter makeSlides

resource/deck.html

+<!DOCTYPE html>
+<html$if(lang)$ lang="$lang$"$endif$>
+<head>
+  <meta charset="utf-8">
+  <meta name="generator" content="pandoc">
+$for(author-meta)$
+  <meta name="author" content="$author-meta$" />
+$endfor$
+$if(date-meta)$
+  <meta name="dcterms.date" content="$date-meta$" />
+$endif$
+  <title>$if(title-prefix)$$title-prefix$ - $endif$$pagetitle$</title>
+  <meta name="apple-mobile-web-app-capable" content="yes" />
+  <meta name="apple-mobile-web-app-status-bar-style" content="black-translucent" />
+  <meta name="viewport" content="width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=no">
+  <link rel="stylesheet" href="$revealjs-url$/css/reveal.css"/>
+  <style type="text/css">code{white-space: pre;}</style>
+$if(highlighting-css)$
+  <style type="text/css">
+$highlighting-css$
+  </style>
+$endif$
+$if(theme)$
+  <link rel="stylesheet" href="$revealjs-url$/css/theme/$theme$.css" id="theme">
+$else$
+  <link rel="stylesheet" href="$revealjs-url$/css/theme/black.css" id="theme">
+$endif$
+$for(css)$
+  <link rel="stylesheet" href="$css$"/>
+$endfor$
+  <!-- If the query includes 'print-pdf', include the PDF print sheet -->
+  <script>
+    if( window.location.search.match( /print-pdf/gi ) ) {
+      var link = document.createElement( 'link' );
+      link.rel = 'stylesheet';
+      link.type = 'text/css';
+      link.href = '$revealjs-url$/css/print/pdf.css';
+      document.getElementsByTagName( 'head' )[0].appendChild( link );
+    }
+  </script>
+  <!--[if lt IE 9]>
+  <script src="$revealjs-url$/lib/js/html5shiv.js"></script>
+  <![endif]-->
+$if(math)$
+  $math$
+$endif$
+$for(header-includes)$
+  $header-includes$
+$endfor$
+</head>
+<body>
+$for(include-before)$
+$include-before$
+$endfor$
+  <div class="reveal">
+    <div class="slides">
+
+$if(title)$
+<section>
+    <h1 class="title">$title$</h1>
+$if(subtitle)$
+  <h1 class="subtitle">$subtitle$</h1>
+$endif$
+$for(author)$
+    <h2 class="author">$author$</h2>
+$endfor$
+    <h3 class="date">$date$</h3>
+</section>
+$endif$
+$if(toc)$
+<section id="$idprefix$TOC">
+$toc$
+</section>
+$endif$
+
+$body$
+    </div>
+  </div>
+
+  <script src="$revealjs-url$/lib/js/head.min.js"></script>
+  <script src="$revealjs-url$/js/reveal.js"></script>
+
+  <script>
+
+      var sn = false;
+
+      // Full list of configuration options available here:
+      // https://github.com/hakimel/reveal.js#configuration
+      Reveal.initialize({
+        keyboard: {
+            84: function() {
+              sn = !sn;
+              Reveal.configure({ showNotes: sn });
+            }
+        },
+        showNotes: sn,
+        controls: false,         // Display controls in the bottom right corner
+        progress: true,         // Display a presentation progress bar
+        history: $if(history)$$history$$else$true$endif$,          // Push each slide change to the browser history
+        center: $if(center)$$center$$else$true$endif$,                       // Vertical centering of slides
+        maxScale: $if(maxScale)$$maxScale$$else$1.5$endif$,                  // Bounds for smallest/largest possible content scale
+        slideNumber: $if(slideNumber)$true$else$false$endif$,                // Display the page number of the current slide
+        theme: $if(theme)$'$theme$'$else$Reveal.getQueryHash().theme$endif$, // available themes are in /css/theme
+        transition: $if(transition)$'$transition$'$else$Reveal.getQueryHash().transition || 'default'$endif$, // default/cube/page/concave/zoom/linear/fade/none
+
+        // Optional libraries used to extend on reveal.js
+        dependencies: [
+          { src: '$revealjs-url$/lib/js/classList.js', condition: function() { return !document.body.classList; } },
+          { src: '$revealjs-url$/plugin/zoom-js/zoom.js', async: true, condition: function() { return !!document.body.classList; } },
+          { src: '$revealjs-url$/plugin/notes/notes.js', async: true, condition: function() { return !!document.body.classList; } },
+//          { src: '$revealjs-url$/plugin/search/search.js', async: true, condition: function() { return !!document.body.classList; }, }
+//          { src: '$revealjs-url$/plugin/remotes/remotes.js', async: true, condition: function() { return !!document.body.classList; } }
+]});
+  </script>
+  $for(include-after)$
+  $include-after$
+  $endfor$
+  </body>
+</html>