Commit 0e2e1e60 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Store JSON encoded Pandoc meta data in a global variable

1. Makes it much easier to pass values from Decker meta data to the
RevealJs configuration (or any other Javascript code).
2. Allows access to the language dictionary from JavaScript.

Only used for the 'controls' option to test it.
parent 4580c998
......@@ -130,6 +130,12 @@ $endif$
$for(template.css)$
<link rel="stylesheet" href="$template.css$"/>
$endfor$
<script>
/* Store JSON encoded Pandoc meta data in a global variable for easy
reference from any script. */
window.Decker = {meta: $decker-meta$};
</script>
<!-- Printing and PDF exports -->
<script>
var link = document.createElement( 'link' );
......@@ -332,9 +338,7 @@ $endfor$
pdfMaxPagesPerSlide: 10,
pdfSeparateFragments: false,
// Display controls in the bottom right corner
$if(controls)$
controls: $controls$,
$endif$
controls: Decker.meta.controls,
// Display a presentation progress bar
$if(progress)$
progress: $progress$,
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Text.Decker.Internal.Meta
( DeckerException(..)
, FromMetaValue(..)
, addMetaValue
, globalMetaFileName
, mergePandocMeta'
, pandocMeta
, setMetaValue
, adjustMetaValue
, adjustMetaValueM
, adjustMetaStringsBelow
, adjustMetaStringsBelowM
, toPandocMeta
, toPandocMeta'
, lookupMeta
, lookupMetaOrElse
, lookupMetaOrFail
, lookupInDictionary
, mapMeta
, mapMetaM
, mapMetaValues
, mapMetaValuesM
, mapMetaWithKey
, readMetaDataFile
) where
( DeckerException (..),
FromMetaValue (..),
addMetaValue,
globalMetaFileName,
mergePandocMeta',
pandocMeta,
setMetaValue,
adjustMetaValue,
adjustMetaValueM,
adjustMetaStringsBelow,
adjustMetaStringsBelowM,
toPandocMeta,
toPandocMeta',
lookupMeta,
lookupMetaOrElse,
lookupMetaOrFail,
lookupInDictionary,
mapMeta,
mapMetaM,
mapMetaValues,
mapMetaValuesM,
mapMetaWithKey,
readMetaDataFile,
embedMetaMeta,
)
where
import Control.Exception
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as H
import qualified Data.List as List
import Data.List.Safe ((!!))
import qualified Data.Map.Lazy as Map
import qualified Data.Map.Strict as M
......@@ -41,9 +44,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vec
import qualified Data.Yaml as Y
import Relude
import Text.Decker.Internal.Exception
import Text.Pandoc hiding (lookupMeta)
import Text.Pandoc.Builder hiding (fromList, lookupMeta, toList)
......@@ -85,7 +86,18 @@ toPandocMeta' (Y.Number scientific) = MetaString $ Text.pack $ show scientific
toPandocMeta' (Y.Bool bool) = MetaBool bool
toPandocMeta' Y.Null = MetaList []
-- | Split a compound meta key at the dots and separate the array indexes.
fromPandocMeta :: Meta -> A.Value
fromPandocMeta (Meta map) = fromPandocMeta' (MetaMap map)
fromPandocMeta' :: MetaValue -> A.Value
fromPandocMeta' (MetaMap map) = A.Object (H.fromList $ Map.toList $ Map.map fromPandocMeta' map)
fromPandocMeta' (MetaList list) = A.Array (Vec.fromList $ List.map fromPandocMeta' list)
fromPandocMeta' (MetaBool value) = A.Bool value
fromPandocMeta' (MetaString value) = A.String value
fromPandocMeta' (MetaInlines value) = A.String (stringify value)
fromPandocMeta' (MetaBlocks value) = A.Null
-- |  Split a compound meta key at the dots and separate the array indexes.
splitKey = concatMap splitIndex . Text.splitOn "."
where
splitIndex key =
......@@ -100,25 +112,25 @@ splitKey = concatMap splitIndex . Text.splitOn "."
getMetaValue :: Text -> Meta -> Maybe MetaValue
getMetaValue key meta = lookup' (splitKey key) (MetaMap (unMeta meta))
where
lookup' (key:path) (MetaMap map) = M.lookup key map >>= lookup' path
lookup' (key:path) (MetaList list) =
lookup' (key : path) (MetaMap map) = M.lookup key map >>= lookup' path
lookup' (key : path) (MetaList list) =
(readMaybe . Text.unpack) key >>= (!!) list >>= lookup' path
lookup' (_:_) _ = Nothing
lookup' (_ : _) _ = Nothing
lookup' [] mv = Just mv
-- | Sets a meta value at the compound key in the meta data. If any intermediate
-- containers do not exist, they are created.
-- containers do not exist, they are created.
setMetaValue :: ToMetaValue a => Text -> a -> Meta -> Meta
setMetaValue key value meta = Meta $ set (splitKey key) (MetaMap (unMeta meta))
where
set [k] (MetaMap map) = M.insert k (toMetaValue value) map
set (k:p) (MetaMap map) =
set (k : p) (MetaMap map) =
case M.lookup k map of
Just value -> M.insert k (MetaMap $ set p value) map
_ -> M.insert k (MetaMap $ set p $ MetaMap M.empty) map
set _ _ =
throw $
InternalException $ "Cannot set meta value on non object at: " <> show key
InternalException $ "Cannot set meta value on non object at: " <> show key
-- | Recursively deconstruct a compound key and drill into the meta data hierarchy.
-- Apply the function to the value if the key exists.
......@@ -128,19 +140,19 @@ adjustMetaValue f key meta =
where
adjust :: [Text] -> MetaValue -> Map Text MetaValue
adjust [k] (MetaMap map) = M.adjust f k map
adjust (k:p) (MetaMap map) =
adjust (k : p) (MetaMap map) =
case M.lookup k map of
Just value -> M.insert k (MetaMap $ adjust p value) map
_ -> map
adjust _ _ =
throw $
InternalException $
"Cannot adjust meta value on non object at: " <> show key
InternalException $
"Cannot adjust meta value on non object at: " <> show key
-- | Recursively deconstruct a compound key and drill into the meta data hierarchy.
-- Apply the IO action to the value if the key exists.
adjustMetaValueM ::
Monad m => (MetaValue -> m MetaValue) -> Text -> Meta -> m Meta
Monad m => (MetaValue -> m MetaValue) -> Text -> Meta -> m Meta
adjustMetaValueM action key meta =
Meta <$> adjust (splitKey key) (MetaMap (unMeta meta))
where
......@@ -150,7 +162,7 @@ adjustMetaValueM action key meta =
v' <- action v
return $ M.insert k v' map
_ -> return map
adjust (k:p) (MetaMap map) =
adjust (k : p) (MetaMap map) =
case M.lookup k map of
Just value -> do
m' <- adjust p value
......@@ -158,8 +170,8 @@ adjustMetaValueM action key meta =
_ -> return map
adjust _ _ =
throw $
InternalException $
"Cannot adjust meta value on non object at: " <> show key
InternalException $
"Cannot adjust meta value on non object at: " <> show key
-- | Recursively traverse all meta values below the compound key that can be
-- stringified and transform them by the supplied function.
......@@ -169,11 +181,11 @@ adjustMetaStringsBelow func = adjustMetaValue (mapMetaValues func)
-- | Recursively traverse all meta values below the compound key that can be
-- stringified and transform them by the supplied action.
adjustMetaStringsBelowM ::
(MonadFail m, Monad m) => (Text -> m Text) -> Text -> Meta -> m Meta
(MonadFail m, Monad m) => (Text -> m Text) -> Text -> Meta -> m Meta
adjustMetaStringsBelowM action = adjustMetaValueM (mapMetaValuesM action)
-- | Adds a meta value to the list found at the compund key in the meta data.
-- If any intermediate containers do not exist, they are created.
-- If any intermediate containers do not exist, they are created.
addMetaValue :: ToMetaValue a => Text -> a -> Meta -> Meta
addMetaValue key value meta =
case add (splitKey key) (MetaMap (unMeta meta)) of
......@@ -185,14 +197,14 @@ addMetaValue key value meta =
case M.lookup k m of
Just value -> MetaMap $ M.insert k (add [] value) m
_ -> MetaMap $ M.insert k (add [] $ MetaList []) m
add (k:p) (MetaMap m) =
add (k : p) (MetaMap m) =
case M.lookup k m of
Just value -> MetaMap $ M.insert k (add p value) m
_ -> MetaMap $ M.insert k (add p $ MetaMap M.empty) m
add _ _ =
throw $
InternalException $
"Cannot add meta value to non list at: " <> toString key
InternalException $
"Cannot add meta value to non list at: " <> toString key
pandocMeta :: (Text -> Meta -> Maybe a) -> Pandoc -> Text -> Maybe a
pandocMeta f (Pandoc m _) = flip f m
......@@ -229,16 +241,20 @@ instance (Ord a, FromMetaValue a) => FromMetaValue (Set a) where
fromMetaValue (MetaList list) = Just $ fromList $ mapMaybe fromMetaValue list
fromMetaValue _ = Nothing
instance {-# OVERLAPS #-} (Ord a, FromMetaValue a) =>
FromMetaValue (Map Text a) where
instance
{-# OVERLAPS #-}
(Ord a, FromMetaValue a) =>
FromMetaValue (Map Text a)
where
fromMetaValue (MetaMap metaMap) =
case M.foldlWithKey'
(\a k v ->
case fromMetaValue v of
Just string -> M.insert k string a
_ -> a)
M.empty
metaMap of
( \a k v ->
case fromMetaValue v of
Just string -> M.insert k string a
_ -> a
)
M.empty
metaMap of
stringMap
| null stringMap -> Nothing
stringMap -> Just stringMap
......@@ -297,12 +313,12 @@ mapMetaM f meta = do
-- Converts MetaInlines to MetaStrings. This may be a problem in some distant
-- future.
mapMetaValuesM ::
(MonadFail m, Monad m) => (Text -> m Text) -> MetaValue -> m MetaValue
(MonadFail m, Monad m) => (Text -> m Text) -> MetaValue -> m MetaValue
mapMetaValuesM f value = map' value
where
map' (MetaMap m) =
MetaMap . Map.fromList <$>
mapM (\(k, v) -> (k, ) <$> map' v) (Map.toList m)
MetaMap . Map.fromList
<$> mapM (\(k, v) -> (k,) <$> map' v) (Map.toList m)
map' (MetaList l) = MetaList <$> mapM map' l
map' (MetaString s) = MetaString <$> f s
map' (MetaInlines i) = MetaString <$> f (stringify i)
......@@ -315,7 +331,7 @@ mapMetaValues :: (Text -> Text) -> MetaValue -> MetaValue
mapMetaValues f value = map' value
where
map' (MetaMap m) =
MetaMap . Map.fromList $ map (\(k, v) -> (k, ) $ map' v) (Map.toList m)
MetaMap . Map.fromList $ map (\(k, v) -> (k,) $ map' v) (Map.toList m)
map' (MetaList l) = MetaList $ map map' l
map' (MetaString s) = MetaString $ f s
map' (MetaInlines i) = MetaString $ f (stringify i)
......@@ -323,17 +339,17 @@ mapMetaValues f value = map' value
-- | Map meta values in maps with the compound key.
mapMetaWithKey ::
(MonadFail m, Monad m) => (Text -> Text -> m Text) -> Meta -> m Meta
(MonadFail m, Monad m) => (Text -> Text -> m Text) -> Meta -> m Meta
mapMetaWithKey f meta = do
(MetaMap m) <- map' "" (MetaMap (unMeta meta))
return (Meta m)
where
map' k' (MetaMap m) =
MetaMap . Map.fromList <$>
mapM (\(k, v) -> (k, ) <$> map' (join k' k) v) (Map.toList m)
MetaMap . Map.fromList
<$> mapM (\(k, v) -> (k,) <$> map' (join k' k) v) (Map.toList m)
map' k (MetaList l) =
MetaList <$>
mapM (\(n, v) -> map' (k <> "[" <> show n <> "]") v) (zip [0 ..] l)
MetaList
<$> mapM (\(n, v) -> map' (k <> "[" <> show n <> "]") v) (zip [0 ..] l)
map' k (MetaString s) = MetaString <$> f k s
map' k (MetaInlines i) = MetaString <$> f k (stringify i)
map' _ v = return v
......@@ -342,3 +358,8 @@ mapMetaWithKey f meta = do
-- | Reads a single meta data file.
readMetaDataFile :: FilePath -> IO Meta
readMetaDataFile file = toPandocMeta <$> Y.decodeFileThrow file
embedMetaMeta :: Pandoc -> Pandoc
embedMetaMeta (Pandoc meta blocks) = Pandoc metaMeta blocks
where
metaMeta = addMetaField "decker-meta" (decodeUtf8 $ A.encode $ fromPandocMeta meta :: Text) meta
\ No newline at end of file
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Text.Decker.Writer.Html
( writeIndexLists
, markdownToHtmlDeck
, markdownToHtmlHandout
, markdownToHtmlPage
) where
import Text.Decker.Filter.Filter
import Text.Decker.Internal.Common
import Text.Decker.Internal.Meta
import Text.Decker.Project.Project
import Text.Decker.Project.Shake
import Text.Decker.Reader.Markdown
import Text.Decker.Resource.Template
( writeIndexLists,
markdownToHtmlDeck,
markdownToHtmlHandout,
markdownToHtmlPage,
)
where
import Control.Monad.State
import qualified Data.Map as M
......@@ -25,6 +18,13 @@ import qualified Data.Text.IO as T
import Development.Shake
import qualified System.Directory as Dir
import System.FilePath.Posix
import Text.Decker.Filter.Filter
import Text.Decker.Internal.Common
import Text.Decker.Internal.Meta
import Text.Decker.Project.Project
import Text.Decker.Project.Shake
import Text.Decker.Reader.Markdown
import Text.Decker.Resource.Template
import Text.DocTemplates
import Text.Pandoc hiding (getTemplate, lookupMeta)
import Text.Pandoc.Highlighting
......@@ -36,7 +36,7 @@ writeIndexLists meta targets out baseUrl = do
let decks = zip (_decks targets) (_decksPdf targets)
let handouts = zip (_handouts targets) (_handoutsPdf targets)
let pages = zip (_pages targets) (_pagesPdf targets)
let questions = zip (_questions targets) (_questions targets)
let questions = zip (_questions targets) (_questions targets)
decksLinks <- makeGroupedLinks decks
handoutsLinks <- makeGroupedLinks handouts
pagesLinks <- makeGroupedLinks pages
......@@ -44,35 +44,37 @@ writeIndexLists meta targets out baseUrl = do
cwd <- liftIO Dir.getCurrentDirectory
liftIO $
writeFile out $
unlines
[ "---"
, "title: Generated Index"
, "subtitle: " ++ cwd
, "---"
, "# Slide decks"
, unlines decksLinks
, "# Handouts"
, unlines handoutsLinks
, "# Supporting Documents"
, unlines pagesLinks
, "# Questions"
, unlines questLinks
]
unlines
[ "---",
"title: Generated Index",
"subtitle: " ++ cwd,
"---",
"# Slide decks",
unlines decksLinks,
"# Handouts",
unlines handoutsLinks,
"# Supporting Documents",
unlines pagesLinks,
"# Questions",
unlines questLinks
]
where
makeLink (html, pdf) = do
pdfExists <- liftIO $ Dir.doesFileExist pdf
if pdfExists
then return $
printf
"- [%s <i class='fab fa-html5'></i>](%s) [<i class='fas fa-file-pdf'></i>](%s)"
(takeFileName html)
(makeRelative baseUrl html)
(makeRelative baseUrl pdf)
else return $
printf
"- [%s <i class='fab fa-html5'></i>](%s)"
(takeFileName html)
(makeRelative baseUrl html)
then
return $
printf
"- [%s <i class='fab fa-html5'></i>](%s) [<i class='fas fa-file-pdf'></i>](%s)"
(takeFileName html)
(makeRelative baseUrl html)
(makeRelative baseUrl pdf)
else
return $
printf
"- [%s <i class='fab fa-html5'></i>](%s)"
(takeFileName html)
(makeRelative baseUrl html)
makeGroupedLinks :: [(FilePath, FilePath)] -> Action [String]
makeGroupedLinks files =
let grouped = MM.fromList (zip (map (takeDirectory . fst) files) files)
......@@ -85,8 +87,8 @@ writeIndexLists meta targets out baseUrl = do
writeNativeWhileDebugging :: FilePath -> String -> Pandoc -> Action ()
writeNativeWhileDebugging out mod doc =
liftIO $
runIO (writeNative pandocWriterOpts doc) >>= handleError >>=
T.writeFile (out -<.> mod <.> ".hs")
runIO (writeNative pandocWriterOpts doc) >>= handleError
>>= T.writeFile (out -<.> mod <.> ".hs")
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlDeck :: Meta -> TemplateCache -> FilePath -> FilePath -> Action ()
......@@ -104,20 +106,21 @@ markdownToHtmlDeck meta getTemplate markdownFile out = do
-- dachdeckerUrl' <- liftIO getDachdeckerUrl
let options =
pandocWriterOpts
{ writerSlideLevel = Just 1
, writerSectionDivs = False
, writerTemplate = Just template
, writerHighlightStyle = highlightStyle
, writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta)
, writerVariables =
{ writerSlideLevel = Just 1,
writerSectionDivs = False,
writerTemplate = Just template,
writerHighlightStyle = highlightStyle,
writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta),
writerVariables =
Context $
M.fromList
[ ( "decker-support-dir"
, SimpleVal $ Text 0 $ T.pack relSupportDir)
-- , ("dachdecker-url", SimpleVal $ Text 0 $ T.pack dachdeckerUrl')
]
, writerCiteMethod = Citeproc
M.fromList
[ ( "decker-support-dir",
SimpleVal $ Text 0 $ T.pack relSupportDir
)
-- , ("dachdecker-url", SimpleVal $ Text 0 $ T.pack dachdeckerUrl')
],
writerCiteMethod = Citeproc
}
writePandocFile "revealjs" options out pandoc
when (lookupMetaOrElse False "write-notebook" meta) $
......@@ -127,7 +130,7 @@ markdownToHtmlDeck meta getTemplate markdownFile out = do
writePandocFile :: T.Text -> WriterOptions -> FilePath -> Pandoc -> Action ()
writePandocFile fmt options out pandoc =
liftIO $
runIO (writeRevealJs options pandoc) >>= handleError >>= T.writeFile out
runIO (writeRevealJs options (embedMetaMeta pandoc)) >>= handleError >>= T.writeFile out
-- | Write a markdown file to a HTML file using the page template.
markdownToHtmlPage :: Meta -> TemplateCache -> FilePath -> FilePath -> Action ()
......@@ -140,51 +143,53 @@ markdownToHtmlPage meta getTemplate markdownFile out = do
template <- getTemplate (templateFile disp)
let options =
pandocWriterOpts
{ writerTemplate = Just template
, writerSectionDivs = False
, writerHighlightStyle = Just pygments
, writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta)
, writerVariables =
{ writerTemplate = Just template,
writerSectionDivs = False,
writerHighlightStyle = Just pygments,
writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta),
writerVariables =
Context $
M.fromList
[ ( "decker-support-dir"
, SimpleVal $ Text 0 $ T.pack relSupportDir)
]
, writerCiteMethod = Citeproc
, writerTableOfContents = lookupMetaOrElse False "show-toc" docMeta
, writerTOCDepth = lookupMetaOrElse 1 "toc-depth" docMeta
M.fromList
[ ( "decker-support-dir",
SimpleVal $ Text 0 $ T.pack relSupportDir
)
],
writerCiteMethod = Citeproc,
writerTableOfContents = lookupMetaOrElse False "show-toc" docMeta,
writerTOCDepth = lookupMetaOrElse 1 "toc-depth" docMeta
}
writePandocFile "html5" options out pandoc
-- | Write a markdown file to a HTML file using the handout template.
markdownToHtmlHandout ::
Meta -> TemplateCache -> FilePath -> FilePath -> Action ()
Meta -> TemplateCache -> FilePath -> FilePath -> Action ()
markdownToHtmlHandout meta getTemplate markdownFile out = do
putCurrentDocument out
let relSupportDir = relativeSupportDir (takeDirectory out)
let disp = Disposition Handout Html
pandoc@(Pandoc docMeta _) <-
wrapSlidesinDivs <$> readAndFilterMarkdownFile disp meta markdownFile
-- pandoc@(Pandoc docMeta _) <-
-- wrapSlidesinDivs <$> readAndProcessMarkdown meta markdownFile disp
-- pandoc@(Pandoc docMeta _) <-
-- wrapSlidesinDivs <$> readAndProcessMarkdown meta markdownFile disp
template <- getTemplate (templateFile disp)
let options =
pandocWriterOpts
{ writerTemplate = Just template
, writerSectionDivs = False
, writerHighlightStyle = Just pygments
, writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta)
, writerVariables =
{ writerTemplate = Just template,
writerSectionDivs = False,
writerHighlightStyle = Just pygments,
writerHTMLMathMethod =
MathJax (lookupMetaOrElse "" "mathjax-url" meta),
writerVariables =
Context $
M.fromList
[ ( "decker-support-dir"
, SimpleVal $ Text 0 $ T.pack relSupportDir)
]
, writerCiteMethod = Citeproc
, writerTableOfContents = lookupMetaOrElse False "show-toc" docMeta
, writerTOCDepth = lookupMetaOrElse 1 "toc-depth" docMeta
M.fromList
[ ( "decker-support-dir",
SimpleVal $ Text 0 $ T.pack relSupportDir
)
],
writerCiteMethod = Citeproc,
writerTableOfContents = lookupMetaOrElse False "show-toc" docMeta,
writerTOCDepth = lookupMetaOrElse 1 "toc-depth" docMeta
}
writePandocFile "html5" options out pandoc
......@@ -195,18 +200,19 @@ markdownToNotebook meta markdownFile out = do
let relSupportDir = relativeSupportDir (takeDirectory out)
let disp = Disposition Notebook Html
--pandoc@(Pandoc docMeta _) <-
--filterNotebookSlides <$> readAndProcessMarkdown meta markdownFile disp
--filterNotebookSlides <$> readAndProcessMarkdown meta markdownFile disp
pandoc@(Pandoc docMeta _) <-
filterNotebookSlides <$> readAndFilterMarkdownFile disp meta markdownFile
let options =
pandocWriterOpts
{ writerTemplate = Nothing
, writerHighlightStyle = Just pygments
, writerVariables =
{ writerTemplate = Nothing,
writerHighlightStyle = Just pygments,
writerVariables =
Context $
M.fromList
[ ( "decker-support-dir"
, SimpleVal $ Text 0 $ T.pack relSupportDir)
]
M.fromList
[ ( "decker-support-dir",
SimpleVal $ Text 0 $ T.pack relSupportDir
)
]
}
writePandocFile "ipynb" options out pandoc
---
title: Background Images
controls: false
---
# Background Images
......
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