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
|
{-
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 ( LuaState, StackValue(..), newtable, pop, rawget, rawset )
import Scripting.Lua.Aeson ()
import Text.Pandoc.Definition ( Block(..), Inline(..), Meta(..), Pandoc(..) )
import qualified Scripting.Lua as Lua
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 _ = Lua.TTABLE
instance StackValue Meta where
push lua = push lua . toJSON
peek lua = fmap maybeFromJson . peek lua
valuetype _ = Lua.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 _ = Lua.TTABLE
instance StackValue Inline where
push lua = \case
Emph inlns -> pushTagged lua "Emph" inlns
LineBreak -> pushTagged' lua "LineBreak"
Note blcks -> pushTagged lua "Note" blcks
SmallCaps inlns -> pushTagged lua "SmallCaps" inlns
SoftBreak -> pushTagged' lua "SoftBreak"
Space -> pushTagged' lua "Space"
Str s -> pushTagged lua "Str" s
Strikeout inlns -> pushTagged lua "Strikeout" inlns
Strong inlns -> pushTagged lua "Strong" inlns
Subscript inlns -> pushTagged lua "Subscript" inlns
Superscript inlns -> pushTagged lua "Superscript" inlns
x -> push lua (toJSON x)
peek = peekInline
valuetype _ = Lua.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 _ = Lua.TSTRING
-- | 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
"Emph" -> fmap Emph <$> elementContent
"LineBreak" -> return (Just LineBreak)
"Note" -> fmap Note <$> elementContent
"SmallCaps" -> fmap SmallCaps <$> elementContent
"SoftBreak" -> return (Just SoftBreak)
"Space" -> return (Just Space)
"Str" -> fmap Str <$> elementContent
"Strikeout" -> fmap Strikeout <$> elementContent
"Strong" -> fmap Strong <$> elementContent
"Subscript" -> fmap Subscript <$> elementContent
"Superscript"-> fmap Superscript <$> 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"
-- | 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
rawget 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
rawset lua (idx `adjustIndexBy` 2)
|
