Commit f9d4607b authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Inital commit

parents
.DS_Store/
.stack-work/
TAGS
*.swp
server.log
generated-index.md
generated-index.html
index.html
*-deck.html
*-handout.html
*-page.html
import Distribution.Simple
main = defaultMain
{-# 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"}
#!/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))
#!/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)))
#!/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
#!/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
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Text.Pandoc.Definition
import Text.Pandoc.JSON
import Text.Pandoc.Walk
import Filter
main :: IO ()
main = toJSONFilter expandMacros
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
#!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Filter
import Text.Pandoc.JSON
main :: IO ()
main = toJSONFilter makeSlides
<!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>
---
theme: htr-slides
author: Henrik Tramberend