From 425df8fff435c105590986e1b85efbcca8986931 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Thu, 13 Apr 2017 22:57:50 +0200
Subject: [PATCH] Use lua constructors to push meta values
---
data/pandoc.lua | 42 ++++++
src/Text/Pandoc/Lua.hs | 4 +-
src/Text/Pandoc/Lua/StackInstances.hs | 178 +++++++++++++++++++++-----
test/Tests/Lua.hs | 8 +-
4 files changed, 198 insertions(+), 34 deletions(-)
diff --git a/data/pandoc.lua b/data/pandoc.lua
index 8d4d89bcd..6e434d1e7 100644
--- a/data/pandoc.lua
+++ b/data/pandoc.lua
@@ -163,6 +163,48 @@ function M.Doc(blocks, meta)
end
+------------------------------------------------------------------------
+-- MetaValue
+-- @section MetaValue
+M.MetaValue = Element:make_subtype{}
+M.MetaValue.__call = function(t, ...)
+ return t:new(...)
+end
+--- Meta blocks
+-- @function MetaBlocks
+-- @tparam {Block,...} blocks blocks
+--- Meta inlines
+-- @function MetaInlines
+-- @tparam {Inline,...} inlines inlines
+--- Meta list
+-- @function MetaList
+-- @tparam {MetaValue,...} meta_values list of meta values
+--- Meta boolean
+-- @function MetaBool
+-- @tparam boolean bool boolean value
+--- Meta map
+-- @function MetaMap
+-- @tparam table a string-index map of meta values
+--- Meta string
+-- @function MetaString
+-- @tparam string str string value
+M.meta_value_types = {
+ "MetaBlocks",
+ "MetaBool",
+ "MetaInlines",
+ "MetaList",
+ "MetaMap",
+ "MetaString"
+}
+for i = 1, #M.meta_value_types do
+ M[M.meta_value_types[i]] = M.MetaValue:create_constructor(
+ M.meta_value_types[i],
+ function(content)
+ return {c = content}
+ end
+ )
+end
+
--- Inline element class
-- @type Inline
M.Inline = Element:make_subtype{}
diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs
index ccd820682..95bc1ef35 100644
--- a/src/Text/Pandoc/Lua.hs
+++ b/src/Text/Pandoc/Lua.hs
@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Pandoc lua utils.
-}
-module Text.Pandoc.Lua ( runLuaFilter ) where
+module Text.Pandoc.Lua ( runLuaFilter, pushPandocModule ) where
import Control.Monad ( (>=>), when )
import Control.Monad.Trans ( MonadIO(..) )
@@ -39,7 +39,7 @@ import Data.Text.Encoding ( decodeUtf8 )
import Scripting.Lua ( LuaState, StackValue(..) )
import Scripting.Lua.Aeson ( newstate )
import Text.Pandoc.Definition ( Block(..), Inline(..), Pandoc(..) )
-import Text.Pandoc.Lua.PandocModule
+import Text.Pandoc.Lua.PandocModule ( pushPandocModule )
import Text.Pandoc.Lua.StackInstances ()
import Text.Pandoc.Walk
diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs
index 690557788..5387f94e5 100644
--- a/src/Text/Pandoc/Lua/StackInstances.hs
+++ b/src/Text/Pandoc/Lua/StackInstances.hs
@@ -35,16 +35,19 @@ StackValue instances for pandoc types.
-}
module Text.Pandoc.Lua.StackInstances () where
+import Control.Applicative ( (<|>) )
import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON )
import Scripting.Lua
( LTYPE(..), LuaState, StackValue(..)
- , gettable, newtable, pop, rawgeti, rawset, rawseti, settable
+ , call, getglobal2, gettable, ltype, newtable, next, objlen
+ , pop, pushnil, rawgeti, rawset, rawseti, settable
)
import Scripting.Lua.Aeson ()
import Text.Pandoc.Definition
- ( Block(..), Inline(..), Meta(..), Pandoc(..)
+ ( Block(..), Inline(..), Meta(..), MetaValue(..), Pandoc(..)
, Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )
+import qualified Data.Map as M
import qualified Text.Pandoc.UTF8 as UTF8
maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a
@@ -55,8 +58,8 @@ maybeFromJson mv = fromJSON <$> mv >>= \case
instance StackValue Pandoc where
push lua (Pandoc meta blocks) = do
newtable lua
- setField lua (-1) "blocks" blocks
- setField lua (-1) "meta" meta
+ addKeyValue lua "blocks" blocks
+ addKeyValue lua "meta" meta
peek lua idx = do
blocks <- getField lua idx "blocks"
meta <- getField lua idx "meta"
@@ -64,10 +67,58 @@ instance StackValue Pandoc where
valuetype _ = TTABLE
instance StackValue Meta where
- push lua = push lua . toJSON
- peek lua = fmap maybeFromJson . peek lua
+ push lua (Meta mmap) = push lua mmap
+ peek lua idx = fmap Meta <$> peek lua idx
valuetype _ = TTABLE
+instance StackValue MetaValue where
+ push lua = \case
+ MetaBlocks blcks -> pushViaConstructor lua "MetaBlocks" blcks
+ MetaBool b -> pushViaConstructor lua "MetaBool" b
+ MetaInlines inlns -> pushViaConstructor lua "MetaInlines" inlns
+ MetaList metalist -> pushViaConstructor lua "MetaList" metalist
+ MetaMap metamap -> pushViaConstructor lua "MetaMap" metamap
+ MetaString cs -> pushViaConstructor lua "MetaString" cs
+ peek lua idx = do
+ luatype <- ltype lua idx
+ case luatype of
+ TBOOLEAN -> fmap MetaBool <$> peek lua idx
+ TSTRING -> fmap MetaString <$> peek lua idx
+ TTABLE -> do
+ tag <- push lua "t"
+ *> gettable lua (idx `adjustIndexBy` 1)
+ *> peek lua (-1)
+ <* pop lua 1
+ case tag of
+ Just "MetaBlocks" -> fmap MetaBlocks <$> peekContent lua idx
+ Just "MetaBool" -> fmap MetaBool <$> peekContent lua idx
+ Just "MetaMap" -> fmap MetaMap <$> peekContent lua idx
+ Just "MetaInlines" -> fmap MetaInlines <$> peekContent lua idx
+ Just "MetaList" -> fmap MetaList <$> peekContent lua idx
+ Just "MetaString" -> fmap MetaString <$> peekContent lua idx
+ Nothing -> do
+ len <- objlen lua idx
+ if len <= 0
+ then fmap MetaMap <$> peek lua idx
+ else (fmap MetaInlines <$> peek lua idx)
+ <|> (fmap MetaBlocks <$> peek lua idx)
+ <|> (fmap MetaList <$> peek lua idx)
+ _ -> return Nothing
+ _ -> return Nothing
+ valuetype = \case
+ MetaBlocks _ -> TTABLE
+ MetaBool _ -> TBOOLEAN
+ MetaInlines _ -> TTABLE
+ MetaList _ -> TTABLE
+ MetaMap _ -> TTABLE
+ MetaString _ -> TSTRING
+
+peekContent :: StackValue a => LuaState -> Int -> IO (Maybe a)
+peekContent lua idx = do
+ push lua "c"
+ gettable lua (idx `adjustIndexBy` 1)
+ peek lua (-1) <* pop lua 1
+
instance StackValue Block where
push lua = \case
BlockQuote blcks -> pushTagged lua "BlockQuote" blcks
@@ -77,6 +128,7 @@ instance StackValue Block where
Null -> pushTagged' lua "Null"
Para blcks -> pushTagged lua "Para" blcks
Plain blcks -> pushTagged lua "Plain" blcks
+ RawBlock f cs -> pushTagged lua "RawBlock" (f, cs)
-- fall back to conversion via aeson's Value
x -> push lua (toJSON x)
peek lua i = peekBlock lua i
@@ -109,12 +161,12 @@ instance StackValue Inline where
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)
+ addKeyValue lua "citationId" (citationId c)
+ addKeyValue lua "citationPrefix" (citationPrefix c)
+ addKeyValue lua "citationSuffix" (citationSuffix c)
+ addKeyValue lua "citationMode" (citationMode c)
+ addKeyValue lua "citationNoteNum" (citationNoteNum c)
+ addKeyValue lua "citationHash" (citationHash c)
peek lua idx = do
id' <- getField lua idx "citationId"
prefix <- getField lua idx "citationPrefix"
@@ -186,11 +238,11 @@ instance StackValue [Char] where
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
+ addIndexedValue lua 1 a
+ addIndexedValue lua 2 b
peek lua idx = do
- a <- getIntField lua idx 1
- b <- getIntField lua idx 2
+ a <- getIndexedValue lua idx 1
+ b <- getIndexedValue lua idx 2
return $ (,) <$> a <*> b
valuetype _ = TTABLE
@@ -199,24 +251,82 @@ instance (StackValue a, StackValue b, StackValue 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
+ addIndexedValue lua 1 a
+ addIndexedValue lua 2 b
+ addIndexedValue lua 3 c
peek lua idx = do
- a <- getIntField lua idx 1
- b <- getIntField lua idx 2
- c <- getIntField lua idx 3
+ a <- getIndexedValue lua idx 1
+ b <- getIndexedValue lua idx 2
+ c <- getIndexedValue lua idx 3
return $ (,,) <$> a <*> b <*> c
valuetype _ = TTABLE
+instance (Ord a, StackValue a, StackValue b) =>
+ StackValue (M.Map a b) where
+ push lua m = do
+ newtable lua
+ mapM_ (uncurry $ addKeyValue lua) $ M.toList m
+ peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
+ valuetype _ = TTABLE
+
+-- | Try reading the value under the given index as a list of key-value pairs.
+keyValuePairs :: (StackValue a, StackValue b)
+ => LuaState -> Int -> IO (Maybe [(a, b)])
+keyValuePairs lua idx = do
+ pushnil lua
+ sequence <$> remainingPairs
+ where
+ remainingPairs = do
+ res <- nextPair
+ case res of
+ Nothing -> return []
+ Just a -> (a:) <$> remainingPairs
+ nextPair :: (StackValue a, StackValue b) => IO (Maybe (Maybe (a,b)))
+ nextPair = do
+ hasNext <- next lua (idx `adjustIndexBy` 1)
+ if hasNext
+ then do
+ val <- peek lua (-1)
+ key <- peek lua (-2)
+ pop lua 1 -- removes the value, keeps the key
+ return $ Just <$> ((,) <$> key <*> val)
+ else do
+ return Nothing
+
+
+-- | Helper class for pushing a single value to the stack via a lua function.
+-- See @pushViaCall@.
+class PushViaCall a where
+ pushViaCall' :: LuaState -> String -> IO () -> Int -> a
+
+instance PushViaCall (IO ()) where
+ pushViaCall' lua fn pushArgs num = do
+ getglobal2 lua fn
+ pushArgs
+ call lua num 1
+
+instance (StackValue a, PushViaCall b) => PushViaCall (a -> b) where
+ pushViaCall' lua fn pushArgs num x =
+ pushViaCall' lua fn (pushArgs *> push lua x) (num + 1)
+
+-- | Push an value to the stack via a lua function. The lua function is called
+-- with all arguments that are passed to this function and is expected to return
+-- a single value.
+pushViaCall :: PushViaCall a => LuaState -> String -> a
+pushViaCall lua fn = pushViaCall' lua fn (return ()) 0
+
+-- | Call a pandoc element constructor within lua, passing all given arguments.
+pushViaConstructor :: PushViaCall a => LuaState -> String -> a
+pushViaConstructor lua pandocFn = pushViaCall lua ("pandoc." ++ pandocFn)
+
-- | 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
+ addKeyValue lua "t" tag
+ addKeyValue lua "c" value
pushTagged' :: LuaState -> String -> IO ()
pushTagged' lua tag = do
@@ -296,21 +406,29 @@ getField lua idx key = do
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
+setKeyValue :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()
+setKeyValue lua idx key value = do
push lua key
push lua value
settable lua (idx `adjustIndexBy` 2)
+-- | Add a key-value pair to the table at the top of the stack
+addKeyValue :: (StackValue a, StackValue b) => LuaState -> a -> b -> IO ()
+addKeyValue lua = setKeyValue lua (-1)
+
-- | Get value behind key from table at given index.
-getIntField :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)
-getIntField lua idx key =
+getIndexedValue :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)
+getIndexedValue 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
+setIndexedValue :: StackValue a => LuaState -> Int -> Int -> a -> IO ()
+setIndexedValue lua idx key value = do
push lua value
rawseti lua (idx `adjustIndexBy` 1) key
+
+-- | Set numeric key/value in table at the top of the stack.
+addIndexedValue :: StackValue a => LuaState -> Int -> a -> IO ()
+addIndexedValue lua = setIndexedValue lua (-1)
diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs
index 64c35b298..4196ff4b7 100644
--- a/test/Tests/Lua.hs
+++ b/test/Tests/Lua.hs
@@ -64,10 +64,14 @@ roundtripEqual x = (x ==) <$> roundtripped
roundtripped :: (Lua.StackValue a) => IO a
roundtripped = do
lua <- Lua.newstate
+ Lua.openlibs lua
+ pushPandocModule lua
+ Lua.setglobal lua "pandoc"
+ oldSize <- Lua.gettop lua
Lua.push lua x
size <- Lua.gettop lua
- when (size /= 1) $
- error ("not exactly one element on the stack: " ++ show size)
+ when ((size - oldSize) /= 1) $
+ error ("not exactly one additional element on the stack: " ++ show size)
res <- Lua.peek lua (-1)
retval <- case res of
Nothing -> error "could not read from stack"