From 86d76055d9eaa67f2e5b77832c684e8c76070a54 Mon Sep 17 00:00:00 2001
From: Henrik Tramberend <henrik.tramberend@beuth-hochschule.de>
Date: Tue, 9 Jan 2018 14:54:01 +0100
Subject: [PATCH] Starting on the decker monaad
---
app/decker.hs | 2 +-
decker.cabal | 2 +
resource/template/help-page.md | 2 +-
src/Common.hs | 38 ++++++++
src/Filter.hs | 80 +++++------------
src/Macro.hs | 159 +++++++++++++++++++++++++++++++++
src/Utilities.hs | 18 ++--
7 files changed, 229 insertions(+), 72 deletions(-)
create mode 100644 src/Macro.hs
diff --git a/app/decker.hs b/app/decker.hs
index fba4791..06cc441 100644
--- a/app/decker.hs
+++ b/app/decker.hs
@@ -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
--
diff --git a/decker.cabal b/decker.cabal
index 3b64996..a28ead1 100644
--- a/decker.cabal
+++ b/decker.cabal
@@ -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
diff --git a/resource/template/help-page.md b/resource/template/help-page.md
index 88654e1..261f5a2 100644
--- a/resource/template/help-page.md
+++ b/resource/template/help-page.md
@@ -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`
diff --git a/src/Common.hs b/src/Common.hs
index 7365422..25cc01f 100644
--- a/src/Common.hs
+++ b/src/Common.hs
@@ -1,12 +1,20 @@
{-- 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
diff --git a/src/Filter.hs b/src/Filter.hs
index a22074c..350dce3 100644
--- a/src/Filter.hs
+++ b/src/Filter.hs
@@ -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
diff --git a/src/Macro.hs b/src/Macro.hs
new file mode 100644
index 0000000..1ac9abf
--- /dev/null
+++ b/src/Macro.hs
@@ -0,0 +1,159 @@
+{-- 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
diff --git a/src/Utilities.hs b/src/Utilities.hs
index b00ccf7..4aa486e 100644
--- a/src/Utilities.hs
+++ b/src/Utilities.hs
@@ -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
--
GitLab