From a493c7029cf2bc8490d96fff04b0a0c624987601 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Tue, 26 Oct 2021 14:40:10 +0200
Subject: Lua: marshal Block values as userdata objects
Properties of Block values are marshalled lazily, which generally
improves performance considerably. Script users may also notice the
following differences:
- Block element properties can no longer be accessed by numerical
indexing of the `.c` field. The `.c` property now serves as an alias
for `.content`, so some filter that used this undocumented method
for property access may continue to work, while others will need to
be updated and use proper property names.
- The marshalled Block elements now have a `show` method, and a
`__tostring` metamethod. Both return the Haskell string
representation of the element.
- Block values now have the Lua type `userdata` instead of `table`.
---
src/Text/Pandoc/Lua/Init.hs | 4 -
src/Text/Pandoc/Lua/Marshaling/AST.hs | 431 +++++++++++++++++++++++++---------
src/Text/Pandoc/Lua/Module/Pandoc.hs | 168 ++++++++++---
src/Text/Pandoc/Lua/Module/Types.hs | 4 -
4 files changed, 461 insertions(+), 146 deletions(-)
(limited to 'src/Text')
diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs
index d9b210c55..60475e25c 100644
--- a/src/Text/Pandoc/Lua/Init.hs
+++ b/src/Text/Pandoc/Lua/Init.hs
@@ -83,12 +83,8 @@ initLuaState = do
-- stack.
putConstructorsInRegistry :: PandocLua ()
putConstructorsInRegistry = liftPandocLua $ do
- constrsToReg $ Pandoc.Pandoc mempty mempty
- constrsToReg $ Pandoc.Str mempty
- constrsToReg $ Pandoc.Para mempty
constrsToReg $ Pandoc.Meta mempty
constrsToReg $ Pandoc.MetaList mempty
- constrsToReg $ Pandoc.Citation mempty mempty mempty Pandoc.AuthorInText 0 0
putInReg "ListAttributes" -- used for ListAttributes type alias
putInReg "List" -- pandoc.List
putInReg "SimpleTable" -- helper for backward-compatible table handling
diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs
index e436ffffc..22c78bff9 100644
--- a/src/Text/Pandoc/Lua/Marshaling/AST.hs
+++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs
@@ -19,21 +19,27 @@ Marshaling/unmarshaling instances for document AST elements.
module Text.Pandoc.Lua.Marshaling.AST
( peekAttr
, peekBlock
+ , peekBlockFuzzy
, peekBlocks
+ , peekBlocksFuzzy
, peekCaption
, peekCitation
+ , peekColSpec
+ , peekDefinitionItem
, peekFormat
, peekInline
+ , peekInlineFuzzy
, peekInlines
+ , peekInlinesFuzzy
, peekListAttributes
, peekMeta
, peekMetaValue
, peekPandoc
, peekMathType
, peekQuoteType
-
- , peekFuzzyInlines
- , peekFuzzyBlocks
+ , peekTableBody
+ , peekTableHead
+ , peekTableFoot
, pushAttr
, pushBlock
@@ -46,7 +52,7 @@ module Text.Pandoc.Lua.Marshaling.AST
import Control.Applicative ((<|>), optional)
import Control.Monad.Catch (throwM)
-import Control.Monad ((<$!>), (>=>))
+import Control.Monad ((<$!>))
import Data.Data (showConstr, toConstr)
import Data.Text (Text)
import Data.Version (Version)
@@ -54,7 +60,7 @@ import HsLua hiding (Operation (Div))
import HsLua.Module.Version (peekVersionFuzzy)
import Text.Pandoc.Definition
import Text.Pandoc.Error (PandocError (PandocLuaError))
-import Text.Pandoc.Lua.Util (pushViaConstr', pushViaConstructor)
+import Text.Pandoc.Lua.Util (pushViaConstr')
import Text.Pandoc.Lua.Marshaling.Attr (peekAttr, pushAttr)
import Text.Pandoc.Lua.Marshaling.List (pushPandocList)
@@ -102,14 +108,6 @@ instance Pushable MetaValue where
instance Pushable Block where
push = pushBlock
--- Inline
-instance Pushable Inline where
- push = pushInline
-
--- Citation
-instance Pushable Citation where
- push = pushCitation
-
typeCitation :: LuaError e => DocumentedType e Citation
typeCitation = deftype "Citation" []
[ property "id" "citation ID / key"
@@ -232,69 +230,188 @@ peekMetaValue = retrieving "MetaValue $ " . \idx -> do
Nothing -> peekUntagged
_ -> failPeek "could not get meta value"
+typeBlock :: LuaError e => DocumentedType e Block
+typeBlock = deftype "Block"
+ [ operation Eq $ lambda
+ ### liftPure2 (==)
+ <#> parameter peekBlockFuzzy "Block" "a" ""
+ <#> parameter peekBlockFuzzy "Block" "b" ""
+ =#> boolResult "whether the two values are equal"
+ , operation Tostring $ lambda
+ ### liftPure show
+ <#> udparam typeBlock "self" ""
+ =#> functionResult pushString "string" "Haskell representation"
+ ]
+ [ possibleProperty "attr" "element attributes"
+ (pushAttr, \case
+ CodeBlock attr _ -> Actual attr
+ Div attr _ -> Actual attr
+ Header _ attr _ -> Actual attr
+ Table attr _ _ _ _ _ -> Actual attr
+ _ -> Absent)
+ (peekAttr, \case
+ CodeBlock _ code -> Actual . flip CodeBlock code
+ Div _ blks -> Actual . flip Div blks
+ Header lvl _ blks -> Actual . (\attr -> Header lvl attr blks)
+ Table _ c cs h bs f -> Actual . (\attr -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "bodies" "table bodies"
+ (pushPandocList pushTableBody, \case
+ Table _ _ _ _ bs _ -> Actual bs
+ _ -> Absent)
+ (peekList peekTableBody, \case
+ Table attr c cs h _ f -> Actual . (\bs -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "caption" "element caption"
+ (pushCaption, \case {Table _ capt _ _ _ _ -> Actual capt; _ -> Absent})
+ (peekCaption, \case
+ Table attr _ cs h bs f -> Actual . (\c -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "colspecs" "column alignments and widths"
+ (pushPandocList pushColSpec, \case
+ Table _ _ cs _ _ _ -> Actual cs
+ _ -> Absent)
+ (peekList peekColSpec, \case
+ Table attr c _ h bs f -> Actual . (\cs -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "content" "element content"
+ (pushContent, getBlockContent)
+ (peekContent, setBlockContent)
+ , possibleProperty "foot" "table foot"
+ (pushTableFoot, \case {Table _ _ _ _ _ f -> Actual f; _ -> Absent})
+ (peekTableFoot, \case
+ Table attr c cs h bs _ -> Actual . (\f -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "format" "format of raw content"
+ (pushFormat, \case {RawBlock f _ -> Actual f; _ -> Absent})
+ (peekFormat, \case
+ RawBlock _ txt -> Actual . (`RawBlock` txt)
+ _ -> const Absent)
+ , possibleProperty "head" "table head"
+ (pushTableHead, \case {Table _ _ _ h _ _ -> Actual h; _ -> Absent})
+ (peekTableHead, \case
+ Table attr c cs _ bs f -> Actual . (\h -> Table attr c cs h bs f)
+ _ -> const Absent)
+ , possibleProperty "level" "heading level"
+ (pushIntegral, \case {Header lvl _ _ -> Actual lvl; _ -> Absent})
+ (peekIntegral, \case
+ Header _ attr inlns -> Actual . \lvl -> Header lvl attr inlns
+ _ -> const Absent)
+ , possibleProperty "listAttributes" "ordered list attributes"
+ (pushListAttributes, \case
+ OrderedList listAttr _ -> Actual listAttr
+ _ -> Absent)
+ (peekListAttributes, \case
+ OrderedList _ content -> Actual . (`OrderedList` content)
+ _ -> const Absent)
+ , possibleProperty "text" "text contents"
+ (pushText, getBlockText)
+ (peekText, setBlockText)
+
+ , readonly "tag" "type of Block"
+ (pushString, showConstr . toConstr )
+
+ , alias "t" "tag" ["tag"]
+ , alias "c" "content" ["content"]
+ , alias "identifier" "element identifier" ["attr", "identifier"]
+ , alias "classes" "element classes" ["attr", "classes"]
+ , alias "attributes" "other element attributes" ["attr", "attributes"]
+ , alias "start" "ordered list start number" ["listAttributes", "start"]
+ , alias "style" "ordered list style" ["listAttributes", "style"]
+ , alias "delimiter" "numbering delimiter" ["listAttributes", "delimiter"]
+
+ , method $ defun "clone"
+ ### return
+ <#> parameter peekBlock "Block" "block" "self"
+ =#> functionResult pushBlock "Block" "cloned Block"
+
+ , method $ defun "show"
+ ### liftPure show
+ <#> parameter peekBlock "Block" "self" ""
+ =#> functionResult pushString "string" "Haskell string representation"
+ ]
+ where
+ boolResult = functionResult pushBool "boolean"
+
+getBlockContent :: Block -> Possible Content
+getBlockContent = \case
+ -- inline content
+ Para inlns -> Actual $ ContentInlines inlns
+ Plain inlns -> Actual $ ContentInlines inlns
+ -- inline content
+ BlockQuote blks -> Actual $ ContentBlocks blks
+ Div _ blks -> Actual $ ContentBlocks blks
+ -- lines content
+ LineBlock lns -> Actual $ ContentLines lns
+ -- list items content
+ BulletList itms -> Actual $ ContentListItems itms
+ OrderedList _ itms -> Actual $ ContentListItems itms
+ -- definition items content
+ DefinitionList itms -> Actual $ ContentDefItems itms
+ _ -> Absent
+
+setBlockContent :: Block -> Content -> Possible Block
+setBlockContent = \case
+ -- inline content
+ Para _ -> Actual . Para . inlineContent
+ Plain _ -> Actual . Plain . inlineContent
+ -- block content
+ BlockQuote _ -> Actual . BlockQuote . blockContent
+ Div attr _ -> Actual . Div attr . blockContent
+ -- lines content
+ LineBlock _ -> Actual . LineBlock . lineContent
+ -- list items content
+ BulletList _ -> Actual . BulletList . listItemContent
+ OrderedList la _ -> Actual . OrderedList la . listItemContent
+ -- definition items content
+ DefinitionList _ -> Actual . DefinitionList . defItemContent
+ _ -> const Absent
+ where
+ inlineContent = \case
+ ContentInlines inlns -> inlns
+ c -> throwM . PandocLuaError $ "expected Inlines, got " <>
+ contentTypeDescription c
+ blockContent = \case
+ ContentBlocks blks -> blks
+ ContentInlines inlns -> [Plain inlns]
+ c -> throwM . PandocLuaError $ "expected Blocks, got " <>
+ contentTypeDescription c
+ lineContent = \case
+ ContentLines lns -> lns
+ c -> throwM . PandocLuaError $ "expected list of lines, got " <>
+ contentTypeDescription c
+ defItemContent = \case
+ ContentDefItems itms -> itms
+ c -> throwM . PandocLuaError $ "expected definition items, got " <>
+ contentTypeDescription c
+ listItemContent = \case
+ ContentBlocks blks -> [blks]
+ ContentLines lns -> map ((:[]) . Plain) lns
+ ContentListItems itms -> itms
+ c -> throwM . PandocLuaError $ "expected list of items, got " <>
+ contentTypeDescription c
+
+getBlockText :: Block -> Possible Text
+getBlockText = \case
+ CodeBlock _ lst -> Actual lst
+ RawBlock _ raw -> Actual raw
+ _ -> Absent
+
+setBlockText :: Block -> Text -> Possible Block
+setBlockText = \case
+ CodeBlock attr _ -> Actual . CodeBlock attr
+ RawBlock f _ -> Actual . RawBlock f
+ _ -> const Absent
+
-- | Push a block element to the top of the Lua stack.
pushBlock :: forall e. LuaError e => Block -> LuaE e ()
-pushBlock = \case
- BlockQuote blcks -> pushViaConstructor @e "BlockQuote" blcks
- BulletList items -> pushViaConstructor @e "BulletList" items
- CodeBlock attr code -> pushViaConstr' @e "CodeBlock"
- [ push code, pushAttr attr ]
- DefinitionList items -> pushViaConstructor @e "DefinitionList" items
- Div attr blcks -> pushViaConstr' @e "Div"
- [push blcks, pushAttr attr]
- Header lvl attr inlns -> pushViaConstr' @e "Header"
- [push lvl, push inlns, pushAttr attr]
- HorizontalRule -> pushViaConstructor @e "HorizontalRule"
- LineBlock blcks -> pushViaConstructor @e "LineBlock" blcks
- OrderedList lstAttr list -> pushViaConstr' @e "OrderedList"
- [ push list, pushListAttributes @e lstAttr ]
- Null -> pushViaConstructor @e "Null"
- Para blcks -> pushViaConstructor @e "Para" blcks
- Plain blcks -> pushViaConstructor @e "Plain" blcks
- RawBlock f cs -> pushViaConstructor @e "RawBlock" f cs
- Table attr blkCapt specs thead tbody tfoot ->
- pushViaConstr' @e "Table"
- [ pushCaption blkCapt, push specs, push thead, push tbody
- , push tfoot, pushAttr attr]
+pushBlock = pushUD typeBlock
-- | Return the value at the given index as block if possible.
peekBlock :: forall e. LuaError e => Peeker e Block
-peekBlock = fmap (retrieving "Block")
- . typeChecked "table" Lua.istable
- $ \idx -> do
- -- Get the contents of an AST element.
- let mkBlock :: (a -> Block) -> Peeker e a -> Peek e Block
- mkBlock f p = f <$!> peekFieldRaw p "c" idx
- LuaUtil.getTag idx >>= \case
- "BlockQuote" -> mkBlock BlockQuote peekBlocks
- "BulletList" -> mkBlock BulletList (peekList peekBlocks)
- "CodeBlock" -> mkBlock (uncurry CodeBlock)
- (peekPair peekAttr peekText)
- "DefinitionList" -> mkBlock DefinitionList
- (peekList (peekPair peekInlines (peekList peekBlocks)))
- "Div" -> mkBlock (uncurry Div) (peekPair peekAttr peekBlocks)
- "Header" -> mkBlock (\(lvl, attr, lst) -> Header lvl attr lst)
- (peekTriple peekIntegral peekAttr peekInlines)
- "HorizontalRule" -> return HorizontalRule
- "LineBlock" -> mkBlock LineBlock (peekList peekInlines)
- "OrderedList" -> mkBlock (uncurry OrderedList)
- (peekPair peekListAttributes (peekList peekBlocks))
- "Null" -> return Null
- "Para" -> mkBlock Para peekInlines
- "Plain" -> mkBlock Plain peekInlines
- "RawBlock" -> mkBlock (uncurry RawBlock)
- (peekPair peekFormat peekText)
- "Table" -> mkBlock id
- (retrieving "Table" . (liftLua . absindex >=> (\idx' -> cleanup $ do
- attr <- liftLua (rawgeti idx' 1) *> peekAttr top
- capt <- liftLua (rawgeti idx' 2) *> peekCaption top
- cs <- liftLua (rawgeti idx' 3) *> peekList peekColSpec top
- thead <- liftLua (rawgeti idx' 4) *> peekTableHead top
- tbods <- liftLua (rawgeti idx' 5) *> peekList peekTableBody top
- tfoot <- liftLua (rawgeti idx' 6) *> peekTableFoot top
- return $! Table attr capt cs thead tbods tfoot)))
- Name tag -> failPeek ("Unknown block type: " <> tag)
+peekBlock = retrieving "Block" . peekUD typeBlock
+-- | Retrieves a list of Block elements.
peekBlocks :: LuaError e => Peeker e [Block]
peekBlocks = peekList peekBlock
@@ -304,6 +421,16 @@ peekInlines = peekList peekInline
pushInlines :: LuaError e => Pusher e [Inline]
pushInlines = pushPandocList pushInline
+-- | Retrieves a single definition item from a the stack; it is expected
+-- to be a pair of a list of inlines and a list of list of blocks. Uses
+-- fuzzy parsing, i.e., tries hard to convert mismatching types into the
+-- expected result.
+peekDefinitionItem :: LuaError e => Peeker e ([Inline], [[Block]])
+peekDefinitionItem = peekPair peekInlinesFuzzy $ choice
+ [ peekList peekBlocksFuzzy
+ , \idx -> (:[]) <$!> peekBlocksFuzzy idx
+ ]
+
-- | Push Caption element
pushCaption :: LuaError e => Caption -> LuaE e ()
pushCaption (Caption shortCaption longCaption) = do
@@ -318,37 +445,48 @@ peekCaption = retrieving "Caption" . \idx -> do
long <- peekFieldRaw peekBlocks "long" idx
return $! Caption short long
-peekColWidth :: LuaError e => Peeker e ColWidth
-peekColWidth = retrieving "ColWidth" . \idx -> do
- maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx)
+-- | Push a ColSpec value as a pair of Alignment and ColWidth.
+pushColSpec :: LuaError e => Pusher e ColSpec
+pushColSpec = pushPair (pushString . show) pushColWidth
+-- | Peek a ColSpec value as a pair of Alignment and ColWidth.
peekColSpec :: LuaError e => Peeker e ColSpec
peekColSpec = peekPair peekRead peekColWidth
-instance Pushable ColWidth where
- push = \case
- (ColWidth w) -> Lua.push w
- ColWidthDefault -> Lua.pushnil
+peekColWidth :: LuaError e => Peeker e ColWidth
+peekColWidth = retrieving "ColWidth" . \idx -> do
+ maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx)
-instance Pushable Row where
- push (Row attr cells) = Lua.push (attr, cells)
+-- | Push a ColWidth value by pushing the width as a plain number, or
+-- @nil@ for ColWidthDefault.
+pushColWidth :: LuaError e => Pusher e ColWidth
+pushColWidth = \case
+ (ColWidth w) -> Lua.push w
+ ColWidthDefault -> Lua.pushnil
-instance Peekable Row where
- peek = forcePeek . peekRow
+-- | Push a table row as a pair of attr and the list of cells.
+pushRow :: LuaError e => Pusher e Row
+pushRow (Row attr cells) =
+ pushPair pushAttr (pushPandocList pushCell) (attr, cells)
+-- | Push a table row from a pair of attr and the list of cells.
peekRow :: LuaError e => Peeker e Row
peekRow = ((uncurry Row) <$!>)
. retrieving "Row"
. peekPair peekAttr (peekList peekCell)
-instance Pushable TableBody where
- push (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do
+-- | Pushes a 'TableBody' value as a Lua table with fields @attr@,
+-- @row_head_columns@, @head@, and @body@.
+pushTableBody :: LuaError e => Pusher e TableBody
+pushTableBody (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do
Lua.newtable
LuaUtil.addField "attr" attr
LuaUtil.addField "row_head_columns" rowHeadColumns
LuaUtil.addField "head" head'
LuaUtil.addField "body" body
+-- | Retrieves a 'TableBody' value from a Lua table with fields @attr@,
+-- @row_head_columns@, @head@, and @body@.
peekTableBody :: LuaError e => Peeker e TableBody
peekTableBody = fmap (retrieving "TableBody")
. typeChecked "table" Lua.istable
@@ -358,17 +496,25 @@ peekTableBody = fmap (retrieving "TableBody")
<*> peekFieldRaw (peekList peekRow) "head" idx
<*> peekFieldRaw (peekList peekRow) "body" idx
-instance Pushable TableHead where
- push (TableHead attr rows) = Lua.push (attr, rows)
+-- | Push a table head value as the pair of its Attr and rows.
+pushTableHead :: LuaError e => Pusher e TableHead
+pushTableHead (TableHead attr rows) =
+ pushPair pushAttr (pushPandocList pushRow) (attr, rows)
+-- | Peek a table head value from a pair of Attr and rows.
peekTableHead :: LuaError e => Peeker e TableHead
peekTableHead = ((uncurry TableHead) <$!>)
. retrieving "TableHead"
. peekPair peekAttr (peekList peekRow)
-instance Pushable TableFoot where
- push (TableFoot attr cells) = Lua.push (attr, cells)
+-- | Pushes a 'TableFoot' value as a pair of the Attr value and the list
+-- of table rows.
+pushTableFoot :: LuaError e => Pusher e TableFoot
+pushTableFoot (TableFoot attr rows) =
+ pushPair pushAttr (pushPandocList pushRow) (attr, rows)
+-- | Retrieves a 'TableFoot' value from a pair containing an Attr value
+-- and a list of table rows.
peekTableFoot :: LuaError e => Peeker e TableFoot
peekTableFoot = ((uncurry TableFoot) <$!>)
. retrieving "TableFoot"
@@ -380,6 +526,8 @@ instance Pushable Cell where
instance Peekable Cell where
peek = forcePeek . peekCell
+-- | Push a table cell as a table with fields @attr@, @alignment@,
+-- @row_span@, @col_span@, and @contents@.
pushCell :: LuaError e => Cell -> LuaE e ()
pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do
Lua.newtable
@@ -416,9 +564,42 @@ setInlineText = \case
Str _ -> Actual . Str
_ -> const Absent
+-- | Helper type to represent all the different types a `content`
+-- attribute can have.
data Content
= ContentBlocks [Block]
| ContentInlines [Inline]
+ | ContentLines [[Inline]]
+ | ContentDefItems [([Inline], [[Block]])]
+ | ContentListItems [[Block]]
+
+contentTypeDescription :: Content -> Text
+contentTypeDescription = \case
+ ContentBlocks {} -> "list of Block items"
+ ContentInlines {} -> "list of Inline items"
+ ContentLines {} -> "list of Inline lists (i.e., a list of lines)"
+ ContentDefItems {} -> "list of definition items items"
+ ContentListItems {} -> "list items (i.e., list of list of Block elements)"
+
+pushContent :: LuaError e => Pusher e Content
+pushContent = \case
+ ContentBlocks blks -> pushPandocList pushBlock blks
+ ContentInlines inlns -> pushPandocList pushInline inlns
+ ContentLines lns -> pushPandocList (pushPandocList pushInline) lns
+ ContentDefItems itms ->
+ let pushItem = pushPair (pushPandocList pushInline)
+ (pushPandocList (pushPandocList pushBlock))
+ in pushPandocList pushItem itms
+ ContentListItems itms ->
+ pushPandocList (pushPandocList pushBlock) itms
+
+peekContent :: LuaError e => Peeker e Content
+peekContent idx =
+ (ContentInlines <$!> peekInlinesFuzzy idx) <|>
+ (ContentLines <$!> peekList (peekList peekInlineFuzzy) idx) <|>
+ (ContentBlocks <$!> peekBlocksFuzzy idx ) <|>
+ (ContentListItems <$!> peekList peekBlocksFuzzy idx) <|>
+ (ContentDefItems <$!> peekList (peekDefinitionItem) idx)
setInlineContent :: Inline -> Content -> Possible Inline
setInlineContent = \case
@@ -438,13 +619,13 @@ setInlineContent = \case
where
inlineContent = \case
ContentInlines inlns -> inlns
- ContentBlocks _ -> throwM $
- PandocLuaError "expected Inlines, got Blocks"
+ c -> throwM . PandocLuaError $ "expected Inlines, got " <>
+ contentTypeDescription c
blockContent = \case
ContentBlocks blks -> blks
ContentInlines [] -> []
- ContentInlines _ -> throwM $
- PandocLuaError "expected Blocks, got Inlines"
+ c -> throwM . PandocLuaError $ "expected Blocks, got " <>
+ contentTypeDescription c
getInlineContent :: Inline -> Possible Content
getInlineContent = \case
@@ -496,16 +677,6 @@ showInline = defun "show"
<#> parameter peekInline "inline" "Inline" "Object"
=#> functionResult pushString "string" "stringified Inline"
-pushContent :: LuaError e => Pusher e Content
-pushContent = \case
- ContentBlocks blks -> pushPandocList pushBlock blks
- ContentInlines inlns -> pushPandocList pushInline inlns
-
-peekContent :: LuaError e => Peeker e Content
-peekContent idx =
- (ContentInlines <$!> peekList peekInline idx) <|>
- (ContentBlocks <$!> peekList peekBlock idx)
-
typeInline :: LuaError e => DocumentedType e Inline
typeInline = deftype "Inline"
[ operation Tostring showInline
@@ -591,22 +762,37 @@ pushInline = pushUD typeInline
peekInline :: forall e. LuaError e => Peeker e Inline
peekInline = retrieving "Inline" . \idx -> peekUD typeInline idx
+-- | Try extra hard to retrieve an Inline value from the stack. Treats
+-- bare strings as @Str@ values.
+peekInlineFuzzy :: LuaError e => Peeker e Inline
+peekInlineFuzzy = retrieving "Inline" . choice
+ [ peekUD typeInline
+ , \idx -> Str <$!> peekText idx
+ ]
+
-- | Try extra-hard to return the value at the given index as a list of
-- inlines.
-peekFuzzyInlines :: LuaError e => Peeker e [Inline]
-peekFuzzyInlines = choice
- [ peekList peekInline
- , fmap pure . peekInline
- , \idx -> pure . Str <$!> peekText idx
+peekInlinesFuzzy :: LuaError e => Peeker e [Inline]
+peekInlinesFuzzy = choice
+ [ peekList peekInlineFuzzy
+ , fmap pure . peekInlineFuzzy
]
-peekFuzzyBlocks :: LuaError e => Peeker e [Block]
-peekFuzzyBlocks = choice
- [ peekList peekBlock
- , fmap pure . peekBlock
- , \idx -> pure . Plain . pure . Str <$!> peekText idx
+-- | Try extra hard to retrieve a Block value from the stack. Treats bar
+-- Inline elements as if they were wrapped in 'Plain'.
+peekBlockFuzzy :: LuaError e => Peeker e Block
+peekBlockFuzzy = choice
+ [ peekBlock
+ , (\idx -> Plain <$!> peekInlinesFuzzy idx)
]
+-- | Try extra-hard to return the value at the given index as a list of
+-- blocks.
+peekBlocksFuzzy :: LuaError e => Peeker e [Block]
+peekBlocksFuzzy = choice
+ [ peekList peekBlockFuzzy
+ , (<$!>) pure . peekBlockFuzzy
+ ]
pushListAttributes :: forall e. LuaError e => ListAttributes -> LuaE e ()
pushListAttributes (start, style, delimiter) =
@@ -619,6 +805,26 @@ peekListAttributes = retrieving "ListAttributes" . peekTriple
peekRead
peekRead
+-- * Orphan Instances
+
+instance Pushable Inline where
+ push = pushInline
+
+instance Pushable Citation where
+ push = pushCitation
+
+instance Pushable Row where
+ push = pushRow
+
+instance Pushable TableBody where
+ push = pushTableBody
+
+instance Pushable TableFoot where
+ push = pushTableFoot
+
+instance Pushable TableHead where
+ push = pushTableHead
+
-- These instances exist only for testing. It's a hack to avoid making
-- the marshalling modules public.
instance Peekable Inline where
@@ -633,6 +839,9 @@ instance Peekable Meta where
instance Peekable Pandoc where
peek = forcePeek . peekPandoc
+instance Peekable Row where
+ peek = forcePeek . peekRow
+
instance Peekable Version where
peek = forcePeek . peekVersionFuzzy
diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs
index bc9ddc5e5..f08914eba 100644
--- a/src/Text/Pandoc/Lua/Module/Pandoc.hs
+++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs
@@ -16,13 +16,14 @@ module Text.Pandoc.Lua.Module.Pandoc
) where
import Prelude hiding (read)
-import Control.Applicative (optional)
-import Control.Monad ((>=>), forM_, when)
+import Control.Applicative ((<|>), optional)
+import Control.Monad ((>=>), (<$!>), forM_, when)
import Control.Monad.Catch (catch, throwM)
import Control.Monad.Except (throwError)
import Data.Default (Default (..))
import Data.Maybe (fromMaybe)
-import HsLua as Lua hiding (pushModule)
+import Data.Text (Text)
+import HsLua as Lua hiding (Div, pushModule)
import HsLua.Class.Peekable (PeekError)
import System.Exit (ExitCode (..))
import Text.Pandoc.Class.PandocIO (runIO)
@@ -65,20 +66,25 @@ pushModule = do
pushDocumentedFunction fn
rawset (nth 3)
forM_ otherConstructors addConstr
+ forM_ blockConstructors addConstr
forM_ inlineConstructors addConstr
- -- add constructors to Inlines.constructor
- newtable -- constructor
- forM_ (inlineConstructors @PandocError) $ \fn -> do
- let name = functionName fn
- pushName name
- pushName name
- rawget (nth 4)
- rawset (nth 3)
- -- set as pandoc.Inline.constructor
- pushName "Inline"
- newtable *> pushName "constructor" *> pushvalue (nth 4) *> rawset (nth 3)
- rawset (nth 4)
- pop 1 -- remaining constructor table
+ let addConstructorTable constructors = do
+ -- add constructors to Inlines.constructor
+ newtable -- constructor
+ forM_ constructors $ \fn -> do
+ let name = functionName fn
+ pushName name
+ pushName name
+ rawget (nth 4)
+ rawset (nth 3)
+ -- set as pandoc.Inline.constructor
+ pushName "Inline"
+ newtable *> pushName "constructor" *>
+ pushvalue (nth 4) *> rawset (nth 3)
+ rawset (nth 4)
+ pop 1 -- remaining constructor table
+ addConstructorTable (blockConstructors @PandocError)
+ addConstructorTable (inlineConstructors @PandocError)
return 1
inlineConstructors :: LuaError e => [DocumentedFunction e]
@@ -86,7 +92,7 @@ inlineConstructors =
[ defun "Cite"
### liftPure2 Cite
<#> parameter (peekList peekCitation) "citations" "list of Citations" ""
- <#> parameter peekFuzzyInlines "content" "Inline" "placeholder content"
+ <#> parameter peekInlinesFuzzy "content" "Inline" "placeholder content"
=#> functionResult pushInline "Inline" "cite element"
, defun "Code"
### liftPure2 (flip Code)
@@ -99,7 +105,7 @@ inlineConstructors =
let attr = fromMaybe nullAttr mattr
title = fromMaybe mempty mtitle
in Image attr caption (src, title))
- <#> parameter peekFuzzyInlines "Inlines" "caption" "image caption / alt"
+ <#> parameter peekInlinesFuzzy "Inlines" "caption" "image caption / alt"
<#> parameter peekText "string" "src" "path/URL of the image file"
<#> optionalParameter peekText "string" "title" "brief image description"
<#> optionalParameter peekAttr "Attr" "attr" "image attributes"
@@ -112,7 +118,7 @@ inlineConstructors =
let attr = fromMaybe nullAttr mattr
title = fromMaybe mempty mtitle
in Link attr content (target, title))
- <#> parameter peekFuzzyInlines "Inlines" "content" "text for this link"
+ <#> parameter peekInlinesFuzzy "Inlines" "content" "text for this link"
<#> parameter peekText "string" "target" "the link target"
<#> optionalParameter peekText "string" "title" "brief link description"
<#> optionalParameter peekAttr "Attr" "attr" "link attributes"
@@ -124,12 +130,12 @@ inlineConstructors =
=#> functionResult pushInline "Inline" "math element"
, defun "Note"
### liftPure Note
- <#> parameter peekFuzzyBlocks "content" "Blocks" "note content"
+ <#> parameter peekBlocksFuzzy "content" "Blocks" "note content"
=#> functionResult pushInline "Inline" "note"
, defun "Quoted"
### liftPure2 Quoted
<#> parameter peekQuoteType "quotetype" "QuoteType" "type of quotes"
- <#> parameter peekFuzzyInlines "content" "Inlines" "inlines in quotes"
+ <#> parameter peekInlinesFuzzy "content" "Inlines" "inlines in quotes"
=#> functionResult pushInline "Inline" "quoted element"
, defun "RawInline"
### liftPure2 RawInline
@@ -145,11 +151,11 @@ inlineConstructors =
=#> functionResult pushInline "Inline" "new space"
, defun "Span"
### liftPure2 (\inlns mattr -> Span (fromMaybe nullAttr mattr) inlns)
- <#> parameter peekFuzzyInlines "content" "Inlines" "inline content"
+ <#> parameter peekInlinesFuzzy "content" "Inlines" "inline content"
<#> optionalParameter peekAttr "attr" "Attr" "additional attributes"
=#> functionResult pushInline "Inline" "span element"
, defun "Str"
- ### liftPure (\s -> s `seq` Str s)
+ ### liftPure Str
<#> parameter peekText "text" "string" ""
=#> functionResult pushInline "Inline" "new Str object"
, mkInlinesConstr "Strong" Strong
@@ -159,11 +165,119 @@ inlineConstructors =
, mkInlinesConstr "Underline" Underline
]
+blockConstructors :: LuaError e => [DocumentedFunction e]
+blockConstructors =
+ [ defun "BlockQuote"
+ ### liftPure BlockQuote
+ <#> blocksParam
+ =#> blockResult "BlockQuote element"
+
+ , defun "BulletList"
+ ### liftPure BulletList
+ <#> blockItemsParam "list items"
+ =#> blockResult "BulletList element"
+
+ , defun "CodeBlock"
+ ### liftPure2 (\code mattr -> CodeBlock (fromMaybe nullAttr mattr) code)
+ <#> textParam "text" "code block content"
+ <#> optAttrParam
+ =#> blockResult "CodeBlock element"
+
+ , defun "DefinitionList"
+ ### liftPure DefinitionList
+ <#> parameter (choice
+ [ peekList peekDefinitionItem
+ , \idx -> (:[]) <$!> peekDefinitionItem idx
+ ])
+ "{{Inlines, {Blocks,...}},...}"
+ "content" "definition items"
+ =#> blockResult "DefinitionList element"
+
+ , defun "Div"
+ ### liftPure2 (\content mattr -> Div (fromMaybe nullAttr mattr) content)
+ <#> blocksParam
+ <#> optAttrParam
+ =#> blockResult "Div element"
+
+ , defun "Header"
+ ### liftPure3 (\lvl content mattr ->
+ Header lvl (fromMaybe nullAttr mattr) content)
+ <#> parameter peekIntegral "integer" "level" "heading level"
+ <#> parameter peekInlinesFuzzy "Inlines" "content" "inline content"
+ <#> optAttrParam
+ =#> blockResult "Header element"
+
+ , defun "HorizontalRule"
+ ### return HorizontalRule
+ =#> blockResult "HorizontalRule element"
+
+ , defun "LineBlock"
+ ### liftPure LineBlock
+ <#> parameter (peekList peekInlinesFuzzy) "{Inlines,...}" "content" "lines"
+ =#> blockResult "LineBlock element"
+
+ , defun "Null"
+ ### return Null
+ =#> blockResult "Null element"
+
+ , defun "OrderedList"
+ ### liftPure2 (\items mListAttrib ->
+ let defListAttrib = (1, DefaultStyle, DefaultDelim)
+ in OrderedList (fromMaybe defListAttrib mListAttrib) items)
+ <#> blockItemsParam "ordered list items"
+ <#> optionalParameter peekListAttributes "ListAttributes" "listAttributes"
+ "specifier for the list's numbering"
+ =#> blockResult "OrderedList element"
+
+ , defun "Para"
+ ### liftPure Para
+ <#> parameter peekInlinesFuzzy "Inlines" "content" "paragraph content"
+ =#> blockResult "Para element"
+
+ , defun "Plain"
+ ### liftPure Plain
+ <#> parameter peekInlinesFuzzy "Inlines" "content" "paragraph content"
+ =#> blockResult "Plain element"
+
+ , defun "RawBlock"
+ ### liftPure2 RawBlock
+ <#> parameter peekFormat "Format" "format" "format of content"
+ <#> parameter peekText "string" "text" "raw content"
+ =#> blockResult "RawBlock element"
+
+ , defun "Table"
+ ### (\capt colspecs thead tbodies tfoot mattr ->
+ let attr = fromMaybe nullAttr mattr
+ in return $! attr `seq` capt `seq` colspecs `seq` thead `seq` tbodies
+ `seq` tfoot `seq` Table attr capt colspecs thead tbodies tfoot)
+ <#> parameter peekCaption "Caption" "caption" "table caption"
+ <#> parameter (peekList peekColSpec) "{ColSpec,...}" "colspecs"
+ "column alignments and widths"
+ <#> parameter peekTableHead "TableHead" "head" "table head"
+ <#> parameter (peekList peekTableBody) "{TableBody,...}" "bodies"
+ "table bodies"
+ <#> parameter peekTableFoot "TableFoot" "foot" "table foot"
+ <#> optAttrParam
+ =#> blockResult "Table element"
+ ]
+ where
+ blockResult = functionResult pushBlock "Block"
+ blocksParam = parameter peekBlocksFuzzy "Blocks" "content" "block content"
+ blockItemsParam = parameter peekItemsFuzzy "List of Blocks" "content"
+ peekItemsFuzzy idx = peekList peekBlocksFuzzy idx
+ <|> ((:[]) <$!> peekBlocksFuzzy idx)
+
+textParam :: LuaError e => Text -> Text -> Parameter e Text
+textParam = parameter peekText "string"
+
+optAttrParam :: LuaError e => Parameter e (Maybe Attr)
+optAttrParam = optionalParameter peekAttr "attr" "Attr" "additional attributes"
+
mkInlinesConstr :: LuaError e
=> Name -> ([Inline] -> Inline) -> DocumentedFunction e
mkInlinesConstr name constr = defun name
### liftPure (\x -> x `seq` constr x)
- <#> parameter peekFuzzyInlines "content" "Inlines" ""
+ <#> parameter peekInlinesFuzzy "content" "Inlines" ""
=#> functionResult pushInline "Inline" "new object"
otherConstructors :: LuaError e => [DocumentedFunction e]
@@ -181,8 +295,8 @@ otherConstructors =
})
<#> parameter peekText "string" "cid" "citation ID (e.g. bibtex key)"
<#> parameter peekRead "citation mode" "mode" "citation rendering mode"
- <#> optionalParameter peekFuzzyInlines "prefix" "Inlines" ""
- <#> optionalParameter peekFuzzyInlines "suffix" "Inlines" ""
+ <#> optionalParameter peekInlinesFuzzy "prefix" "Inlines" ""
+ <#> optionalParameter peekInlinesFuzzy "suffix" "Inlines" ""
<#> optionalParameter peekIntegral "note_num" "integer" "note number"
<#> optionalParameter peekIntegral "hash" "integer" "hash number"
=#> functionResult pushCitation "Citation" "new citation object"
@@ -283,7 +397,7 @@ pushPipeError pipeErr = do
mkPandoc :: PandocLua NumResults
mkPandoc = liftPandocLua $ do
doc <- forcePeek $ do
- blks <- peekBlocks (nthBottom 1)
+ blks <- peekBlocksFuzzy (nthBottom 1)
mMeta <- optional $ peekMeta (nthBottom 2)
pure $ Pandoc (fromMaybe nullMeta mMeta) blks
pushPandoc doc
diff --git a/src/Text/Pandoc/Lua/Module/Types.hs b/src/Text/Pandoc/Lua/Module/Types.hs
index 4a7d14d2f..fb09235de 100644
--- a/src/Text/Pandoc/Lua/Module/Types.hs
+++ b/src/Text/Pandoc/Lua/Module/Types.hs
@@ -35,13 +35,9 @@ pushModule = do
pushCloneTable :: LuaE PandocError NumResults
pushCloneTable = do
Lua.newtable
- addFunction "Attr" $ cloneWith peekAttr pushAttr
- addFunction "Block" $ cloneWith peekBlock pushBlock
- addFunction "Inline" $ cloneWith peekInline pushInline
addFunction "Meta" $ cloneWith peekMeta Lua.push
addFunction "MetaValue" $ cloneWith peekMetaValue pushMetaValue
addFunction "ListAttributes" $ cloneWith peekListAttributes pushListAttributes
- addFunction "Pandoc" $ cloneWith peekPandoc pushPandoc
return 1
cloneWith :: Peeker PandocError a
--
cgit v1.2.3