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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
|
{-
Copyright © 2012-2015 John MacFarlane <jgm@berkeley.edu>
2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Module : Text.Pandoc.Lua.StackInstances
Copyright : Copyright © 2017 Albert Krewinkel
License : GNU GPL, version 2 or above
Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
StackValue instances for pandoc types.
-}
module Text.Pandoc.Lua.StackInstances () where
import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON )
import Scripting.Lua
( LTYPE(..), LuaState, StackValue(..)
, gettable, newtable, pop, rawgeti, rawset, rawseti, settable
)
import Scripting.Lua.Aeson ()
import Text.Pandoc.Definition
( Block(..), Inline(..), Meta(..), Pandoc(..)
, Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )
import qualified Text.Pandoc.UTF8 as UTF8
maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a
maybeFromJson mv = fromJSON <$> mv >>= \case
Success x -> Just x
_ -> Nothing
instance StackValue Pandoc where
push lua (Pandoc meta blocks) = do
newtable lua
setField lua (-1) "blocks" blocks
setField lua (-1) "meta" meta
peek lua idx = do
blocks <- getField lua idx "blocks"
meta <- getField lua idx "meta"
return $ Pandoc <$> meta <*> blocks
valuetype _ = TTABLE
instance StackValue Meta where
push lua = push lua . toJSON
peek lua = fmap maybeFromJson . peek lua
valuetype _ = TTABLE
instance StackValue Block where
push lua = \case
BlockQuote blcks -> pushTagged lua "BlockQuote" blcks
BulletList items -> pushTagged lua "BulletList" items
HorizontalRule -> pushTagged' lua "HorizontalRule"
LineBlock blcks -> pushTagged lua "LineBlock" blcks
Null -> pushTagged' lua "Null"
Para blcks -> pushTagged lua "Para" blcks
Plain blcks -> pushTagged lua "Plain" blcks
-- fall back to conversion via aeson's Value
x -> push lua (toJSON x)
peek lua i = peekBlock lua i
valuetype _ = TTABLE
instance StackValue Inline where
push lua = \case
Cite citations lst -> pushTagged lua "Cite" (citations, lst)
Code attr lst -> pushTagged lua "Code" (attr, lst)
Emph inlns -> pushTagged lua "Emph" inlns
Image attr lst tgt -> pushTagged lua "Image" (attr, lst, tgt)
LineBreak -> pushTagged' lua "LineBreak"
Link attr lst tgt -> pushTagged lua "Link" (attr, lst, tgt)
Note blcks -> pushTagged lua "Note" blcks
Math mty str -> pushTagged lua "Math" (mty, str)
Quoted qt inlns -> pushTagged lua "Quoted" (qt, inlns)
RawInline f cs -> pushTagged lua "RawInline" (f, cs)
SmallCaps inlns -> pushTagged lua "SmallCaps" inlns
SoftBreak -> pushTagged' lua "SoftBreak"
Space -> pushTagged' lua "Space"
Span attr inlns -> pushTagged lua "Span" (attr, inlns)
Str str -> pushTagged lua "Str" str
Strikeout inlns -> pushTagged lua "Strikeout" inlns
Strong inlns -> pushTagged lua "Strong" inlns
Subscript inlns -> pushTagged lua "Subscript" inlns
Superscript inlns -> pushTagged lua "Superscript" inlns
peek = peekInline
valuetype _ = TTABLE
instance StackValue Citation where
push lua c = do
newtable lua
setField lua (-1) "citationId" (citationId c)
setField lua (-1) "citationPrefix" (citationPrefix c)
setField lua (-1) "citationSuffix" (citationSuffix c)
setField lua (-1) "citationMode" (citationMode c)
setField lua (-1) "citationNoteNum" (citationNoteNum c)
setField lua (-1) "citationHash" (citationHash c)
peek lua idx = do
id' <- getField lua idx "citationId"
prefix <- getField lua idx "citationPrefix"
suffix <- getField lua idx "citationSuffix"
mode <- getField lua idx "citationMode"
num <- getField lua idx "citationNoteNum"
hash <- getField lua idx "citationHash"
return $ Citation
<$> id'
<*> prefix
<*> suffix
<*> mode
<*> num
<*> hash
valuetype _ = TTABLE
instance StackValue CitationMode where
push lua = \case
AuthorInText -> pushTagged' lua "AuthorInText"
NormalCitation -> pushTagged' lua "NormalCitation"
SuppressAuthor -> pushTagged' lua "SuppressAuthor"
peek lua idx = do
tag <- getField lua idx "t"
case tag of
Just "AuthorInText" -> return $ Just AuthorInText
Just "NormalCitation" -> return $ Just NormalCitation
Just "SuppressAuthor" -> return $ Just SuppressAuthor
_ -> return Nothing
valuetype _ = TSTRING
instance StackValue Format where
push lua (Format f) = push lua f
peek lua idx = fmap Format <$> peek lua idx
valuetype _ = TSTRING
instance StackValue MathType where
push lua = \case
InlineMath -> pushTagged' lua "InlineMath"
DisplayMath -> pushTagged' lua "DisplayMath"
peek lua idx = do
res <- getField lua idx "t"
case res of
Just "InlineMath" -> return $ Just InlineMath
Just "DisplayMath" -> return $ Just DisplayMath
_ -> return Nothing
valuetype _ = TTABLE
instance StackValue QuoteType where
push lua = \case
SingleQuote -> pushTagged' lua "SingleQuote"
DoubleQuote -> pushTagged' lua "DoubleQuote"
peek lua idx = do
res <- getField lua idx "t"
case res of
Just "SingleQuote" -> return $ Just SingleQuote
Just "DoubleQuote" -> return $ Just DoubleQuote
_ -> return Nothing
valuetype _ = TTABLE
#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
push lua cs = push lua (UTF8.fromString cs)
peek lua i = fmap UTF8.toString <$> peek lua i
valuetype _ = TSTRING
instance (StackValue a, StackValue b) => StackValue (a, b) where
push lua (a, b) = do
newtable lua
setIntField lua (-1) 1 a
setIntField lua (-1) 2 b
peek lua idx = do
a <- getIntField lua idx 1
b <- getIntField lua idx 2
return $ (,) <$> a <*> b
valuetype _ = TTABLE
instance (StackValue a, StackValue b, StackValue c) =>
StackValue (a, b, c)
where
push lua (a, b, c) = do
newtable lua
setIntField lua (-1) 1 a
setIntField lua (-1) 2 b
setIntField lua (-1) 3 c
peek lua idx = do
a <- getIntField lua idx 1
b <- getIntField lua idx 2
c <- getIntField lua idx 3
return $ (,,) <$> a <*> b <*> c
valuetype _ = TTABLE
-- | Push a value to the lua stack, tagged with a given string. This currently
-- creates a structure equivalent to what the JSONified value would look like
-- when pushed to lua.
pushTagged :: StackValue a => LuaState -> String -> a -> IO ()
pushTagged lua tag value = do
newtable lua
setField lua (-1) "t" tag
setField lua (-1) "c" value
pushTagged' :: LuaState -> String -> IO ()
pushTagged' lua tag = do
newtable lua
push lua "t"
push lua tag
rawset lua (-3)
-- | Return the value at the given index as inline if possible.
peekInline :: LuaState -> Int -> IO (Maybe Inline)
peekInline lua idx = do
tag <- getField lua idx "t"
case tag of
Nothing -> return Nothing
Just t -> case t of
"Cite" -> fmap (uncurry Cite) <$> elementContent
"Code" -> fmap (uncurry Code) <$> elementContent
"Emph" -> fmap Emph <$> elementContent
"Image" -> fmap (\(attr, lst, tgt) -> Image attr lst tgt)
<$> elementContent
"Link" -> fmap (\(attr, lst, tgt) -> Link attr lst tgt)
<$> elementContent
"LineBreak" -> return (Just LineBreak)
"Note" -> fmap Note <$> elementContent
"Math" -> fmap (uncurry Math) <$> elementContent
"Quoted" -> fmap (uncurry Quoted) <$> elementContent
"RawInline" -> fmap (uncurry RawInline) <$> elementContent
"SmallCaps" -> fmap SmallCaps <$> elementContent
"SoftBreak" -> return (Just SoftBreak)
"Space" -> return (Just Space)
"Span" -> fmap (uncurry Span) <$> elementContent
"Str" -> fmap Str <$> elementContent
"Strikeout" -> fmap Strikeout <$> elementContent
"Strong" -> fmap Strong <$> elementContent
"Subscript" -> fmap Subscript <$> elementContent
"Superscript"-> fmap Superscript <$> elementContent
_ -> return Nothing
where
-- Get the contents of an AST element.
elementContent :: StackValue a => IO (Maybe a)
elementContent = getField lua idx "c"
-- | Return the value at the given index as block if possible.
peekBlock :: LuaState -> Int -> IO (Maybe Block)
peekBlock lua idx = do
tag <- getField lua idx "t"
case tag of
Nothing -> return Nothing
Just t -> case t of
"BlockQuote" -> fmap BlockQuote <$> elementContent
"BulletList" -> fmap BulletList <$> elementContent
"HorizontalRule" -> return (Just HorizontalRule)
"LineBlock" -> fmap LineBlock <$> elementContent
"Null" -> return (Just Null)
"Para" -> fmap Para <$> elementContent
"Plain" -> fmap Plain <$> elementContent
-- fall back to construction via aeson's Value
_ -> maybeFromJson <$> peek lua idx
where
-- Get the contents of an AST element.
elementContent :: StackValue a => IO (Maybe a)
elementContent = getField lua idx "c"
-- | Adjust the stack index, assuming that @n@ new elements have been pushed on
-- the stack.
adjustIndexBy :: Int -> Int -> Int
adjustIndexBy idx n =
if idx < 0
then idx - n
else idx
-- | Get value behind key from table at given index.
getField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b)
getField lua idx key = do
push lua key
gettable lua (idx `adjustIndexBy` 1)
peek lua (-1) <* pop lua 1
-- | Set value for key for table at the given index
setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()
setField lua idx key value = do
push lua key
push lua value
settable lua (idx `adjustIndexBy` 2)
-- | Get value behind key from table at given index.
getIntField :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)
getIntField lua idx key =
rawgeti lua idx key
*> peek lua (-1)
<* pop lua 1
-- | Set numeric key/value in table at the given index
setIntField :: StackValue a => LuaState -> Int -> Int -> a -> IO ()
setIntField lua idx key value = do
push lua value
rawseti lua (idx `adjustIndexBy` 1) key
|