Utilities.hs 22.4 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
Henrik Tramberend's avatar
Henrik Tramberend committed
2
module Utilities
Henrik Tramberend's avatar
Henrik Tramberend committed
3
  ( runShakeInContext
4 5
  , watchFiles
  , writeIndex
6 7
  , writeIndexTable
  , writeIndexLists
8 9 10 11 12 13 14 15 16 17 18 19 20 21
  , readMetaDataForDir
  , substituteMetaData
  , markdownToHtmlDeck
  , markdownToHtmlHandout
  , markdownToPdfHandout
  , markdownToHtmlPage
  , markdownToPdfPage
  , writeExampleProject
  , metaValueAsString
  , (<++>)
  , writeEmbeddedFiles
  , pandocMakePdf
  , fixMustacheMarkup
  , fixMustacheMarkupText
22
  , toPandocMeta
23
  , deckerPandocExtensions
24 25
  , DeckerException(..)
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
26

Henrik Tramberend's avatar
Henrik Tramberend committed
27
import Action
Henrik Tramberend's avatar
Henrik Tramberend committed
28
import Common
29 30
import Context
import Control.Arrow
Henrik Tramberend's avatar
Henrik Tramberend committed
31
import Control.Exception
32 33
import Control.Monad
import Control.Monad.Loops
Henrik Tramberend's avatar
Henrik Tramberend committed
34
import Control.Monad.State
35 36 37 38
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
39 40
import Data.List as List
import Data.List.Extra as List
41
import qualified Data.Map.Lazy as Map
Henrik Tramberend's avatar
Henrik Tramberend committed
42
import qualified Data.Text as T
43
import qualified Data.Text.Encoding as E
Henrik Tramberend's avatar
Henrik Tramberend committed
44
import qualified Data.Text.IO as T
45 46 47 48
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Filter
49
import Macro
Henrik Tramberend's avatar
Henrik Tramberend committed
50
import Meta
51
import Network.URI
Henrik Tramberend's avatar
Henrik Tramberend committed
52
import Project
53
import Render
54
import Resources
55
import Server
56
import qualified System.Directory as Dir
57
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
58 59 60
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
61
import Text.Pandoc.Builder
Henrik Tramberend's avatar
Henrik Tramberend committed
62
import Text.Pandoc.Highlighting
Henrik Tramberend's avatar
Henrik Tramberend committed
63
import Text.Pandoc.PDF
64
import Text.Pandoc.Shared
65
import Text.Pandoc.Walk
66
import Text.Printf
67
import Watch
Henrik Tramberend's avatar
Henrik Tramberend committed
68

69
runShakeInContext :: ActionContext -> ShakeOptions -> Rules () -> IO ()
70 71 72 73 74 75 76 77
runShakeInContext context options rules = do
  opts <- setActionContext context options
  catch
    (untilM_ (tryRunShake opts) nothingToWatch)
    (\(SomeException e) -> putStrLn $ "Terminated: " ++ show e)
  cleanup
  where
    tryRunShake opts =
Henrik Tramberend's avatar
Henrik Tramberend committed
78
      handle (\(SomeException _) -> return ()) (shakeArgs opts rules)
79
    cleanup = do
80
      server <- readIORef $ ctxServerHandle context
81
      forM_ server stopHttpServer
82 83 84 85 86
    nothingToWatch = do
      files <- readIORef $ ctxFilesToWatch context
      if null files
        then return True
        else do
87
          server <- readIORef $ ctxServerHandle context
88
          forM_ server reloadClients
89
          _ <- waitForTwitchPassive [public $ ctxDirs context]
90
          return False
Henrik Tramberend's avatar
Henrik Tramberend committed
91

92
watchFiles :: [FilePath] -> Action ()
93
watchFiles = setFilesToWatch
Henrik Tramberend's avatar
Henrik Tramberend committed
94 95

-- | Monadic version of list concatenation.
96
(<++>) :: Monad m => m [a] -> m [a] -> m [a]
97
(<++>) = liftM2 (++)
Henrik Tramberend's avatar
Henrik Tramberend committed
98

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
-- | Generates an index.md file with links to all generated files of interest.
writeIndexTable ::
     FilePath -> FilePath -> [[FilePath]] -> [[FilePath]] -> Action ()
writeIndexTable out baseUrl deckData pageData = do
  dirs <- getProjectDirs
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
      , "subtitle: " ++ project dirs
      , "---"
      , "# Slide decks"
      , "| Deck HTML | Handout HTML | Deck PDF | Handout PDF|"
      , "|-----------|--------------|----------|------------|"
      , unlines $ makeRow deckData
      , "# Pages"
      , "| Page HTML | Page PDF |"
      , "|-----------|----------|"
      , unlines $ makeRow pageData
      ]
  where
    makeRow = map (("| " ++) . (++ " | ") . intercalate " | " . map makeLink)
    makeLink file =
      "[" ++ takeFileName file ++ "](" ++ makeRelative baseUrl file ++ ")"

125
-- | Generates an index.md file with links to all generated files of interest.
126 127
writeIndex ::
     FilePath -> FilePath -> [FilePath] -> [FilePath] -> [FilePath] -> Action ()
128 129 130 131
writeIndex out baseUrl decks handouts pages = do
  let decksLinks = map (makeRelative baseUrl) decks
  let handoutsLinks = map (makeRelative baseUrl) handouts
  let pagesLinks = map (makeRelative baseUrl) pages
132
  dirs <- getProjectDirs
133 134 135 136 137
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
Henrik Tramberend's avatar
Henrik Tramberend committed
138
      , "subtitle: " ++ project dirs
139 140 141 142 143 144 145 146 147
      , "---"
      , "# Slide decks"
      , unlines $ map makeLink $ sort decksLinks
      , "# Handouts"
      , unlines $ map makeLink $ sort handoutsLinks
      , "# Supporting Documents"
      , unlines $ map makeLink $ sort pagesLinks
      ]
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
148
    makeLink file = "-    [" ++ takeFileName file ++ "](" ++ file ++ ")"
149

150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
-- | Generates an index.md file with links to all generated files of interest.
writeIndexLists ::
     FilePath
  -> FilePath
  -> [(FilePath, FilePath)]
  -> [(FilePath, FilePath)]
  -> [(FilePath, FilePath)]
  -> Action ()
writeIndexLists out baseUrl decks handouts pages = do
  dirs <- getProjectDirs
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
      , "subtitle: " ++ project dirs
      , "---"
      , "# Slide decks"
      , unlines $ map makeLink decks
      , "# Handouts"
      , unlines $ map makeLink handouts
      , "# Supporting Documents"
      , unlines $ map makeLink pages
      ]
  where
    makeLink (html, pdf) =
      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)

182 183 184 185 186 187
-- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkup :: B.ByteString -> T.Text
fixMustacheMarkup content = fixMustacheMarkupText $ E.decodeUtf8 content

-- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkupText :: T.Text -> T.Text
188 189 190 191 192 193
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

194
substituteMetaData :: T.Text -> MT.Value -> T.Text
Henrik Tramberend's avatar
Henrik Tramberend committed
195 196
substituteMetaData source metaData = do
  let fixed = fixMustacheMarkupText source
197 198 199
  let result = M.compileTemplate "internal" fixed
  case result of
    Right template -> M.substituteValue template metaData
Henrik Tramberend's avatar
Henrik Tramberend committed
200
    Left errMsg -> throw $ MustacheException (show errMsg)
201

202
getTemplate :: FilePath -> Action String
Henrik Tramberend's avatar
Henrik Tramberend committed
203
getTemplate file = liftIO $ getResourceString ("template" </> file)
204

Henrik Tramberend's avatar
Henrik Tramberend committed
205
-- | Write a markdown file to a HTML file using the page template.
206 207
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
208
  putCurrentDocument out
209 210
  supportDir <- support <$> getProjectDirs
  need [supportDir </> "decker.css"]
Henrik Tramberend's avatar
Henrik Tramberend committed
211 212
  supportDirRel <- getRelativeSupportDir (takeDirectory out)
  template <- getTemplate "deck.html"
213 214
  let options =
        pandocWriterOpts
215
        { writerSlideLevel = Just 1
Henrik Tramberend's avatar
Henrik Tramberend committed
216
        , writerTemplate = Just template
217
        , writerHighlightStyle = Just pygments
218
        , writerHTMLMathMethod =
219
            MathJax
220
              (supportDirRel </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
221
        , writerVariables =
222
            [ ("revealjs-url", supportDirRel </> "node_modules" </> "reveal.js")
223
            , ("decker-support-dir", supportDirRel)
224
            ]
225 226
        , writerCiteMethod = Citeproc
        }
227
  readAndProcessMarkdown markdownFile (Disposition Deck Html) >>=
228 229
    writePandocFile "revealjs" options out

Henrik Tramberend's avatar
Henrik Tramberend committed
230 231 232
runIOQuietly :: PandocIO a -> IO (Either PandocError a)
runIOQuietly act = runIO (setVerbosity ERROR >> act)

233 234
writePandocFile :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
writePandocFile fmt options out pandoc =
235 236 237 238 239 240 241 242 243
  liftIO $
  case getWriter fmt of
    Right (TextWriter writePandoc, _) ->
      runIOQuietly (writePandoc options pandoc) >>= handleError >>=
      T.writeFile out
    Right (ByteStringWriter writePandoc, _) ->
      runIOQuietly (writePandoc options pandoc) >>= handleError >>=
      LB.writeFile out
    Left e -> throw $ PandocException e
Henrik Tramberend's avatar
Henrik Tramberend committed
244

245 246
versionCheck :: Meta -> Action ()
versionCheck meta =
247
  unless isDevelopmentVersion $
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
  case lookupMeta "decker-version" meta of
    Just (MetaInlines version) -> check $ stringify version
    Just (MetaString version) -> check version
    _ ->
      putNormal $
      "  - Document version unspecified. This is decker version " ++
      deckerVersion ++ "."
  where
    check version =
      when (List.trim version /= List.trim deckerVersion) $
      putNormal $
      "  - Document version " ++
      version ++
      ". This is decker version " ++ deckerVersion ++ ". Expect problems."

Henrik Tramberend's avatar
Henrik Tramberend committed
263
-- | Reads a markdownfile, expands the included files, and substitutes mustache
264
-- template variables and calls need.
265
readAndProcessMarkdown :: FilePath -> Disposition -> Action Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
266 267
readAndProcessMarkdown markdownFile disp = do
  pandoc@(Pandoc meta _) <-
268
    readMetaMarkdown markdownFile >>= processIncludes baseDir
Henrik Tramberend's avatar
Henrik Tramberend committed
269
  processPandoc pipeline baseDir disp (provisioningFromMeta meta) pandoc
270 271 272 273 274
  where
    baseDir = takeDirectory markdownFile
    pipeline =
      concatM
        [ expandDeckerMacros
275
        , renderCodeBlocks
Henrik Tramberend's avatar
Henrik Tramberend committed
276
        , provisionResources
277
        , makeSlides
278
        , renderMediaTags
279
        , processCitesWithDefault
280
        , appendScripts
281 282 283 284
        ]
  -- Disable automatic caching of remote images for a while
  -- >>= walkM (cacheRemoteImages (cache dirs))

Henrik Tramberend's avatar
WIP  
Henrik Tramberend committed
285
provisionResources :: Pandoc -> Decker Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
286
provisionResources pandoc = do
Henrik Tramberend's avatar
Henrik Tramberend committed
287 288
  base <- gets basePath
  method <- gets provisioning
Henrik Tramberend's avatar
Henrik Tramberend committed
289
  lift $
Henrik Tramberend's avatar
Henrik Tramberend committed
290 291
    mapMetaResources (provisionMetaResource base method) pandoc >>=
    mapResources (provisionResource base method)
Henrik Tramberend's avatar
Henrik Tramberend committed
292

Henrik Tramberend's avatar
Henrik Tramberend committed
293 294 295
provisionMetaResource ::
     FilePath -> Provisioning -> (String, FilePath) -> Action FilePath
provisionMetaResource base method (key, url)
296
  | key `elem` runtimeMetaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
297
    filePath <- urlToFilePathIfLocal base url
Henrik Tramberend's avatar
Henrik Tramberend committed
298
    provisionResource base method filePath
Henrik Tramberend's avatar
Henrik Tramberend committed
299
provisionMetaResource base _ (key, url)
300
  | key `elem` compiletimeMetaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
301
    filePath <- urlToFilePathIfLocal base url
302 303
    need [filePath]
    return filePath
Henrik Tramberend's avatar
Henrik Tramberend committed
304
provisionMetaResource _ _ (_, url) = return url
305 306 307 308 309

-- | Determines if a URL can be resolved to a local file. Absolute file URLs are
-- resolved against and copied or linked to public from 
--    1. the project root 
--    2. the local filesystem root 
Henrik Tramberend's avatar
WIP  
Henrik Tramberend committed
310
--
311 312 313 314
-- Relative file URLs are resolved against and copied or linked to public from 
--
--    1. the directory path of the referencing file 
--    2. the project root Copy and link operations target the public directory
Henrik Tramberend's avatar
WIP  
Henrik Tramberend committed
315 316 317
--       in the project root and recreate the source directory structure. 
--
-- This function is used to provision resources that are used at presentation
318 319 320
--       time.
--
-- Returns a public URL relative to base
Henrik Tramberend's avatar
Henrik Tramberend committed
321
provisionResource :: FilePath -> Provisioning -> FilePath -> Action FilePath
322
provisionResource base method filePath =
Henrik Tramberend's avatar
Henrik Tramberend committed
323 324
  case parseRelativeReference filePath of
    Nothing -> return filePath
325
    Just uri -> do
Henrik Tramberend's avatar
Henrik Tramberend committed
326
      dirs <- getProjectDirs
327 328
      need [uriPath uri]
      let resource = resourcePathes dirs base uri
329
      publicResource <- getPublicResource
330
      withResource publicResource 1 $
331
        liftIO $
Henrik Tramberend's avatar
Henrik Tramberend committed
332
        case method of
333 334 335 336
          Copy -> copyResource resource
          SymLink -> linkResource resource
          Absolute -> absRefResource resource
          Relative -> relRefResource base resource
Henrik Tramberend's avatar
Henrik Tramberend committed
337

338
putCurrentDocument :: FilePath -> Action ()
339 340 341
putCurrentDocument out = do
  dirs <- getProjectDirs
  let rel = makeRelative (public dirs) out
Henrik Tramberend's avatar
Henrik Tramberend committed
342
  putNormal $ "# pandoc (for " ++ rel ++ ")"
343

Henrik Tramberend's avatar
Henrik Tramberend committed
344
-- | Write a markdown file to a HTML file using the page template.
345 346
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
347
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
348
  supportDir <- getRelativeSupportDir (takeDirectory out)
349
  template <- getTemplate "page.html"
350 351
  let options =
        pandocWriterOpts
352 353
        { writerTemplate = Just template
        , writerHighlightStyle = Just pygments
354
        , writerHTMLMathMethod =
355 356
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
357 358 359
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
360
  readAndProcessMarkdown markdownFile (Disposition Page Html) >>=
361
    writePandocFile "html5" options out
Henrik Tramberend's avatar
Henrik Tramberend committed
362 363

-- | Write a markdown file to a PDF file using the handout template.
364 365
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
366
  putCurrentDocument out
Bernward's avatar
Bernward committed
367
  template <- getTemplate "page.tex"
368 369
  let options =
        pandocWriterOpts
370
        { writerTemplate = Just template
371
        , writerHighlightStyle = Just pygments
372 373
        , writerCiteMethod = Citeproc
        }
374 375 376 377
  readAndProcessMarkdown markdownFile (Disposition Page Pdf) >>=
    pandocMakePdf options out

pandocMakePdf :: WriterOptions -> FilePath -> Pandoc -> Action ()
378
pandocMakePdf options out pandoc =
379
  liftIO $ do
Henrik Tramberend's avatar
Henrik Tramberend committed
380
    result <-
381
      runIOQuietly (makePDF "xelatex" [] writeLaTeX options pandoc) >>=
Henrik Tramberend's avatar
Henrik Tramberend committed
382
      handleError
383 384 385
    case result of
      Left errMsg -> throw $ PandocException (show errMsg)
      Right pdf -> liftIO $ LB.writeFile out pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
386 387

-- | Write a markdown file to a HTML file using the handout template.
388 389
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
390
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
391
  supportDir <- getRelativeSupportDir (takeDirectory out)
392
  template <- getTemplate "handout.html"
393 394
  let options =
        pandocWriterOpts
395 396
        { writerTemplate = Just template
        , writerHighlightStyle = Just pygments
397
        , writerHTMLMathMethod =
398 399
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
400 401 402
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
403
  readAndProcessMarkdown markdownFile (Disposition Handout Html) >>=
404
    writePandocFile "html5" options out
Henrik Tramberend's avatar
Henrik Tramberend committed
405 406

-- | Write a markdown file to a PDF file using the handout template.
407
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
408
markdownToPdfHandout markdownFile out = do
409
  putCurrentDocument out
Bernward's avatar
Bernward committed
410
  template <- getTemplate "handout.tex"
411 412
  let options =
        pandocWriterOpts
413
        { writerTemplate = Just template
414
        , writerHighlightStyle = Just pygments
415 416
        , writerCiteMethod = Citeproc
        }
417 418
  readAndProcessMarkdown markdownFile (Disposition Handout Pdf) >>=
    pandocMakePdf options out
419

420 421 422
-- | 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.
423
readMetaMarkdown :: FilePath -> Action Pandoc
424 425
readMetaMarkdown markdownFile = do
  need [markdownFile]
426
  -- read external meta data for this directory
Henrik Tramberend's avatar
Henrik Tramberend committed
427
  externalMeta <- readMetaDataForDir (takeDirectory markdownFile)
428
  -- extract embedded meta data from the document
429
  markdown <- liftIO $ T.readFile markdownFile
Henrik Tramberend's avatar
Henrik Tramberend committed
430 431
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
432
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
433 434 435
  let combinedMeta = mergePandocMeta documentMeta (toPandocMeta externalMeta)
  let mustacheMeta = toMustacheMeta combinedMeta
   -- use mustache to substitute
436
  let substituted = substituteMetaData markdown mustacheMeta
Henrik Tramberend's avatar
Henrik Tramberend committed
437
  -- read markdown with substitutions again
Henrik Tramberend's avatar
Henrik Tramberend committed
438
  let Pandoc _ blocks = readMarkdownOrThrow pandocReaderOpts substituted
439
  case combinedMeta of
Henrik Tramberend's avatar
Henrik Tramberend committed
440 441 442 443 444
    (MetaMap m) -> do
      versionCheck (Meta m)
      let pandoc = Pandoc (Meta m) blocks
      mapResources (urlToFilePathIfLocal (takeDirectory markdownFile)) pandoc
    _ -> throw $ PandocException "Meta format conversion failed."
445 446

urlToFilePathIfLocal :: FilePath -> FilePath -> Action FilePath
447
urlToFilePathIfLocal base uri =
448 449 450
  case parseRelativeReference uri of
    Nothing -> return uri
    Just relativeUri -> do
Henrik Tramberend's avatar
Henrik Tramberend committed
451
      let filePath = uriPath relativeUri
452 453 454
      absBase <- liftIO $ Dir.makeAbsolute base
      absRoot <- project <$> getProjectDirs
      let absPath =
Henrik Tramberend's avatar
Henrik Tramberend committed
455 456 457
            if isAbsolute filePath
              then absRoot </> makeRelative "/" filePath
              else absBase </> filePath
458
      return absPath
459

460 461 462
readMarkdownOrThrow :: ReaderOptions -> T.Text -> Pandoc
readMarkdownOrThrow opts markdown =
  case runPure (readMarkdown opts markdown) of
463
    Right pandoc -> pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
464
    Left errMsg -> throw $ PandocException (show errMsg)
465

466
-- Remove automatic identifier creation for headers. It does not work well with
467
-- the current include mechanism if slides have duplicate titles in separate
468
-- include files.
469 470
deckerPandocExtensions :: Extensions
deckerPandocExtensions = disableExtension Ext_auto_identifiers pandocExtensions
471 472

pandocReaderOpts :: ReaderOptions
473
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
474 475

pandocWriterOpts :: WriterOptions
476
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
477

478
mapResources :: (FilePath -> Action FilePath) -> Pandoc -> Action Pandoc
479 480 481
mapResources transform (Pandoc meta blocks) =
  Pandoc meta <$> walkM (mapInline transform) blocks >>=
  walkM (mapBlock transform)
482

483
mapAttributes :: (FilePath -> Action FilePath) -> Attr -> Action Attr
Henrik Tramberend's avatar
Henrik Tramberend committed
484 485
mapAttributes transform (ident, classes, kvs) = do
  processed <- mapM mapAttr kvs
486 487
  return (ident, classes, processed)
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
488 489
    mapAttr kv@(key, value) =
      if key `elem` elementAttributes
490 491 492 493 494
        then do
          transformed <- transform value
          return (key, transformed)
        else return kv

495
mapInline :: (FilePath -> Action FilePath) -> Inline -> Action Inline
Henrik Tramberend's avatar
Henrik Tramberend committed
496
mapInline transform (Image attr inlines (url, title)) = do
497 498 499
  a <- mapAttributes transform attr
  u <- transform url
  return $ Image a inlines (u, title)
Henrik Tramberend's avatar
Henrik Tramberend committed
500
mapInline transform lnk@(Link attr@(_, cls, _) inlines (url, title)) =
501
  if "resource" `elem` cls
502 503 504 505 506 507 508 509 510 511 512 513 514
    then do
      a <- mapAttributes transform attr
      u <- transform url
      return (Link a inlines (u, title))
    else return lnk
mapInline transform (Span attr inlines) = do
  attribs <- mapAttributes transform attr
  return (Span attribs inlines)
mapInline transform (Code attr string) = do
  attribs <- mapAttributes transform attr
  return (Code attribs string)
mapInline _ inline = return inline

515
mapBlock :: (FilePath -> Action FilePath) -> Block -> Action Block
516 517 518 519 520 521 522 523 524 525 526
mapBlock transform (CodeBlock attr string) = do
  attribs <- mapAttributes transform attr
  return (CodeBlock attribs string)
mapBlock transform (Header n attr inlines) = do
  attribs <- mapAttributes transform attr
  return (Header n attribs inlines)
mapBlock transform (Div attr blocks) = do
  attribs <- mapAttributes transform attr
  return (Div attribs blocks)
mapBlock _ block = return block

527 528
mapMetaResources ::
     ((String, FilePath) -> Action FilePath) -> Pandoc -> Action Pandoc
529 530 531 532 533 534
mapMetaResources transform (Pandoc (Meta kvmap) blocks) = do
  mapped <- mapM mapMeta $ Map.toList kvmap
  return $ Pandoc (Meta $ Map.fromList mapped) blocks
  where
    mapMeta (k, MetaString v)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
535
        transformed <- transform (k, v)
536 537 538
        return (k, MetaString transformed)
    mapMeta (k, MetaInlines inlines)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
539
        transformed <- transform (k, stringify inlines)
540 541 542
        return (k, MetaString transformed)
    mapMeta (k, MetaList l)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
543
        transformed <- mapM (mapMetaList k) l
544 545
        return (k, MetaList transformed)
    mapMeta kv = return kv
Henrik Tramberend's avatar
Henrik Tramberend committed
546 547 548 549
    mapMetaList k (MetaString v) = MetaString <$> transform (k, v)
    mapMetaList k (MetaInlines inlines) =
      MetaString <$> transform (k, stringify inlines)
    mapMetaList _ v = return v
550

Henrik Tramberend's avatar
Henrik Tramberend committed
551 552 553
-- | These resources are needed at runtime. If they are specified as local URLs,
-- the resource must exists at compile time. Remote URLs are passed through
-- unchanged.
Henrik Tramberend's avatar
Henrik Tramberend committed
554
elementAttributes :: [String]
555 556 557 558 559 560 561 562 563
elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

Henrik Tramberend's avatar
Henrik Tramberend committed
564 565
-- | Resources in meta data that are needed at compile time. They have to be
-- specified as local URLs and must exist.
566
runtimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
567 568
runtimeMetaKeys = ["css"]

569
compiletimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
570 571
compiletimeMetaKeys = ["bibliography", "csl", "citation-abbreviations"]

572
metaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
573
metaKeys = runtimeMetaKeys ++ compiletimeMetaKeys
574

Henrik Tramberend's avatar
Henrik Tramberend committed
575
-- Transitively splices all include files into the pandoc document.
576
processIncludes :: FilePath -> Pandoc -> Action Pandoc
577 578
processIncludes baseDir (Pandoc meta blocks) =
  Pandoc meta <$> processBlocks baseDir blocks
579 580
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
581 582
    processBlocks base blcks =
      concat . reverse <$> foldM (include base) [] blcks
583
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
584
    include base result (Para [Link _ [Str ":include"] (url, _)]) = do
585 586 587 588
      includeFile <- urlToFilePathIfLocal base url
      need [includeFile]
      Pandoc _ b <- readMetaMarkdown includeFile
      included <- processBlocks (takeDirectory includeFile) b
589
      return $ included : result
590
    include _ result block = return $ [block] : result
591

592 593 594 595
processCitesWithDefault :: Pandoc -> Decker Pandoc
processCitesWithDefault pandoc@(Pandoc meta blocks) =
  lift $ do
    document <-
596 597 598 599 600 601 602
      case lookupMeta "csl" meta of
        Nothing -> do
          dir <- appData <$> getProjectDirs
          let defaultCsl = dir </> "template" </> "acm-sig-proceedings.csl"
          let cslMeta = setMeta "csl" (MetaString defaultCsl) meta
          return (Pandoc cslMeta blocks)
        _ -> return pandoc
603
    liftIO $ processCites' document
Henrik Tramberend's avatar
Henrik Tramberend committed
604

605
writeExampleProject :: Action ()
606
writeExampleProject = liftIO $ writeResourceFiles "example" "."
607 608

{--
Henrik Tramberend's avatar
Henrik Tramberend committed
609
writeExampleProject :: Action ()
610
writeExampleProject = mapM_ writeOne deckerExampleDir
611
  where
612 613
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
614
      unless exists $ do
615
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
616 617
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
618
--}
619
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
620 621 622
writeEmbeddedFiles files dir = do
  exists <- doesDirectoryExist dir
  unless exists $ do
Henrik Tramberend's avatar
Henrik Tramberend committed
623
    putNormal $ "# write embedded files for (" ++ dir ++ ")"
624 625
    let absolute = map (first (dir </>)) files
    mapM_ write absolute
626
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
627 628 629 630
    write (filePath, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory filePath)
      exists <- liftIO $ Dir.doesFileExist filePath
      unless exists $ liftIO $ B.writeFile filePath contents
631

Henrik Tramberend's avatar
Henrik Tramberend committed
632
lookupValue :: String -> Y.Value -> Maybe Y.Value
633
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
634
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
635

636
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
637
metaValueAsString key meta =
638 639 640
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
641 642
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
643
    lookup' [] (Just (Y.String s)) = Just (T.unpack s)
644 645 646 647
    lookup' [] (Just (Y.Number n)) = Just (show n)
    lookup' [] (Just (Y.Bool b)) = Just (show b)
    lookup' (k:ks) (Just obj@(Y.Object _)) = lookup' ks (lookupValue k obj)
    lookup' _ _ = Nothing