1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{- |
Module : Text.Pandoc.Lua.Writer
Copyright : Copyright (C) 2012-2022 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <[email protected]>
Stability : alpha
Portability : portable
Conversion of Pandoc documents using a custom Lua writer.
-}
module Text.Pandoc.Lua.Writer
( writeCustom
) where
import Control.Exception
import Control.Monad ((<=<))
import Data.Default (def)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import HsLua
import HsLua.Core.Run (newGCManagedState, withGCManagedState)
import Control.Monad.IO.Class (MonadIO)
import Text.Pandoc.Class (PandocMonad, findFileWithDataFallback)
import Text.Pandoc.Error (PandocError (..))
import Text.Pandoc.Format (ExtensionsConfig (..))
import Text.Pandoc.Lua.Global (Global (..), setGlobals)
import Text.Pandoc.Lua.Init (runLuaWith)
import Text.Pandoc.Lua.Marshal.Format (peekExtensionsConfig)
import Text.Pandoc.Lua.Marshal.WriterOptions (pushWriterOptions)
import Text.Pandoc.Writers (Writer (..))
import qualified Text.Pandoc.Lua.Writer.Classic as Classic
-- | Convert Pandoc to custom markup.
writeCustom :: (PandocMonad m, MonadIO m)
=> FilePath -> m (Writer m, ExtensionsConfig, Maybe Text)
writeCustom luaFile = do
luaState <- liftIO newGCManagedState
luaFile' <- fromMaybe luaFile <$> findFileWithDataFallback "writers" luaFile
either throw pure <=< runLuaWith luaState $ do
setGlobals [ PANDOC_DOCUMENT mempty
, PANDOC_SCRIPT_FILE luaFile'
, PANDOC_WRITER_OPTIONS def
]
dofileTrace luaFile' >>= \case
OK -> pure ()
_ -> throwErrorAsException
-- Most classic writers contain code that throws an error if a global
-- is not present. This would break our check for the existence of a
-- "Writer" function. We resort to raw access for that reason, but
-- could also catch the error instead.
let rawgetglobal x = do
pushglobaltable
pushName x
rawget (nth 2) <* remove (nth 2) -- remove global table
let writerField = "Pandoc Writer function"
extsConf <- rawgetglobal "Extensions" >>= \case
TypeNil -> ExtensionsConfig mempty mempty <$ pop 1
_ -> forcePeek $ peekExtensionsConfig top `lastly` pop 1
mtemplate <- rawgetglobal "Template" >>= \case
TypeNil -> pure Nothing
TypeFunction -> Just <$> do
callTrace 0 1
forcePeek $ peekText top `lastly` pop 1
_ -> Just <$> do
forcePeek $ peekText top `lastly` pop 1
let addProperties = (, extsConf, mtemplate)
rawgetglobal "Writer" >>= \case
TypeNil -> rawgetglobal "ByteStringWriter" >>= \case
TypeNil -> do
-- Neither `Writer` nor `BinaryWriter` are defined. Try to
-- use the file as a classic writer.
pop 1 -- remove nil
pure $ addProperties . TextWriter $ \opts doc ->
liftIO $ withGCManagedState luaState $ do
Classic.runCustom @PandocError opts doc
_ -> do
-- Binary writer. Writer function is on top of the stack.
setfield registryindex writerField
pure $ addProperties . ByteStringWriter $ \opts doc ->
-- Call writer with document and writer options as arguments.
liftIO $ withGCManagedState luaState $ do
getfield registryindex writerField
push doc
pushWriterOptions opts
callTrace 2 1
forcePeek @PandocError $ peekLazyByteString top
_ -> do
-- New-type text writer. Writer function is on top of the stack.
setfield registryindex writerField
pure $ addProperties . TextWriter $ \opts doc ->
liftIO $ withGCManagedState luaState $ do
getfield registryindex writerField
push doc
pushWriterOptions opts
callTrace 2 1
forcePeek @PandocError $ peekText top
|
