From 7e3705c1c4a7b63ce6818c1e3cb3496ff618ac0f Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Tue, 11 Apr 2017 23:31:55 +0200 Subject: Lua filter: use custom StackValue Inline instance Inline elements are no longer pushed and pulled via aeson's Value. --- data/pandoc.lua | 4 - src/Text/Pandoc/Lua.hs | 8 +- src/Text/Pandoc/Lua/StackInstances.hs | 175 +++++++++++++++++++++++++++++----- 3 files changed, 156 insertions(+), 31 deletions(-) diff --git a/data/pandoc.lua b/data/pandoc.lua index 79729fc35..d705b8566 100644 --- a/data/pandoc.lua +++ b/data/pandoc.lua @@ -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", diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index a68810bd7..d7c54b6af 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -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 () diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 07ca06798..690557788 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -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 -- cgit v1.2.3