41ebdee · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Lua filter: improve doc filter performance

41ebdeeAlbert Krewinkel10 years ago

src/Text/Pandoc/Lua/StackInstances.hs+47−36

compare with master

unifiedsplit

@@ -38,7 +38,7 @@ module Text.Pandoc.Lua.StackInstances () where

38import Data.Aeson ( FromJSON(..), ToJSON(..), Result(..), Value, fromJSON )

39import Scripting.Lua ( LuaState, StackValue(..), newtable, pop, rawget, rawset )

40import Scripting.Lua.Aeson ()

41−import Text.Pandoc.Definition ( Block(..), Inline(..), Pandoc(..) )

41+import Text.Pandoc.Definition ( Block(..), Inline(..), Meta(..), Pandoc(..) )

43import qualified Scripting.Lua as Lua

44import qualified Text.Pandoc.UTF8 as UTF8

@@ -49,19 +49,30 @@ maybeFromJson mv = fromJSON <$> mv >>= \case

49 _ -> Nothing

51instance StackValue Pandoc where

52+ push lua (Pandoc meta blocks) = do

53+ newtable lua

54+ setField lua (-1) "blocks" blocks

55+ setField lua (-1) "meta" meta

56+ peek lua idx = do

57+ blocks <- getField lua idx "blocks"

58+ meta <- getField lua idx "meta"

59+ return $ Pandoc <$> meta <*> blocks

60+ valuetype _ = Lua.TTABLE

61+

62+instance StackValue Meta where

52− push lua = Lua.push lua . toJSON

63+ push lua = push lua . toJSON

53− peek lua i = maybeFromJson <$> peek lua i

64+ peek lua = fmap maybeFromJson . peek lua

54 valuetype _ = Lua.TTABLE

65 valuetype _ = Lua.TTABLE

56instance StackValue Block where

67instance StackValue Block where

57 push lua = \case

68 push lua = \case

58− BlockQuote blcks -> pushTagged lua "BlockQuote" blcks

69+ BlockQuote blcks -> pushTagged lua "BlockQuote" blcks

59− BulletList items -> pushTagged lua "BulletList" items

70+ BulletList items -> pushTagged lua "BulletList" items

60 HorizontalRule -> pushTagged' lua "HorizontalRule"

71 HorizontalRule -> pushTagged' lua "HorizontalRule"

61− LineBlock blcks -> pushTagged lua "LineBlock" blcks

72+ LineBlock blcks -> pushTagged lua "LineBlock" blcks

62 Null -> pushTagged' lua "Null"

73 Null -> pushTagged' lua "Null"

63− Para blcks -> pushTagged lua "Para" blcks

74+ Para blcks -> pushTagged lua "Para" blcks

64− Plain blcks -> pushTagged lua "Plain" blcks

75+ Plain blcks -> pushTagged lua "Plain" blcks

65 -- fall back to conversion via aeson's Value

76 -- fall back to conversion via aeson's Value

66 x -> push lua (toJSON x)

77 x -> push lua (toJSON x)

67 peek lua i = peekBlock lua i

78 peek lua i = peekBlock lua i

@@ -69,17 +80,17 @@ instance StackValue Block where

70instance StackValue Inline where

81instance StackValue Inline where

71 push lua = \case

82 push lua = \case

72− Emph inlns -> pushTagged lua "Emph" inlns

83+ Emph inlns -> pushTagged lua "Emph" inlns

73 LineBreak -> pushTagged' lua "LineBreak"

84 LineBreak -> pushTagged' lua "LineBreak"

74− Note blcks -> pushTagged lua "Note" blcks

85+ Note blcks -> pushTagged lua "Note" blcks

75− SmallCaps inlns -> pushTagged lua "SmallCaps" inlns

86+ SmallCaps inlns -> pushTagged lua "SmallCaps" inlns

76 SoftBreak -> pushTagged' lua "SoftBreak"

87 SoftBreak -> pushTagged' lua "SoftBreak"

77 Space -> pushTagged' lua "Space"

88 Space -> pushTagged' lua "Space"

78− Str s -> pushTagged lua "Str" s

89+ Str s -> pushTagged lua "Str" s

79− Strikeout inlns -> pushTagged lua "Strikeout" inlns

90+ Strikeout inlns -> pushTagged lua "Strikeout" inlns

80− Strong inlns -> pushTagged lua "Strong" inlns

91+ Strong inlns -> pushTagged lua "Strong" inlns

81− Subscript inlns -> pushTagged lua "Subscript" inlns

92+ Subscript inlns -> pushTagged lua "Subscript" inlns

82− Superscript inlns -> pushTagged lua "Superscript" inlns

93+ Superscript inlns -> pushTagged lua "Superscript" inlns

83 x -> push lua (toJSON x)

94 x -> push lua (toJSON x)

84 peek = peekInline

95 peek = peekInline

85 valuetype _ = Lua.TTABLE

96 valuetype _ = Lua.TTABLE

@@ -99,12 +110,8 @@ instance StackValue [Char] where

99pushTagged :: StackValue a => LuaState -> String -> a -> IO ()

110pushTagged :: StackValue a => LuaState -> String -> a -> IO ()

100pushTagged lua tag value = do

111pushTagged lua tag value = do

101 newtable lua

112 newtable lua

102− push lua "t"

113+ setField lua (-1) "t" tag

103− push lua tag

114+ setField lua (-1) "c" value

104− rawset lua (-3)

105− push lua "c"

106− push lua value

107− rawset lua (-3)

108

115

109pushTagged' :: LuaState -> String -> IO ()

116pushTagged' :: LuaState -> String -> IO ()

110pushTagged' lua tag = do

117pushTagged' lua tag = do

@@ -116,9 +123,7 @@ pushTagged' lua tag = do

116-- | Return the value at the given index as inline if possible.

123-- | Return the value at the given index as inline if possible.

117peekInline :: LuaState -> Int -> IO (Maybe Inline)

124peekInline :: LuaState -> Int -> IO (Maybe Inline)

118peekInline lua idx = do

125peekInline lua idx = do

119− push lua "t"

126+ tag <- getField lua idx "t"

120− rawget lua (idx `adjustIndexBy` 1)

121− tag <- peek lua (-1) <* pop lua 1

122 case tag of

127 case tag of

123 Nothing -> return Nothing

128 Nothing -> return Nothing

124 Just t -> case t of

129 Just t -> case t of

@@ -138,17 +143,12 @@ peekInline lua idx = do

138 where

143 where

139 -- Get the contents of an AST element.

144 -- Get the contents of an AST element.

140 elementContent :: StackValue a => IO (Maybe a)

145 elementContent :: StackValue a => IO (Maybe a)

141− elementContent = do

146+ elementContent = getField lua idx "c"

142− push lua "c"

143− rawget lua (idx `adjustIndexBy` 1)

144− peek lua (-1) <* pop lua 1

145

147

146-- | Return the value at the given index as block if possible.

148-- | Return the value at the given index as block if possible.

147peekBlock :: LuaState -> Int -> IO (Maybe Block)

149peekBlock :: LuaState -> Int -> IO (Maybe Block)

148peekBlock lua idx = do

150peekBlock lua idx = do

149− push lua "t"

151+ tag <- getField lua idx "t"

150− rawget lua (idx `adjustIndexBy` 1)

151− tag <- peek lua (-1) <* pop lua 1

152 case tag of

153 Nothing -> return Nothing

154 Just t -> case t of

@@ -164,10 +164,7 @@ peekBlock lua idx = do

164 where

165 -- Get the contents of an AST element.

166 elementContent :: StackValue a => IO (Maybe a)

167− elementContent = do

167+ elementContent = getField lua idx "c"

168− push lua "c"

169− rawget lua (idx `adjustIndexBy` 1)

170− peek lua (-1) <* pop lua 1

171

168

172-- | Adjust the stack index, assuming that @n@ new elements have been pushed on

169-- | Adjust the stack index, assuming that @n@ new elements have been pushed on

173-- the stack.

170-- the stack.

@@ -176,3 +173,17 @@ adjustIndexBy idx n =

176 if idx < 0

173 if idx < 0

177 then idx - n

174 then idx - n

178 else idx

175 else idx

176+

177+-- | Get value behind key from table at given index.

178+getField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> IO (Maybe b)

179+getField lua idx key = do

180+ push lua key

181+ rawget lua (idx `adjustIndexBy` 1)

182+ peek lua (-1) <* pop lua 1

183+

184+-- | Set value for key for table at the given index

185+setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()

186+setField lua idx key value = do

187+ push lua key

188+ push lua value

189+ rawset lua (idx `adjustIndexBy` 2)

test/Tests/Lua.hs+9−1

@@ -7,7 +7,9 @@ import Test.Tasty (TestTree)

7import Test.Tasty.HUnit (Assertion, assertEqual, testCase)

8import Test.Tasty.QuickCheck (ioProperty, testProperty)

9import Text.Pandoc.Arbitrary ()

10−import Text.Pandoc.Builder

10+import Text.Pandoc.Definition (Block, Inline, Meta, Pandoc)

11+import Text.Pandoc.Builder ( (<>), bulletList, doc, emph, linebreak, rawBlock

12+ , para, plain, space, str, strong)

11import Text.Pandoc.Lua

13import Text.Pandoc.Lua

13import qualified Scripting.Lua as Lua

15import qualified Scripting.Lua as Lua

@@ -43,6 +45,12 @@ tests =

44 , testProperty "block elements can be round-tripped through the lua stack" $

46 , testProperty "block elements can be round-tripped through the lua stack" $

45 \x -> ioProperty (roundtripEqual (x::Block))

47 \x -> ioProperty (roundtripEqual (x::Block))

48+

49+ , testProperty "meta blocks can be round-tripped through the lua stack" $

50+ \x -> ioProperty (roundtripEqual (x::Meta))

51+

52+ , testProperty "documents can be round-tripped through the lua stack" $

53+ \x -> ioProperty (roundtripEqual (x::Pandoc))

46 ]

54 ]

48assertFilterConversion :: String -> FilePath -> Pandoc -> Pandoc -> Assertion

56assertFilterConversion :: String -> FilePath -> Pandoc -> Pandoc -> Assertion