Avoid RawHtml round trip for background media

- Added video background handling
- Started to cleanup the pandoc filter pipeline. To be continued.

src/Filter.hs

@@ -11,7 +11,7 @@ module Filter
   , escapeToFilePath
   , cachePandocImages
   , extractLocalImagePathes
-  , renderImageVideo
+  , renderMediaTags
   , transformImageSize
   , lazyLoadImage
   , isMacro
@@ -23,18 +23,19 @@ import Data.List
 import Data.List.Split
 import qualified Data.Map as Map (Map, fromList, lookup)
 import Data.Maybe
+import qualified Data.Set as Set
 import Debug.Trace
 import Network.HTTP.Conduit
 import Network.HTTP.Simple
-import Network.URI
+import Network.URI (parseURI, uriScheme)
 import System.Directory
 import System.FilePath
 import System.FilePath.Posix
 import Text.Blaze (customAttribute)
 import Text.Blaze.Html.Renderer.String
 import Text.Blaze.Html5 as H
-       ((!), audio, div, figure, iframe, img, p, source, stringTag,
-        toValue, video, section)
+       ((!), audio, div, figure, iframe, img, p, section, source,
+        stringTag, toValue, video)
 import Text.Blaze.Html5.Attributes as A
        (alt, class_, height, id, src, style, title, width)
 import Text.Pandoc
@@ -44,7 +45,6 @@ import Text.Pandoc.Shared
 import Text.Pandoc.Walk
 import Text.Printf
 import Text.Read
-import qualified Data.Set as Set
 
 type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
 
@@ -162,10 +162,9 @@ expandInlineMacros :: Format -> Meta -> Inline -> Inline
 expandInlineMacros format meta inline =
   fromMaybe inline (expand inline format meta)
 
-expandMacros :: Maybe Format -> Pandoc -> Pandoc
-expandMacros (Just format) doc@(Pandoc meta _) =
+expandMacros :: Format -> Pandoc -> Pandoc
+expandMacros format doc@(Pandoc meta _) =
   walk (expandInlineMacros format meta) doc
-expandMacros _ doc = doc
 
 isSlideHeader :: Block -> Bool
 isSlideHeader (Header level _ _) = level == 1
@@ -227,38 +226,50 @@ fragmentRelated =
 deFragment :: [String] -> [String]
 deFragment = filter (`notElem` fragmentRelated)
 
--- Transform raw inline image or video elements within the header line with background attributes of the respective
--- section. Media elements were transformed to raw inline elements before by Filter.renderImageVideo
--- see execution order in Utilities.markdownToHtmlDeck.
-setBackground :: [Block] -> [Block]
-setBackground slide@(Header 1 (id_, cls, kvs) inlines:body) = case (getSrcFromFstRawInline inlines) of
-  Nothing -> slide
-  Just src -> modifiedHeader:body
-    where
-      modifiedHeader = Header 1 (id_, cls, [(attributeName, src)]) modifiedInlines
-      attributeName = case takeExtension src of
-        ext | ext `elem` videoExtensions -> "data-background-video"
-        _ -> "data-background"
+deconstructSlide :: [Block] -> (Maybe Inline, Maybe Block, [Block])
+deconstructSlide (header:body) =
+  case header of
+    Header 1 attribs inlines ->
+      ( listToMaybe $ query allImages inlines
+      , Just $ Header 1 attribs (map zapImages inlines)
+      , body)
+deconstructSlide blocks = (Nothing, Nothing, blocks)
+
+allImages image@Image {} = [image]
+allImages _ = []
+
+zapImages Image {} = Space
+zapImages inline = inline
+
+-- Transform inline image or video elements within the header line with
+-- background attributes of the respective section. 
+setSlideBackground :: [Block] -> [Block]
+setSlideBackground slide@((Header 1 (headerId, headerClasses, headerAttributes) inlines):slideBody) =
+  case query allImages inlines of
+    [] -> slide
+    Image (_, imageClasses, imageAttributes) _ (imageSrc, _):_ ->
+      Header
+        1
+        ( headerId
+        , headerClasses ++ imageClasses
+        , srcAttribute imageSrc :
+          headerAttributes ++ map transform imageAttributes)
+        (walk zapImages inlines) :
+      slideBody
   where
-    getSrcFromFstRawInline :: [Inline] -> Maybe String
-    getSrcFromFstRawInline inlines = foldl collect Nothing inlines
-      where
-        collect Nothing inline = getSrcFromRawInline inline
-        collect (Just src) _ = Just src
-    getSrcFromRawInline :: Inline -> Maybe String
-    getSrcFromRawInline (RawInline _ string) =
-      case (or [isPrefixOf "<img " string, isPrefixOf "<video " string]) of
-          True -> case find (\str -> isPrefixOf "data-src" str) (words string) of
-            -- split spring by the quotation character that proceeds "data-src=", eihter \" or \'
-            Just string | length string > 10 -> Just ((split (dropDelims $ oneOf ((string!!9):[])) string)!!1)
-            _ -> Nothing
-          False -> Nothing
-    getSrcFromRawInline _ = Nothing
-    modifiedInlines = filter (isNothing . getSrcFromRawInline) inlines
-    isImageVideoRawInline :: Maybe String -> Bool
-    isImageVideoRawInline (Just _) = True
-    isImageVideoRawInline Nothing = False
-setBackground slide = slide
+    transform ("size", value) = ("data-background-size", value)
+    transform ("position", value) = ("data-background-position", value)
+    transform ("repeat", value) = ("data-background-repeat", value)
+    transform ("loop", value) = ("data-background-video-loop", value)
+    transform ("muted", value) = ("data-background-video-muted", value)
+    transform ("color", value) = ("data-background-color", value)
+    transform kv = kv
+    srcAttribute src =
+      case classifyFilePath src of
+        VideoMedia -> ("data-background-video", src)
+        AudioMedia -> ("data-background-audio", src)
+        ImageMedia -> ("data-background-image", src)
+setSlideBackground slide = slide
 
 wrapBoxes :: [Block] -> [Block]
 wrapBoxes (header:body) = header : concatMap wrap boxes
@@ -291,12 +302,12 @@ mapSlides func (Pandoc meta blocks) = Pandoc meta (concatMap func slides)
   where
     slides = split (keepDelimsL $ whenElt isSlideHeader) blocks
 
-makeSlides :: Maybe Format -> Pandoc -> Pandoc
-makeSlides (Just (Format "revealjs")) =
+makeSlides :: Format -> Pandoc -> Pandoc
+makeSlides (Format "revealjs") =
   walk (mapSlides splitColumns) .
-  walk (mapSlides setBackground) .
+  walk (mapSlides setSlideBackground) .
   walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteRevealjs)
-makeSlides (Just (Format "beamer")) =
+makeSlides (Format "beamer") =
   walk (mapSlides splitColumns) .
   walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer)
 makeSlides _ = Prelude.id
@@ -346,7 +357,7 @@ localImagePath (Image _ _ (url, _)) =
 localImagePath _ = []
 
 extractLocalImagePathes :: Pandoc -> [FilePath]
-extractLocalImagePathes pandoc = Text.Pandoc.Walk.query localImagePath pandoc
+extractLocalImagePathes = Text.Pandoc.Walk.query localImagePath
 
 isHttpUri :: String -> Bool
 isHttpUri url =
@@ -373,10 +384,16 @@ cacheImageIO uri cacheDir = do
   createDirectoryIfMissing True cacheDir
   L8.writeFile cacheFile body
 
--- File extensions that signify video content.
+renderMediaTags :: Disposition -> Pandoc -> Pandoc
+renderMediaTags disposition = walk (renderImageAudioVideoTag disposition)
+
+-- | File extensions that signify video content.
+videoExtensions :: [String]
 videoExtensions =
   [".mp4", ".webm", ".ogg", ".avi", ".dv", ".mp2", ".mov", ".qt"]
 
+-- | File extensions that signify audio content.
+audioExtensions :: [String]
 audioExtensions = [".mp3", ".ogg", ".wav"]
 
 data Disposition
@@ -385,23 +402,31 @@ data Disposition
   | Handout
   deriving (Eq)
 
+data MediaType
+  = ImageMedia
+  | AudioMedia
+  | VideoMedia
+
+classifyFilePath :: FilePath -> MediaType
+classifyFilePath name =
+  case takeExtension name of
+    ext
+      | ext `elem` videoExtensions -> VideoMedia
+    ext
+      | ext `elem` audioExtensions -> AudioMedia
+    _ -> ImageMedia
+
 -- Renders an image with a video reference to a video tag in raw HTML. Faithfully
 -- transfers attributes to the video tag.
-renderImageVideo :: Disposition -> Inline -> IO Inline
-renderImageVideo disposition image@(Image (ident, cls, values) inlines (url, tit)) =
-  return $ RawInline (Format "html") (renderHtml $ imageVideoTag)
+renderImageAudioVideoTag :: Disposition -> Inline -> Inline
+renderImageAudioVideoTag disposition (Image (ident, cls, values) inlines (url, tit)) =
+  RawInline (Format "html") (renderHtml imageVideoTag)
   where
     imageVideoTag =
-      case takeExtension url of
-        ext | ext `elem` videoExtensions ->
-          case "background" `elem` cls of
-            True -> (section "") ! customAttribute "data-background-video" (toValue url) ! customAttribute "class" "slide"
-            False -> mediaTag (video "Browser does not support video.")
-        ext | ext `elem` audioExtensions -> mediaTag (audio "Browser does not support audio.")
-        _ ->
-          case "background" `elem` cls of
-            True -> (section "") ! customAttribute "data-background" (toValue url)
-            False -> mediaTag img
+      case classifyFilePath url of
+        VideoMedia -> mediaTag (video "Browser does not support video.")
+        AudioMedia -> mediaTag (audio "Browser does not support audio.")
+        ImageMedia -> mediaTag img
     appendAttr element (key, value) =
       element ! customAttribute (stringTag key) (toValue value)
     mediaTag tag =
@@ -419,7 +444,7 @@ renderImageVideo disposition image@(Image (ident, cls, values) inlines (url, tit
         else "src"
     transformedValues = (lazyLoad . transformImageSize) values
     lazyLoad vs = (srcAttr, url) : vs
-renderImageVideo _ inline = return inline
+renderImageAudioVideoTag _ inline = inline
 
 -- | Mimic pandoc for handling the 'width' and 'height' attributes of images.
 -- That is, transfer 'width' and 'height' attribute values to css style values

src/Utilities.hs

@@ -329,8 +329,7 @@ readAndPreprocessMarkdown markdownFile disposition = do
   let method = provisioningFromMeta meta
   liftIO $
     mapMetaResources (provisionMetaResource method dirs baseDir) pandoc >>=
-    mapResources (provisionExistingResource method dirs baseDir) >>=
-    walkM (renderImageVideo disposition)
+    mapResources (provisionExistingResource method dirs baseDir) 
     -- Disable automatic caching of remote images for a while
     -- >>= walkM (cacheRemoteImages (cache dirs))
 
@@ -440,7 +439,9 @@ markdownToPdfHandout markdownFile out = do
   putNormal $ "# pandoc (for " ++ out ++ ")"
   pandocMakePdf options processed out
 
--- | Reads a markdown file and returns a pandoc document. 
+-- | Reads a markdown file and returns a pandoc document. Handles meta data
+-- extraction and template substitution. All references to local resources are
+-- converted to absolute pathes.
 readMetaMarkdown :: FilePath -> Action Pandoc
 readMetaMarkdown markdownFile = do
   need [markdownFile]
@@ -719,30 +720,26 @@ downloadUrl url = do
 hashURI :: String -> String
 hashURI uri = show (md5 $ L8.pack uri) SF.<.> SF.takeExtension uri
 
+justFormat :: String -> Maybe Format
+justFormat = Just . Format
+
 processPandocPage :: String -> Pandoc -> Action Pandoc
 processPandocPage format pandoc = do
-  let f = Just (Format format)
   dirs <- getProjectDirs
-  processed <- liftIO $ processCites' pandoc
-  --  processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
-  return $ expandMacros f processed
+  cited <- liftIO $ processCites' pandoc
+  return $ (renderMediaTags Page . expandMacros (Format format)) cited
 
 processPandocDeck :: String -> Pandoc -> Action Pandoc
 processPandocDeck format pandoc = do
-  let f = Just (Format format)
   dirs <- getProjectDirs
-  processed <- liftIO $ processCites' pandoc
-  -- processed <- liftIO $ walkM (useCachedImages cacheD(cache dirs)ir) pandoc
-  return $ (makeSlides f . expandMacros f) processed
+  cited <- liftIO $ processCites' pandoc
+  return $ (renderMediaTags Page . makeSlides (Format format) . expandMacros (Format format)) cited
 
 processPandocHandout :: String -> Pandoc -> Action Pandoc
 processPandocHandout format pandoc = do
-  let f = Just (Format format)
   dirs <- getProjectDirs
-  processed <- liftIO $ processCites' (makeBoxes pandoc)
-  -- processed <- liftIO $ walkM (useCachedImages (cache dirs)) pandoc
-  -- return $ (expandMacros f . filterNotes f) processed
-  return $ expandMacros f processed
+  cited <- liftIO $ processCites' pandoc
+  return $ (renderMediaTags Page . expandMacros (Format format)) cited
 
 type StringWriter = WriterOptions -> Pandoc -> String
 

test/decks/background-image-deck.md

+---
+history: True
+---
+
 # Background Images
 
 ## Four slides with background image
 
-1. RevealJS style with `data-background-image` attribute
-1. decker style with image only header
-2. decker style with image and title text header
-2. decker style with first image on slide with class `background` 
+1.  RevealJS style with `data-background-image` attribute
+2.  decker style with image and title text header
+3.  decker style with image and title text header and attributes
+4.  decker style with image and title text header and attributes
 
 # RevealJs Style {data-background-image="include/06-metal.png"}
 
-# ![](include/06-metal.png)
+## Source
+
+    # RevealJs Style {data-background-image="include/06-metal.png"}
+
+# Image in Title 1 ![](include/06-metal.png)
+
+## Source
+
+    # Image in Title 1 ![](include/06-metal.png)
+
+# Image in Title 2 ![](include/06-metal.png){size="30%" repeat="repeat"}
+
+## Source
+
+    # Image in Title 2 ![](include/06-metal.png){size="50%" repeat="repeat"}
 
-# Image in Title ![](include/06-metal.png)
+# Image in Title 3 ![](include/06-metal.png){size="50%" repeat="no-repeat" color="black"}
 
-# First Image on Slide 
+## Source
 
-![](include/06-metal.png){.background}
+    # Image in Title 3 ![](include/06-metal.png){size="50%" repeat="no-repeat" color="black"}

test/decks/background-video-deck.md

+---
+history: True
+---
+
+# Background Videos
+
+## Four slides with background video
+
+1.  RevealJS style with `data-background-video` attribute
+2.  decker style with image and title text header
+3.  decker style with image and title text header and `loop` attribute
+
+# RevealJs Style {data-background-video="movie.mp4"}
+
+## Source
+
+    # RevealJs Style {data-background-video="movie.mp4"}
+
+# Video in Title 1 ![](movie.mp4)
+
+## Source
+
+    # Image in Title 1 ![](movie.mp4)
+
+# Video in Title 2 ![](movie.mp4){loop="1"}
+
+## Source
+
+    # Image in Title 2 ![](movie.mp4){loop="1"}