diff options
Diffstat (limited to 'src/Text/Pandoc/Lua/Marshaling')
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/AST.hs | 543 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/AnyValue.hs | 24 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/CommonState.hs | 122 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/Context.hs | 4 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/List.hs | 30 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/MediaBag.hs | 73 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/PandocError.hs | 62 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs | 106 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs | 37 | ||||
| -rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/Version.hs | 168 |
10 files changed, 521 insertions, 648 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 diff --git a/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs b/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs deleted file mode 100644 index 82e26b963..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs +++ /dev/null @@ -1,24 +0,0 @@ -{- | - Module : Text.Pandoc.Lua.Marshaling.AnyValue - Copyright : © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> - Stability : alpha - -Helper type to work with raw Lua stack indices instead of unmarshaled -values. - -TODO: Most of this module should be abstracted, factored out, and go -into HsLua. --} -module Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) where - -import Foreign.Lua (Peekable (peek), StackIndex) - --- | Dummy type to allow values of arbitrary Lua type. This just wraps --- stack indices, using it requires extra care. -newtype AnyValue = AnyValue StackIndex - -instance Peekable AnyValue where - peek = return . AnyValue diff --git a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs index 147197c5d..857551598 100644 --- a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs +++ b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua.Marshaling.CommonState @@ -11,92 +9,62 @@ Instances to marshal (push) and unmarshal (peek) the common state. -} -module Text.Pandoc.Lua.Marshaling.CommonState () where +module Text.Pandoc.Lua.Marshaling.CommonState + ( typeCommonState + , peekCommonState + , pushCommonState + ) where -import Foreign.Lua (Lua, Peekable, Pushable) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) +import HsLua.Core +import HsLua.Marshalling +import HsLua.Packaging import Text.Pandoc.Class (CommonState (..)) import Text.Pandoc.Logging (LogMessage, showLogMessage) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import Text.Pandoc.Lua.Marshaling.List (pushPandocList) -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +-- | Lua type used for the @CommonState@ object. +typeCommonState :: LuaError e => DocumentedType e CommonState +typeCommonState = deftype "pandoc CommonState" [] + [ readonly "input_files" "input files passed to pandoc" + (pushPandocList pushString, stInputFiles) --- | Name used by Lua for the @CommonState@ type. -commonStateTypeName :: String -commonStateTypeName = "Pandoc CommonState" + , readonly "output_file" "the file to which pandoc will write" + (maybe pushnil pushString, stOutputFile) -instance Peekable CommonState where - peek idx = reportValueOnFailure commonStateTypeName - (`toAnyWithName` commonStateTypeName) idx + , readonly "log" "list of log messages" + (pushPandocList (pushUD typeLogMessage), stLog) -instance Pushable CommonState where - push st = pushAnyWithMetatable pushCommonStateMetatable st - where - pushCommonStateMetatable = ensureUserdataMetatable commonStateTypeName $ do - LuaUtil.addFunction "__index" indexCommonState - LuaUtil.addFunction "__pairs" pairsCommonState + , readonly "request_headers" "headers to add for HTTP requests" + (pushPandocList (pushPair pushText pushText), stRequestHeaders) -indexCommonState :: CommonState -> AnyValue -> Lua Lua.NumResults -indexCommonState st (AnyValue idx) = Lua.ltype idx >>= \case - Lua.TypeString -> 1 <$ (Lua.peek idx >>= pushField) - _ -> 1 <$ Lua.pushnil - where - pushField :: Text.Text -> Lua () - pushField name = case lookup name commonStateFields of - Just pushValue -> pushValue st - Nothing -> Lua.pushnil + , readonly "resource_path" + "path to search for resources like included images" + (pushPandocList pushString, stResourcePath) -pairsCommonState :: CommonState -> Lua Lua.NumResults -pairsCommonState st = do - Lua.pushHaskellFunction nextFn - Lua.pushnil - Lua.pushnil - return 3 - where - nextFn :: AnyValue -> AnyValue -> Lua Lua.NumResults - nextFn _ (AnyValue idx) = - Lua.ltype idx >>= \case - Lua.TypeNil -> case commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (key, pushValue):_ -> 2 <$ (Lua.push key *> pushValue st) - Lua.TypeString -> do - key <- Lua.peek idx - case tail $ dropWhile ((/= key) . fst) commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (nextKey, pushValue):_ -> 2 <$ (Lua.push nextKey *> pushValue st) - _ -> 2 <$ (Lua.pushnil *> Lua.pushnil) + , readonly "source_url" "absolute URL + dir of 1st source file" + (maybe pushnil pushText, stSourceURL) -commonStateFields :: [(Text.Text, CommonState -> Lua ())] -commonStateFields = - [ ("input_files", Lua.push . stInputFiles) - , ("output_file", Lua.push . Lua.Optional . stOutputFile) - , ("log", Lua.push . stLog) - , ("request_headers", Lua.push . Map.fromList . stRequestHeaders) - , ("resource_path", Lua.push . stResourcePath) - , ("source_url", Lua.push . Lua.Optional . stSourceURL) - , ("user_data_dir", Lua.push . Lua.Optional . stUserDataDir) - , ("trace", Lua.push . stTrace) - , ("verbosity", Lua.push . show . stVerbosity) - ] + , readonly "user_data_dir" "directory to search for data files" + (maybe pushnil pushString, stUserDataDir) + + , readonly "trace" "controls whether tracing messages are issued" + (pushBool, stTrace) --- | Name used by Lua for the @CommonState@ type. -logMessageTypeName :: String -logMessageTypeName = "Pandoc LogMessage" + , readonly "verbosity" "verbosity level" + (pushString . show, stVerbosity) + ] -instance Peekable LogMessage where - peek idx = reportValueOnFailure logMessageTypeName - (`toAnyWithName` logMessageTypeName) idx +peekCommonState :: LuaError e => Peeker e CommonState +peekCommonState = peekUD typeCommonState -instance Pushable LogMessage where - push msg = pushAnyWithMetatable pushLogMessageMetatable msg - where - pushLogMessageMetatable = ensureUserdataMetatable logMessageTypeName $ - LuaUtil.addFunction "__tostring" tostringLogMessage +pushCommonState :: LuaError e => Pusher e CommonState +pushCommonState = pushUD typeCommonState -tostringLogMessage :: LogMessage -> Lua Text.Text -tostringLogMessage = return . showLogMessage +typeLogMessage :: LuaError e => DocumentedType e LogMessage +typeLogMessage = deftype "pandoc LogMessage" + [ operation Index $ defun "__tostring" + ### liftPure showLogMessage + <#> udparam typeLogMessage "msg" "object" + =#> functionResult pushText "string" "stringified log message" + ] + mempty -- no members diff --git a/src/Text/Pandoc/Lua/Marshaling/Context.hs b/src/Text/Pandoc/Lua/Marshaling/Context.hs index 606bdcfb2..8ee25565e 100644 --- a/src/Text/Pandoc/Lua/Marshaling/Context.hs +++ b/src/Text/Pandoc/Lua/Marshaling/Context.hs @@ -12,8 +12,8 @@ Marshaling instance for doctemplates Context and its components. -} module Text.Pandoc.Lua.Marshaling.Context () where -import qualified Foreign.Lua as Lua -import Foreign.Lua (Pushable) +import qualified HsLua as Lua +import HsLua (Pushable) import Text.DocTemplates (Context(..), Val(..), TemplateTarget) import Text.DocLayout (render) diff --git a/src/Text/Pandoc/Lua/Marshaling/List.hs b/src/Text/Pandoc/Lua/Marshaling/List.hs index 0446302a1..57ccd4501 100644 --- a/src/Text/Pandoc/Lua/Marshaling/List.hs +++ b/src/Text/Pandoc/Lua/Marshaling/List.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : Text.Pandoc.Lua.Marshaling.List Copyright : © 2012-2021 John MacFarlane @@ -14,27 +15,30 @@ Marshaling/unmarshaling instances for @pandoc.List@s. -} module Text.Pandoc.Lua.Marshaling.List ( List (..) + , peekList' + , pushPandocList ) where +import Control.Monad ((<$!>)) import Data.Data (Data) -import Foreign.Lua (Peekable, Pushable) +import HsLua (LuaError, Peeker, Pusher, Pushable (push), peekList, pushList) import Text.Pandoc.Walk (Walkable (..)) -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) - -import qualified Foreign.Lua as Lua +import Text.Pandoc.Lua.Util (pushViaConstr') -- | List wrapper which is marshalled as @pandoc.List@. newtype List a = List { fromList :: [a] } deriving (Data, Eq, Show) instance Pushable a => Pushable (List a) where - push (List xs) = - pushViaConstructor "List" xs + push (List xs) = pushPandocList push xs + +-- | Pushes a list as a numerical Lua table, setting a metatable that offers a +-- number of convenience functions. +pushPandocList :: LuaError e => Pusher e a -> Pusher e [a] +pushPandocList pushItem xs = pushViaConstr' "List" [pushList pushItem xs] -instance Peekable a => Peekable (List a) where - peek idx = defineHowTo "get List" $ do - xs <- Lua.peek idx - return $ List xs +peekList' :: LuaError e => Peeker e a -> Peeker e (List a) +peekList' p = (List <$!>) . peekList p -- List is just a wrapper, so we can reuse the walk instance for -- unwrapped Hasekll lists. diff --git a/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs b/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs deleted file mode 100644 index 70bd010a0..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- | - Module : Text.Pandoc.Lua.Marshaling.MediaBag - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> - Stability : alpha - -Instances to marshal (push) and unmarshal (peek) media data. --} -module Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator) where - -import Foreign.Ptr (Ptr) -import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr) -import Foreign.Lua (Lua, NumResults, Peekable, Pushable, StackIndex) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) -import Text.Pandoc.MediaBag (MediaBag, mediaItems) -import Text.Pandoc.MIME (MimeType) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) - -import qualified Data.ByteString.Lazy as BL -import qualified Foreign.Lua as Lua -import qualified Foreign.Storable as Storable - --- | A list of 'MediaBag' items. -newtype MediaItems = MediaItems [(String, MimeType, BL.ByteString)] - -instance Pushable MediaItems where - push = pushMediaItems - -instance Peekable MediaItems where - peek = peekMediaItems - --- | Push an iterator triple to be used with Lua's @for@ loop construct. --- Each iterator invocation returns a triple containing the item's --- filename, MIME type, and content. -pushIterator :: MediaBag -> Lua NumResults -pushIterator mb = do - Lua.pushHaskellFunction nextItem - Lua.push (MediaItems $ mediaItems mb) - Lua.pushnil - return 3 - --- | Lua type name for @'MediaItems'@. -mediaItemsTypeName :: String -mediaItemsTypeName = "pandoc MediaItems" - --- | Push a @MediaItems@ element to the stack. -pushMediaItems :: MediaItems -> Lua () -pushMediaItems xs = pushAnyWithMetatable pushMT xs - where - pushMT = ensureUserdataMetatable mediaItemsTypeName (return ()) - --- | Retrieve a @MediaItems@ element from the stack. -peekMediaItems :: StackIndex -> Lua MediaItems -peekMediaItems = reportValueOnFailure mediaItemsTypeName - (`toAnyWithName` mediaItemsTypeName) - --- | Retrieve a list of items from an iterator state, return the first --- item (if present), and advance the state. -nextItem :: Ptr (StablePtr MediaItems) -> AnyValue -> Lua NumResults -nextItem ptr _ = do - (MediaItems items) <- Lua.liftIO $ deRefStablePtr =<< Storable.peek ptr - case items of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (key, mt, content):xs -> do - Lua.liftIO $ Storable.poke ptr =<< newStablePtr (MediaItems xs) - Lua.push key - Lua.push mt - Lua.push content - return 3 diff --git a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs index f698704e0..6f29a5c89 100644 --- a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs +++ b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs @@ -1,7 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.PandocError Copyright : © 2020-2021 Albert Krewinkel @@ -15,51 +15,37 @@ Marshaling of @'PandocError'@ values. module Text.Pandoc.Lua.Marshaling.PandocError ( peekPandocError , pushPandocError + , typePandocError ) where -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import HsLua.Core (LuaError) +import HsLua.Marshalling (Peeker, Pusher, pushString, liftLua) +import HsLua.Packaging import Text.Pandoc.Error (PandocError (PandocLuaError)) -import qualified Foreign.Lua as Lua -import qualified Foreign.Lua.Userdata as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +import qualified HsLua as Lua import qualified Text.Pandoc.UTF8 as UTF8 --- | Userdata name used by Lua for the @PandocError@ type. -pandocErrorName :: String -pandocErrorName = "pandoc error" +-- | Lua userdata type definition for PandocError. +typePandocError :: LuaError e => DocumentedType e PandocError +typePandocError = deftype "PandocError" + [ operation Tostring $ defun "__tostring" + ### liftPure (show @PandocError) + <#> udparam typePandocError "obj" "PandocError object" + =#> functionResult pushString "string" "string representation of error." + ] + mempty -- no members -- | Peek a @'PandocError'@ element to the Lua stack. -pushPandocError :: PandocError -> Lua () -pushPandocError = Lua.pushAnyWithMetatable pushPandocErrorMT - where - pushPandocErrorMT = Lua.ensureUserdataMetatable pandocErrorName $ - LuaUtil.addFunction "__tostring" __tostring +pushPandocError :: LuaError e => Pusher e PandocError +pushPandocError = pushUD typePandocError -- | Retrieve a @'PandocError'@ from the Lua stack. -peekPandocError :: StackIndex -> Lua PandocError -peekPandocError idx = Lua.ltype idx >>= \case - Lua.TypeUserdata -> do - errMb <- Lua.toAnyWithName idx pandocErrorName - return $ case errMb of - Just err -> err - Nothing -> PandocLuaError "could not retrieve original error" - _ -> do - Lua.pushvalue idx - msg <- Lua.state >>= \l -> Lua.liftIO (Lua.errorMessage l) - return $ PandocLuaError (UTF8.toText msg) - --- | Convert to string. -__tostring :: PandocError -> Lua String -__tostring = return . show - --- --- Instances --- - -instance Pushable PandocError where - push = pushPandocError - -instance Peekable PandocError where - peek = peekPandocError +peekPandocError :: LuaError e => Peeker e PandocError +peekPandocError idx = Lua.retrieving "PandocError" $ + liftLua (Lua.ltype idx) >>= \case + Lua.TypeUserdata -> peekUD typePandocError idx + _ -> do + msg <- liftLua $ Lua.state >>= \l -> Lua.liftIO (Lua.popErrorMessage l) + return $ PandocLuaError (UTF8.toText msg) diff --git a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs index dd7bf2e61..2cc39ee3a 100644 --- a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs +++ b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,67 +12,60 @@ Marshaling instance for ReaderOptions and its components. -} -module Text.Pandoc.Lua.Marshaling.ReaderOptions () where +module Text.Pandoc.Lua.Marshaling.ReaderOptions + ( peekReaderOptions + , pushReaderOptions + ) where -import Data.Data (showConstr, toConstr) -import Foreign.Lua (Lua, Pushable) -import Text.Pandoc.Extensions (Extensions) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) -import Text.Pandoc.Lua.Marshaling.CommonState () -import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) - -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +import HsLua as Lua +import Text.Pandoc.Lua.Marshaling.List (pushPandocList) +import Text.Pandoc.Options (ReaderOptions (..)) -- -- Reader Options -- -instance Pushable Extensions where - push exts = Lua.push (show exts) -instance Pushable TrackChanges where - push = Lua.push . showConstr . toConstr +peekReaderOptions :: LuaError e => Peeker e ReaderOptions +peekReaderOptions = peekUD typeReaderOptions + +pushReaderOptions :: LuaError e => Pusher e ReaderOptions +pushReaderOptions = pushUD typeReaderOptions -instance Pushable ReaderOptions where - push ro = do - let ReaderOptions - (extensions :: Extensions) - (standalone :: Bool) - (columns :: Int) - (tabStop :: Int) - (indentedCodeClasses :: [Text.Text]) - (abbreviations :: Set.Set Text.Text) - (defaultImageExtension :: Text.Text) - (trackChanges :: TrackChanges) - (stripComments :: Bool) - = ro - Lua.newtable - LuaUtil.addField "extensions" extensions - LuaUtil.addField "standalone" standalone - LuaUtil.addField "columns" columns - LuaUtil.addField "tab_stop" tabStop - LuaUtil.addField "indented_code_classes" indentedCodeClasses - LuaUtil.addField "abbreviations" abbreviations - LuaUtil.addField "default_image_extension" defaultImageExtension - LuaUtil.addField "track_changes" trackChanges - LuaUtil.addField "strip_comments" stripComments +typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions +typeReaderOptions = deftype "pandoc ReaderOptions" + [ operation Tostring luaShow + ] + [ readonly "extensions" "" + ( pushString . show + , readerExtensions) + , readonly "standalone" "" + ( pushBool + , readerStandalone) + , readonly "columns" "" + ( pushIntegral + , readerColumns) + , readonly "tab_stop" "" + ( pushIntegral + , readerTabStop) + , readonly "indented_code_classes" "" + ( pushPandocList pushText + , readerIndentedCodeClasses) + , readonly "abbreviations" "" + ( pushSet pushText + , readerAbbreviations) + , readonly "track_changes" "" + ( pushString . show + , readerTrackChanges) + , readonly "strip_comments" "" + ( pushBool + , readerStripComments) + , readonly "default_image_extension" "" + ( pushText + , readerDefaultImageExtension) + ] - -- add metatable - let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults - indexReaderOptions _tbl (AnyValue key) = do - Lua.ltype key >>= \case - Lua.TypeString -> Lua.peek key >>= \case - ("defaultImageExtension" :: Text.Text) - -> Lua.push defaultImageExtension - "indentedCodeClasses" -> Lua.push indentedCodeClasses - "stripComments" -> Lua.push stripComments - "tabStop" -> Lua.push tabStop - "trackChanges" -> Lua.push trackChanges - _ -> Lua.pushnil - _ -> Lua.pushnil - return 1 - Lua.newtable - LuaUtil.addFunction "__index" indexReaderOptions - Lua.setmetatable (Lua.nthFromTop 2) +luaShow :: LuaError e => DocumentedFunction e +luaShow = defun "__tostring" + ### liftPure show + <#> udparam typeReaderOptions "state" "object to print in native format" + =#> functionResult pushString "string" "Haskell representation" diff --git a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs b/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs index 6d43039fa..e9c169dc0 100644 --- a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs +++ b/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.SimpleTable Copyright : © 2020-2021 Albert Krewinkel @@ -16,12 +19,11 @@ module Text.Pandoc.Lua.Marshaling.SimpleTable ) where -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import Control.Monad ((<$!>)) +import HsLua as Lua import Text.Pandoc.Definition -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor, rawField) -import Text.Pandoc.Lua.Marshaling.AST () - -import qualified Foreign.Lua as Lua +import Text.Pandoc.Lua.Util (pushViaConstructor) +import Text.Pandoc.Lua.Marshaling.AST -- | A simple (legacy-style) table. data SimpleTable = SimpleTable @@ -32,16 +34,10 @@ data SimpleTable = SimpleTable , simpleTableBody :: [[[Block]]] } -instance Pushable SimpleTable where - push = pushSimpleTable - -instance Peekable SimpleTable where - peek = peekSimpleTable - -- | Push a simple table to the stack by calling the -- @pandoc.SimpleTable@ constructor. -pushSimpleTable :: SimpleTable -> Lua () -pushSimpleTable tbl = pushViaConstructor "SimpleTable" +pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e () +pushSimpleTable tbl = pushViaConstructor @e "SimpleTable" (simpleTableCaption tbl) (simpleTableAlignments tbl) (simpleTableColumnWidths tbl) @@ -49,11 +45,10 @@ pushSimpleTable tbl = pushViaConstructor "SimpleTable" (simpleTableBody tbl) -- | Retrieve a simple table from the stack. -peekSimpleTable :: StackIndex -> Lua SimpleTable -peekSimpleTable idx = defineHowTo "get SimpleTable" $ - SimpleTable - <$> rawField idx "caption" - <*> rawField idx "aligns" - <*> rawField idx "widths" - <*> rawField idx "headers" - <*> rawField idx "rows" +peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable +peekSimpleTable idx = retrieving "SimpleTable" $ SimpleTable + <$!> peekFieldRaw peekInlines "caption" idx + <*> peekFieldRaw (peekList peekRead) "aligns" idx + <*> peekFieldRaw (peekList peekRealFloat) "widths" idx + <*> peekFieldRaw (peekList peekBlocks) "headers" idx + <*> peekFieldRaw (peekList (peekList peekBlocks)) "rows" idx diff --git a/src/Text/Pandoc/Lua/Marshaling/Version.hs b/src/Text/Pandoc/Lua/Marshaling/Version.hs index 4f4ffac51..2af36e5c8 100644 --- a/src/Text/Pandoc/Lua/Marshaling/Version.hs +++ b/src/Text/Pandoc/Lua/Marshaling/Version.hs @@ -16,133 +16,92 @@ default comparison operators (like @>@ and @<=@). module Text.Pandoc.Lua.Marshaling.Version ( peekVersion , pushVersion + , peekVersionFuzzy ) where -import Data.Text (Text) import Data.Maybe (fromMaybe) import Data.Version (Version (..), makeVersion, parseVersion, showVersion) -import Foreign.Lua (Lua, Optional (..), NumResults, - Peekable, Pushable, StackIndex) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) -import Safe (atMay, lastMay) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import HsLua as Lua +import Safe (lastMay) import Text.ParserCombinators.ReadP (readP_to_S) +import qualified Text.Pandoc.UTF8 as UTF8 -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil - --- | Push a @'Version'@ element to the Lua stack. -pushVersion :: Version -> Lua () -pushVersion version = pushAnyWithMetatable pushVersionMT version - where - pushVersionMT = ensureUserdataMetatable versionTypeName $ do - LuaUtil.addFunction "__eq" __eq - LuaUtil.addFunction "__le" __le - LuaUtil.addFunction "__lt" __lt - LuaUtil.addFunction "__len" __len - LuaUtil.addFunction "__index" __index - LuaUtil.addFunction "__pairs" __pairs - LuaUtil.addFunction "__tostring" __tostring +instance Peekable Version where + peek = forcePeek . peekVersionFuzzy instance Pushable Version where push = pushVersion -peekVersion :: StackIndex -> Lua Version -peekVersion idx = Lua.ltype idx >>= \case +-- | Push a @'Version'@ element to the Lua stack. +pushVersion :: LuaError e => Pusher e Version +pushVersion = pushUD typeVersion + +peekVersionFuzzy :: LuaError e => Peeker e Version +peekVersionFuzzy idx = retrieving "Version" $ liftLua (Lua.ltype idx) >>= \case + Lua.TypeUserdata -> peekVersion idx Lua.TypeString -> do - versionStr <- Lua.peek idx + versionStr <- peekString idx let parses = readP_to_S parseVersion versionStr case lastMay parses of Just (v, "") -> return v - _ -> Lua.throwMessage $ "could not parse as Version: " ++ versionStr + _ -> Lua.failPeek $ + UTF8.fromString $ "could not parse as Version: " ++ versionStr - Lua.TypeUserdata -> - reportValueOnFailure versionTypeName - (`toAnyWithName` versionTypeName) - idx Lua.TypeNumber -> do - n <- Lua.peek idx - return (makeVersion [n]) + (makeVersion . (:[])) <$> peekIntegral idx Lua.TypeTable -> - makeVersion <$> Lua.peek idx + makeVersion <$> peekList peekIntegral idx _ -> - Lua.throwMessage "could not peek Version" - -instance Peekable Version where - peek = peekVersion - --- | Name used by Lua for the @CommonState@ type. -versionTypeName :: String -versionTypeName = "HsLua Version" - -__eq :: Version -> Version -> Lua Bool -__eq v1 v2 = return (v1 == v2) - -__le :: Version -> Version -> Lua Bool -__le v1 v2 = return (v1 <= v2) - -__lt :: Version -> Version -> Lua Bool -__lt v1 v2 = return (v1 < v2) - --- | Get number of version components. -__len :: Version -> Lua Int -__len = return . length . versionBranch - --- | Access fields. -__index :: Version -> AnyValue -> Lua NumResults -__index v (AnyValue k) = do - ty <- Lua.ltype k - case ty of - Lua.TypeNumber -> do - n <- Lua.peek k - let versionPart = atMay (versionBranch v) (n - 1) - Lua.push (Lua.Optional versionPart) - return 1 - Lua.TypeString -> do - (str :: Text) <- Lua.peek k - if str == "must_be_at_least" - then 1 <$ Lua.pushHaskellFunction must_be_at_least - else 1 <$ Lua.pushnil - _ -> 1 <$ Lua.pushnil - --- | Create iterator. -__pairs :: Version -> Lua NumResults -__pairs v = do - Lua.pushHaskellFunction nextFn - Lua.pushnil - Lua.pushnil - return 3 - where - nextFn :: AnyValue -> Optional Int -> Lua Lua.NumResults - nextFn _ (Optional key) = - case key of - Nothing -> case versionBranch v of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - n:_ -> 2 <$ (Lua.push (1 :: Int) *> Lua.push n) - Just n -> case atMay (versionBranch v) n of - Nothing -> 2 <$ (Lua.pushnil *> Lua.pushnil) - Just b -> 2 <$ (Lua.push (n + 1) *> Lua.push b) - --- | Convert to string. -__tostring :: Version -> Lua String -__tostring v = return (showVersion v) - --- | Default error message when a version is too old. This message is --- formatted in Lua with the expected and actual versions as arguments. -versionTooOldMessage :: String -versionTooOldMessage = "expected version %s or newer, got %s" + Lua.failPeek "could not peek Version" + +peekVersion :: LuaError e => Peeker e Version +peekVersion = peekUD typeVersion + +typeVersion :: LuaError e => DocumentedType e Version +typeVersion = deftype "Version" + [ operation Eq $ defun "__eq" + ### liftPure2 (==) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 == v2" + , operation Lt $ defun "__lt" + ### liftPure2 (<) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 < v2" + , operation Le $ defun "__le" + ### liftPure2 (<=) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 <= v2" + , operation Len $ defun "__len" + ### liftPure (length . versionBranch) + <#> parameter peekVersionFuzzy "Version" "v1" "" + =#> functionResult pushIntegral "integer" "number of version components" + , operation Tostring $ defun "__tostring" + ### liftPure showVersion + <#> parameter peekVersionFuzzy "Version" "version" "" + =#> functionResult pushString "string" "stringified version" + ] + [ method $ defun "must_be_at_least" + ### must_be_at_least + <#> parameter peekVersionFuzzy "Version" "self" "version to check" + <#> parameter peekVersionFuzzy "Version" "reference" "minimum version" + <#> optionalParameter peekString "string" "msg" "alternative message" + =?> "Returns no result, and throws an error if this version is older than reference" + ] -- | Throw an error if this version is older than the given version. -- FIXME: This function currently requires the string library to be -- loaded. -must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults -must_be_at_least actual expected optMsg = do - let msg = fromMaybe versionTooOldMessage (fromOptional optMsg) +must_be_at_least :: LuaError e + => Version -> Version -> Maybe String + -> LuaE e NumResults +must_be_at_least actual expected mMsg = do + let msg = fromMaybe versionTooOldMessage mMsg if expected <= actual then return 0 else do @@ -152,3 +111,8 @@ must_be_at_least actual expected optMsg = do Lua.push (showVersion actual) Lua.call 3 1 Lua.error + +-- | Default error message when a version is too old. This message is +-- formatted in Lua with the expected and actual versions as arguments. +versionTooOldMessage :: String +versionTooOldMessage = "expected version %s or newer, got %s" |