425df8f · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Use lua constructors to push meta values

425df8fAlbert Krewinkel10 years ago

data/pandoc.lua+42

compare with master

unifiedsplit

@@ -163,6 +163,48 @@ function M.Doc(blocks, meta)

163end

164

165

166+------------------------------------------------------------------------

167+-- MetaValue

168+-- @section MetaValue

169+M.MetaValue = Element:make_subtype{}

170+M.MetaValue.__call = function(t, ...)

171+ return t:new(...)

172+end

173+--- Meta blocks

174+-- @function MetaBlocks

175+-- @tparam {Block,...} blocks blocks

176+--- Meta inlines

177+-- @function MetaInlines

178+-- @tparam {Inline,...} inlines inlines

179+--- Meta list

180+-- @function MetaList

181+-- @tparam {MetaValue,...} meta_values list of meta values

182+--- Meta boolean

183+-- @function MetaBool

184+-- @tparam boolean bool boolean value

185+--- Meta map

186+-- @function MetaMap

187+-- @tparam table a string-index map of meta values

188+--- Meta string

189+-- @function MetaString

190+-- @tparam string str string value

191+M.meta_value_types = {

192+ "MetaBlocks",

193+ "MetaBool",

194+ "MetaInlines",

195+ "MetaList",

196+ "MetaMap",

197+ "MetaString"

198+}

199+for i = 1, #M.meta_value_types do

200+ M[M.meta_value_types[i]] = M.MetaValue:create_constructor(

201+ M.meta_value_types[i],

202+ function(content)

203+ return {c = content}

204+ end

205+ )

206+end

207+

166--- Inline element class

208--- Inline element class

167-- @type Inline

209-- @type Inline

168M.Inline = Element:make_subtype{}

210M.Inline = Element:make_subtype{}

src/Text/Pandoc/Lua.hs+2−2

@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

30Pandoc lua utils.

31-}

32−module Text.Pandoc.Lua ( runLuaFilter ) where

32+module Text.Pandoc.Lua ( runLuaFilter, pushPandocModule ) where

34import Control.Monad ( (>=>), when )

35import Control.Monad.Trans ( MonadIO(..) )

@@ -39,7 +39,7 @@ import Data.Text.Encoding ( decodeUtf8 )

39import Scripting.Lua ( LuaState, StackValue(..) )

40import Scripting.Lua.Aeson ( newstate )

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

42−import Text.Pandoc.Lua.PandocModule

42+import Text.Pandoc.Lua.PandocModule ( pushPandocModule )

43import Text.Pandoc.Lua.StackInstances ()

44import Text.Pandoc.Walk

src/Text/Pandoc/Lua/StackInstances.hs+148−30

@@ -35,16 +35,19 @@ StackValue instances for pandoc types.

35-}

36module Text.Pandoc.Lua.StackInstances () where

38+import Control.Applicative ( (<|>) )

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

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

39import Scripting.Lua

40import Scripting.Lua

40 ( LTYPE(..), LuaState, StackValue(..)

41 ( LTYPE(..), LuaState, StackValue(..)

42+ , call, getglobal2, gettable, ltype, newtable, next, objlen

41− , gettable, newtable, pop, rawgeti, rawset, rawseti, settable

43+ , pop, pushnil, rawgeti, rawset, rawseti, settable

42 )

44 )

43import Scripting.Lua.Aeson ()

45import Scripting.Lua.Aeson ()

44import Text.Pandoc.Definition

46import Text.Pandoc.Definition

45− ( Block(..), Inline(..), Meta(..), Pandoc(..)

47+ ( Block(..), Inline(..), Meta(..), MetaValue(..), Pandoc(..)

46 , Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )

48 , Citation(..), CitationMode(..), Format(..), MathType(..), QuoteType(..) )

50+import qualified Data.Map as M

48import qualified Text.Pandoc.UTF8 as UTF8

51import qualified Text.Pandoc.UTF8 as UTF8

50maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a

53maybeFromJson :: (FromJSON a) => Maybe Value -> Maybe a

@@ -55,8 +58,8 @@ maybeFromJson mv = fromJSON <$> mv >>= \case

55instance StackValue Pandoc where

58instance StackValue Pandoc where

56 push lua (Pandoc meta blocks) = do

59 push lua (Pandoc meta blocks) = do

57 newtable lua

60 newtable lua

58− setField lua (-1) "blocks" blocks

61+ addKeyValue lua "blocks" blocks

59− setField lua (-1) "meta" meta

62+ addKeyValue lua "meta" meta

60 peek lua idx = do

63 peek lua idx = do

61 blocks <- getField lua idx "blocks"

64 blocks <- getField lua idx "blocks"

62 meta <- getField lua idx "meta"

65 meta <- getField lua idx "meta"

@@ -64,10 +67,58 @@ instance StackValue Pandoc where

64 valuetype _ = TTABLE

67 valuetype _ = TTABLE

66instance StackValue Meta where

69instance StackValue Meta where

67− push lua = push lua . toJSON

70+ push lua (Meta mmap) = push lua mmap

68− peek lua = fmap maybeFromJson . peek lua

71+ peek lua idx = fmap Meta <$> peek lua idx

69 valuetype _ = TTABLE

72 valuetype _ = TTABLE

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+

71instance StackValue Block where

122instance StackValue Block where

72 push lua = \case

123 push lua = \case

73 BlockQuote blcks -> pushTagged lua "BlockQuote" blcks

124 BlockQuote blcks -> pushTagged lua "BlockQuote" blcks

@@ -77,6 +128,7 @@ instance StackValue Block where

77 Null -> pushTagged' lua "Null"

128 Null -> pushTagged' lua "Null"

78 Para blcks -> pushTagged lua "Para" blcks

129 Para blcks -> pushTagged lua "Para" blcks

79 Plain blcks -> pushTagged lua "Plain" blcks

130 Plain blcks -> pushTagged lua "Plain" blcks

131+ RawBlock f cs -> pushTagged lua "RawBlock" (f, cs)

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

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

81 x -> push lua (toJSON x)

133 x -> push lua (toJSON x)

82 peek lua i = peekBlock lua i

134 peek lua i = peekBlock lua i

@@ -109,12 +161,12 @@ instance StackValue Inline where

109instance StackValue Citation where

161instance StackValue Citation where

110 push lua c = do

162 push lua c = do

111 newtable lua

163 newtable lua

112− setField lua (-1) "citationId" (citationId c)

164+ addKeyValue lua "citationId" (citationId c)

113− setField lua (-1) "citationPrefix" (citationPrefix c)

165+ addKeyValue lua "citationPrefix" (citationPrefix c)

114− setField lua (-1) "citationSuffix" (citationSuffix c)

166+ addKeyValue lua "citationSuffix" (citationSuffix c)

115− setField lua (-1) "citationMode" (citationMode c)

167+ addKeyValue lua "citationMode" (citationMode c)

116− setField lua (-1) "citationNoteNum" (citationNoteNum c)

168+ addKeyValue lua "citationNoteNum" (citationNoteNum c)

117− setField lua (-1) "citationHash" (citationHash c)

169+ addKeyValue lua "citationHash" (citationHash c)

118 peek lua idx = do

170 peek lua idx = do

119 id' <- getField lua idx "citationId"

171 id' <- getField lua idx "citationId"

120 prefix <- getField lua idx "citationPrefix"

172 prefix <- getField lua idx "citationPrefix"

@@ -186,11 +238,11 @@ instance StackValue [Char] where

186instance (StackValue a, StackValue b) => StackValue (a, b) where

238instance (StackValue a, StackValue b) => StackValue (a, b) where

187 push lua (a, b) = do

239 push lua (a, b) = do

188 newtable lua

240 newtable lua

189− setIntField lua (-1) 1 a

241+ addIndexedValue lua 1 a

190− setIntField lua (-1) 2 b

242+ addIndexedValue lua 2 b

191 peek lua idx = do

243 peek lua idx = do

192− a <- getIntField lua idx 1

244+ a <- getIndexedValue lua idx 1

193− b <- getIntField lua idx 2

245+ b <- getIndexedValue lua idx 2

194 return $ (,) <$> a <*> b

246 return $ (,) <$> a <*> b

195 valuetype _ = TTABLE

247 valuetype _ = TTABLE

196

248

@@ -199,24 +251,82 @@ instance (StackValue a, StackValue b, StackValue c) =>

199 where

251 where

200 push lua (a, b, c) = do

252 push lua (a, b, c) = do

201 newtable lua

253 newtable lua

202− setIntField lua (-1) 1 a

254+ addIndexedValue lua 1 a

203− setIntField lua (-1) 2 b

255+ addIndexedValue lua 2 b

204− setIntField lua (-1) 3 c

256+ addIndexedValue lua 3 c

205 peek lua idx = do

257 peek lua idx = do

206− a <- getIntField lua idx 1

258+ a <- getIndexedValue lua idx 1

207− b <- getIntField lua idx 2

259+ b <- getIndexedValue lua idx 2

208− c <- getIntField lua idx 3

260+ c <- getIndexedValue lua idx 3

209 return $ (,,) <$> a <*> b <*> c

261 return $ (,,) <$> a <*> b <*> c

210 valuetype _ = TTABLE

262 valuetype _ = TTABLE

211

263

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+

212-- | Push a value to the lua stack, tagged with a given string. This currently

322-- | Push a value to the lua stack, tagged with a given string. This currently

213-- creates a structure equivalent to what the JSONified value would look like

323-- creates a structure equivalent to what the JSONified value would look like

214-- when pushed to lua.

324-- when pushed to lua.

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

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

216pushTagged lua tag value = do

326pushTagged lua tag value = do

217 newtable lua

327 newtable lua

218− setField lua (-1) "t" tag

328+ addKeyValue lua "t" tag

219− setField lua (-1) "c" value

329+ addKeyValue lua "c" value

220

330

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

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

222pushTagged' lua tag = do

332pushTagged' lua tag = do

@@ -296,21 +406,29 @@ getField lua idx key = do

296 peek lua (-1) <* pop lua 1

406 peek lua (-1) <* pop lua 1

297

407

298-- | Set value for key for table at the given index

408-- | Set value for key for table at the given index

299−setField :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()

409+setKeyValue :: (StackValue a, StackValue b) => LuaState -> Int -> a -> b -> IO ()

300−setField lua idx key value = do

410+setKeyValue lua idx key value = do

301 push lua key

411 push lua key

302 push lua value

412 push lua value

303 settable lua (idx `adjustIndexBy` 2)

413 settable lua (idx `adjustIndexBy` 2)

304

414

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+

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

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

306−getIntField :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)

420+getIndexedValue :: StackValue a => LuaState -> Int -> Int -> IO (Maybe a)

307−getIntField lua idx key =

421+getIndexedValue lua idx key =

308 rawgeti lua idx key

422 rawgeti lua idx key

309 *> peek lua (-1)

423 *> peek lua (-1)

310 <* pop lua 1

424 <* pop lua 1

311

425

312-- | Set numeric key/value in table at the given index

426-- | Set numeric key/value in table at the given index

313−setIntField :: StackValue a => LuaState -> Int -> Int -> a -> IO ()

427+setIndexedValue :: StackValue a => LuaState -> Int -> Int -> a -> IO ()

314−setIntField lua idx key value = do

428+setIndexedValue lua idx key value = do

315 push lua value

429 push lua value

316 rawseti lua (idx `adjustIndexBy` 1) key

430 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)

test/Tests/Lua.hs+6−2

@@ -64,10 +64,14 @@ roundtripEqual x = (x ==) <$> roundtripped

64 roundtripped :: (Lua.StackValue a) => IO a

65 roundtripped = do

66 lua <- Lua.newstate

67+ Lua.openlibs lua

68+ pushPandocModule lua

69+ Lua.setglobal lua "pandoc"

70+ oldSize <- Lua.gettop lua

67 Lua.push lua x

71 Lua.push lua x

68 size <- Lua.gettop lua

72 size <- Lua.gettop lua

69− when (size /= 1) $

73+ when ((size - oldSize) /= 1) $

70− error ("not exactly one element on the stack: " ++ show size)

74+ error ("not exactly one additional element on the stack: " ++ show size)

71 res <- Lua.peek lua (-1)

75 res <- Lua.peek lua (-1)

72 retval <- case res of

76 retval <- case res of

73 Nothing -> error "could not read from stack"

77 Nothing -> error "could not read from stack"