From a493c7029cf2bc8490d96fff04b0a0c624987601 Mon Sep 17 00:00:00 2001 From: Albert Krewinkel 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`. --- data/pandoc.lua | 205 ---------------- 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 - test/lua/module/pandoc.lua | 120 ++++++++++ 6 files changed, 581 insertions(+), 351 deletions(-) diff --git a/data/pandoc.lua b/data/pandoc.lua index 47343b28c..a20ce1e8c 100644 --- a/data/pandoc.lua +++ b/data/pandoc.lua @@ -273,22 +273,6 @@ local function ensureInlineList (x) end end ---- Ensure that the given object is a definition pair, convert if necessary. --- @local -local function ensureDefinitionPairs (pair) - local inlines = ensureInlineList(pair[1] or {}) - local blocks = ensureList(pair[2] or {}):map(ensureList) - return {inlines, blocks} -end - ---- Try hard to turn the arguments into an Attr object. -local function ensureAttr(attr) - if type(attr) == 'userdata' then - return attr - end - return M.Attr(attr) -end - ------------------------------------------------------------------------ -- Meta -- @section Meta @@ -364,199 +348,10 @@ function M.MetaBool(bool) return bool end ------------------------------------------------------------------------- --- Blocks --- @section Block - ---- Block elements -M.Block = AstElement:make_subtype'Block' -M.Block.behavior.clone = M.types.clone.Block - ---- Creates a block quote element --- @function BlockQuote --- @tparam {Block,...} content block content --- @treturn Block block quote element -M.BlockQuote = M.Block:create_constructor( - "BlockQuote", - function(content) return {c = ensureList(content)} end, - "content" -) - ---- Creates a bullet (i.e. unordered) list. --- @function BulletList --- @tparam {{Block,...},...} content list of items --- @treturn Block bullet list element -M.BulletList = M.Block:create_constructor( - "BulletList", - function(content) return {c = ensureList(content):map(ensureList)} end, - "content" -) - ---- Creates a code block element --- @function CodeBlock --- @tparam string text code string --- @tparam[opt] Attr attr element attributes --- @treturn Block code block element -M.CodeBlock = M.Block:create_constructor( - "CodeBlock", - function(text, attr) return {c = {ensureAttr(attr), text}} end, - {{attr = {"identifier", "classes", "attributes"}}, "text"} -) - ---- Creates a definition list, containing terms and their explanation. --- @function DefinitionList --- @tparam {{{Inline,...},{{Block,...}}},...} content list of items --- @treturn Block definition list element -M.DefinitionList = M.Block:create_constructor( - "DefinitionList", - function(content) - return {c = ensureList(content):map(ensureDefinitionPairs)} - end, - "content" -) - ---- Creates a div element --- @function Div --- @tparam {Block,...} content block content --- @tparam[opt] Attr attr element attributes --- @treturn Block div element -M.Div = M.Block:create_constructor( - "Div", - function(content, attr) - return {c = {ensureAttr(attr), ensureList(content)}} - end, - {{attr = {"identifier", "classes", "attributes"}}, "content"} -) - ---- Creates a header element. --- @function Header --- @tparam int level header level --- @tparam {Inline,...} content inline content --- @tparam[opt] Attr attr element attributes --- @treturn Block header element -M.Header = M.Block:create_constructor( - "Header", - function(level, content, attr) - return {c = {level, ensureAttr(attr), ensureInlineList(content)}} - end, - {"level", {attr = {"identifier", "classes", "attributes"}}, "content"} -) - ---- Creates a horizontal rule. --- @function HorizontalRule --- @treturn Block horizontal rule -M.HorizontalRule = M.Block:create_constructor( - "HorizontalRule", - function() return {} end -) - ---- Creates a line block element. --- @function LineBlock --- @tparam {{Inline,...},...} content inline content --- @treturn Block line block element -M.LineBlock = M.Block:create_constructor( - "LineBlock", - function(content) return {c = ensureList(content):map(ensureInlineList)} end, - "content" -) - ---- Creates a null element. --- @function Null --- @treturn Block null element -M.Null = M.Block:create_constructor( - "Null", - function() return {} end -) - ---- Creates an ordered list. --- @function OrderedList --- @tparam {{Block,...},...} items list items --- @param[opt] listAttributes list parameters --- @treturn Block ordered list element -M.OrderedList = M.Block:create_constructor( - "OrderedList", - function(items, listAttributes) - listAttributes = listAttributes or M.ListAttributes() - return {c = {listAttributes, ensureList(items):map(ensureList)}} - end, - {{listAttributes = {"start", "style", "delimiter"}}, "content"} -) - ---- Creates a para element. --- @function Para --- @tparam {Inline,...} content inline content --- @treturn Block paragraph element -M.Para = M.Block:create_constructor( - "Para", - function(content) return {c = ensureInlineList(content)} end, - "content" -) - ---- Creates a plain element. --- @function Plain --- @tparam {Inline,...} content inline content --- @treturn Block plain element -M.Plain = M.Block:create_constructor( - "Plain", - function(content) return {c = ensureInlineList(content)} end, - "content" -) - ---- Creates a raw content block of the specified format. --- @function RawBlock --- @tparam string format format of content --- @tparam string text string content --- @treturn Block raw block element -M.RawBlock = M.Block:create_constructor( - "RawBlock", - function(format, text) return {c = {format, text}} end, - {"format", "text"} -) - ---- Creates a table element. --- @function Table --- @tparam Caption caption table caption --- @tparam {ColSpec,...} colspecs column alignments and widths --- @tparam TableHead head table head --- @tparam {TableBody,..} bodies table bodies --- @treturn TableFoot foot table foot --- @tparam[opt] Attr attr attributes -M.Table = M.Block:create_constructor( - "Table", - function(caption, colspecs, head, bodies, foot, attr) - return { - c = { - ensureAttr(attr), - caption, - List:new(colspecs), - head, - List:new(bodies), - foot - } - } - end, - {"attr", "caption", "colspecs", "head", "bodies", "foot"} -) - - ------------------------------------------------------------------------ -- Element components -- @section components --- Monkey-patch setters for `attr` fields to be more forgiving in the input that --- results in a valid Attr value. -function augment_attr_setter (setters) - if setters.attr then - local orig = setters.attr - setters.attr = function(k, v) - orig(k, ensureAttr(v)) - end - end -end -for _, blk in pairs(M.Block.constructor) do - augment_attr_setter(blk.behavior.setters) -end - -- ListAttributes M.ListAttributes = AstElement:make_subtype 'ListAttributes' M.ListAttributes.behavior.clone = M.types.clone.ListAttributes 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 diff --git a/test/lua/module/pandoc.lua b/test/lua/module/pandoc.lua index ba6d2a1df..173c9bb29 100644 --- a/test/lua/module/pandoc.lua +++ b/test/lua/module/pandoc.lua @@ -98,6 +98,126 @@ return { assert.are_equal(count, 3) end) }, + group "Block elements" { + group "BulletList" { + test('access items via property `content`', function () + local para = pandoc.Para 'one' + local blist = pandoc.BulletList{{para}} + assert.are_same({{para}}, blist.content) + end), + test('property `content` uses fuzzy marshalling', function () + local old = pandoc.Plain 'old' + local new = pandoc.Plain 'new' + local blist = pandoc.BulletList{{old}} + blist.content = {{new}} + assert.are_same({{new}}, blist:clone().content) + blist.content = new + assert.are_same({{new}}, blist:clone().content) + end), + }, + group "OrderedList" { + test('access items via property `content`', function () + local para = pandoc.Plain 'one' + local olist = pandoc.OrderedList{{para}} + assert.are_same({{para}}, olist.content) + end), + test('forgiving constructor', function () + local plain = pandoc.Plain 'old' + local olist = pandoc.OrderedList({plain}, {3, 'Example', 'Period'}) + local listAttribs = pandoc.ListAttributes(3, 'Example', 'Period') + assert.are_same(olist.listAttributes, listAttribs) + end), + test('has list attribute aliases', function () + local olist = pandoc.OrderedList({}, {4, 'Decimal', 'OneParen'}) + assert.are_equal(olist.start, 4) + assert.are_equal(olist.style, 'Decimal') + assert.are_equal(olist.delimiter, 'OneParen') + end) + }, + group 'DefinitionList' { + test('access items via property `content`', function () + local deflist = pandoc.DefinitionList{ + {'apple', {{pandoc.Plain 'fruit'}, {pandoc.Plain 'company'}}}, + {pandoc.Str 'coffee', 'Best when hot.'} + } + assert.are_equal(#deflist.content, 2) + assert.are_same(deflist.content[1][1], {pandoc.Str 'apple'}) + assert.are_same(deflist.content[1][2][2], + {pandoc.Plain{pandoc.Str 'company'}}) + assert.are_same(deflist.content[2][2], + {{pandoc.Plain{pandoc.Str 'Best when hot.'}}}) + end), + test('modify items via property `content`', function () + local deflist = pandoc.DefinitionList{ + {'apple', {{{'fruit'}}, {{'company'}}}} + } + deflist.content[1][1] = pandoc.Str 'orange' + deflist.content[1][2][1] = {pandoc.Plain 'tasty fruit'} + local newlist = pandoc.DefinitionList{ + { {pandoc.Str 'orange'}, + {{pandoc.Plain 'tasty fruit'}, {pandoc.Plain 'company'}} + } + } + assert.are_equal(deflist, newlist) + end), + }, + group 'Para' { + test('access inline via property `content`', function () + local para = pandoc.Para{'Moin, ', pandoc.Space(), 'Sylt!'} + assert.are_same( + para.content, + {pandoc.Str 'Moin, ', pandoc.Space(), pandoc.Str 'Sylt!'} + ) + end), + test('modifying `content` changes the element', function () + local para = pandoc.Para{'Moin, ', pandoc.Space(), pandoc.Str 'Sylt!'} + + para.content[3] = 'Hamburg!' + assert.are_same( + para:clone().content, + {pandoc.Str 'Moin, ', pandoc.Space(), pandoc.Str 'Hamburg!'} + ) + + para.content = 'Huh' + assert.are_same( + para:clone().content, + {pandoc.Str 'Huh'} + ) + end), + }, + group 'LineBlock' { + test('access lines via property `content`', function () + local spc = pandoc.Space() + local lineblock = pandoc.LineBlock{ + {'200', spc, 'Main', spc, 'St.'}, + {'Berkeley', spc, 'CA', spc, '94718'} + } + assert.are_equal(#lineblock.content, 2) -- has two lines + assert.are_same(lineblock.content[2][1], pandoc.Str 'Berkeley') + end), + test('modifying `content` alter the element', function () + local spc = pandoc.Space() + local lineblock = pandoc.LineBlock{ + {'200', spc, 'Main', spc, 'St.'}, + {'Berkeley', spc, 'CA', spc, '94718'} + } + lineblock.content[1][1] = '404' + assert.are_same( + lineblock:clone().content[1], + {pandoc.Str '404', spc, pandoc.Str 'Main', spc, pandoc.Str 'St.'} + ) + + lineblock.content = {{'line1'}, {'line2'}} + assert.are_same( + lineblock:clone(), + pandoc.LineBlock{ + {pandoc.Str 'line1'}, + {pandoc.Str 'line2'} + } + ) + end) + } + }, group 'HTML-like attribute tables' { test('in element constructor', function () local html_attributes = { -- cgit v1.2.3