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
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
  , watchFiles
  , writeIndex
  , readMetaDataForDir
  , substituteMetaData
  , markdownToHtmlDeck
  , markdownToHtmlHandout
  , markdownToPdfHandout
  , markdownToHtmlPage
  , markdownToPdfPage
  , writeExampleProject
  , metaValueAsString
  , (<++>)
  , writeEmbeddedFiles
  , getRelativeSupportDir
  , pandocMakePdf
  , fixMustacheMarkup
  , fixMustacheMarkupText
21
  , toPandocMeta
22
23
  , DeckerException(..)
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
24

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

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

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

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

100
-- | Generates an index.md file with links to all generated files of interest.
101
102
writeIndex ::
     FilePath -> FilePath -> [FilePath] -> [FilePath] -> [FilePath] -> Action ()
103
104
105
106
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
107
  dirs <- getProjectDirs
108
109
110
111
112
  liftIO $
    writeFile out $
    unlines
      [ "---"
      , "title: Generated Index"
Henrik Tramberend's avatar
Henrik Tramberend committed
113
      , "subtitle: " ++ project dirs
114
115
116
117
118
119
120
121
122
123
124
      , "---"
      , "# Slide decks"
      , unlines $ map makeLink $ sort decksLinks
      , "# Handouts"
      , unlines $ map makeLink $ sort handoutsLinks
      , "# Supporting Documents"
      , unlines $ map makeLink $ sort pagesLinks
      ]
  where
    makeLink path = "-    [" ++ takeFileName path ++ "](" ++ path ++ ")"

125
126
127
128
129
130
-- | 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
131
132
133
134
135
136
fixMustacheMarkupText content =
  T.replace
    (T.pack "{{\\#")
    (T.pack "{{#")
    (T.replace (T.pack "{{\\^") (T.pack "{{^") content)

137
138
139
140
141
142
143
144
substituteMetaData :: T.Text -> MT.Value -> T.Text
substituteMetaData text metaData = do
  let fixed = fixMustacheMarkupText text
  let result = M.compileTemplate "internal" fixed
  case result of
    Right template -> M.substituteValue template metaData
    Left err -> throw $ MustacheException (show err)

145
146
147
getTemplate :: FilePath -> Action String
getTemplate path = liftIO $ getResourceString ("template" </> path)

148
getRelativeSupportDir :: FilePath -> Action FilePath
149
getRelativeSupportDir from = do
150
  dirs <- getProjectDirs
151
  return $
152
153
    invertPath (makeRelative (public dirs) (takeDirectory from)) </>
    makeRelative (public dirs) (support dirs)
Henrik Tramberend's avatar
Henrik Tramberend committed
154
155

invertPath :: FilePath -> FilePath
156
invertPath fp = joinPath $ map (const "..") $ filter ("." /=) $ splitPath fp
Henrik Tramberend's avatar
Henrik Tramberend committed
157
158

-- | Write a markdown file to a HTML file using the page template.
159
160
markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
161
  putCurrentDocument out
162
  supportDir <- getRelativeSupportDir out
163
  template <- getTemplate "deck.html"
164
165
  let options =
        pandocWriterOpts
166
        { writerSlideLevel = Just 1
Henrik Tramberend's avatar
Henrik Tramberend committed
167
        , writerTemplate = Just template
168
        -- , writerStandalone = True
169
        , writerHighlight = True
170
        -- , writerHighlightStyle = pygments
171
        , writerHTMLMathMethod =
172
173
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
174
175
176
177
        -- ,writerHTMLMathMethod =
        --    KaTeX (supportDir </> "katex-0.6.0/katex.min.js")
        --          (supportDir </> "katex-0.6.0/katex.min.css")
        , writerVariables =
Henrik Tramberend's avatar
Henrik Tramberend committed
178
            [ ("revealjs-url", supportDir </> "reveal.js-3.5.0")
179
180
            , ("decker-support-dir", supportDir)
            ]
181
182
        , writerCiteMethod = Citeproc
        }
183
  pandoc <- readAndPreprocessMarkdown markdownFile Deck
184
185
  processed <- processPandocDeck "revealjs" pandoc
  writePandocString "revealjs" options out processed
186

Henrik Tramberend's avatar
Henrik Tramberend committed
187
188
189
190
191
192
193
194
195
-- | Selects a matching pandoc string writer for the format string, or throws an
-- exception.
getPandocWriter :: String -> StringWriter
getPandocWriter format =
  case getWriter format of
    Right (PureStringWriter w) -> w
    Left e -> throw $ PandocException e
    _ -> throw $ PandocException $ "No writer for format: " ++ format

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
versionCheck :: Meta -> Action ()
versionCheck meta =
  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
213
-- | Reads a markdownfile, expands the included files, and substitutes mustache
214
-- template variables and calls need.
215
216
readAndPreprocessMarkdown :: FilePath -> Disposition -> Action Pandoc
readAndPreprocessMarkdown markdownFile disposition = do
217
  let baseDir = takeDirectory markdownFile
218
  pandoc@(Pandoc meta _) <-
219
    readMetaMarkdown markdownFile >>= processIncludes baseDir
220
  versionCheck meta
Henrik Tramberend's avatar
Henrik Tramberend committed
221
  let method = provisioningFromMeta meta
222
  mapMetaResources (provisionMetaResource method baseDir) pandoc >>=
223
224
    renderCodeBlocks >>=
    mapResources (provisionResource method baseDir)
225
226
  -- Disable automatic caching of remote images for a while
  -- >>= walkM (cacheRemoteImages (cache dirs))
Henrik Tramberend's avatar
Henrik Tramberend committed
227

228
229
230
231
232
233
lookupBool :: String -> Bool -> Meta -> Bool
lookupBool key def meta =
  case lookupMeta key meta of
    Just (MetaBool b) -> b
    _ -> def

Henrik Tramberend's avatar
Henrik Tramberend committed
234
provisionMetaResource ::
235
236
     Provisioning -> FilePath -> (String, FilePath) -> Action FilePath
provisionMetaResource method base (key, path)
237
238
239
  | key `elem` runtimeMetaKeys = do
    filePath <- urlToFilePathIfLocal base path
    provisionResource method base filePath
240
provisionMetaResource method base (key, path)
241
242
243
244
  | key `elem` compiletimeMetaKeys = do
    filePath <- urlToFilePathIfLocal base path
    need [filePath]
    return filePath
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
provisionMetaResource _ _ (key, path) = return path

-- | 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 
-- 
-- 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
--       in the project root and recreate the source directory structure. This
--       function is used to provision resources that are used at presentation
--       time.
--
-- Returns a public URL relative to base
provisionResource :: Provisioning -> FilePath -> FilePath -> Action FilePath
provisionResource provisioning base path =
  case parseRelativeReference path of
    Nothing -> return path
    Just uri -> do
      dirs <- getProjectDirs
      need [uriPath uri]
      let resource = resourcePathes dirs base uri
269
270
271
272
273
274
275
276
      publicResource <- getPublicResource
      withResource publicResource 1 $ do
        liftIO $
          case provisioning of
            Copy -> copyResource resource
            SymLink -> linkResource resource
            Absolute -> absRefResource resource
            Relative -> relRefResource base resource
Henrik Tramberend's avatar
Henrik Tramberend committed
277

278
putCurrentDocument :: FilePath -> Action ()
279
280
281
282
283
putCurrentDocument out = do
  dirs <- getProjectDirs
  let rel = makeRelative (public dirs) out
  putNormal $ "# pandoc for (" ++ rel ++ ")"

Henrik Tramberend's avatar
Henrik Tramberend committed
284
-- | Write a markdown file to a HTML file using the page template.
285
286
markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
287
  putCurrentDocument out
288
  supportDir <- getRelativeSupportDir out
289
  template <- getTemplate "page.html"
290
291
292
  let options =
        pandocWriterOpts
        { writerHtml5 = True
293
        -- , writerStandalone = True
294
        , writerTemplate = Just template
295
        , writerHighlight = True
296
        -- , writerHighlightStyle = pygments
297
        , writerHTMLMathMethod =
298
299
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
300
301
302
303
304
305
        -- ,writerHTMLMathMethod =
        --    KaTeX (supportDir </> "katex-0.6.0/katex.min.js")
        --          (supportDir </> "katex-0.6.0/katex.min.css")
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
306
  pandoc <- readAndPreprocessMarkdown markdownFile Page
307
308
  processed <- processPandocPage "html5" pandoc
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
309
310

-- | Write a markdown file to a PDF file using the handout template.
311
312
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
313
  putCurrentDocument out
Bernward's avatar
Bernward committed
314
  template <- getTemplate "page.tex"
315
316
  let options =
        pandocWriterOpts
317
        { writerTemplate = Just template
318
        -- , writerStandalone = True
319
        , writerHighlight = True
320
        -- , writerHighlightStyle = pygments
321
322
        , writerCiteMethod = Citeproc
        }
323
  pandoc <- readAndPreprocessMarkdown markdownFile Page
324
325
326
327
  processed <- processPandocPage "latex" pandoc
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out

328
pandocMakePdf :: WriterOptions -> Pandoc -> FilePath -> Action ()
329
330
331
332
333
pandocMakePdf options processed out = do
  result <- liftIO $ makePDF "pdflatex" writeLaTeX options processed
  case result of
    Left err -> throw $ PandocException (show err)
    Right pdf -> liftIO $ LB.writeFile out pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
334
335

-- | Write a markdown file to a HTML file using the handout template.
336
337
markdownToHtmlHandout :: FilePath -> FilePath -> Action ()
markdownToHtmlHandout markdownFile out = do
338
  putCurrentDocument out
339
  pandoc <- readAndPreprocessMarkdown markdownFile Handout
340
341
  processed <- processPandocHandout "html" pandoc
  supportDir <- getRelativeSupportDir out
342
  template <- getTemplate "handout.html"
343
344
345
  let options =
        pandocWriterOpts
        { writerHtml5 = True
346
        , writerTemplate = Just template
347
348
        , writerHighlight = True
        , writerHTMLMathMethod =
349
350
            MathJax
              (supportDir </> "MathJax-2.7/MathJax.js?config=TeX-AMS_HTML")
351
352
353
354
        , writerVariables = [("decker-support-dir", supportDir)]
        , writerCiteMethod = Citeproc
        }
  writePandocString "html5" options out processed
Henrik Tramberend's avatar
Henrik Tramberend committed
355
356

-- | Write a markdown file to a PDF file using the handout template.
357
markdownToPdfHandout :: FilePath -> FilePath -> Action ()
358
markdownToPdfHandout markdownFile out = do
359
  putCurrentDocument out
360
  pandoc <- readAndPreprocessMarkdown markdownFile Handout
361
  processed <- processPandocHandout "latex" pandoc
Bernward's avatar
Bernward committed
362
  template <- getTemplate "handout.tex"
363
364
  let options =
        pandocWriterOpts
365
        { writerTemplate = Just template
366
367
368
369
370
        , writerHighlight = True
        , writerCiteMethod = Citeproc
        }
  putNormal $ "# pandoc (for " ++ out ++ ")"
  pandocMakePdf options processed out
371

372
373
374
-- | 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.
375
readMetaMarkdown :: FilePath -> Action Pandoc
376
377
readMetaMarkdown markdownFile = do
  need [markdownFile]
378
  -- read external meta data for this directory
Henrik Tramberend's avatar
Henrik Tramberend committed
379
  externalMeta <- readMetaDataForDir (takeDirectory markdownFile)
380
  -- extract embedded meta data from the document
Henrik Tramberend's avatar
Henrik Tramberend committed
381
382
383
  markdown <- liftIO $ S.readFile markdownFile
  let Pandoc meta _ = readMarkdownOrThrow pandocReaderOpts markdown
  let documentMeta = MetaMap $ unMeta meta
384
  -- combine the meta data with preference on the embedded data
Henrik Tramberend's avatar
Henrik Tramberend committed
385
386
387
388
389
390
391
392
393
  let combinedMeta = mergePandocMeta documentMeta (toPandocMeta externalMeta)
  let mustacheMeta = toMustacheMeta combinedMeta
   -- use mustache to substitute
  let substituted = substituteMetaData (T.pack markdown) mustacheMeta
  -- read markdown with substitutions again
  let Pandoc _ blocks =
        readMarkdownOrThrow pandocReaderOpts $ T.unpack substituted
  let (MetaMap m) = combinedMeta
  let pandoc = Pandoc (Meta m) blocks
394
  -- adjust local media urls
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
  -- mapResources (locateFileIfLocal (takeDirectory markdownFile)) pandoc
  mapResources (urlToFilePathIfLocal (takeDirectory markdownFile)) pandoc

urlToFilePathIfLocal :: FilePath -> FilePath -> Action FilePath
urlToFilePathIfLocal base uri = do
  case parseRelativeReference uri of
    Nothing -> return uri
    Just relativeUri -> do
      let path = uriPath relativeUri
      absBase <- liftIO $ Dir.makeAbsolute base
      absRoot <- project <$> getProjectDirs
      let absPath =
            if isAbsolute path
              then absRoot </> makeRelative "/" path
              else absBase </> path
      return absPath
411
412
413
414
415
416

readMarkdownOrThrow :: ReaderOptions -> String -> Pandoc
readMarkdownOrThrow opts string =
  case readMarkdown opts string of
    Right pandoc -> pandoc
    Left err -> throw $ PandocException (show err)
417

418
-- Remove automatic identifier creation for headers. It does not work well with
419
-- the current include mechanism if slides have duplicate titles in separate
420
421
422
423
424
-- include files.
deckerPandocExtensions :: Set.Set Extension
deckerPandocExtensions = Set.delete Ext_auto_identifiers pandocExtensions

pandocReaderOpts :: ReaderOptions
425
pandocReaderOpts = def {readerExtensions = deckerPandocExtensions}
426
427

pandocWriterOpts :: WriterOptions
428
pandocWriterOpts = def {writerExtensions = deckerPandocExtensions}
429

430
mapResources :: (FilePath -> Action FilePath) -> Pandoc -> Action Pandoc
431
432
433
434
435
mapResources transform pandoc@(Pandoc meta blocks) = do
  processedBlocks <-
    walkM (mapInline transform) blocks >>= walkM (mapBlock transform)
  return (Pandoc meta processedBlocks)

436
mapAttributes :: (FilePath -> Action FilePath) -> Attr -> Action Attr
437
438
439
440
mapAttributes transform (ident, classes, kv) = do
  processed <- mapM mapAttr kv
  return (ident, classes, processed)
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
441
442
    mapAttr kv@(key, value) =
      if key `elem` elementAttributes
443
444
445
446
447
        then do
          transformed <- transform value
          return (key, transformed)
        else return kv

448
mapInline :: (FilePath -> Action FilePath) -> Inline -> Action Inline
Henrik Tramberend's avatar
Henrik Tramberend committed
449
mapInline transform img@(Image attr@(_, cls, _) inlines (url, title)) =
450
451
452
453
  if not $ isMacro $ stringify inlines
    then do
      a <- mapAttributes transform attr
      u <- transform url
Henrik Tramberend's avatar
Henrik Tramberend committed
454
      return $ Image a inlines (u, title)
455
    else return img
Henrik Tramberend's avatar
Henrik Tramberend committed
456
457
mapInline transform lnk@(Link attr@(_, cls, _) inlines (url, title)) =
  if not (isMacro $ stringify inlines) && "resource" `elem` cls
458
459
460
461
462
463
464
465
466
467
468
469
470
    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

471
mapBlock :: (FilePath -> Action FilePath) -> Block -> Action Block
472
473
474
475
476
477
478
479
480
481
482
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

483
484
mapMetaResources ::
     ((String, FilePath) -> Action FilePath) -> Pandoc -> Action Pandoc
485
486
487
488
489
490
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
491
        transformed <- transform (k, v)
492
493
494
        return (k, MetaString transformed)
    mapMeta (k, MetaInlines inlines)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
495
        transformed <- transform (k, stringify inlines)
496
497
498
        return (k, MetaString transformed)
    mapMeta (k, MetaList l)
      | k `elem` metaKeys = do
Henrik Tramberend's avatar
Henrik Tramberend committed
499
        transformed <- mapM (mapMetaList k) l
500
501
        return (k, MetaList transformed)
    mapMeta kv = return kv
Henrik Tramberend's avatar
Henrik Tramberend committed
502
503
504
505
    mapMetaList k (MetaString v) = MetaString <$> transform (k, v)
    mapMetaList k (MetaInlines inlines) =
      MetaString <$> transform (k, stringify inlines)
    mapMetaList _ v = return v
506

Henrik Tramberend's avatar
Henrik Tramberend committed
507
508
509
-- | 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.
510
511
512
513
514
515
516
517
518
elementAttributes =
  [ "src"
  , "data-src"
  , "data-markdown"
  , "data-background-video"
  , "data-background-image"
  , "data-background-iframe"
  ]

Henrik Tramberend's avatar
Henrik Tramberend committed
519
520
-- | Resources in meta data that are needed at compile time. They have to be
-- specified as local URLs and must exist.
521
runtimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
522
523
runtimeMetaKeys = ["css"]

524
compiletimeMetaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
525
526
compiletimeMetaKeys = ["bibliography", "csl", "citation-abbreviations"]

527
metaKeys :: [String]
Henrik Tramberend's avatar
Henrik Tramberend committed
528
metaKeys = runtimeMetaKeys ++ compiletimeMetaKeys
529

Henrik Tramberend's avatar
Henrik Tramberend committed
530
-- Transitively splices all include files into the pandoc document.
531
532
processIncludes :: FilePath -> Pandoc -> Action Pandoc
processIncludes baseDir (Pandoc meta blocks) = do
533
534
  included <- processBlocks baseDir blocks
  return $ Pandoc meta included
535
536
537
  where
    processBlocks :: FilePath -> [Block] -> Action [Block]
    processBlocks base blcks = do
538
539
      spliced <- foldM (include base) [] blcks
      return $ concat $ reverse spliced
540
    include :: FilePath -> [[Block]] -> Block -> Action [[Block]]
541
    include base result (Para [Link _ [Str ":include"] (url, _)]) = do
542
543
544
545
      includeFile <- urlToFilePathIfLocal base url
      need [includeFile]
      Pandoc _ b <- readMetaMarkdown includeFile
      included <- processBlocks (takeDirectory includeFile) b
546
      return $ included : result
547
    include _ result block = return $ [block] : result
548

Henrik Tramberend's avatar
Henrik Tramberend committed
549
550
551
552
553
processCitesWithDefault :: Pandoc -> Action Pandoc
processCitesWithDefault pandoc@(Pandoc meta blocks) = do
  document <-
    do case lookupMeta "csl" meta of
         Nothing -> do
Henrik Tramberend's avatar
Henrik Tramberend committed
554
555
556
557
           dir <- appData <$> getProjectDirs
           let defaultCsl = dir </> "template" </> "acm-sig-proceedings.csl"
           let cslMeta = setMeta "csl" (MetaString defaultCsl) meta
           return (Pandoc cslMeta blocks)
Henrik Tramberend's avatar
Henrik Tramberend committed
558
559
560
         _ -> return pandoc
  liftIO $ processCites' document

561
processPandocPage :: String -> Pandoc -> Action Pandoc
562
processPandocPage format pandoc = do
Henrik Tramberend's avatar
Henrik Tramberend committed
563
  cited <- processCitesWithDefault pandoc
564
  return $ (renderMediaTags Page . expandMacros (Format format)) cited
565
566
567

processPandocDeck :: String -> Pandoc -> Action Pandoc
processPandocDeck format pandoc = do
Henrik Tramberend's avatar
Henrik Tramberend committed
568
  cited <- processCitesWithDefault pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
569
570
571
572
  return $
    (renderMediaTags Page .
     makeSlides (Format format) . expandMacros (Format format))
      cited
573
574
575

processPandocHandout :: String -> Pandoc -> Action Pandoc
processPandocHandout format pandoc = do
Henrik Tramberend's avatar
Henrik Tramberend committed
576
  cited <- processCitesWithDefault pandoc
577
  return $ (renderMediaTags Page . expandMacros (Format format)) cited
Henrik Tramberend's avatar
Henrik Tramberend committed
578
579
580

type StringWriter = WriterOptions -> Pandoc -> String

581
writePandocString :: String -> WriterOptions -> FilePath -> Pandoc -> Action ()
582
583
writePandocString format options out pandoc = do
  let writer = getPandocWriter format
Henrik Tramberend's avatar
Henrik Tramberend committed
584
  writeFile' out (writer options pandoc)
Henrik Tramberend's avatar
Henrik Tramberend committed
585

586
587
588
589
590
writeExampleProject :: Action ()
writeExampleProject = do
  liftIO $ writeResourceFiles "example" "."

{--
Henrik Tramberend's avatar
Henrik Tramberend committed
591
writeExampleProject :: Action ()
592
writeExampleProject = mapM_ writeOne deckerExampleDir
593
  where
594
595
    writeOne (path, contents) = do
      exists <- Development.Shake.doesFileExist path
596
      unless exists $ do
597
        liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
598
599
        liftIO $ B.writeFile path contents
        putNormal $ "# create (for " ++ path ++ ")"
600
--}
601
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
602
603
604
writeEmbeddedFiles files dir = do
  exists <- doesDirectoryExist dir
  unless exists $ do
Henrik Tramberend's avatar
Henrik Tramberend committed
605
    putNormal $ "# write embedded files for (" ++ dir ++ ")"
606
607
    let absolute = map (first (dir </>)) files
    mapM_ write absolute
608
  where
609
610
611
612
    write (path, contents) = do
      liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
      exists <- liftIO $ Dir.doesFileExist path
      unless exists $ liftIO $ B.writeFile path contents
613

Henrik Tramberend's avatar
Henrik Tramberend committed
614
lookupValue :: String -> Y.Value -> Maybe Y.Value
615
lookupValue key (Y.Object hashTable) = HashMap.lookup (T.pack key) hashTable
616
lookupValue _ _ = Nothing
Henrik Tramberend's avatar
Henrik Tramberend committed
617

618
metaValueAsString :: String -> Y.Value -> Maybe String
Henrik Tramberend's avatar
Henrik Tramberend committed
619
metaValueAsString key meta =
620
621
622
  case splitOn "." key of
    [] -> Nothing
    k:ks -> lookup' ks (lookupValue k meta)
623
624
  where
    lookup' :: [String] -> Maybe Y.Value -> Maybe String
625
    lookup' [] (Just (Y.String text)) = Just (T.unpack text)
626
627
628
629
    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