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

First shot at d3 embedding

parent 803bf357
......@@ -6,6 +6,7 @@ public/
cache/
log/
generated/
code/
*-deck.html
*-handout.html
*-page.html
......
before_script:
- stack --version
- stack setup
build:
script:
- stack build
formatting:
script:
bin/check-formatting.sh
\ No newline at end of file
......@@ -58,7 +58,7 @@ main = do
let indexA = return [index] :: Action [FilePath]
let everythingA = decksA <++> handoutsA <++> pagesA
let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
let cruft = ["index.md.generated", "log", "//.shake", "generated"]
let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"]
context <- makeActionContext dirs
runShakeInContext context (options projectDir) $
--
......
......@@ -57,6 +57,7 @@ executable decker
, file-embed
, filepath
, fsnotify
, groom
, hashable
, highlighting-kate
, http-conduit
......@@ -69,7 +70,6 @@ executable decker
, pandoc
, pandoc-citeproc
, pandoc-types
, groom
, process
, pureMD5
, random
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -6,12 +6,15 @@ module Common
, OutputFormat(..)
, Disposition(..)
, MediaType(..)
, Provisioning(..)
, Script(..)
, Decker
, doIO
, needFile
, needFiles
, deckerVersion
, isDevelopmentVersion
, addScript
) where
import Control.Exception
......@@ -21,6 +24,7 @@ import Data.Version (showVersion, versionBranch)
import Development.Shake (Action, need)
import Network.URI as U
import Paths_decker (version)
import System.FilePath.Posix
-- | The version from the cabal file
deckerVersion :: String
......@@ -63,6 +67,9 @@ instance Show DeckerException where
type Decker = StateT DeckerState Action
doIO :: IO a -> Decker a
doIO = lift . liftIO
needFile :: FilePath -> Decker ()
needFile path = lift $ need [path]
......@@ -84,7 +91,7 @@ data DeckerState = DeckerState
data Script
= ScriptURI { scriptLang :: String
, scriptUri :: U.URI }
, scriptUri :: String }
| ScriptSource { scriptLang :: String
, scriptSource :: String }
deriving (Eq, Show, Ord)
......@@ -110,3 +117,10 @@ data MediaType
| AudioMedia
| VideoMedia
| IframeMedia
data Provisioning
= Copy -- Copy to public and relative URL
| SymLink -- Symbolic link to public and relative URL
| Absolute -- Absolute local URL
| Relative -- Relative local URL
deriving (Eq, Show, Read)
......@@ -13,9 +13,13 @@ module Context
, actionContextKey
, getActionContext
, getPublicResource
, withShakeLock
, getRelativeSupportDir
) where
import Control.Monad ()
import Common
import Data.Dynamic
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
......@@ -24,6 +28,8 @@ import Data.Typeable ()
import Development.Shake as Shake
import Project
import Server
import System.FilePath.Posix
import Text.Printf
data ActionContext = ActionContext
{ ctxFilesToWatch :: IORef [FilePath]
......@@ -98,3 +104,14 @@ getPublicResource :: Action Shake.Resource
getPublicResource = do
ctx <- getActionContext
return $ ctxPublicResource ctx
withShakeLock :: Action a -> Action a
withShakeLock action = do
publicResource <- getPublicResource
withResource publicResource 1 action
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
dir <- project <$> getProjectDirs
let support = dir </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from support
module Path
( Path
, publicURIRelativeTo
, makePath
) where
import Common
import Network.URI
data Path = Path
{ absoluteFile :: FilePath
, absolutePublicFile :: FilePath
} deriving (Eq, Show)
publicURIRelativeTo :: FilePath -> Path -> Decker FilePath
makePath :: FilePath -> Decker Path
\ No newline at end of file
......@@ -12,28 +12,22 @@ module Project
, projectDirectories
, provisioningFromMeta
, provisioningFromClasses
, invertPath
, Resource(..)
, Provisioning(..)
, ProjectDirs(..)
) where
import Common
import Data.Maybe
import Development.Shake (Action)
import Extra
import Network.URI
import Resources
import qualified System.Directory as D
import System.FilePath
import System.Posix.Files
import Text.Pandoc.Definition
import Text.Pandoc.Shared
import Resources
data Provisioning
= Copy -- Copy to public and relative URL
| SymLink -- Symbolic link to public and relative URL
| Absolute -- Absolute local URL
| Relative -- Relative local URL
deriving (Eq, Show, Read)
provisioningFromMeta :: Meta -> Provisioning
provisioningFromMeta meta =
......@@ -93,8 +87,8 @@ data ProjectDirs = ProjectDirs
, log :: FilePath
} deriving (Eq, Show)
-- Find the project directory.
-- The project directory is the first upwards directory that contains a .git directory entry.
-- Find the project directory. The project directory is the first upwards
-- directory that contains a .git directory entry.
findProjectDirectory :: IO FilePath
findProjectDirectory = do
cwd <- D.getCurrentDirectory
......
......@@ -19,14 +19,17 @@ import Data.List.Extra
import qualified Data.Map.Lazy as Map
import Data.Maybe
import qualified Data.Set as Set
import Debug.Trace
import Development.Shake
import Extra
import Network.URI
import Project
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath.Posix
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H ((!), canvas, script, toHtml, toValue)
import Text.Blaze.Html5 as H
((!), canvas, div, preEscapedToHtml, script, toHtml, toValue)
import Text.Blaze.Html5.Attributes as A
(alt, class_, height, id, src, style, title, width)
import Text.Pandoc
......@@ -36,13 +39,12 @@ import Text.Printf
-- | Evaluate code blocks
renderCodeBlocks :: Pandoc -> Decker Pandoc
renderCodeBlocks pandoc =
walk maybeRenderImage <$> walkM maybeRenderCodeBlock pandoc
walkM maybeRenderImage pandoc >>= walkM maybeRenderCodeBlock
data Processor = Processor
{ srcExtensions :: [String]
, extension :: String
, compile :: Processor -> String -> Attr -> Decker Inline
} deriving (Show)
{ extension :: String
, compiler :: String -> Attr -> Decker Inline
}
renderClass :: String
renderClass = "render"
......@@ -57,125 +59,122 @@ gnuplotPrelude _ = "set terminal svg;"
processors :: Map.Map String Processor
processors =
Map.fromList
[ ("dot", Processor [".dot"] "" "")
, ("gnuplot", Processor [".gnuplot", ".gpi", ".plt", "gp"] "" "")
, ( "tikz"
, Processor
[".tex", ".latex"]
"\\documentclass{standalone} \\usepackage{tikz} \\usepackage{verbatim} \\begin{document} \\pagestyle{empty}"
"\\end{document}")
[ ("dot", Processor ".dot" (shakeCompile ".svg"))
, ("gnuplot", Processor ".gnuplot" (shakeCompile ".svg"))
, ("tikz", Processor ".tex" (bracketedShakeCompile ".svg" tikzPre tikzPost))
, ("d3", Processor ".js" d3Canvas)
]
-- | Assumes that the code is stored in a file regardless of origin.
process :: Processor -> FilePath -> Attr -> Decker Inline
d3Canvas :: Processor -> FilePath -> Attr -> Decker Inline
d3Canvas processor sourceFile (eid, classes, keyvals) = do
sourceUrl <- provisionResource sourceFile
addScript $ ScriptURI "javascript" "https://d3js.org/d3.v4.min.js"
addScript $ ScriptSource "javascript" sourceFile
return $ RawInline (Format "html") $ renderHtml $ canvas ! A.id (toValue eid)
bracketShakeCompile ::
String -> String -> Processor -> FilePath -> Attr -> Decker Inline
bracketCode preamble postamble processor sourceFile attr = do
let contents = preamble ++ "\n" ++ code ++ "\n" ++ postamble
let path = writeCompiled contents
tikzPre =
"\\documentclass{standalone} \\usepackage{tikz} \\usepackage{verbatim}\n" ++
"\\begin{document} \\pagestyle{empty}"
tikzPost = "\\end{document}"
d3Canvas :: FilePath -> Attr -> Decker Inline
d3Canvas sourceFile (eid, classes, keyvals) = do
needFile sourceFile
base <- gets basePath
supportDir <- lift $ getRelativeSupportDir base
source <- doIO $ readFile sourceFile
addScript $
ScriptURI "javascript" (supportDir </> "d3.v4.min.js")
addScript $ ScriptSource "javascript" source
let element = fromMaybe "svg" $ lookup "element" keyvals
let classStr = intercalate " " classes
case element of
"canvas" ->
return $
RawInline (Format "html") $
renderHtml $
H.canvas ! A.id (toValue eid) ! A.class_ (toValue classStr) $ ""
"div" ->
return $
RawInline (Format "html") $
renderHtml $
H.div ! A.id (toValue eid) ! A.class_ (toValue classStr) $ ""
_ ->
return $
RawInline (Format "html") $
printf "<svg id=\"%v\" class=\"%v\"></svg>" eid classStr
bracketedShakeCompile ::
String -> String -> String -> FilePath -> Attr -> Decker Inline
bracketedShakeCompile extension preamble postamble sourceFile attr = do
source <- doIO $ readFile sourceFile
let bracketed = preamble ++ "\n" ++ source ++ "\n" ++ postamble
codePath <- writeCodeIfChanged bracketed (takeExtension sourceFile)
let path = codePath <.> extension
needFile path
return $ Image attr [] (path, "")
shakeCompile :: Processor -> FilePath -> Attr -> Decker Inline
shakeCompile processor sourceFile attr =
shakeCompile :: String -> FilePath -> Attr -> Decker Inline
shakeCompile extension sourceFile attr = do
let path = sourceFile <.> extension
needFile path
return $ Image attr [] (path, "")
-- | Calculates the list of all known file extensions that can be rendered into
-- an SVG image.
renderedCodeExtensions :: [String]
renderedCodeExtensions =
Map.foldr (\p es -> (srcExtensions p) ++ es) [] processors
renderedCodeExtensions = [".dot", ".gnuplot", ".tex", ".js"]
-- | Selects a processor based on a list of CSS class names. The first processor
-- that is mentioned in that list is returned.
findProcessor :: [String] -> Maybe Processor
findProcessor classes =
if renderClass `elem` classes
then listToMaybe $ Map.elems matching
else Nothing
findProcessor classes
| "render" `elem` classes = listToMaybe $ Map.elems matching
where
matching = Map.restrictKeys processors (Set.fromList classes)
-- | Generates a unique pathname in `/generated` with the given file extension
codeFilePath :: String -> Decker FilePath
codeFilePath extension =
let crc = printf "%08x" (calc_crc32 code)
let basepath =
"generated" </>
(concat $ intersperse "-" [defaultString "code" basename, crc])
-- | Extracts a file containing the original source code from an rendered image
-- URL. Just returns the url.
extractCodeFromImage :: Inline -> Decker FilePath
extractCodeFromImage (Image _ _ (url, _)) = return url
-- | Extracts the source code from a code block to a file in the /generated
-- directory.
extractCodeFromBlock :: Block -> Decker FilePath
findProcessor _ = Nothing
-- | Appends `.svg` to file urls with extensions that belong to a known render
-- processor. The dependeny for the new file url is established at a later
-- stage, along with the handling of the normal image file urls.
maybeRenderImage :: Inline -> Inline
maybeRenderImage image@(Image (id, classes, namevals) inlines (url, title)) =
if takeExtension url `elem` [".dot", ".gnuplot", ".tex"]
then let svgFile = url <.> "svg"
in Image (id, classes, namevals) inlines (svgFile, title)
else image
maybeRenderImage inline = inline
-- stage, along with the handling of the normal image file urls. TODO: Fetch and
-- cache remote URLs here. For now, assume local urls.
maybeRenderImage :: Inline -> Decker Inline
maybeRenderImage image@(Image attr@(id, classes, namevals) inlines (url, title)) =
case findProcessor classes of
Just processor -> do
(compiler processor) url attr
Nothing -> return image
maybeRenderImage inline = return inline
maybeRenderCodeBlock :: Block -> Decker Block
maybeRenderCodeBlock code@(CodeBlock (id, classes, namevals) contents) =
maybeRenderCodeBlock block@(CodeBlock attr@(eid, classes, namevals) code) =
case findProcessor classes of
Just processor -> do
svgFile <- extractCodeIfChanged "" processor contents
return $
Para
[ Image
(id, classes, namevals)
[]
(svgFile, "Generated from embedded code block")
]
Nothing -> return code
path <- writeCodeIfChanged code (extension processor)
inline <- (compiler processor) path attr
return $ Plain [inline]
Nothing -> return block
maybeRenderCodeBlock block = return block
{--
provideResources namevals = do
case lookup "resources" namevals of
Just resources -> do
method <- gets provisioning
--}
-- | 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)))
extractCodeIfChanged :: String -> Processor -> FilePath -> Decker FilePath
extractCodeIfChanged basename processor code = do
writeCodeIfChanged :: String -> String -> Decker FilePath
writeCodeIfChanged code extension = do
projectDir <- project <$> (lift $ getProjectDirs)
let crc = printf "%08x" (calc_crc32 code)
let basepath =
"generated" </>
(concat $ intersperse "-" [defaultString "code" basename, crc])
let extension = (head . srcExtensions) processor
let sourceFile = projectDir </> basepath <.> extension
let svgFile = projectDir </> basepath <.> extension <.> ".svg"
publicResource <- lift $ getPublicResource
let basepath = "code" </> (concat $ intersperse "-" ["code", crc])
let path = projectDir </> basepath <.> extension
lift $
withResource publicResource 1 $
withShakeLock $
liftIO $
unlessM (System.Directory.doesFileExist svgFile) $ do
createDirectoryIfMissing True (takeDirectory sourceFile)
writeFile
sourceFile
((preamble processor) ++ "\n" ++ code ++ "\n" ++ (postamble processor))
needFile svgFile
return svgFile
defaultString :: String -> String -> String
defaultString d str
| null str = d
defaultString _ str = str
unlessM (System.Directory.doesFileExist path) $ do
createDirectoryIfMissing True (takeDirectory path)
writeFile path code
return path
appendScripts :: Pandoc -> Decker Pandoc
appendScripts pandoc@(Pandoc meta blocks) = do
......@@ -189,7 +188,9 @@ appendScripts pandoc@(Pandoc meta blocks) = do
renderScript (ScriptURI lang uri) =
RawBlock (Format "html") $
renderHtml $
H.script ! class_ "generated decker" ! src (toValue $ show uri) $ ""
renderScript (ScriptSource lang source) =
H.script ! class_ "generated decker" ! src (toValue uri) $ ""
renderScript (ScriptSource lang source) = do
RawBlock (Format "html") $
renderHtml $ H.script ! class_ "generated decker" $ toHtml source
printf "<script class=\"generated decker\">%s</script>" source
-- renderHtml $
-- H.script ! class_ "generated decker" $ preEscapedToHtml source
......@@ -14,7 +14,6 @@ module Utilities
, metaValueAsString
, (<++>)
, writeEmbeddedFiles
, getRelativeSupportDir
, pandocMakePdf
, fixMustacheMarkup
, fixMustacheMarkupText
......@@ -29,7 +28,8 @@ import Control.Arrow
import Control.Exception
import Control.Monad
import Control.Monad.Loops
import Control.Monad.Trans.Class
import Control.Monad.State
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.HashMap.Lazy as HashMap
......@@ -147,24 +147,14 @@ substituteMetaData text metaData = do
getTemplate :: FilePath -> Action String
getTemplate path = liftIO $ getResourceString ("template" </> path)
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
dirs <- getProjectDirs
return $
invertPath (makeRelative (public dirs) (takeDirectory from)) </>
makeRelative (public dirs) (support dirs)
invertPath :: FilePath -> FilePath
invertPath fp = joinPath $ map (const "..") $ filter ("." /=) $ splitPath fp
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
putCurrentDocument out
supportDirRel <- getRelativeSupportDir out
supportDir <- support <$> getProjectDirs
template <- getTemplate "deck.html"
need [supportDir </> "decker.css"]
supportDirRel <- getRelativeSupportDir (takeDirectory out)
template <- getTemplate "deck.html"
let options =
pandocWriterOpts
{ writerSlideLevel = Just 1
......@@ -218,7 +208,7 @@ versionCheck meta =
-- template variables and calls need.
readAndProcessMarkdown :: FilePath -> Disposition -> Action Pandoc
readAndProcessMarkdown markdownFile disposition = do
Pandoc meta blocks <-
pandoc@(Pandoc meta blocks) <-
readMetaMarkdown markdownFile >>= processIncludes baseDir
processPandoc pipeline baseDir disposition (provisioningFromMeta meta) pandoc
where
......@@ -226,10 +216,10 @@ readAndProcessMarkdown markdownFile disposition = do
pipeline =
concatM
[ expandDeckerMacros
, provisionResources
, renderCodeBlocks
, provisionResources
, renderMediaTags
, makeSlides
, renderCodeBlocks
, processCitesWithDefault
, appendScripts
]
......@@ -237,10 +227,12 @@ readAndProcessMarkdown markdownFile disposition = do
-- >>= walkM (cacheRemoteImages (cache dirs))
provisionResources :: Pandoc -> Decker Pandoc
provisionResources pandoc =
lift $
mapMetaResources provisionMetaResource pandoc >>=
mapResources provisionResource
provisionResources pandoc@(Pandoc meta blocks) = do
base <- gets basePath
method <- gets provisioning
lift $
mapMetaResources (provisionMetaResource base method) pandoc >>=
mapResources (provisionResource base method)
lookupBool :: String -> Bool -> Meta -> Bool
lookupBool key def meta =
......@@ -248,19 +240,17 @@ lookupBool key def meta =
Just (MetaBool b) -> b
_ -> def
provisionMetaResource :: (String, FilePath) -> Decker FilePath
provisionMetaResource (key, path)
provisionMetaResource :: FilePath -> Provisioning -> (String, FilePath) -> Action FilePath
provisionMetaResource base method (key, path)
| key `elem` runtimeMetaKeys = do
base <- gets basePath
filePath <- lift $ urlToFilePathIfLocal base path
provisionResource filePath
provisionMetaResource (key, path)
filePath <- urlToFilePathIfLocal base path
provisionResource base method filePath
provisionMetaResource base method (key, path)
| key `elem` compiletimeMetaKeys = do
base <- gets basePath
filePath <- urlToFilePathIfLocal base path
need [filePath]
return filePath
provisionMetaResource (key, path) = return path
provisionMetaResource base method (key, path) = return path
-- | Determines if a URL can be resolved to a local file. Absolute file URLs are
-- resolved against and copied or linked to public from
......@@ -277,21 +267,18 @@ provisionMetaResource (key, path) = return path
-- time.
--
-- Returns a public URL relative to base
provisionResource :: FilePath -> Decker FilePath
provisionResource path = do
base <- gets basePath
method <- gets provisioning
provisionResource :: FilePath -> Provisioning -> FilePath -> Action FilePath
provisionResource base method path = do
case parseRelativeReference path of
Nothing -> return path
Just uri -> do
dirs <- lift $ getProjectDirs
dirs <- getProjectDirs
need [uriPath uri]
let resource = resourcePathes dirs base uri
publicResource <- getPublicResource
withResource publicResource 1 $
lift $
liftIO $
case provisioning of
case method of
Copy -> copyResource resource
SymLink -> linkResource resource
Absolute -> absRefResource resource
......@@ -307,7 +294,7 @@ putCurrentDocument out = do
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
putCurrentDocument out
supportDir <- getRelativeSupportDir out
supportDir <- getRelativeSupportDir (takeDirectory out)
template <- getTemplate "page.html"
let options =
pandocWriterOpts
......@@ -348,7 +335,7 @@ pandocMakePdf options out pandoc = do
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
putCurrentDocument out
supportDir <- getRelativeSupportDir out
supportDir <- getRelativeSupportDir (takeDirectory out)
template <- getTemplate "handout.html"
let options =
pandocWriterOpts
......
......@@ -12,8 +12,9 @@ import Render
import System.FSNotify
import System.FilePath
-- | Wait for something to happen on one of the matching files
-- in one of the supplied directories.
-- | Wait for something to happen on one of the matching files in one of the
-- supplied directories. TODO: Get rid of the twitchExtensions. Watch
-- everything, except the public dir.
waitForTwitch :: [FilePath] -> IO FilePath
waitForTwitch directories = do
done <- newEmptyMVar
......@@ -32,7 +33,7 @@ waitForTwitch directories = do