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