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

Henrik Tramberend's avatar
Henrik Tramberend committed
25
import Common
26
import Exception
27
28
29
30
31
32
33
34
35
import Filter
import Macro
import Meta
import Project
import Render
import Resources
import Server
import Shake

36
import Control.Arrow
37
import Control.Concurrent
Henrik Tramberend's avatar
Henrik Tramberend committed
38
import Control.Exception
39
import Control.Lens ((^.))
40
41
import Control.Monad
import Control.Monad.Loops
Henrik Tramberend's avatar
Henrik Tramberend committed
42
import Control.Monad.State
43
import Control.Monad.Trans.Class
44
import Control.Monad.Trans.Maybe
45
46
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
47
import Data.Dynamic
48
49
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
50
51
import Data.List as List
import Data.List.Extra as List
52
import qualified Data.Map.Lazy as Map
53
import Data.Maybe
Henrik Tramberend's avatar
Henrik Tramberend committed
54
import qualified Data.Text as T
55
import qualified Data.Text.Encoding as E
Henrik Tramberend's avatar
Henrik Tramberend committed
56
import qualified Data.Text.IO as T
57
58
59
60
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Network.URI
61
import qualified System.Directory as Dir
62
import System.FilePath.Glob
63
import Text.CSL.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
64
65
66
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
67
import Text.Pandoc.Builder
Henrik Tramberend's avatar
Henrik Tramberend committed
68
import Text.Pandoc.Highlighting
Henrik Tramberend's avatar
Henrik Tramberend committed
69
import Text.Pandoc.PDF
70
import Text.Pandoc.Shared
71
import Text.Pandoc.Walk
72
import Text.Printf
Henrik Tramberend's avatar
Henrik Tramberend committed
73
74

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

78
79
80
81
-- | 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
82
  dirs <- projectDirsA
83
84
85
86
87
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
88
      , "subtitle: " ++ dirs ^. project
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
      , "---"
      , "# 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 ++ ")"

104
-- | Generates an index.md file with links to all generated files of interest.
105
106
writeIndex ::
     FilePath -> FilePath -> [FilePath] -> [FilePath] -> [FilePath] -> Action ()
107
108
109
110
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
111
  dirs <- projectDirsA
112
113
114
115
116
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
117
      , "subtitle: " ++ dirs ^. project
118
119
120
121
122
123
124
125
126
      , "---"
      , "# 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
127
    makeLink file = "-    [" ++ takeFileName file ++ "](" ++ file ++ ")"
128

129
-- | Generates an index.md file with links to all generated files of interest.
130
131
132
133
134
135
136
writeIndexLists :: FilePath -> FilePath -> Action ()
writeIndexLists out baseUrl = do
  dirs <- projectDirsA
  ts <- targetsA
  let decks = (zip (_decks ts) (_decksPdf ts))
  let handouts = (zip (_handouts ts) (_handoutsPdf ts))
  let pages = (zip (_pages ts) (_pagesPdf ts))
137
138
139
140
141
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
142
      , "subtitle: " ++ dirs ^. project
143
144
145
146
147
148
149
150
151
152
153
154
155
      , "---"
      , "# 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)
Henrik Tramberend's avatar
Henrik Tramberend committed
156
157
        (makeRelative baseUrl html)
        (makeRelative baseUrl pdf)
158

159
160
161
162
163
164
-- | 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
165
166
167
168
169
170
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

171
substituteMetaData :: T.Text -> MT.Value -> T.Text
Henrik Tramberend's avatar
Henrik Tramberend committed
172
173
substituteMetaData source metaData = do
  let fixed = fixMustacheMarkupText source
174
175
176
  let result = M.compileTemplate "internal" fixed
  case result of
    Right template -> M.substituteValue template metaData
Henrik Tramberend's avatar
Henrik Tramberend committed
177
    Left errMsg -> throw $ MustacheException (show errMsg)
178

179
180
getTemplate :: Meta -> Disposition -> Action String
getTemplate meta disp = do
181
182
183
184
  let templateOverridePath =
        case templateFromMeta meta of
          Just template -> Just $ template </> (getTemplateFileName disp)
          Nothing -> Nothing
185
186
187
188
189
190
  if isJust templateOverridePath
    then do
      let templateOverridePath' = fromJust templateOverridePath
      need [templateOverridePath']
      liftIO $ readFile templateOverridePath'
    else liftIO $ getResourceString ("template" </> (getTemplateFileName disp))
191

192
193
getSupportDir :: Meta -> FilePath -> FilePath -> Action FilePath
getSupportDir meta out defaultPath = do
194
  dirs <- projectDirsA
195
  cur <- liftIO Dir.getCurrentDirectory
Henrik Tramberend's avatar
Henrik Tramberend committed
196
197
198
  return $
    case templateFromMeta meta of
      Just template ->
199
        (makeRelativeTo (takeDirectory out) (dirs ^. public)) </>
Henrik Tramberend's avatar
Henrik Tramberend committed
200
201
202
203
204
205
206
207
208
209
        (makeRelativeTo cur template)
      Nothing -> defaultPath

-- | Write Pandoc in native format right next to the output file
writeNativeWhileDebugging :: FilePath -> String -> Pandoc -> Action Pandoc
writeNativeWhileDebugging out mod doc@(Pandoc meta body) = do
  liftIO $
    runIOQuietly (writeNative pandocWriterOpts doc) >>= handleError >>=
    T.writeFile (out -<.> mod <.> ".hs")
  return doc
210

Henrik Tramberend's avatar
Henrik Tramberend committed
211
-- | Write a markdown file to a HTML file using the page template.
212
213
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
214
  putCurrentDocument out
215
  supportDir <- _support <$> projectDirsA
Henrik Tramberend's avatar
Henrik Tramberend committed
216
  supportDirRel <- getRelativeSupportDir (takeDirectory out)
217
218
219
  let disp = Disposition Deck Html
  pandoc@(Pandoc meta _) <- readAndProcessMarkdown markdownFile disp
  template <- getTemplate meta disp
220
  templateSupportDir <- getSupportDir meta out supportDirRel
221
222
  let options =
        pandocWriterOpts
Henrik Tramberend's avatar
Henrik Tramberend committed
223
224
225
226
227
228
229
230
231
232
233
234
235
236
          { writerSlideLevel = Just 1
          , writerTemplate = Just template
          , writerHighlightStyle = Just pygments
          , writerHTMLMathMethod =
              MathJax
                (supportDirRel </> "node_modules" </> "mathjax" </>
                 "MathJax.js?config=TeX-AMS_HTML")
          , writerVariables =
              [ ( "revealjs-url"
                , supportDirRel </> "node_modules" </> "reveal.js")
              , ("decker-support-dir", templateSupportDir)
              ]
          , writerCiteMethod = Citeproc
          }
237
  readAndProcessMarkdown markdownFile (Disposition Deck Html) >>=
Henrik Tramberend's avatar
Henrik Tramberend committed
238
    writeNativeWhileDebugging out "filtered" >>=
239
240
    writePandocFile "revealjs" options out

Henrik Tramberend's avatar
Henrik Tramberend committed
241
242
243
runIOQuietly :: PandocIO a -> IO (Either PandocError a)
runIOQuietly act = runIO (setVerbosity ERROR >> act)

244
245
writePandocFile :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
writePandocFile fmt options out pandoc =
246
247
248
249
  liftIO $
  case getWriter fmt of
    Right (TextWriter writePandoc, _) ->
      runIOQuietly (writePandoc options pandoc) >>= handleError >>=
250
        B.writeFile out . E.encodeUtf8
251
252
253
254
    Right (ByteStringWriter writePandoc, _) ->
      runIOQuietly (writePandoc options pandoc) >>= handleError >>=
      LB.writeFile out
    Left e -> throw $ PandocException e
Henrik Tramberend's avatar
Henrik Tramberend committed
255

256
257
versionCheck :: Meta -> Action ()
versionCheck meta =
258
  unless isDevelopmentVersion $
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
  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
274
-- | Reads a markdownfile, expands the included files, and substitutes mustache
275
-- template variables and calls need.
276
277
readAndProcessMarkdown :: FilePath -> Disposition -> Action Pandoc
readAndProcessMarkdown markdownFile disp = do
Henrik Tramberend's avatar
Henrik Tramberend committed
278
  pandoc@(Pandoc meta _) <-
Henrik Tramberend's avatar
Henrik Tramberend committed
279
    readMetaMarkdown markdownFile >>= processIncludes baseDir -- >>= writeNativeWhileDebugging markdownFile "parsed"
280
  processPandoc pipeline baseDir disp (provisioningFromMeta meta) pandoc
281
282
283
284
285
  where
    baseDir = takeDirectory markdownFile
    pipeline =
      concatM
        [ expandDeckerMacros
286
        , renderCodeBlocks
Henrik Tramberend's avatar
Henrik Tramberend committed
287
        , provisionResources
288
        , processSlides
289
        , renderMediaTags
290
        , extractFigures
291
        , processCitesWithDefault
292
        , appendScripts
293
294
295
296
        ]
  -- Disable automatic caching of remote images for a while
  -- >>= walkM (cacheRemoteImages (cache dirs))

297
298
-- | Determines which template file name to use
-- for a certain disposition type
299
300
getTemplateFileName :: Disposition -> String
getTemplateFileName (Disposition Deck Html) = "deck.html"
Henrik Tramberend's avatar
Henrik Tramberend committed
301
getTemplateFileName (Disposition Deck Latex) = "deck.tex"
302
getTemplateFileName (Disposition Page Html) = "page.html"
Henrik Tramberend's avatar
Henrik Tramberend committed
303
getTemplateFileName (Disposition Page Latex) = "page.tex"
304
getTemplateFileName (Disposition Handout Html) = "handout.html"
Henrik Tramberend's avatar
Henrik Tramberend committed
305
getTemplateFileName (Disposition Handout Latex) = "handout.tex"
306

Henrik Tramberend's avatar
WIP    
Henrik Tramberend committed
307
provisionResources :: Pandoc -> Decker Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
308
provisionResources pandoc = do
Henrik Tramberend's avatar
Henrik Tramberend committed
309
310
  base <- gets basePath
  method <- gets provisioning
Henrik Tramberend's avatar
Henrik Tramberend committed
311
  lift $
Henrik Tramberend's avatar
Henrik Tramberend committed
312
313
    mapMetaResources (provisionMetaResource base method) pandoc >>=
    mapResources (provisionResource base method)
Henrik Tramberend's avatar
Henrik Tramberend committed
314

Henrik Tramberend's avatar
Henrik Tramberend committed
315
316
317
provisionMetaResource ::
     FilePath -> Provisioning -> (String, FilePath) -> Action FilePath
provisionMetaResource base method (key, url)
318
  | key `elem` runtimeMetaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
319
    filePath <- urlToFilePathIfLocal base url
Henrik Tramberend's avatar
Henrik Tramberend committed
320
    provisionResource base method filePath
321
322
323
324
325
provisionMetaResource base method (key, url)
  | key `elem` templateOverrideMetaKeys = do
    cwd <- liftIO $ Dir.getCurrentDirectory
    filePath <- urlToFilePathIfLocal cwd url
    provisionTemplateOverrideSupportTopLevel cwd method filePath
Henrik Tramberend's avatar
Henrik Tramberend committed
326
provisionMetaResource base _ (key, url)
327
  | key `elem` compiletimeMetaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
328
    filePath <- urlToFilePathIfLocal base url
329
330
    need [filePath]
    return filePath
331
332
provisionMetaResource _ _ (key, url) = return url

333
334
335
336
337
338
provisionTemplateOverrideSupport ::
     FilePath -> Provisioning -> FilePath -> Action ()
provisionTemplateOverrideSupport base method url = do
  let newBase = base </> url
  exists <- liftIO $ Dir.doesDirectoryExist url
  if exists
339
    then liftIO (Dir.listDirectory url) >>= mapM_ recurseProvision
340
341
342
343
344
345
    else do
      need [url]
      provisionResource base method url
      return ()
  where
    recurseProvision x = provisionTemplateOverrideSupport url method (url </> x)
346

347
348
provisionTemplateOverrideSupportTopLevel ::
     FilePath -> Provisioning -> FilePath -> Action FilePath
349
provisionTemplateOverrideSupportTopLevel base method url = do
350
351
  liftIO (Dir.listDirectory url) >>= filterM dirFilter >>=
    mapM_ recurseProvision
352
353
354
355
  return $ url
  where
    dirFilter x = liftIO $ Dir.doesDirectoryExist (url </> x)
    recurseProvision x = provisionTemplateOverrideSupport url method (url </> x)
356
357
358
359
360

-- | 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
361
--
362
363
364
365
-- 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
366
367
368
--       in the project root and recreate the source directory structure. 
--
-- This function is used to provision resources that are used at presentation
369
370
371
--       time.
--
-- Returns a public URL relative to base
Henrik Tramberend's avatar
Henrik Tramberend committed
372
provisionResource :: FilePath -> Provisioning -> FilePath -> Action FilePath
373
provisionResource base method filePath =
Henrik Tramberend's avatar
Henrik Tramberend committed
374
375
  case parseRelativeReference filePath of
    Nothing -> return filePath
376
    Just uri -> do
377
      dirs <- projectDirsA
Henrik Tramberend's avatar
Henrik Tramberend committed
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
      let path = uriPath uri
      fileExists <- doesFileExist path
      if fileExists
        then do
          need [path]
          let resource = resourcePathes dirs base uri
          p <- publicResourceA
          withResource p 1 $
            liftIO $
            case method of
              Copy -> copyResource resource
              SymLink -> linkResource resource
              Absolute -> absRefResource resource
              Relative -> relRefResource base resource
        else throw $ ResourceException $ "resource does not exist: " ++ path
Henrik Tramberend's avatar
Henrik Tramberend committed
393

394
putCurrentDocument :: FilePath -> Action ()
395
putCurrentDocument out = do
396
397
  public <- publicA
  let rel = makeRelative public out
Henrik Tramberend's avatar
Henrik Tramberend committed
398
  putNormal $ "# pandoc (for " ++ rel ++ ")"
399

Henrik Tramberend's avatar
Henrik Tramberend committed
400
-- | Write a markdown file to a HTML file using the page template.
401
402
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
403
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
404
  supportDir <- getRelativeSupportDir (takeDirectory out)
405
  let disp = Disposition Page Html
406
  pandoc@(Pandoc meta _) <- readAndProcessMarkdown markdownFile disp
407
  template <- getTemplate meta disp
408
  templateSupportDir <- getSupportDir meta out supportDir
409
410
  let options =
        pandocWriterOpts
Henrik Tramberend's avatar
Henrik Tramberend committed
411
412
413
414
415
416
417
418
419
          { writerTemplate = Just template
          , writerHighlightStyle = Just pygments
          , writerHTMLMathMethod =
              MathJax
                (supportDir </> "node_modules" </> "mathjax" </>
                 "MathJax.js?config=TeX-AMS_HTML")
          , writerVariables = [("decker-support-dir", templateSupportDir)]
          , writerCiteMethod = Citeproc
          }
420
  readAndProcessMarkdown markdownFile (Disposition Page Html) >>=
421
    writePandocFile "html5" options out
Henrik Tramberend's avatar
Henrik Tramberend committed
422
423

-- | Write a markdown file to a PDF file using the handout template.
424
425
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
426
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
427
  let disp = Disposition Page Latex
428
429
  pandoc@(Pandoc meta _) <- readAndProcessMarkdown markdownFile disp
  template <- getTemplate meta disp
430
431
  let options =
        pandocWriterOpts
432
433
434
435
          { writerTemplate = Just template
          , writerHighlightStyle = Just pygments
          , writerCiteMethod = Citeproc
          }
436
  pandocMakePdf options out pandoc
437

438
439
pandocMakePdf :: WriterOptions -> FilePath -> Pandoc -> Action ()
pandocMakePdf options out pandoc =
440
  liftIO $ do
Henrik Tramberend's avatar
Henrik Tramberend committed
441
    result <-
442
      runIOQuietly (makePDF "xelatex" [] writeLaTeX options pandoc) >>=
Henrik Tramberend's avatar
Henrik Tramberend committed
443
      handleError
444
445
446
    case result of
      Left errMsg -> throw $ PandocException (show errMsg)
      Right pdf -> liftIO $ LB.writeFile out pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
447
448

-- | Write a markdown file to a HTML file using the handout template.
449
450
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
451
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
452
  supportDir <- getRelativeSupportDir (takeDirectory out)
453
454
455
  let disp = Disposition Handout Html
  pandoc@(Pandoc meta _) <- readAndProcessMarkdown markdownFile disp
  template <- getTemplate meta disp
456
  templateSupportDir <- getSupportDir meta out supportDir
457
458
  let options =
        pandocWriterOpts
Henrik Tramberend's avatar
Henrik Tramberend committed
459
460
461
462
463
464
465
466
467
          { writerTemplate = Just template
          , writerHighlightStyle = Just pygments
          , writerHTMLMathMethod =
              MathJax
                (supportDir </> "node_modules" </> "mathjax" </>
                 "MathJax.js?config=TeX-AMS_HTML")
          , writerVariables = [("decker-support-dir", templateSupportDir)]
          , writerCiteMethod = Citeproc
          }
468
  readAndProcessMarkdown markdownFile (Disposition Handout Html) >>=
469
    writePandocFile "html5" options out
Henrik Tramberend's avatar
Henrik Tramberend committed
470
471

-- | Write a markdown file to a PDF file using the handout template.
472
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
473
markdownToPdfHandout markdownFile out = do
474
  putCurrentDocument out
Henrik Tramberend's avatar
Henrik Tramberend committed
475
  let disp = Disposition Handout Latex
476
477
  pandoc@(Pandoc meta _) <- readAndProcessMarkdown markdownFile disp
  template <- getTemplate meta disp
478
479
  let options =
        pandocWriterOpts
480
481
482
483
          { writerTemplate = Just template
          , writerHighlightStyle = Just pygments
          , writerCiteMethod = Citeproc
          }
484
  pandocMakePdf options out pandoc
485

486
487
488
-- | 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.
489
readMetaMarkdown :: FilePath -> Action Pandoc
490
readMetaMarkdown markdownFile = do
491
  projectDir <- projectA
492
  need [markdownFile]
493
  -- read external meta data for this directory
494
495
  externalMeta <-
    liftIO $ aggregateMetaData projectDir (takeDirectory markdownFile)
496
  -- extract embedded meta data from the document
497
  markdown <- liftIO $ E.decodeUtf8 <$> B.readFile markdownFile
Henrik Tramberend's avatar
Henrik Tramberend committed
498
499
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
500
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
501
502
503
  let combinedMeta = mergePandocMeta documentMeta (toPandocMeta externalMeta)
  let mustacheMeta = toMustacheMeta combinedMeta
   -- use mustache to substitute
504
  let substituted = substituteMetaData markdown mustacheMeta
Henrik Tramberend's avatar
Henrik Tramberend committed
505
  -- read markdown with substitutions again
Henrik Tramberend's avatar
Henrik Tramberend committed
506
  let Pandoc _ blocks = readMarkdownOrThrow pandocReaderOpts substituted
507
  case combinedMeta of
Henrik Tramberend's avatar
Henrik Tramberend committed
508
509
510
511
512
    (MetaMap m) -> do
      versionCheck (Meta m)
      let pandoc = Pandoc (Meta m) blocks
      mapResources (urlToFilePathIfLocal (takeDirectory markdownFile)) pandoc
    _ -> throw $ PandocException "Meta format conversion failed."
513
514

urlToFilePathIfLocal :: FilePath -> FilePath -> Action FilePath
515
urlToFilePathIfLocal base uri =
516
517
518
  case parseRelativeReference uri of
    Nothing -> return uri
    Just relativeUri -> do
Henrik Tramberend's avatar
Henrik Tramberend committed
519
      let filePath = uriPath relativeUri
520
      absBase <- liftIO $ Dir.makeAbsolute base
521
      absRoot <- projectA
522
      let absPath =
Henrik Tramberend's avatar
Henrik Tramberend committed
523
524
525
            if isAbsolute filePath
              then absRoot </> makeRelative "/" filePath
              else absBase </> filePath
526
      return absPath
527

528
529
530
readMarkdownOrThrow :: ReaderOptions -> T.Text -> Pandoc
readMarkdownOrThrow opts markdown =
  case runPure (readMarkdown opts markdown) of
531
    Right pandoc -> pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
532
    Left errMsg -> throw $ PandocException (show errMsg)
533

534
-- Remove automatic identifier creation for headers. It does not work well with
535
-- the current include mechanism if slides have duplicate titles in separate
536
-- include files.
537
538
deckerPandocExtensions :: Extensions
deckerPandocExtensions = disableExtension Ext_auto_identifiers pandocExtensions
539
540

pandocReaderOpts :: ReaderOptions
541
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
542
543

pandocWriterOpts :: WriterOptions
544
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
545

546
mapResources :: (FilePath -> Action FilePath) -> Pandoc -> Action Pandoc
547
548
549
mapResources transform (Pandoc meta blocks) =
  Pandoc meta <$> walkM (mapInline transform) blocks >>=
  walkM (mapBlock transform)
550

551
mapAttributes :: (FilePath -> Action FilePath) -> Attr -> Action Attr
Henrik Tramberend's avatar
Henrik Tramberend committed
552
553
mapAttributes transform (ident, classes, kvs) = do
  processed <- mapM mapAttr kvs
554
555
  return (ident, classes, processed)
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
556
557
    mapAttr kv@(key, value) =
      if key `elem` elementAttributes
558
559
560
561
562
        then do
          transformed <- transform value
          return (key, transformed)
        else return kv

563
mapInline :: (FilePath -> Action FilePath) -> Inline -> Action Inline
Henrik Tramberend's avatar
Henrik Tramberend committed
564
mapInline transform (Image attr inlines (url, title)) = do
565
566
567
  a <- mapAttributes transform attr
  u <- transform url
  return $ Image a inlines (u, title)
Henrik Tramberend's avatar
Henrik Tramberend committed
568
mapInline transform lnk@(Link attr@(_, cls, _) inlines (url, title)) =
569
  if "resource" `elem` cls
570
571
572
573
574
575
576
577
578
579
580
581
582
    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

583
mapBlock :: (FilePath -> Action FilePath) -> Block -> Action Block
584
585
586
587
588
589
590
591
592
593
594
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

595
596
mapMetaResources ::
     ((String, FilePath) -> Action FilePath) -> Pandoc -> Action Pandoc
597
598
599
600
601
602
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
603
        transformed <- transform (k, v)
604
605
606
        return (k, MetaString transformed)
    mapMeta (k, MetaInlines inlines)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
607
        transformed <- transform (k, stringify inlines)
608
609
610
        return (k, MetaString transformed)
    mapMeta (k, MetaList l)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
611
        transformed <- mapM (mapMetaList k) l
612
613
        return (k, MetaList transformed)
    mapMeta kv = return kv
Henrik Tramberend's avatar
Henrik Tramberend committed
614
615
616
617
    mapMetaList k (MetaString v) = MetaString <$> transform (k, v)
    mapMetaList k (MetaInlines inlines) =
      MetaString <$> transform (k, stringify inlines)
    mapMetaList _ v = return v
618

Henrik Tramberend's avatar
Henrik Tramberend committed
619
620
621
-- | 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
622
elementAttributes :: [String]
623
624
625
626
627
628
629
630
631
elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

Henrik Tramberend's avatar
Henrik Tramberend committed
632
633
-- | Resources in meta data that are needed at compile time. They have to be
-- specified as local URLs and must exist.
634
runtimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
635
636
runtimeMetaKeys = ["css"]

637
638
639
templateOverrideMetaKeys :: [String]
templateOverrideMetaKeys = ["template"]

640
compiletimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
641
642
compiletimeMetaKeys = ["bibliography", "csl", "citation-abbreviations"]

643
metaKeys :: [String]
644
metaKeys = runtimeMetaKeys ++ compiletimeMetaKeys ++ templateOverrideMetaKeys
645

Henrik Tramberend's avatar
Henrik Tramberend committed
646
-- Transitively splices all include files into the pandoc document.
647
processIncludes :: FilePath -> Pandoc -> Action Pandoc
648
-- TODO: also change include to ![](include:) or something
649
650
processIncludes baseDir (Pandoc meta blocks) =
  Pandoc meta <$> processBlocks baseDir blocks
651
652
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
653
654
    processBlocks base blcks =
      concat . reverse <$> foldM (include base) [] blcks
655
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
656
    include base result (Para [Link _ [Str ":include"] (url, _)]) = do
657
658
659
660
      includeFile <- urlToFilePathIfLocal base url
      need [includeFile]
      Pandoc _ b <- readMetaMarkdown includeFile
      included <- processBlocks (takeDirectory includeFile) b
661
      return $ included : result
662
    include _ result block = return $ [block] : result
663

664
665
666
667
processCitesWithDefault :: Pandoc -> Decker Pandoc
processCitesWithDefault pandoc@(Pandoc meta blocks) =
  lift $ do
    document <-
668
669
      case lookupMeta "csl" meta of
        Nothing -> do
670
          dir <- appDataA
671
672
673
674
          let defaultCsl = dir </> "template" </> "acm-sig-proceedings.csl"
          let cslMeta = setMeta "csl" (MetaString defaultCsl) meta
          return (Pandoc cslMeta blocks)
        _ -> return pandoc
675
    liftIO $ processCites' document
Henrik Tramberend's avatar
Henrik Tramberend committed
676

677
-- moved to Resources.hs
678
679
-- writeExampleProject :: Action ()
-- writeExampleProject = liftIO $ writeResourceFiles "example" "."
680
681

{--
Henrik Tramberend's avatar
Henrik Tramberend committed
682
writeExampleProject :: Action ()
683
writeExampleProject = mapM_ writeOne deckerExampleDir
684
  where
685
686
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
687
      unless exists $ do
688
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
689
690
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
691
--}
692
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
693
694
695
writeEmbeddedFiles files dir = do
  exists <- doesDirectoryExist dir
  unless exists $ do
Henrik Tramberend's avatar
Henrik Tramberend committed
696
    putNormal $ "# write embedded files for (" ++ dir ++ ")"
697
698
    let absolute = map (first (dir </>)) files
    mapM_ write absolute
699
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
700
701
702
703
    write (filePath, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory filePath)
      exists <- liftIO $ Dir.doesFileExist filePath
      unless exists $ liftIO $ B.writeFile filePath contents
704

Henrik Tramberend's avatar
Henrik Tramberend committed
705
lookupValue :: String -> Y.Value -> Maybe Y.Value
706
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
707
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
708

709
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
710
metaValueAsString key meta =
711
712
713
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
714
715
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
716
    lookup' [] (Just (Y.String s)) = Just (T.unpack s)
717
718
719
720
    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
721
722
723
724
725
726
727
728
729
730
731
732
733

lookupPandocMeta :: String -> Meta -> Maybe String
lookupPandocMeta key (Meta m) =
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (Map.lookup k m)
  where
    lookup' :: [String] -> Maybe MetaValue -> Maybe String
    lookup' (k:ks) (Just (MetaMap m)) = lookup' ks (Map.lookup k m)
    lookup' [] (Just (MetaBool b)) = Just $ show b
    lookup' [] (Just (MetaString s)) = Just s
    lookup' [] (Just (MetaInlines i)) = Just $ stringify i
    lookup' _ _ = Nothing