Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Lua filter: use custom StackValue Inline instance

Browse source 
Inline elements are no longer pushed and pulled via aeson's Value.
This commit is contained in:
Albert Krewinkel 2017-04-11 23:31:55 +02:00
parent d4e5fe02b0
commit 7e3705c1c4
No known key found for this signature in database
GPG key ID: 388DC0B21F631124
3 changed files with 156 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
data/pandoc.lua
View file

@ -83,18 +83,14 @@ M.block_types = {
M.inline_types = {
"Cite",
"Code",
"DisplayMath",
"DoubleQuoted",
"Emph",
"Image",
"InlineMath",
"LineBreak",
"Link",
"Math",
"Note",
"Quoted",
"RawInline",
"SingleQuoted",
"SmallCaps",
"SoftBreak",
"Space",

8
src/Text/Pandoc/Lua.hs
View file

@ -170,9 +170,11 @@ runLuaFilterFunction lua lf inline = do
pushFilterFunction lua lf
Lua.push lua inline
Lua.call lua 1 1
Just res <- Lua.peek lua (-1)
Lua.pop lua 1
return res
mbres <- Lua.peek lua (-1)
case mbres of
Nothing -> error $ "Error while trying to get a filter's return "
++ "value from lua stack."
Just res -> res <$ Lua.pop lua 1
-- | Push the filter function to the top of the stack.
pushFilterFunction :: Lua.LuaState -> LuaFilterFunction a -> IO ()

175
src/Text/Pandoc/Lua/StackInstances.hs
View file

@ -36,11 +36,15 @@ 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
( LTYPE(..), LuaState, StackValue(..)
, gettable, newtable, pop, rawgeti, rawset, rawseti, settable
)
import Scripting.Lua.Aeson ()
import Text.Pandoc.Definition ( Block(..), Inline(..), Meta(..), Pandoc(..) )
import Text.Pandoc.Definition
( Block(..), Inline(..), Meta(..), Pandoc(..)
, Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )
import qualified Scripting.Lua as Lua
import qualified Text.Pandoc.UTF8 as UTF8
maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a
@ -57,12 +61,12 @@ instance StackValue Pandoc where
blocks <- getField lua idx "blocks"
meta <- getField lua idx "meta"
return $ Pandoc <$> meta <*> blocks
valuetype _ = Lua.TTABLE
valuetype _ = TTABLE
instance StackValue Meta where
push lua = push lua . toJSON
peek lua = fmap maybeFromJson . peek lua
valuetype _ = Lua.TTABLE
valuetype _ = TTABLE
instance StackValue Block where
push lua = \case
@ -76,24 +80,99 @@ instance StackValue Block where
-- fall back to conversion via aeson's Value
x -> push lua (toJSON x)
peek lua i = peekBlock lua i
valuetype _ = Lua.TTABLE
valuetype _ = 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)
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 _ = Lua.TTABLE
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
@ -102,7 +181,33 @@ 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
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
@ -127,19 +232,28 @@ peekInline lua idx = do
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
-- fall back to construction via aeson's Value
_ -> maybeFromJson <$> peek lua idx
_ -> return Nothing
where
-- Get the contents of an AST element.
elementContent :: StackValue a => IO (Maybe a)
@ -178,7 +292,7 @@ adjustIndexBy idx n =
getField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b)
getField lua idx key = do
push lua key
rawget lua (idx `adjustIndexBy` 1)
gettable lua (idx `adjustIndexBy` 1)
peek lua (-1) <* pop lua 1
-- | Set value for key for table at the given index
@ -186,4 +300,17 @@ 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)
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