Commit 86d76055 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Starting on the decker monaad

parent b538e45f
......@@ -70,7 +70,7 @@ main = do
everythingA <++> indexA >>= need
need ["support"]
--
-- phony "pdf" $ pagesPdfA <++> handoutsPdfA <++> indexA >>= need
phony "pdf" $ pagesPdfA <++> handoutsPdfA <++> indexA >>= need
--
-- phony "pdf-decks" $ decksPdfA <++> indexA >>= need
--
......
......@@ -25,6 +25,7 @@ executable decker
other-modules: Action
, Cache
, CRC32
, Macro
, Meta
, Watch
, Embed
......@@ -61,6 +62,7 @@ executable decker
, http-conduit
, http-types
, monad-loops
, mtl
, multimap
, mustache
, network-uri
......
......@@ -82,7 +82,7 @@ decker [options] [target]
using `pandoc`:
``` {.sh}
decker help | pandoc -s -t html > ~/tmp/decker-help.html
decker help | pandoc -s -t html > decker-help.html
```
`decker check`
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Common
( DeckerException(..)
, DeckerState(..)
, Layout(..)
, OutputFormat(..)
, Disposition(..)
, MediaType(..)
, Decker
, deckerVersion
) where
import Control.Exception
import Control.Monad.State
import Data.Typeable
import Data.Version (showVersion)
import Network.URI as U
import Paths_decker (version)
-- | The version from the cabal file
......@@ -38,3 +46,33 @@ instance Show DeckerException where
show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
show RsyncUrlException =
"attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"
data DeckerState = DeckerState
{ disposition :: Disposition
, slideCount :: Int
, externalReferences :: [U.URI]
}
type Decker = StateT DeckerState IO
data Layout
= Deck
| Page
| Handout
deriving (Eq, Show)
data OutputFormat
= Html
| Pdf
deriving (Eq, Show)
data Disposition = Disposition
{ layout :: Layout
, format :: OutputFormat
} deriving (Eq, Show)
data MediaType
= ImageMedia
| AudioMedia
| VideoMedia
| IframeMedia
......@@ -2,9 +2,11 @@
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Filter
( Disposition(..)
( Layout(..)
, OutputFormat(..)
, Disposition(..)
, processPandoc
, hasAttrib
, hasLayout
, blockClasses
, expandMacros
, makeSlides
......@@ -25,13 +27,16 @@ module Filter
import Common
import Control.Exception
import Control.Monad
import Control.Monad.State
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Default ()
import Data.List
import Data.List.Split
import Data.Maybe
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import Debug.Trace
import Macro
import Network.HTTP.Conduit
import Network.HTTP.Simple
import qualified Network.URI as U
......@@ -52,7 +57,17 @@ import Text.Pandoc.Walk
import Text.Printf
import Text.Read
type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
processPandoc :: Disposition -> Pandoc -> IO Pandoc
processPandoc disposition pandoc =
evalStateT (processPandoc_ pandoc) (DeckerState disposition 0 [])
processPandoc_ :: Pandoc -> Decker Pandoc
processPandoc_ pandoc@(Pandoc meta blocks) = do
disp <- gets disposition
case disp of
(Disposition Deck _) -> walkM (expandDeckerMacros meta) pandoc
(Disposition Page _) -> walkM (expandDeckerMacros meta) pandoc
(Disposition Handout _) -> walkM (expandDeckerMacros meta) pandoc
-- iframe resizing, see:
-- https://css-tricks.com/NetMag/FluidWidthVideo/Article-FluidWidthVideo.php
......@@ -190,12 +205,6 @@ hasAnyClass which = isJust . firstClass which
firstClass :: [String] -> Block -> Maybe String
firstClass which block = listToMaybe $ filter ((flip hasClass) block) which
-- | Slide layouts
data Layout = Layout
{ name :: String
, areas :: [String]
} deriving (Show)
-- | Slide layouts are rows of one ore more columns.
data RowLayout = RowLayout
{ lname :: String
......@@ -278,15 +287,6 @@ layoutSlides slide@(header, body) =
in (header, renderLayout areas layout)
Nothing -> slide
masters :: [(String, Layout)]
masters =
[ ("default", Layout "default" [])
, ("columns", Layout "columns" ["left", "right"])
, ("top2columns", Layout "top2columns" ["top", "left", "right"])
, ("bottom2columns", Layout "bottom2columns" ["left", "right", "bottom"])
, ("centeredoverlay", Layout "centeredoverlay" ["back", "front"])
]
hasAttrib :: String -> Block -> Maybe String
hasAttrib which (Div (_, _, keyvals) _) = lookup which keyvals
hasAttrib which (Header 1 (_, _, keyvals) _) = lookup which keyvals
......@@ -294,9 +294,6 @@ hasAttrib which (CodeBlock (_, _, keyvals) _) = lookup which keyvals
hasAttrib which (Para [Image (_, _, keyvals) _ _]) = lookup which keyvals
hasAttrib _ _ = Nothing
hasLayout :: Block -> Maybe Layout
hasLayout block = hasAttrib "layout" block >>= (flip lookup) masters
blockClasses :: Block -> [String]
blockClasses (Div (_, classes, _) _) = classes
blockClasses (Header 1 (_, classes, _) _) = classes
......@@ -311,31 +308,6 @@ blockAttribs (CodeBlock attribs _) = attribs
blockAttribs (Para [Image attribs _ _]) = attribs
blockAttribs _ = ("", [], [])
-- | Fit slide to layout
fitLayout :: [Block] -> [Block]
fitLayout slide@(header:body) =
case hasLayout header of
Just layout ->
let wrapArea blocks@(first:_) =
case whichArea first of
Just area ->
let (_, _, attribs) = blockAttribs first
in [Div ("", [(name layout), area], attribs) blocks]
Nothing -> blocks
wrapArea block = block
whichArea block =
listToMaybe $ intersect (blockClasses block) (areas layout)
slideAreas =
split (keepDelimsL $ whenElt (hasAnyClass (areas layout))) body
orderedAreas =
catMaybes $
map
(\a -> find (maybe False (hasClass a) . listToMaybe) slideAreas)
(areas layout)
in header : concatMap wrapArea orderedAreas
Nothing -> slide
fitLayout [] = []
-- | Split join columns with CSS3. Must be performed after `wrapBoxes`.
splitJoinColumns :: Slide -> Slide
splitJoinColumns (header, body) = (header, concatMap wrapRow rows)
......@@ -446,7 +418,7 @@ mapSlides func (Pandoc meta blocks) =
extractHeader (rule@(HorizontalRule):blocks) = (rule, blocks)
extractHeader slide =
throw $
PandocException $ "Error extracting slide header: \n" ++ show slide -- never happens
PandocException $ "Error extracting slide header: \n" ++ show slide
prependHeader (header, blocks) = header : blocks
makeSlides :: Format -> Pandoc -> Pandoc
......@@ -528,18 +500,6 @@ audioExtensions = [".m4a", ".mp3", ".ogg", ".wav"]
iframeExtensions :: [String]
iframeExtensions = [".html", ".html", ".pdf"]
data Disposition
= Deck
| Page
| Handout
deriving (Eq)
data MediaType
= ImageMedia
| AudioMedia
| VideoMedia
| IframeMedia
uriPathExtension :: String -> String
uriPathExtension path =
case U.parseRelativeReference path of
......@@ -581,7 +541,7 @@ renderImageAudioVideoTag disposition (Image (ident, cls, values) inlines (url, t
then element
else element ! attr (toValue value)
srcAttr =
if disposition == Deck
if disposition == Disposition Deck Html
then "data-src"
else "src"
transformedValues = (lazyLoad . transformImageSize) values
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Macro
( expandDeckerMacros
, MacroFunc
) where
import Common
import Control.Monad.State
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import System.FilePath
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H
((!), 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
import Text.Pandoc.Definition ()
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
expandDeckerMacros :: Meta -> Inline -> Decker Inline
expandDeckerMacros meta inline = return inline
type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
type MacroAction = [String] -> Attr -> Target -> Meta -> Decker Inline
-- iframe resizing, see:
-- https://css-tricks.com/NetMag/FluidWidthVideo/Article-FluidWidthVideo.php
-- YouTube links: iv_load_policy=3 disables annotations, rel=0 disables related
-- videos. See:
-- https://developers.google.com/youtube/player_parameters?hl=de#IFrame_Player_API
embedYoutubeHtml :: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid, _) =
RawInline (Format "html") (renderHtml html)
where
url =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
vid :: String
vidWidthStr = macroArg 0 args "560"
vidHeightStr = macroArg 1 args "315"
vidWidth = readDefault 560.0 vidWidthStr :: Float
vidHeight = readDefault 315.0 vidHeightStr :: Float
wrapperStyle =
printf
"position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
(vidHeight / vidWidth * 100.0) :: String
iframeStyle =
"position:absolute;top:0;left:0;width:100%;height:100%;" :: String
figureStyle (_, _, kv) =
foldl (\s (k, v) -> s ++ printf "%s:%s;" k v :: String) "" kv
figureClass (_, cls, _) = unwords cls
html =
H.figure ! class_ (toValue (figureClass attr)) !
style (toValue (figureStyle attr)) $
H.div ! style (toValue wrapperStyle) $
iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
height (toValue vidHeightStr) !
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
H.p ""
embedYoutubePdf :: [String] -> Attr -> Target -> Inline
embedYoutubePdf args attr (vid, _) =
Link nullAttr [Image attr [Str text] (imageUrl, "")] (videoUrl, "")
where
videoUrl =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
vid :: String
imageUrl =
printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
text = printf "YouTube: %s" vid :: String
youtube :: MacroFunc
youtube args attr target meta = do
disp <- gets disposition
case disp of
Disposition _ Html -> return $ embedYoutubeHtml args attr target
Disposition _ Pdf -> return $ embedYoutubePdf args attr target
fontAwesome :: MacroFunc
fontAwesome _ _ (iconName, _) _ = do
disp <- gets disposition
case disp of
Disposition _ Html ->
return $
RawInline (Format "html") $ "<i class=\"fa fa-" ++ iconName ++ "\"></i>"
Disposition _ Pdf -> return $ Str $ "[" ++ iconName ++ "]"
metaValue :: MacroFunc
metaValue _ _ (key, _) meta =
case splitOn "." key of
[] -> return $ Str key
k:ks -> return $ lookup' ks (lookupMeta k meta)
where
lookup' :: [String] -> Maybe MetaValue -> Inline
lookup' [] (Just (MetaString s)) = Str s
lookup' [] (Just (MetaInlines i)) = Span nullAttr i
lookup' (k:ks) (Just (MetaMap metaMap)) = lookup' ks (Map.lookup k metaMap)
lookup' _ _ = Strikeout [Str key]
type MacroMap = Map.Map String MacroFunc
macroMap :: MacroMap
macroMap =
Map.fromList [("meta", metaValue), ("youtube", youtube), ("fa", fontAwesome)]
readDefault :: Read a => a -> String -> a
readDefault default_ string = fromMaybe default_ (readMaybe string)
macroArg :: Int -> [String] -> String -> String
macroArg n args default_ =
if length args > n
then args !! n
else default_
parseMacro :: String -> Maybe [String]
parseMacro (pre:invocation)
| pre == ':' = Just (words invocation)
parseMacro _ = Nothing
isMacro :: String -> Bool
isMacro (pre:_) = pre == ':'
isMacro _ = False
onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only []
where
only ss (Str s) = s : ss
only ss _ = ss
expand :: Inline -> Format -> Meta -> Maybe Inline
expand (Link attr text target) format meta =
expand_ attr text target format meta
expand x _ _ = Just x
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do
name:args <- parseMacro $ stringify text
func <- Map.lookup name macroMap
return (func args attr target format meta)
expandInlineMacros :: Format -> Meta -> Inline -> Inline
expandInlineMacros format meta inline =
fromMaybe inline (expand inline format meta)
expandMacros :: Format -> Pandoc -> Pandoc
expandMacros format doc@(Pandoc meta _) =
walk (expandInlineMacros format meta) doc
......@@ -180,7 +180,7 @@ markdownToHtmlDeck markdownFile out = do
]
, writerCiteMethod = Citeproc
}
pandoc <- readAndPreprocessMarkdown markdownFile Deck
pandoc <- readAndPreprocessMarkdown markdownFile (Disposition Deck Html)
processed <- processPandocDeck "revealjs" pandoc
writePandocString "revealjs" options out processed
......@@ -303,7 +303,7 @@ markdownToHtmlPage markdownFile out = do
, writerVariables = [("decker-support-dir", supportDir)]
, writerCiteMethod = Citeproc
}
pandoc <- readAndPreprocessMarkdown markdownFile Page
pandoc <- readAndPreprocessMarkdown markdownFile (Disposition Page Html)
processed <- processPandocPage "html5" pandoc
writePandocString "html5" options out processed
......@@ -315,12 +315,10 @@ markdownToPdfPage markdownFile out = do
let options =
pandocWriterOpts
{ writerTemplate = Just template
-- , writerStandalone = True
, writerHighlight = True
-- , writerHighlightStyle = pygments
, writerCiteMethod = Citeproc
}
pandoc <- readAndPreprocessMarkdown markdownFile Page
pandoc <- readAndPreprocessMarkdown markdownFile (Disposition Page Pdf)
processed <- processPandocPage "latex" pandoc
putNormal $ "# pandoc (for " ++ out ++ ")"
pandocMakePdf options processed out
......@@ -336,7 +334,7 @@ pandocMakePdf options processed out = do
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
putCurrentDocument out
pandoc <- readAndPreprocessMarkdown markdownFile Handout
pandoc <- readAndPreprocessMarkdown markdownFile (Disposition Handout Html)
processed <- processPandocHandout "html" pandoc
supportDir <- getRelativeSupportDir out
template <- getTemplate "handout.html"
......@@ -357,7 +355,7 @@ markdownToHtmlHandout markdownFile out = do
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
markdownToPdfHandout markdownFile out = do
putCurrentDocument out
pandoc <- readAndPreprocessMarkdown markdownFile Handout
pandoc <- readAndPreprocessMarkdown markdownFile (Disposition Handout Pdf)
processed <- processPandocHandout "latex" pandoc
template <- getTemplate "handout.tex"
let options =
......@@ -561,20 +559,20 @@ processCitesWithDefault pandoc@(Pandoc meta blocks) = do
processPandocPage :: String -> Pandoc -> Action Pandoc
processPandocPage format pandoc = do
cited <- processCitesWithDefault pandoc
return $ (renderMediaTags Page . expandMacros (Format format)) cited
return $ (renderMediaTags (Disposition Page Html) . expandMacros (Format format)) cited
processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
cited <- processCitesWithDefault pandoc
return $
(renderMediaTags Page .
(renderMediaTags (Disposition Deck Html) .
makeSlides (Format format) . expandMacros (Format format))
cited
processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
cited <- processCitesWithDefault pandoc
return $ (renderMediaTags Page . expandMacros (Format format)) cited
return $ (renderMediaTags (Disposition Handout Html) . expandMacros (Format format)) cited
type StringWriter = WriterOptions -> Pandoc -> String
......
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