diff options
Diffstat (limited to 'src/Text/Pandoc/Lua/Marshaling/AST.hs')
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/AST.hs | 543 |
1 files changed, 302 insertions, 241 deletions
diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs index 8e12d232c..eedf00a94 100644 --- a/src/Text/Pandoc/Lua/Marshaling/AST.hs +++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.AST Copyright : © 2012-2021 John MacFarlane @@ -13,223 +15,254 @@ Marshaling/unmarshaling instances for document AST elements. -} module Text.Pandoc.Lua.Marshaling.AST - ( LuaAttr (..) - , LuaListAttributes (..) + ( peekAttr + , peekBlock + , peekBlocks + , peekCaption + , peekCitation + , peekInline + , peekInlines + , peekListAttributes + , peekMeta + , peekMetaValue + , peekPandoc + + , pushAttr + , pushBlock + , pushInline + , pushListAttributes + , pushMetaValue + , pushPandoc ) where -import Control.Applicative ((<|>)) -import Control.Monad ((<$!>)) -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import Control.Applicative ((<|>), optional) +import Control.Monad ((<$!>), (>=>)) +import HsLua hiding (Operation (Div)) import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) +import Text.Pandoc.Lua.Util (pushViaConstr', pushViaConstructor) import Text.Pandoc.Lua.Marshaling.CommonState () -import qualified Control.Monad.Catch as Catch -import qualified Foreign.Lua as Lua +import qualified HsLua as Lua import qualified Text.Pandoc.Lua.Util as LuaUtil instance Pushable Pandoc where - push (Pandoc meta blocks) = - pushViaConstructor "Pandoc" blocks meta + push = pushPandoc -instance Peekable Pandoc where - peek idx = defineHowTo "get Pandoc value" $! Pandoc - <$!> LuaUtil.rawField idx "meta" - <*> LuaUtil.rawField idx "blocks" +pushPandoc :: LuaError e => Pusher e Pandoc +pushPandoc (Pandoc meta blocks) = + pushViaConstr' "Pandoc" [pushList pushBlock blocks, push meta] + +peekPandoc :: LuaError e => Peeker e Pandoc +peekPandoc = fmap (retrieving "Pandoc value") + . typeChecked "table" Lua.istable $ \idx -> do + meta <- peekFieldRaw peekMeta "meta" idx + blks <- peekFieldRaw peekBlocks "blocks" idx + return $ Pandoc meta blks instance Pushable Meta where push (Meta mmap) = - pushViaConstructor "Meta" mmap -instance Peekable Meta where - peek idx = defineHowTo "get Meta value" $! - Meta <$!> Lua.peek idx + pushViaConstr' "Meta" [push mmap] + +peekMeta :: LuaError e => Peeker e Meta +peekMeta idx = retrieving "Meta" $ + Meta <$!> peekMap peekText peekMetaValue idx instance Pushable MetaValue where push = pushMetaValue -instance Peekable MetaValue where - peek = peekMetaValue instance Pushable Block where push = pushBlock -instance Peekable Block where - peek = peekBlock - -- Inline instance Pushable Inline where push = pushInline -instance Peekable Inline where - peek = peekInline - -- Citation instance Pushable Citation where push (Citation cid prefix suffix mode noteNum hash) = - pushViaConstructor "Citation" cid mode prefix suffix noteNum hash + pushViaConstr' "Citation" + [ push cid, push mode, push prefix, push suffix, push noteNum, push hash + ] + +peekCitation :: LuaError e => Peeker e Citation +peekCitation = fmap (retrieving "Citation") + . typeChecked "table" Lua.istable $ \idx -> do + idx' <- liftLua $ absindex idx + Citation + <$!> peekFieldRaw peekText "id" idx' + <*> peekFieldRaw (peekList peekInline) "prefix" idx' + <*> peekFieldRaw (peekList peekInline) "suffix" idx' + <*> peekFieldRaw peekRead "mode" idx' + <*> peekFieldRaw peekIntegral "note_num" idx' + <*> peekFieldRaw peekIntegral "hash" idx' -instance Peekable Citation where - peek idx = Citation - <$!> LuaUtil.rawField idx "id" - <*> LuaUtil.rawField idx "prefix" - <*> LuaUtil.rawField idx "suffix" - <*> LuaUtil.rawField idx "mode" - <*> LuaUtil.rawField idx "note_num" - <*> LuaUtil.rawField idx "hash" instance Pushable Alignment where - push = Lua.push . show -instance Peekable Alignment where - peek = Lua.peekRead + push = Lua.pushString . show instance Pushable CitationMode where push = Lua.push . show -instance Peekable CitationMode where - peek = Lua.peekRead instance Pushable Format where push (Format f) = Lua.push f -instance Peekable Format where - peek idx = Format <$!> Lua.peek idx + +peekFormat :: LuaError e => Peeker e Format +peekFormat idx = Format <$!> peekText idx instance Pushable ListNumberDelim where push = Lua.push . show -instance Peekable ListNumberDelim where - peek = Lua.peekRead instance Pushable ListNumberStyle where push = Lua.push . show -instance Peekable ListNumberStyle where - peek = Lua.peekRead instance Pushable MathType where push = Lua.push . show -instance Peekable MathType where - peek = Lua.peekRead instance Pushable QuoteType where push = Lua.push . show -instance Peekable QuoteType where - peek = Lua.peekRead -- | Push an meta value element to the top of the lua stack. -pushMetaValue :: MetaValue -> Lua () +pushMetaValue :: LuaError e => MetaValue -> LuaE e () pushMetaValue = \case - MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks + MetaBlocks blcks -> pushViaConstr' "MetaBlocks" [pushList pushBlock blcks] MetaBool bool -> Lua.push bool - MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns - MetaList metalist -> pushViaConstructor "MetaList" metalist - MetaMap metamap -> pushViaConstructor "MetaMap" metamap + MetaInlines inlns -> pushViaConstr' "MetaInlines" + [pushList pushInline inlns] + MetaList metalist -> pushViaConstr' "MetaList" + [pushList pushMetaValue metalist] + MetaMap metamap -> pushViaConstr' "MetaMap" + [pushMap pushText pushMetaValue metamap] MetaString str -> Lua.push str -- | Interpret the value at the given stack index as meta value. -peekMetaValue :: StackIndex -> Lua MetaValue -peekMetaValue idx = defineHowTo "get MetaValue" $ do +peekMetaValue :: forall e. LuaError e => Peeker e MetaValue +peekMetaValue = retrieving "MetaValue $ " . \idx -> do -- Get the contents of an AST element. - let elementContent :: Peekable a => Lua a - elementContent = Lua.peek idx - luatype <- Lua.ltype idx + let mkMV :: (a -> MetaValue) -> Peeker e a -> Peek e MetaValue + mkMV f p = f <$!> p idx + + peekTagged = \case + "MetaBlocks" -> mkMV MetaBlocks $ + retrieving "MetaBlocks" . peekBlocks + "MetaBool" -> mkMV MetaBool $ + retrieving "MetaBool" . peekBool + "MetaMap" -> mkMV MetaMap $ + retrieving "MetaMap" . peekMap peekText peekMetaValue + "MetaInlines" -> mkMV MetaInlines $ + retrieving "MetaInlines" . peekInlines + "MetaList" -> mkMV MetaList $ + retrieving "MetaList" . peekList peekMetaValue + "MetaString" -> mkMV MetaString $ + retrieving "MetaString" . peekText + (Name t) -> failPeek ("Unknown meta tag: " <> t) + + peekUntagged = do + -- no meta value tag given, try to guess. + len <- liftLua $ Lua.rawlen idx + if len <= 0 + then MetaMap <$!> peekMap peekText peekMetaValue idx + else (MetaInlines <$!> peekInlines idx) + <|> (MetaBlocks <$!> peekBlocks idx) + <|> (MetaList <$!> peekList peekMetaValue idx) + luatype <- liftLua $ Lua.ltype idx case luatype of - Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx - Lua.TypeString -> MetaString <$!> Lua.peek idx + Lua.TypeBoolean -> MetaBool <$!> peekBool idx + Lua.TypeString -> MetaString <$!> peekText idx Lua.TypeTable -> do - tag <- try $ LuaUtil.getTag idx - case tag of - Right "MetaBlocks" -> MetaBlocks <$!> elementContent - Right "MetaBool" -> MetaBool <$!> elementContent - Right "MetaMap" -> MetaMap <$!> elementContent - Right "MetaInlines" -> MetaInlines <$!> elementContent - Right "MetaList" -> MetaList <$!> elementContent - Right "MetaString" -> MetaString <$!> elementContent - Right t -> Lua.throwMessage ("Unknown meta tag: " <> t) - Left _ -> do - -- no meta value tag given, try to guess. - len <- Lua.rawlen idx - if len <= 0 - then MetaMap <$!> Lua.peek idx - else (MetaInlines <$!> Lua.peek idx) - <|> (MetaBlocks <$!> Lua.peek idx) - <|> (MetaList <$!> Lua.peek idx) - _ -> Lua.throwMessage "could not get meta value" + optional (LuaUtil.getTag idx) >>= \case + Just tag -> peekTagged tag + Nothing -> peekUntagged + _ -> failPeek "could not get meta value" -- | Push a block element to the top of the Lua stack. -pushBlock :: Block -> Lua () +pushBlock :: forall e. LuaError e => Block -> LuaE e () pushBlock = \case - BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks - BulletList items -> pushViaConstructor "BulletList" items - CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) - DefinitionList items -> pushViaConstructor "DefinitionList" items - Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) - Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) - HorizontalRule -> pushViaConstructor "HorizontalRule" - LineBlock blcks -> pushViaConstructor "LineBlock" blcks - OrderedList lstAttr list -> pushViaConstructor "OrderedList" list - (LuaListAttributes lstAttr) - Null -> pushViaConstructor "Null" - Para blcks -> pushViaConstructor "Para" blcks - Plain blcks -> pushViaConstructor "Plain" blcks - RawBlock f cs -> pushViaConstructor "RawBlock" f cs + 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 -> - pushViaConstructor "Table" blkCapt specs thead tbody tfoot attr + pushViaConstr' @e "Table" + [ pushCaption blkCapt, push specs, push thead, push tbody + , push tfoot, pushAttr attr] -- | Return the value at the given index as block if possible. -peekBlock :: StackIndex -> Lua Block -peekBlock idx = defineHowTo "get Block value" $! do - tag <- LuaUtil.getTag idx - case tag of - "BlockQuote" -> BlockQuote <$!> elementContent - "BulletList" -> BulletList <$!> elementContent - "CodeBlock" -> withAttr CodeBlock <$!> elementContent - "DefinitionList" -> DefinitionList <$!> elementContent - "Div" -> withAttr Div <$!> elementContent - "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) - <$!> elementContent +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" -> LineBlock <$!> elementContent - "OrderedList" -> (\(LuaListAttributes lstAttr, lst) -> - OrderedList lstAttr lst) - <$!> elementContent + "LineBlock" -> mkBlock LineBlock (peekList peekInlines) + "OrderedList" -> mkBlock (uncurry OrderedList) + (peekPair peekListAttributes (peekList peekBlocks)) "Null" -> return Null - "Para" -> Para <$!> elementContent - "Plain" -> Plain <$!> elementContent - "RawBlock" -> uncurry RawBlock <$!> elementContent - "Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) -> - Table (fromLuaAttr attr) - capt - colSpecs - thead - tbodies - tfoot) - <$!> elementContent - _ -> Lua.throwMessage ("Unknown block type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - -instance Pushable Caption where - push = pushCaption - -instance Peekable Caption where - peek = peekCaption + "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) + +peekBlocks :: LuaError e => Peeker e [Block] +peekBlocks = peekList peekBlock + +peekInlines :: LuaError e => Peeker e [Inline] +peekInlines = peekList peekInline -- | Push Caption element -pushCaption :: Caption -> Lua () +pushCaption :: LuaError e => Caption -> LuaE e () pushCaption (Caption shortCaption longCaption) = do Lua.newtable LuaUtil.addField "short" (Lua.Optional shortCaption) LuaUtil.addField "long" longCaption -- | Peek Caption element -peekCaption :: StackIndex -> Lua Caption -peekCaption idx = Caption - <$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short") - <*> LuaUtil.rawField idx "long" +peekCaption :: LuaError e => Peeker e Caption +peekCaption = retrieving "Caption" . \idx -> do + short <- optional $ peekFieldRaw peekInlines "short" idx + long <- peekFieldRaw peekBlocks "long" idx + return $! Caption short long -instance Peekable ColWidth where - peek idx = do - width <- Lua.fromOptional <$!> Lua.peek idx - return $! maybe ColWidthDefault ColWidth width +peekColWidth :: LuaError e => Peeker e ColWidth +peekColWidth = retrieving "ColWidth" . \idx -> do + maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx) + +peekColSpec :: LuaError e => Peeker e ColSpec +peekColSpec = peekPair peekRead peekColWidth instance Pushable ColWidth where push = \case @@ -240,7 +273,12 @@ instance Pushable Row where push (Row attr cells) = Lua.push (attr, cells) instance Peekable Row where - peek = fmap (uncurry Row) . Lua.peek + peek = forcePeek . peekRow + +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 @@ -250,32 +288,38 @@ instance Pushable TableBody where LuaUtil.addField "head" head' LuaUtil.addField "body" body -instance Peekable TableBody where - peek idx = TableBody - <$!> LuaUtil.rawField idx "attr" - <*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns") - <*> LuaUtil.rawField idx "head" - <*> LuaUtil.rawField idx "body" +peekTableBody :: LuaError e => Peeker e TableBody +peekTableBody = fmap (retrieving "TableBody") + . typeChecked "table" Lua.istable + $ \idx -> TableBody + <$!> peekFieldRaw peekAttr "attr" idx + <*> peekFieldRaw ((fmap RowHeadColumns) . peekIntegral) "row_head_columns" idx + <*> peekFieldRaw (peekList peekRow) "head" idx + <*> peekFieldRaw (peekList peekRow) "body" idx instance Pushable TableHead where push (TableHead attr rows) = Lua.push (attr, rows) -instance Peekable TableHead where - peek = fmap (uncurry TableHead) . Lua.peek +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) -instance Peekable TableFoot where - peek = fmap (uncurry TableFoot) . Lua.peek +peekTableFoot :: LuaError e => Peeker e TableFoot +peekTableFoot = ((uncurry TableFoot) <$!>) + . retrieving "TableFoot" + . peekPair peekAttr (peekList peekRow) instance Pushable Cell where push = pushCell instance Peekable Cell where - peek = peekCell + peek = forcePeek . peekCell -pushCell :: Cell -> Lua () +pushCell :: LuaError e => Cell -> LuaE e () pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do Lua.newtable LuaUtil.addField "attr" attr @@ -284,95 +328,112 @@ pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do LuaUtil.addField "col_span" colSpan LuaUtil.addField "contents" contents -peekCell :: StackIndex -> Lua Cell -peekCell idx = Cell - <$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr") - <*> LuaUtil.rawField idx "alignment" - <*> (RowSpan <$!> LuaUtil.rawField idx "row_span") - <*> (ColSpan <$!> LuaUtil.rawField idx "col_span") - <*> LuaUtil.rawField idx "contents" +peekCell :: LuaError e => Peeker e Cell +peekCell = fmap (retrieving "Cell") + . typeChecked "table" Lua.istable + $ \idx -> do + attr <- peekFieldRaw peekAttr "attr" idx + algn <- peekFieldRaw peekRead "alignment" idx + rs <- RowSpan <$!> peekFieldRaw peekIntegral "row_span" idx + cs <- ColSpan <$!> peekFieldRaw peekIntegral "col_span" idx + blks <- peekFieldRaw peekBlocks "contents" idx + return $! Cell attr algn rs cs blks -- | Push an inline element to the top of the lua stack. -pushInline :: Inline -> Lua () +pushInline :: forall e. LuaError e => Inline -> LuaE e () pushInline = \case - Cite citations lst -> pushViaConstructor "Cite" lst citations - Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) - Emph inlns -> pushViaConstructor "Emph" inlns - Underline inlns -> pushViaConstructor "Underline" inlns - Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) - LineBreak -> pushViaConstructor "LineBreak" - Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) - Note blcks -> pushViaConstructor "Note" blcks - Math mty str -> pushViaConstructor "Math" mty str - Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns - RawInline f cs -> pushViaConstructor "RawInline" f cs - SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns - SoftBreak -> pushViaConstructor "SoftBreak" - Space -> pushViaConstructor "Space" - Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) - Str str -> pushViaConstructor "Str" str - Strikeout inlns -> pushViaConstructor "Strikeout" inlns - Strong inlns -> pushViaConstructor "Strong" inlns - Subscript inlns -> pushViaConstructor "Subscript" inlns - Superscript inlns -> pushViaConstructor "Superscript" inlns + Cite citations lst -> pushViaConstructor @e "Cite" lst citations + Code attr lst -> pushViaConstr' @e "Code" + [push lst, pushAttr attr] + Emph inlns -> pushViaConstructor @e "Emph" inlns + Underline inlns -> pushViaConstructor @e "Underline" inlns + Image attr alt (src,tit) -> pushViaConstr' @e "Image" + [push alt, push src, push tit, pushAttr attr] + LineBreak -> pushViaConstructor @e "LineBreak" + Link attr lst (src,tit) -> pushViaConstr' @e "Link" + [push lst, push src, push tit, pushAttr attr] + Note blcks -> pushViaConstructor @e "Note" blcks + Math mty str -> pushViaConstructor @e "Math" mty str + Quoted qt inlns -> pushViaConstructor @e "Quoted" qt inlns + RawInline f cs -> pushViaConstructor @e "RawInline" f cs + SmallCaps inlns -> pushViaConstructor @e "SmallCaps" inlns + SoftBreak -> pushViaConstructor @e "SoftBreak" + Space -> pushViaConstructor @e "Space" + Span attr inlns -> pushViaConstr' @e "Span" + [push inlns, pushAttr attr] + Str str -> pushViaConstructor @e "Str" str + Strikeout inlns -> pushViaConstructor @e "Strikeout" inlns + Strong inlns -> pushViaConstructor @e "Strong" inlns + Subscript inlns -> pushViaConstructor @e "Subscript" inlns + Superscript inlns -> pushViaConstructor @e "Superscript" inlns -- | Return the value at the given index as inline if possible. -peekInline :: StackIndex -> Lua Inline -peekInline idx = defineHowTo "get Inline value" $ do - tag <- LuaUtil.getTag idx - case tag of - "Cite" -> uncurry Cite <$!> elementContent - "Code" -> withAttr Code <$!> elementContent - "Emph" -> Emph <$!> elementContent - "Underline" -> Underline <$!> elementContent - "Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt) - <$!> elementContent - "Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt) - <$!> elementContent +peekInline :: forall e. LuaError e => Peeker e Inline +peekInline = retrieving "Inline" . \idx -> do + -- Get the contents of an AST element. + let mkBlock :: (a -> Inline) -> Peeker e a -> Peek e Inline + mkBlock f p = f <$!> peekFieldRaw p "c" idx + LuaUtil.getTag idx >>= \case + "Cite" -> mkBlock (uncurry Cite) $ + peekPair (peekList peekCitation) peekInlines + "Code" -> mkBlock (uncurry Code) (peekPair peekAttr peekText) + "Emph" -> mkBlock Emph peekInlines + "Underline" -> mkBlock Underline peekInlines + "Image" -> mkBlock (\(attr, lst, tgt) -> Image attr lst tgt) + $ peekTriple peekAttr peekInlines + (peekPair peekText peekText) + "Link" -> mkBlock (\(attr, lst, tgt) -> Link attr lst tgt) $ + peekTriple peekAttr peekInlines (peekPair peekText peekText) "LineBreak" -> return LineBreak - "Note" -> Note <$!> elementContent - "Math" -> uncurry Math <$!> elementContent - "Quoted" -> uncurry Quoted <$!> elementContent - "RawInline" -> uncurry RawInline <$!> elementContent - "SmallCaps" -> SmallCaps <$!> elementContent + "Note" -> mkBlock Note peekBlocks + "Math" -> mkBlock (uncurry Math) (peekPair peekRead peekText) + "Quoted" -> mkBlock (uncurry Quoted) (peekPair peekRead peekInlines) + "RawInline" -> mkBlock (uncurry RawInline) (peekPair peekFormat peekText) + "SmallCaps" -> mkBlock SmallCaps peekInlines "SoftBreak" -> return SoftBreak "Space" -> return Space - "Span" -> withAttr Span <$!> elementContent - -- strict to Lua string is copied before gc - "Str" -> Str <$!> elementContent - "Strikeout" -> Strikeout <$!> elementContent - "Strong" -> Strong <$!> elementContent - "Subscript" -> Subscript <$!> elementContent - "Superscript"-> Superscript <$!> elementContent - _ -> Lua.throwMessage ("Unknown inline type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - -try :: Lua a -> Lua (Either PandocError a) -try = Catch.try - -withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b -withAttr f (attributes, x) = f (fromLuaAttr attributes) x - --- | Wrapper for Attr -newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } - -instance Pushable LuaAttr where - push (LuaAttr (id', classes, kv)) = - pushViaConstructor "Attr" id' classes kv - -instance Peekable LuaAttr where - peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx) - --- | Wrapper for ListAttributes -newtype LuaListAttributes = LuaListAttributes ListAttributes - -instance Pushable LuaListAttributes where - push (LuaListAttributes (start, style, delimiter)) = - pushViaConstructor "ListAttributes" start style delimiter - -instance Peekable LuaListAttributes where - peek = defineHowTo "get ListAttributes value" . - fmap LuaListAttributes . Lua.peek + "Span" -> mkBlock (uncurry Span) (peekPair peekAttr peekInlines) + "Str" -> mkBlock Str peekText + "Strikeout" -> mkBlock Strikeout peekInlines + "Strong" -> mkBlock Strong peekInlines + "Subscript" -> mkBlock Subscript peekInlines + "Superscript"-> mkBlock Superscript peekInlines + Name tag -> Lua.failPeek ("Unknown inline type: " <> tag) + +pushAttr :: forall e. LuaError e => Attr -> LuaE e () +pushAttr (id', classes, kv) = pushViaConstr' @e "Attr" + [ pushText id' + , pushList pushText classes + , pushList (pushPair pushText pushText) kv + ] + +peekAttr :: LuaError e => Peeker e Attr +peekAttr = retrieving "Attr" . peekTriple + peekText + (peekList peekText) + (peekList (peekPair peekText peekText)) + +pushListAttributes :: forall e. LuaError e => ListAttributes -> LuaE e () +pushListAttributes (start, style, delimiter) = + pushViaConstr' "ListAttributes" + [ push start, push style, push delimiter ] + +peekListAttributes :: LuaError e => Peeker e ListAttributes +peekListAttributes = retrieving "ListAttributes" . peekTriple + peekIntegral + peekRead + peekRead + +-- These instances exist only for testing. It's a hack to avoid making +-- the marshalling modules public. +instance Peekable Inline where + peek = forcePeek . peekInline + +instance Peekable Block where + peek = forcePeek . peekBlock + +instance Peekable Meta where + peek = forcePeek . peekMeta + +instance Peekable Pandoc where + peek = forcePeek . peekPandoc |