@@ -35,16 +35,19 @@ StackValue instances for pandoc types.
3535-}
3636module Text.Pandoc.Lua.StackInstances () where
3737
38+import Control.Applicative ( (<|>) )
3839import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON )
3940import Scripting.Lua
4041 ( LTYPE(..), LuaState, StackValue(..)
41− , gettable, newtable, pop, rawgeti, rawset, rawseti, settable
42+ , call, getglobal2, gettable, ltype, newtable, next, objlen
43+ , pop, pushnil, rawgeti, rawset, rawseti, settable
4244 )
4345import Scripting.Lua.Aeson ()
4446import Text.Pandoc.Definition
45− ( Block(..), Inline(..), Meta(..), Pandoc(..)
47+ ( Block(..), Inline(..), Meta(..), MetaValue(..), Pandoc(..)
4648 , Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )
4749
50+import qualified Data.Map as M
4851import qualified Text.Pandoc.UTF8 as UTF8
4952
5053maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a
@@ -55,8 +58,8 @@ maybeFromJson mv = fromJSON <$> mv >>= \case
5558instance StackValue Pandoc where
5659 push lua (Pandoc meta blocks) = do
5760 newtable lua
58− setField lua (-1) "blocks" blocks
59− setField lua (-1) "meta" meta
61+ addKeyValue lua "blocks" blocks
62+ addKeyValue lua "meta" meta
6063 peek lua idx = do
6164 blocks <- getField lua idx "blocks"
6265 meta <- getField lua idx "meta"
@@ -64,10 +67,58 @@ instance StackValue Pandoc where
6467 valuetype _ = TTABLE
6568
6669instance StackValue Meta where
67− push lua = push lua . toJSON
68− peek lua = fmap maybeFromJson . peek lua
70+ push lua (Meta mmap) = push lua mmap
71+ peek lua idx = fmap Meta <$> peek lua idx
6972 valuetype _ = TTABLE
7073
74+instance StackValue MetaValue where
75+ push lua = \case
76+ MetaBlocks blcks -> pushViaConstructor lua "MetaBlocks" blcks
77+ MetaBool b -> pushViaConstructor lua "MetaBool" b
78+ MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns
79+ MetaList metalist -> pushViaConstructor lua "MetaList" metalist
80+ MetaMap metamap -> pushViaConstructor lua "MetaMap" metamap
81+ MetaString cs -> pushViaConstructor lua "MetaString" cs
82+ peek lua idx = do
83+ luatype <- ltype lua idx
84+ case luatype of
85+ TBOOLEAN -> fmap MetaBool <$> peek lua idx
86+ TSTRING -> fmap MetaString <$> peek lua idx
87+ TTABLE -> do
88+ tag <- push lua "t"
89+ *> gettable lua (idx `adjustIndexBy` 1)
90+ *> peek lua (-1)
91+ <* pop lua 1
92+ case tag of
93+ Just "MetaBlocks" -> fmap MetaBlocks <$> peekContent lua idx
94+ Just "MetaBool" -> fmap MetaBool <$> peekContent lua idx
95+ Just "MetaMap" -> fmap MetaMap <$> peekContent lua idx
96+ Just "MetaInlines" -> fmap MetaInlines <$> peekContent lua idx
97+ Just "MetaList" -> fmap MetaList <$> peekContent lua idx
98+ Just "MetaString" -> fmap MetaString <$> peekContent lua idx
99+ Nothing -> do
100+ len <- objlen lua idx
101+ if len <= 0
102+ then fmap MetaMap <$> peek lua idx
103+ else (fmap MetaInlines <$> peek lua idx)
104+ <|> (fmap MetaBlocks <$> peek lua idx)
105+ <|> (fmap MetaList <$> peek lua idx)
106+ _ -> return Nothing
107+ _ -> return Nothing
108+ valuetype = \case
109+ MetaBlocks _ -> TTABLE
110+ MetaBool _ -> TBOOLEAN
111+ MetaInlines _ -> TTABLE
112+ MetaList _ -> TTABLE
113+ MetaMap _ -> TTABLE
114+ MetaString _ -> TSTRING
115+
116+peekContent :: StackValue a => LuaState -> Int -> IO (Maybe a)
117+peekContent lua idx = do
118+ push lua "c"
119+ gettable lua (idx `adjustIndexBy` 1)
120+ peek lua (-1) <* pop lua 1
121+
71122instance StackValue Block where
72123 push lua = \case
73124 BlockQuote blcks -> pushTagged lua "BlockQuote" blcks
@@ -77,6 +128,7 @@ instance StackValue Block where
77128 Null -> pushTagged' lua "Null"
78129 Para blcks -> pushTagged lua "Para" blcks
79130 Plain blcks -> pushTagged lua "Plain" blcks
131+ RawBlock f cs -> pushTagged lua "RawBlock" (f, cs)
80132 -- fall back to conversion via aeson's Value
81133 x -> push lua (toJSON x)
82134 peek lua i = peekBlock lua i
@@ -109,12 +161,12 @@ instance StackValue Inline where
109161instance StackValue Citation where
110162 push lua c = do
111163 newtable lua
112− setField lua (-1) "citationId" (citationId c)
113− setField lua (-1) "citationPrefix" (citationPrefix c)
114− setField lua (-1) "citationSuffix" (citationSuffix c)
115− setField lua (-1) "citationMode" (citationMode c)
116− setField lua (-1) "citationNoteNum" (citationNoteNum c)
117− setField lua (-1) "citationHash" (citationHash c)
164+ addKeyValue lua "citationId" (citationId c)
165+ addKeyValue lua "citationPrefix" (citationPrefix c)
166+ addKeyValue lua "citationSuffix" (citationSuffix c)
167+ addKeyValue lua "citationMode" (citationMode c)
168+ addKeyValue lua "citationNoteNum" (citationNoteNum c)
169+ addKeyValue lua "citationHash" (citationHash c)
118170 peek lua idx = do
119171 id' <- getField lua idx "citationId"
120172 prefix <- getField lua idx "citationPrefix"
@@ -186,11 +238,11 @@ instance StackValue [Char] where
186238instance (StackValue a, StackValue b) => StackValue (a, b) where
187239 push lua (a, b) = do
188240 newtable lua
189− setIntField lua (-1) 1 a
190− setIntField lua (-1) 2 b
241+ addIndexedValue lua 1 a
242+ addIndexedValue lua 2 b
191243 peek lua idx = do
192− a <- getIntField lua idx 1
193− b <- getIntField lua idx 2
244+ a <- getIndexedValue lua idx 1
245+ b <- getIndexedValue lua idx 2
194246 return $ (,) <$> a <*> b
195247 valuetype _ = TTABLE
196248
@@ -199,24 +251,82 @@ instance (StackValue a, StackValue b, StackValue c) =>
199251 where
200252 push lua (a, b, c) = do
201253 newtable lua
202− setIntField lua (-1) 1 a
203− setIntField lua (-1) 2 b
204− setIntField lua (-1) 3 c
254+ addIndexedValue lua 1 a
255+ addIndexedValue lua 2 b
256+ addIndexedValue lua 3 c
205257 peek lua idx = do
206− a <- getIntField lua idx 1
207− b <- getIntField lua idx 2
208− c <- getIntField lua idx 3
258+ a <- getIndexedValue lua idx 1
259+ b <- getIndexedValue lua idx 2
260+ c <- getIndexedValue lua idx 3
209261 return $ (,,) <$> a <*> b <*> c
210262 valuetype _ = TTABLE
211263
264+instance (Ord a, StackValue a, StackValue b) =>
265+ StackValue (M.Map a b) where
266+ push lua m = do
267+ newtable lua
268+ mapM_ (uncurry $ addKeyValue lua) $ M.toList m
269+ peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
270+ valuetype _ = TTABLE
271+
272+-- | Try reading the value under the given index as a list of key-value pairs.
273+keyValuePairs :: (StackValue a, StackValue b)
274+ => LuaState -> Int -> IO (Maybe [(a, b)])
275+keyValuePairs lua idx = do
276+ pushnil lua
277+ sequence <$> remainingPairs
278+ where
279+ remainingPairs = do
280+ res <- nextPair
281+ case res of
282+ Nothing -> return []
283+ Just a -> (a:) <$> remainingPairs
284+ nextPair :: (StackValue a, StackValue b) => IO (Maybe (Maybe (a,b)))
285+ nextPair = do
286+ hasNext <- next lua (idx `adjustIndexBy` 1)
287+ if hasNext
288+ then do
289+ val <- peek lua (-1)
290+ key <- peek lua (-2)
291+ pop lua 1 -- removes the value, keeps the key
292+ return $ Just <$> ((,) <$> key <*> val)
293+ else do
294+ return Nothing
295+
296+
297+-- | Helper class for pushing a single value to the stack via a lua function.
298+-- See @pushViaCall@.
299+class PushViaCall a where
300+ pushViaCall' :: LuaState -> String -> IO () -> Int -> a
301+
302+instance PushViaCall (IO ()) where
303+ pushViaCall' lua fn pushArgs num = do
304+ getglobal2 lua fn
305+ pushArgs
306+ call lua num 1
307+
308+instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where
309+ pushViaCall' lua fn pushArgs num x =
310+ pushViaCall' lua fn (pushArgs *> push lua x) (num + 1)
311+
312+-- | Push an value to the stack via a lua function. The lua function is called
313+-- with all arguments that are passed to this function and is expected to return
314+-- a single value.
315+pushViaCall :: PushViaCall a => LuaState -> String -> a
316+pushViaCall lua fn = pushViaCall' lua fn (return ()) 0
317+
318+-- | Call a pandoc element constructor within lua, passing all given arguments.
319+pushViaConstructor :: PushViaCall a => LuaState -> String -> a
320+pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn)
321+
212322-- | Push a value to the lua stack, tagged with a given string. This currently
213323-- creates a structure equivalent to what the JSONified value would look like
214324-- when pushed to lua.
215325pushTagged :: StackValue a => LuaState -> String -> a -> IO ()
216326pushTagged lua tag value = do
217327 newtable lua
218− setField lua (-1) "t" tag
219− setField lua (-1) "c" value
328+ addKeyValue lua "t" tag
329+ addKeyValue lua "c" value
220330
221331pushTagged' :: LuaState -> String -> IO ()
222332pushTagged' lua tag = do
@@ -296,21 +406,29 @@ getField lua idx key = do
296406 peek lua (-1) <* pop lua 1
297407
298408-- | Set value for key for table at the given index
299−setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()
300−setField lua idx key value = do
409+setKeyValue :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()
410+setKeyValue lua idx key value = do
301411 push lua key
302412 push lua value
303413 settable lua (idx `adjustIndexBy` 2)
304414
415+-- | Add a key-value pair to the table at the top of the stack
416+addKeyValue :: (StackValue a, StackValue b) => LuaState -> a -> b -> IO ()
417+addKeyValue lua = setKeyValue lua (-1)
418+
305419-- | Get value behind key from table at given index.
306−getIntField :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)
307−getIntField lua idx key =
420+getIndexedValue :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)
421+getIndexedValue lua idx key =
308422 rawgeti lua idx key
309423 *> peek lua (-1)
310424 <* pop lua 1
311425
312426-- | Set numeric key/value in table at the given index
313−setIntField :: StackValue a => LuaState -> Int -> Int -> a -> IO ()
314−setIntField lua idx key value = do
427+setIndexedValue :: StackValue a => LuaState -> Int -> Int -> a -> IO ()
428+setIndexedValue lua idx key value = do
315429 push lua value
316430 rawseti lua (idx `adjustIndexBy` 1) key
431+
432+-- | Set numeric key/value in table at the top of the stack.
433+addIndexedValue :: StackValue a => LuaState -> Int -> a -> IO ()
434+addIndexedValue lua = setIndexedValue lua (-1)