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

Generate slide ids and write back markdown

parent 32a8c602
$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$
......@@ -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
......
{-- 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
, markForWriteBack
, metaA
, openBrowser
, pagesA
, pagesPdfA
, projectA
, projectDirsA
, publicA
, cacheA
, supportA
, appDataA
, loggingA
, publicResourceA
, runHttpServer
, startHttpServer
, stopHttpServer
, supportA
, targetsA
, watchChangesAndRepeat
, withShakeLock
) where
import Common
......@@ -35,6 +36,7 @@ import Glob
import Meta
import Project
import Server
import Sketch
import Control.Concurrent
import Control.Exception
......@@ -66,6 +68,7 @@ import qualified System.FSNotify as Notify
import System.FilePath
import System.Info
import System.Process
import Text.Pandoc
instance Show (IORef a) where
show _ = "IORef"
......@@ -74,6 +77,7 @@ data MutableActionState = MutableActionState
{ _server :: IORef (Maybe Server)
, _watch :: IORef Bool
, _publicResource :: Shake.Resource
, _writeBack :: IORef [(FilePath, Pandoc)]
} deriving (Show)
makeLenses ''MutableActionState
......@@ -90,8 +94,9 @@ makeLenses ''ActionContext
initMutableActionState = do
server <- newIORef Nothing
watch <- newIORef False
writeBack <- newIORef []
public <- newResourceIO "public" 1
return $ MutableActionState server watch public
return $ MutableActionState server watch public writeBack
runDecker :: Rules () -> IO ()
runDecker rules = do
......@@ -106,6 +111,7 @@ runShakeOnce state rules = do
catch (shakeArgs options rules) (putError "Error: ")
server <- readIORef (state ^. server)
forM_ server reloadClients
writeBackMarkdown state
keepWatching <- readIORef (state ^. watch)
when keepWatching $ do
let exclude = excludeDirs (context ^. meta)
......@@ -187,6 +193,19 @@ getRelativeSupportDir from = do
let sup = pub </> ("support" ++ "-" ++ deckerVersion)
return $ makeRelativeTo from sup
markForWriteBack :: FilePath -> Pandoc -> Action ()
markForWriteBack filepath pandoc = do
putNormal $ "marked for write back: (" ++ filepath ++ ")"
ref <- _writeBack . _state <$> actionContext
liftIO $ modifyIORef ref ((:) (filepath, pandoc))
writeBackMarkdown :: MutableActionState -> IO ()
writeBackMarkdown state = do
let ref = _writeBack state
writeBack <- readIORef ref
mapM_ (uncurry writeToMarkdownFile) writeBack
writeIORef ref []
publicResourceA = _publicResource . _state <$> actionContext
projectDirsA :: Action ProjectDirs
......@@ -256,7 +275,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 +294,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
......
module Sketch
( randomId
, writeToMarkdownFile
, provideSlideIds
, provideSlideId
, provideSlideIdIO
, idDigits
) where
import Common
import Resources
import Slide
import Control.Monad
import qualified Data.Text.IO as T
import System.FilePath
import System.Random
import Text.Pandoc
import Text.Pandoc.Shared
idDigits = 4
-- | Selects a random id out of idDigits^36 possibilities
randomId :: IO String
randomId = ('s' :) <$> replicateM idDigits randomChar
-- | Rejection sampling for a random character from [0-9] or [a-z].
randomChar :: IO Char
randomChar = do
r <- getStdRandom (randomR ('0', 'z'))
if r > '9' && r < 'a'
then randomChar
else return r
-- | Writes a pandoc document to a markdown file.
writeToMarkdownFile :: FilePath -> Pandoc -> IO ()
writeToMarkdownFile filepath pandoc
-- putStrLn $ "Writing back: " ++ filepath
= do
template <- getResourceString $ "template" </> "deck.md"
let extensions =
(disableExtension Ext_simple_tables .
disableExtension Ext_multiline_tables .
disableExtension Ext_grid_tables . enableExtension Ext_auto_identifiers)
pandocExtensions
let options =
def
{ writerTemplate = Just template
, writerExtensions = extensions
, writerWrapText = WrapAuto
, writerColumns = 999
, writerSetextHeaders = False
}
runIO (writeMarkdown options pandoc) >>= handleError >>= T.writeFile filepath
provideSlideIds :: Pandoc -> IO Pandoc
provideSlideIds (Pandoc meta body) = do
let slides = toSlides body
idSlides <- mapM provideSlideIdIO slides
let idBody = fromSlides idSlides
return $ Pandoc meta idBody
-- Provides unique, random, sticky ids for all slides.
provideSlideId :: Slide -> Decker Slide
provideSlideId = doIO . provideSlideIdIO
provideSlideIdIO :: Slide -> IO Slide
provideSlideIdIO (Slide (Just (Header 1 ("", c, kv) i)) body) = do
sid <- randomId
-- print (Slide (Just $ Header 1 (sid, c, kv) i) body)
return $ Slide (Just $ Header 1 (sid, c, kv) i) body
provideSlideIdIO (Slide Nothing body) = do
sid <- randomId
return $ Slide (Just $ Header 1 (sid, [], []) []) body
provideSlideIdIO slide@(Slide (Just (Header 1 (sid, c, kv) i)) body)
-- print (Slide (Just $ Header 1 (sid, c, kv) i) body)
= do
return slide
module Slide
( Slide(..)
, header
, blocks
, _Slide
, hasClass
, toSlides
, fromSlides
) where
import Text.Pandoc
import Text.Pandoc.Definition ()
import Text.Pandoc.Lens
import Control.Lens
import Data.List.Split
import Data.Maybe
-- A slide has maybe a header followed by zero or more blocks.
data Slide = Slide
{ _header :: Maybe Block
, _body :: [Block]
} deriving (Eq, Show)
-- | 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
-- 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
isSlideSeparator :: Block -> Bool
isSlideSeparator (Header 1 _ _) = True
isSlideSeparator HorizontalRule = True
isSlideSeparator _ = False
demoteHeaders = traverse . _Header . _1 +~ 1
hasClass :: HasAttr a => String -> a -> Bool
hasClass which = elem which . view (attributes . attrClasses)
hasAnyClass :: HasAttr a => [String] -> a -> Bool
hasAnyClass which = isJust . firstClass which
firstClass :: HasAttr a => [String] -> a -> Maybe String
firstClass which fragment = listToMaybe $ filter (`hasClass` fragment) which
attribValue :: HasAttr a => String -> a -> Maybe String
attribValue which = lookup which . view (attributes . attrs)
dropByClass :: HasAttr a => [String] -> [a] -> [a]
dropByClass which =
filter (not . any (`elem` which) . view (attributes . attrClasses))
......@@ -33,11 +33,12 @@ import Render
import Resources
import Server
import Shake
import Sketch
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Lens ((^.))
import Control.Lens ((^.), at)
import Control.Monad
import Control.Monad.Loops
import Control.Monad.State
......@@ -67,6 +68,7 @@ import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.Builder
import Text.Pandoc.Highlighting
import Text.Pandoc.Lens
import Text.Pandoc.PDF
import Text.Pandoc.Shared
import Text.Pandoc.Walk
......@@ -235,8 +237,7 @@ markdownToHtmlDeck markdownFile out = do
]
, writerCiteMethod = Citeproc
}
readAndProcessMarkdown markdownFile (Disposition Deck Html) >>=
writeNativeWhileDebugging out "filtered" >>=
writeNativeWhileDebugging out "filtered" pandoc >>=
writePandocFile "revealjs" options out
runIOQuietly :: PandocIO a -> IO (Either PandocError a)
......@@ -277,8 +278,10 @@ versionCheck meta =
readAndProcessMarkdown :: FilePath -> Disposition -> Action Pandoc
readAndProcessMarkdown markdownFile disp = do
pandoc@(Pandoc meta _) <-
readMetaMarkdown markdownFile >>= processIncludes baseDir -- >>= writeNativeWhileDebugging markdownFile "parsed"
processPandoc pipeline baseDir disp (provisioningFromMeta meta) pandoc
readMetaMarkdown markdownFile >>= processIncludes baseDir
processed@(Pandoc meta body) <-
processPandoc pipeline baseDir disp (provisioningFromMeta meta) pandoc
return processed
where
baseDir = takeDirectory markdownFile
pipeline =
......@@ -418,8 +421,7 @@ markdownToHtmlPage markdownFile out = do
, writerVariables = [("decker-support-dir", templateSupportDir)]
, writerCiteMethod = Citeproc
}
readAndProcessMarkdown markdownFile (Disposition Page Html) >>=
writePandocFile "html5" options out
writePandocFile "html5" options out pandoc
-- | Write a markdown file to a PDF file using the handout template.
markdownToPdfPage :: FilePath -> FilePath -> Action ()
......@@ -466,8 +468,7 @@ markdownToHtmlHandout markdownFile out = do
, writerVariables = [("decker-support-dir", templateSupportDir)]
, writerCiteMethod = Citeproc
}
readAndProcessMarkdown markdownFile (Disposition Handout Html) >>=
writePandocFile "html5" options out
writePandocFile "html5" options out pandoc
-- | Write a markdown file to a PDF file using the handout template.
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
......@@ -496,8 +497,9 @@ readMetaMarkdown markdownFile = do
liftIO $ aggregateMetaData projectDir (takeDirectory markdownFile)
-- extract embedded meta data from the document
markdown <- liftIO $ T.readFile markdownFile
let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
let documentMeta = MetaMap $ unMeta meta
let pandoc = readMarkdownOrThrow pandocReaderOpts markdown
Pandoc fileMeta fileBlocks <- liftIO $ provideSlideIds pandoc
let documentMeta = MetaMap $ unMeta fileMeta
-- combine the meta data with preference on the embedded data
let combinedMeta = mergePandocMeta documentMeta (toPandocMeta externalMeta)
let mustacheMeta = toMustacheMeta combinedMeta
......@@ -508,8 +510,13 @@ readMetaMarkdown markdownFile = do
case combinedMeta of
(MetaMap m) -> do
versionCheck (Meta m)
let pandoc = Pandoc (Meta m) blocks
mapResources (urlToFilePathIfLocal (takeDirectory markdownFile)) pandoc
case lookupMeta "decker-slide-ids" (Meta m) of
Just (MetaBool True) ->
markForWriteBack markdownFile (Pandoc fileMeta fileBlocks)
_ -> pure ()
mapResources
(urlToFilePathIfLocal (takeDirectory markdownFile))
(Pandoc (Meta m) blocks)
_ -> throw $ PandocException "Meta format conversion failed."
urlToFilePathIfLocal :: FilePath -> FilePath -> Action FilePath
......
module SketchTests
( sketchTests
) where
import Sketch
import Slide
import Test.Hspec
import Text.Pandoc
import Text.Pandoc.Lens
import Control.Lens
noIdSlide = Slide (Just $ Header 1 ("", [], []) []) []
someIdSlide = Slide (Just $ Header 1 ("manually-set-id", [], []) []) []
noHeaderSlide = Slide Nothing []
sketchTests = do
describe "randomId" $ do
it "creates a random id" $ length <$> randomId `shouldReturn` idDigits + 1
it "creates a random id that starts with 's'" $
head <$> randomId `shouldReturn` 's'
describe "provideSlideIdIO" $ do
it "adds new id to any slide that does not have one" $
length . view (header . _Just . attributes . attrIdentifier) <$>
provideSlideIdIO noIdSlide `shouldReturn` idDigits + 1
it "adds new header and id to any slide that does not have either" $
length . view (header . _Just . attributes . attrIdentifier) <$>
provideSlideIdIO noHeaderSlide `shouldReturn` idDigits + 1
it "does not touch headers that already have an id" $
view (header . _Just . attributes . attrIdentifier) <$>
provideSlideIdIO someIdSlide `shouldReturn` "manually-set-id"
import Test.Hspec
import WatchTests
import SketchTests
import Control.Lens ((^.))
import qualified Data.ByteString.Char8 as B
......@@ -28,6 +29,7 @@ main = do
--
do
watchTests
sketchTests
describe "makeRelativeTo" $
it "calculates the path of file relative to dir. Includes '..'" $ do
makeRelativeTo "" "img.png" `shouldBe` "img.png"
......
......@@ -11,7 +11,7 @@ watchTests = do
fastGlobFiles [] [] "test" `shouldReturn` []
it "returns all Haskell source files if the extensions include '.hs'" $
fastGlobFiles [] [".hs"] "test" `shouldReturn`
["test/WatchTests.hs", "test/Spec.hs"]
["test/SketchTests.hs", "test/WatchTests.hs", "test/Spec.hs"]
it "globs just one file if root is a single file" $
fastGlobFiles [] [".hs"] "test/Spec.hs" `shouldReturn` ["test/Spec.hs"]
it "does not descend into excluded dirs" $
......
---
decker-slide-ids: True
title: Sketch Pad
---
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# First Slide {#myslide-dont-touch}
Some body text.
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# {#sncdl}
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
# Third Slide {#s85zu}
Some body text.
Supports Markdown
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