Commit 834cd279 authored by Jan-Philipp Stauffert's avatar Jan-Philipp Stauffert
Browse files

Merge branch 'master' into 102-fix-zip

parents b12ffc9a 72c44758
......@@ -29,4 +29,5 @@ resource/support/**
*.cabal
test/decks/*.svg
dist/
node_modules
\ No newline at end of file
node_modules
sketch-pad-index.yaml
\ No newline at end of file
......@@ -34,7 +34,7 @@ main :: IO ()
main = do
when isDevelopmentVersion $
printf
"WARNING: You are running a development build of decker (version: %s, branch: %s, commit: %s, tag: %s). Please make sure that you know what you're doing.\n"
"WARNING: You are running a development build of decker (version: %s, branch: %s, commit: %s, tag: %s). Please be sure that you know what you're doing.\n"
deckerVersion
deckerGitBranch
deckerGitCommitId
......@@ -94,12 +94,23 @@ main = do
--
phony "example" $ liftIO writeExampleProject
--
phony "sketch-pad-index" $ do
indicesA >>= need
indicesA >>= writeSketchPadIndex ((directories ^. public) </> "sketch-pad.yaml")
--
phony "index" $ need ["support", index]
--
priority 2 $
"//*-deck.html" %> \out -> do
src <- calcSource "-deck.html" "-deck.md" out
markdownToHtmlDeck src out
let ind = replaceSuffix "-deck.html" "-deck-index.yaml" out
markdownToHtmlDeck src out ind
--
priority 2 $
"//*-deck-index.yaml" %> \ind -> do
src <- calcSource "-deck-index.yaml" "-deck.md" ind
let out = replaceSuffix "-deck-index.yaml" "-deck.html" ind
markdownToHtmlDeck src out ind
--
priority 2 $
"//*-deck.pdf" %> \out -> do
......
project-name: Decker
provisioning: Copy
exclude-directories:
- app
......
......@@ -78,6 +78,7 @@ dependencies:
- snap-core
- snap-server
- split
- tagsoup
- template-haskell
- temporary
- text
......
$if(titleblock)$
$titleblock$
$endif$
$for(header-includes)$
$header-includes$
$endfor$
$for(include-before)$
$include-before$
$endfor$
$if(toc)$
$table-of-contents$
$endif$
$body$
$for(include-after)$
$include-after$
$endfor$
......@@ -30,10 +30,6 @@
<link rel="stylesheet" href="$decker-support-dir$/handout.css">
<script src="$decker-support-dir$/handout.js"></script>
<!-- $if(math)$ $math$ $endif$ -->
<!--[if lt IE 9]>
<script src="//cdnjs.cloudflare.com/ajax/libs/html5shiv/3.7.3/html5shiv-printshiv.min.js"></script>
<![endif]-->
<script>
var socket = new WebSocket("ws://" + location.host + "/reload");
socket.onmessage = function () {
......
......@@ -107,10 +107,6 @@
}
</style>
$if(math)$ $math$ $endif$
<!--[if lt IE 9]>
<script src="//cdnjs.cloudflare.com/ajax/libs/html5shiv/3.7.3/html5shiv-printshiv.min.js"></script>
<![endif]-->
<script>
var socket = new WebSocket("ws://" + location.host + "/reload");
socket.onmessage = function () {
......
......@@ -6,3 +6,64 @@ require('bootstrap/dist/css/bootstrap.css');
document.addEventListener('load', () => {
$('table').addClass("table table-striped table-bordered table-hover table-condensed table-responsive");
});
// Webpack handling of MathJax copied from
// https://github.com/mathjax/mathjax-v3/wiki/A-first-usable-demo-(using-webpack)
// the MathJax core
const MathJax = require("mathjax3/mathjax3/mathjax.js").MathJax;
// MathML input
const TeX = require("mathjax3/mathjax3/input/tex.js").TeX;
// HTML output
const CHTML = require("mathjax3/mathjax3/output/chtml.js").CHTML;
// Use browser DOM
const adaptor = require("mathjax3/mathjax3/adaptors/browserAdaptor").browserAdaptor();
// Register the HTML document handler
require("mathjax3/mathjax3/handlers/html.js").RegisterHTMLHandler(adaptor);
require("mathjax3/mathjax3/input/tex/ams/AmsConfiguration.js");
require("mathjax3/mathjax3/input/tex/base/BaseConfiguration.js");
require("mathjax3/mathjax3/input/tex/ams/AmsConfiguration.js");
require("mathjax3/mathjax3/input/tex/noundefined/NoUndefinedConfiguration.js");
require("mathjax3/mathjax3/input/tex/newcommand/NewcommandConfiguration.js");
require("mathjax3/mathjax3/input/tex/boldsymbol/BoldsymbolConfiguration.js");
require("mathjax3/mathjax3/input/tex/braket/BraketConfiguration.js");
require("mathjax3/mathjax3/input/tex/mhchem/MhchemConfiguration.js");
require("mathjax3/mathjax3/input/tex/physics/PhysicsConfiguration.js");
require("mathjax3/mathjax3/input/tex/verb/VerbConfiguration.js");
require("mathjax3/mathjax3/input/tex/cancel/CancelConfiguration.js");
require("mathjax3/mathjax3/input/tex/enclose/EncloseConfiguration.js");
// initialize mathjax with with the browser DOM document; other documents are possible
const html = MathJax.document(document, {
InputJax: new TeX({
inlineMath: [["$", "$"], ["\\(", "\\)"]],
packages: [
"base",
"ams",
"noundefined",
"newcommand",
"boldsymbol",
"braket",
"mhchem",
"physics",
"verb",
"cancel",
"enclose"
]
}),
OutputJax: new CHTML({
fontURL:
"https://cdn.rawgit.com/mathjax/mathjax-v3/3.0.0-alpha.4/mathjax2/css/"
})
});
window.addEventListener("load", function() {
console.time("wrapper");
// process the document
html
.findMath()
.compile()
.getMetrics()
.typeset()
.updateDocument();
console.timeEnd("wrapper");
});
......@@ -31,6 +31,7 @@ module Common
, handoutHTMLSuffix
, handoutPDFSuffix
, metaSuffix
, indexSuffix
, sourceSuffixes
, unique
, time
......@@ -198,4 +199,6 @@ handoutPDFSuffix = "-handout.pdf"
metaSuffix = "-meta.yaml"
sourceSuffixes = [deckSuffix, pageSuffix]
indexSuffix = "-deck-index.yaml"
sourceSuffixes = [deckSuffix, pageSuffix, indexSuffix]
......@@ -2,6 +2,7 @@ module CompileTime
( lookupGitBranch
, lookupGitCommitId
, lookupGitTag
, git
) where
import Control.Monad
......
......@@ -14,10 +14,10 @@ module External
import Control.Exception
import Data.Maybe
import Development.Shake
import Exception
import System.Console.ANSI
import System.Exit
import System.Process
import Exception
data ExternalProgram = ExternalProgram
{ options :: [CmdOption]
......@@ -95,6 +95,7 @@ programs =
]
type Program = [String] -> Action ()
type Program' = [String] -> Action String
ssh :: Program
ssh = makeProgram "ssh"
......@@ -142,6 +143,22 @@ makeProgram name =
ExternalException $
"\n" ++ help external ++ "\n\n" ++ err ++ "\n\n" ++ out)
makeProgram' :: String -> ([String] -> Action String)
makeProgram' name =
let external = fromJust $ lookup name programs
in (\arguments -> do
(Exit code, Stdout out, Stderr err) <-
command
(options external)
(path external)
(args external ++ arguments)
case code of
ExitSuccess -> return out
ExitFailure _ ->
throw $
ExternalException $
"\n" ++ help external ++ "\n\n" ++ err ++ "\n\n" ++ out)
checkProgram :: String -> Action Bool
checkProgram name =
liftIO $
......
......@@ -20,6 +20,8 @@ module Filter
import Common
import Control.Exception
import Exception
import Sketch
import Slide
import Control.Applicative
import Control.Lens
......@@ -31,8 +33,6 @@ import Data.List
import Data.List.Extra (for)
import Data.List.Split
import Data.Maybe
-- import Data.Tuple.Select
import Development.Shake (Action)
import Network.HTTP.Conduit hiding (InternalException)
import Network.HTTP.Simple
......@@ -60,12 +60,6 @@ import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Read hiding (lift)
-- A slide has maybe a header followed by zero or more blocks.
data Slide = Slide
{ _header :: Maybe Block
, _body :: [Block]
} deriving (Eq, Show)
processPandoc ::
(Pandoc -> Decker Pandoc)
-> FilePath
......@@ -168,34 +162,6 @@ layoutSlide slide@(Slide (Just header) body) = do
Disposition _ _ -> return slide
layoutSlide slide = return slide
-- | A lens for header access on a slide. See
-- https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/a-little-lens-starter-tutorial
header :: Lens' Slide (Maybe Block)
header = lens (\(Slide h _) -> h) (\(Slide _ b) h -> (Slide h b))
-- | A lens for blocks access on a slide.
blocks :: Lens' Slide [Block]
blocks = lens (\(Slide _ b) -> b) (\(Slide h _) b -> (Slide h b))
-- | A Prism for slides
_Slide :: Prism' Slide (Maybe Block, [Block])
_Slide = prism' (uncurry Slide) (\(Slide h b) -> Just (h, b))
-- | Attributes of a slide are those of the header
instance HasAttr Slide where
attributes f (Slide (Just (Header n a s)) b) =
fmap (\a' -> Slide (Just (Header n a' s)) b) (f a)
attributes _ x = pure x
-- | Attributes of a list of blocks are those of the first block.
instance HasAttr [Block] where
attributes f (b:bs) =
fmap (\a' -> set attributes a' b : bs) (f (view attributes b))
attributes _ x = pure x
hasClass :: HasAttr a => String -> a -> Bool
hasClass which = elem which . view (attributes . attrClasses)
hasAnyClass :: HasAttr a => [String] -> a -> Bool
hasAnyClass which = isJust . firstClass which
......@@ -317,44 +283,6 @@ wrapBoxes slide@(Slide header body) = do
]
wrap box = box
isSlideSeparator :: Block -> Bool
isSlideSeparator (Header 1 _ _) = True
isSlideSeparator HorizontalRule = True
isSlideSeparator _ = False
-- Converts blocks to slides. Slides start at H1 headers or at horizontal rules.
-- A horizontal rule followed by a H1 header collapses to one slide.
toSlides :: [Block] -> [Slide]
toSlides blocks = map extractHeader $ filter (not . null) slideBlocks
where
slideBlocks =
split (keepDelimsL $ whenElt isSlideSeparator) $ killEmpties blocks
-- Deconstruct a list of blocks into a Slide
extractHeader (header@(Header 1 _ _):bs) = Slide (Just header) bs
extractHeader (HorizontalRule:bs) = extractHeader bs
extractHeader blocks = Slide Nothing blocks
-- Remove redundant slide markers
killEmpties (HorizontalRule:header@Header {}:blocks) =
header : killEmpties blocks
killEmpties (b:bs) = b : killEmpties bs
killEmpties [] = []
-- Render slides as a list of Blocks. Always separate slides with a horizontal
-- rule. Slides with the `notes` classes are wrapped in ASIDE and
-- are used as spreaker notes by RevalJs.
fromSlides :: [Slide] -> [Block]
fromSlides = concatMap prependHeader
where
prependHeader (Slide (Just header) body)
| hasClass "notes" header =
[RawBlock "html" "<aside class=\"notes\">"] ++
demoteHeaders (header : body) ++
[RawBlock "html" "</aside>"]
prependHeader (Slide (Just header) body) = HorizontalRule : header : body
prependHeader (Slide Nothing body) = HorizontalRule : body
demoteHeaders = traverse . _Header . _1 +~ 1
-- | Map over all active slides in a deck.
mapSlides :: (Slide -> Decker Slide) -> Pandoc -> Decker Pandoc
mapSlides action (Pandoc meta blocks) = do
......
This diff is collapsed.
......@@ -11,6 +11,7 @@ module Meta
import Common
import Exception
import Markdown
import Control.Arrow
import Control.Exception
......@@ -45,7 +46,7 @@ toMustacheMeta (MetaBlocks blocks) =
writeMarkdownText :: WriterOptions -> Pandoc -> T.Text
writeMarkdownText options pandoc =
case runPure $ writeMarkdown options pandoc of
case runPure $ Markdown.writeMarkdown options pandoc of
Right text -> text
Left err -> throw $ PandocException $ show err
......
......@@ -61,6 +61,7 @@ data Targets = Targets
, _pagesPdf :: [FilePath]
, _handouts :: [FilePath]
, _handoutsPdf :: [FilePath]
, _indices :: [FilePath]
} deriving (Show)
makeLenses ''Targets
......@@ -243,6 +244,7 @@ scanTargets exclude suffixes dirs = do
, _pagesPdf = sort $ calcTargets pageSuffix pagePDFSuffix srcs
, _handouts = sort $ calcTargets deckSuffix handoutHTMLSuffix srcs
, _handoutsPdf = sort $ calcTargets deckSuffix handoutPDFSuffix srcs
, _indices = sort $ calcTargets deckSuffix indexSuffix srcs
}
where
calcTargets :: String -> String -> [(String, [FilePath])] -> [FilePath]
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Shake
( runDecker
, getRelativeSupportDir
, watchChangesAndRepeat
, openBrowser
, startHttpServer
, stopHttpServer
, runHttpServer
, withShakeLock
, allHtmlA
, allPdfA
, appDataA
, cacheA
, calcSource
, projectDirsA
, metaA
, targetsA
, decksA
, decksPdfA
, pagesA
, pagesPdfA
, getRelativeSupportDir
, handoutsA
, handoutsPdfA
, allHtmlA
, allPdfA
, loggingA
, metaA
, indicesA
, openBrowser
, pagesA
, pagesPdfA
, projectA
, projectDirsA
, publicA
, cacheA
, supportA
, appDataA
, loggingA
, publicResourceA
, runHttpServer
, startHttpServer
, stopHttpServer
, supportA
, targetsA
, watchChangesAndRepeat
, writeDeckIndex
, writeSketchPadIndex
, withShakeLock
) where
import Common
import CompileTime
import Exception
import Glob
import Meta
import Project
import Server
import Sketch
import Control.Concurrent
import Control.Exception
import Control.Lens
import Control.Lens.Combinators
import Control.Monad
import Data.Aeson as Json
import Data.Aeson.Lens
import Data.Dynamic
import qualified Data.HashMap.Strict as HashMap
import Data.IORef
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text as T
import Data.Text.Lens
import Data.Typeable
import Data.Yaml as Yaml
import Debug.Trace
import Development.Shake
import Development.Shake as Shake
( Action
......@@ -66,6 +76,11 @@ import qualified System.FSNotify as Notify
import System.FilePath
import System.Info
import System.Process
import Text.Pandoc
import Text.Pandoc.Lens as P
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Printf
instance Show (IORef a) where
show _ = "IORef"
......@@ -81,7 +96,7 @@ makeLenses ''MutableActionState
data ActionContext = ActionContext
{ _dirs :: ProjectDirs
, _targetList :: Targets
, _meta :: Yaml.Value
, _metaData :: Yaml.Value
, _state :: MutableActionState
} deriving (Typeable, Show)
......@@ -108,7 +123,7 @@ runShakeOnce state rules = do
forM_ server reloadClients
keepWatching <- readIORef (state ^. watch)
when keepWatching $ do
let exclude = excludeDirs (context ^. meta)
let exclude = excludeDirs (context ^. metaData)
inDirs <- fastGlobDirs exclude (context ^. dirs . project)
waitForChange inDirs
return keepWatching
......@@ -150,7 +165,6 @@ deckerShakeOptions ctx = do
, shakeColor = True
, shakeExtra = HashMap.insert actionContextKey (toDyn ctx) HashMap.empty
, shakeThreads = cores
-- , shakeLiveFiles = ["shakeLiveFiles.txt"]
, shakeAbbreviations =
[ (ctx ^. dirs . project ++ "/", "")
, (ctx ^. dirs . public ++ "/", "")
......@@ -187,14 +201,100 @@ getRelativeSupportDir from = do
let sup = pub </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from sup
writeDeckIndex :: FilePath -> FilePath -> Pandoc -> Action Pandoc
writeDeckIndex markdownFile out pandoc@(Pandoc meta _) = do
context <- actionContext
branch <- liftIO $ gitT ["rev-parse", "--abbrev-ref", "HEAD"]
commit <- liftIO $ gitT ["rev-parse", "--short", "HEAD"]
gitUrl <- liftIO $ gitT ["remote", "get-url", "--push", "origin"]
let proj = context ^. dirs . project
let publ = context ^. dirs . public
let title = metaP pandoc "title"
let subtitle = metaP pandoc "subtitle"
let indexUrl = T.pack $ "/" </> makeRelative publ out
let sourceDir = T.pack $ makeRelative proj $ takeDirectory markdownFile
let sourceFile = T.pack $ makeRelative proj markdownFile
let slides =
[ object
[ ("id", String $ T.strip $ T.pack i)
, ("title", String $ T.strip $ T.pack t)
]
| (i, t) <- query headers pandoc
]
let yaml =
object
[ ("commit-id", String commit)
, ("branch", String branch)
, ("index-url", String indexUrl)
, ("repository-url", String gitUrl)
, ("source-directory", String sourceDir)
, ("source-file", String sourceFile)
, ("title", String title)
, ("subtitle", String subtitle)
, ("slides", array slides)
]
liftIO $ Yaml.encodeFile out yaml
liftIO $ Json.encodeFile (out -<.> "json") yaml
return pandoc
where
headers (Header 1 (id@(_:_), _, _) text) = [(id, stringify text)]
headers _ = []
gitT args = T.strip . T.pack . fromMaybe "<empty>" <$> git args
metaP p k = T.strip $ T.pack $ stringify (p ^? meta k . _MetaInlines)
writeSketchPadIndex :: FilePath -> [FilePath] -> Action ()
writeSketchPadIndex out indexFiles = do
context <- actionContext
branch <- liftIO $ gitT ["rev-parse", "--abbrev-ref", "HEAD"]
commit <- liftIO $ gitT ["rev-parse", "--short", "HEAD"]
gitUrl <- liftIO $ gitT ["remote", "get-url", "--push", "origin"]
let proj = context ^. dirs . project
let publ = context ^. dirs . public
decks <-
liftIO $ catMaybes <$>
mapM (analyseDeckIndex (takeDirectory out)) indexFiles
let yaml =
object
[ ("commit-id", String commit)
, ("branch", String branch)
, ("repository-url", String gitUrl)
, ("decks", array decks)
]
liftIO $ Yaml.encodeFile out yaml
liftIO $ Json.encodeFile (out -<.> "json") yaml
deckEntry :: FilePath -> T.Text -> T.Text -> Yaml.Value
deckEntry path title subtitle =
object
[ ("path", String $ T.pack path)
, ("title", String title)
, ("subtitle", String subtitle)
]
analyseDeckIndex :: FilePath -> FilePath -> IO (Maybe Yaml.Value)
analyseDeckIndex relDir indexFile = do
result <-
Yaml.decodeFileEither indexFile :: IO (Either Yaml.ParseException Yaml.Value)
return $
case result of
Right yaml -> do
let slides = yaml ^. key "slides" . _Array
if not (null slides)
then Just $
deckEntry
(makeRelative relDir indexFile)
(yaml ^. key "title" . _String)
(yaml ^. key "subtitle" . _String)
else Nothing
Left e -> error $ "No fucking luck: " ++ show e ++ indexFile
publicResourceA = _publicResource . _state <$> actionContext
projectDirsA :: Action ProjectDirs
projectDirsA = _dirs <$> actionContext
metaA :: Action Yaml.Value
metaA = _meta <$> actionContext
projectA :: Action FilePath
projectA = _project <$> projectDirsA
......@@ -216,7 +316,9 @@ loggingA = _logging <$> projectDirsA
targetsA :: Action Targets
targetsA = _targetList <$> actionContext
metaDataA = _meta <$> actionContext
metaA = _metaData <$> actionContext
indicesA = _indices <$> targetsA
decksA :: Action [FilePath]
decksA = _decks <$> targetsA
......@@ -256,7 +358,7 @@ withShakeLock perform = do
-- running.
runHttpServer :: Int -> ProjectDirs -> Maybe String -> Action ()
runHttpServer port dirs url = do
ref <- (_server . _state) <$> actionContext
ref <- _server . _state <$> actionContext
server <- liftIO $ readIORef ref
case server of
Just _ -> return ()
......@@ -275,7 +377,7 @@ openBrowser url =
reloadBrowsers :: Action ()
reloadBrowsers = do
ref <- (_server . _state) <$> actionContext
ref <- _server . _state <$> actionContext
server <- liftIO $ readIORef ref
case server of
Just serv -> liftIO $ reloadClients serv
......