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

Add code block rendering

parent 448af38a
......@@ -29,6 +29,9 @@ main = do
let supportDir = support dirs
let appDataDir = appData dirs
let serverPort = 8888
let serverUrl = "http://0.0.0.0:" ++ (show serverPort)
-- Find sources. These are formulated as actions in the Action mondad, such
-- that each new iteration rescans all possible source files.
let deckSourcesA = globA "**/*-deck.md"
......@@ -78,12 +81,10 @@ main = do
phony "open" $ do
need ["html"]
openBrowser index
return ()
--
phony "server" $ do
need ["watch"]
runHttpServer dirs
openBrowser index
runHttpServer serverPort dirs (Just serverUrl)
--
phony "example" writeExampleProject
--
......@@ -99,11 +100,11 @@ main = do
let src = replaceSuffix "-deck.pdf" "-deck.html" out
need [src]
putNormal $ src ++ " -> " ++ out
runHttpServer dirs
runHttpServer serverPort dirs Nothing
code <-
cmd
"decktape.sh reveal"
("http://localhost:8888" </> makeRelative publicDir src)
(serverUrl </> makeRelative publicDir src)
out
case code of
ExitFailure _ -> throw $ DecktapeException "Unknown."
......
name: decker
version: 0.3.0
version: 0.3.1
synopsis: All inclusive slide deck creation with pandoc.
description: Please see README.md
homepage: https://tramberend.beuth-hochschule.de/decker
......@@ -22,12 +22,13 @@ cabal-version: >=1.10
executable decker
hs-source-dirs: app, src
main-is: decker.hs
other-modules: Action, Cache, Meta, Watch, Embed, Context, Utilities, Filter, Project, Common, Server, Resources, Paths_decker
other-modules: Action, Cache, Meta, Watch, Embed, Context, Utilities, Filter, Project, Common, Server, Resources, Render, Paths_decker
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, Glob
, HTTP
, aeson
, base64-bytestring
, blaze-html
, blaze-markup
, bytestring
......
......@@ -18,6 +18,7 @@ module Action
import Common
import Context
import Control.Exception
import Control.Monad
import Data.IORef
import Data.List as List
import Data.List (isInfixOf)
......@@ -48,15 +49,18 @@ spawn = liftIO . spawnCommand
-- Runs the built-in server on the given directory, if it is not already
-- running. If open is True a browser window is opended.
runHttpServer :: ProjectDirs -> Action ()
runHttpServer dirs = do
runHttpServer :: Int -> ProjectDirs -> Maybe String -> Action ()
runHttpServer port dirs url = do
server <- getServerHandle
case server of
Just _ -> return ()
Nothing -> do
let port = 8888
server <- liftIO $ startHttpServer dirs port
setServerHandle $ Just server
case url of
Just url -> openBrowser url
Nothing -> return ()
openBrowser :: String -> Action ()
openBrowser url = do
......
......@@ -40,8 +40,8 @@ import System.FilePath
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H
((!), audio, div, figure, iframe, img, p, stringTag, toValue,
video, iframe)
((!), audio, div, figure, iframe, iframe, img, p, stringTag,
toValue, video)
import Text.Blaze.Html5.Attributes as A
(alt, class_, height, id, src, style, title, width)
import Text.Pandoc
......@@ -423,7 +423,7 @@ data MediaType
| IframeMedia
uriPathExtension :: String -> String
uriPathExtension path =
uriPathExtension path =
case U.parseRelativeReference path of
Nothing -> takeExtension path
Just uri -> takeExtension (U.uriPath uri)
......@@ -506,3 +506,4 @@ lazyLoadImage (Image (ident, cls, values) inlines (url, tit)) = do
let kvs = ("data-src", url) : [kv | kv <- values, "data-src" /= fst kv]
return (Image (ident, cls, kvs) inlines ("", tit))
lazyLoadImage inline = return inline
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings #-}
module Render
( renderCodeBlocks
) where
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as Map
import Data.Maybe
import qualified Data.Set as Set
import Development.Shake
import System.Exit
import System.Process
import Text.Pandoc
import Text.Pandoc.Walk
-- | Evaluate code blocks
renderCodeBlocks :: Pandoc -> Action Pandoc
renderCodeBlocks pandoc = liftIO $ walkM maybeRenderCodeBlock pandoc
data Processor = Processor
{ command :: String
, args :: [String]
, prelude :: FilePath -> String
}
renderClass = "render"
dotPrelude _ = ""
gnuplotPrelude _ =
"set terminal svg;"
processors =
Map.fromList
[ ("dot", Processor "dot" ["-Tsvg"] dotPrelude)
, ("gnuplot", Processor "gnuplot" ["-d"] gnuplotPrelude)
]
findProcessor :: [String] -> t -> Maybe Processor
findProcessor classes namevals =
if renderClass `elem` classes
then listToMaybe $ Map.elems matching
else Nothing
where
matching = Map.restrictKeys processors (Set.fromList classes)
maybeRenderCodeBlock :: Block -> IO Block
maybeRenderCodeBlock code@(CodeBlock (id, classes, namevals) contents) =
case findProcessor classes namevals of
Just processor -> renderCodeBlock processor code
Nothing -> return code
maybeRenderCodeBlock block = return block
renderCodeBlock (Processor command args prelude) (CodeBlock (id, classes, namevals) contents) = do
result <-
liftIO $ readProcessWithExitCode command args ((prelude "") ++ contents)
case result of
(ExitSuccess, svg, _) ->
return $
Para
[ Image
(id, classes, namevals)
[]
(svgDataUrl svg, "Generated from code block")
]
(ExitFailure exitCode, _, err) ->
return $ Para [Str ("Error running " ++ command ++ ": " ++ err)]
-- | 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)))
......@@ -43,6 +43,7 @@ import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Render
import Filter
import Meta
import Network.URI
......@@ -161,7 +162,7 @@ markdownToHtmlDeck markdownFile out = do
let options =
pandocWriterOpts
{ writerSlideLevel = Just 1
, writerTemplate = Just template
, writerTemplate = Just template
-- , writerStandalone = True
, writerHighlight = True
-- , writerHighlightStyle = pygments
......@@ -217,7 +218,8 @@ readAndPreprocessMarkdown markdownFile disposition = do
versionCheck meta
let method = provisioningFromMeta meta
mapMetaResources (provisionMetaResource method baseDir) pandoc >>=
mapResources (provisionResource method baseDir)
mapResources (provisionResource method baseDir) >>=
renderCodeBlocks
-- Disable automatic caching of remote images for a while
-- >>= walkM (cacheRemoteImages (cache dirs))
......
......@@ -2,4 +2,5 @@ flags: {}
packages:
- '.'
extra-deps:
- containers-0.5.8.1
resolver: lts-9.9
# Slide decks
- [example-deck.html](resource/example/example-deck.html)
# Handouts
- [example-handout.html](resource/example/example-handout.html)
# Supporting Documents
- [title-page.html](exams/templates/catalog/title-page.html)
- [student-title-page.html](exams/templates/exam/student-title-page.html)
- [title-page.html](exams/templates/exam/title-page.html)
- [student-title-page.html](exams/templates/solution/student-title-page.html)
- [title-page.html](exams/templates/solution/title-page.html)
- [example-page.html](resource/example/example-page.html)
- [help-page.html](resource/help-page.html)
\ No newline at end of file
---
history: True
---
# Rendered Code Blocks
Code blocks can be rendered as SVG images
## Formats
- Graphviz (dot)
- Gnuplot
# Embedded Graphviz Code (SVG)
## Highlighted
```` {.dot}
``` {.dot .render width="80%"}
digraph {
node [style = filled]
A {fillcolor = yellowgreen}
A -> B
A -> C
C -> D
C -> E
C -> F
B -> D
}
```
````
###
## Rendered
``` {.dot .render width="80%"}
digraph {
node [style = filled]
A [fillcolor = yellowgreen]
A -> B
A -> C
C -> D
C -> E
C -> F
B -> D
}
```
# Embedded Gnuplot (SVG)
## Highlighted
```` {.gnuplot}
``` {.gnuplot .render width="80%"}
set samples 20, 20
set isosamples 20, 20
set hidden3d back offset 1 trianglepattern 3 undefined 1 altdiagonal bentover
set style data lines
set xrange [ -3.00000 : 3.00000 ] noreverse nowriteback
set yrange [ -2.00000 : 2.00000 ] noreverse nowriteback
DEBUG_TERM_HTIC = 119
DEBUG_TERM_VTIC = 119
splot 1 / (x*x + y*y + 1)
```
````
###
## Rendered
``` {.gnuplot .render}
set samples 20, 20
set isosamples 20, 20
set hidden3d back offset 1 trianglepattern 3 undefined 1 altdiagonal bentover
set style data lines
set xrange [ -3.00000 : 3.00000 ] noreverse nowriteback
set yrange [ -2.00000 : 2.00000 ] noreverse nowriteback
DEBUG_TERM_HTIC = 119
DEBUG_TERM_VTIC = 119
splot 1 / (x*x + y*y + 1)
```
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment