From 3692a1d1e83703fbf235214f2838cd92683c625c Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Sun, 28 Nov 2021 02:08:01 +0100 Subject: Lua: use package pandoc-lua-marshal (#7719) The marshaling functions for pandoc's AST are extracted into a separate package. The package comes with a number of changes: - Pandoc's List module was rewritten in C, thereby improving error messages. - Lists of `Block` and `Inline` elements are marshaled using the new list types `Blocks` and `Inlines`, respectively. These types currently behave identical to the generic List type, but give better error messages. This also opens up the possibility of adding element-specific methods to these lists in the future. - Elements of type `MetaValue` are no longer pushed as values which have `.t` and `.tag` properties. This was already true for `MetaString` and `MetaBool` values, which are still marshaled as Lua strings and booleans, respectively. Affected values: + `MetaBlocks` values are marshaled as a `Blocks` list; + `MetaInlines` values are marshaled as a `Inlines` list; + `MetaList` values are marshaled as a generic pandoc `List`s. + `MetaMap` values are marshaled as plain tables and no longer given any metatable. - The test suite for marshaled objects and their constructors has been extended and improved. - A bug in Citation objects, where setting a citation's suffix modified it's prefix, has been fixed. --- src/Text/Pandoc/Lua.hs | 2 +- src/Text/Pandoc/Lua/ErrorConversion.hs | 2 +- src/Text/Pandoc/Lua/Filter.hs | 13 +- src/Text/Pandoc/Lua/Global.hs | 6 +- src/Text/Pandoc/Lua/Init.hs | 50 +- src/Text/Pandoc/Lua/Marshal/CommonState.hs | 70 ++ src/Text/Pandoc/Lua/Marshal/Context.hs | 28 + src/Text/Pandoc/Lua/Marshal/PandocError.hs | 51 ++ src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs | 133 ++++ src/Text/Pandoc/Lua/Marshaling.hs | 19 - src/Text/Pandoc/Lua/Marshaling/AST.hs | 868 ----------------------- src/Text/Pandoc/Lua/Marshaling/Attr.hs | 237 ------- src/Text/Pandoc/Lua/Marshaling/CommonState.hs | 70 -- src/Text/Pandoc/Lua/Marshaling/Context.hs | 28 - src/Text/Pandoc/Lua/Marshaling/List.hs | 48 -- src/Text/Pandoc/Lua/Marshaling/ListAttributes.hs | 72 -- src/Text/Pandoc/Lua/Marshaling/PandocError.hs | 51 -- src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs | 133 ---- src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs | 92 --- src/Text/Pandoc/Lua/Module/MediaBag.hs | 4 +- src/Text/Pandoc/Lua/Module/Pandoc.hs | 261 +------ src/Text/Pandoc/Lua/Module/Types.hs | 30 +- src/Text/Pandoc/Lua/Module/Utils.hs | 9 +- src/Text/Pandoc/Lua/Orphans.hs | 111 +++ src/Text/Pandoc/Lua/Packages.hs | 7 +- src/Text/Pandoc/Lua/PandocLua.hs | 25 +- src/Text/Pandoc/Lua/Util.hs | 31 +- src/Text/Pandoc/Lua/Walk.hs | 31 +- 28 files changed, 480 insertions(+), 2002 deletions(-) create mode 100644 src/Text/Pandoc/Lua/Marshal/CommonState.hs create mode 100644 src/Text/Pandoc/Lua/Marshal/Context.hs create mode 100644 src/Text/Pandoc/Lua/Marshal/PandocError.hs create mode 100644 src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/AST.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/Attr.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/CommonState.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/Context.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/List.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/ListAttributes.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/PandocError.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs delete mode 100644 src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs create mode 100644 src/Text/Pandoc/Lua/Orphans.hs (limited to 'src') diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index f0e9e076b..2aa84b7fa 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -20,4 +20,4 @@ module Text.Pandoc.Lua import Text.Pandoc.Lua.Filter (runFilterFile) import Text.Pandoc.Lua.Global (Global (..), setGlobals) import Text.Pandoc.Lua.Init (runLua) -import Text.Pandoc.Lua.Marshaling () +import Text.Pandoc.Lua.Orphans () diff --git a/src/Text/Pandoc/Lua/ErrorConversion.hs b/src/Text/Pandoc/Lua/ErrorConversion.hs index 9c4c990a3..5cb1bf825 100644 --- a/src/Text/Pandoc/Lua/ErrorConversion.hs +++ b/src/Text/Pandoc/Lua/ErrorConversion.hs @@ -19,7 +19,7 @@ import HsLua (LuaError, LuaE, top) import HsLua.Marshalling (resultToEither, runPeek) import HsLua.Class.Peekable (PeekError (..)) import Text.Pandoc.Error (PandocError (PandocLuaError)) -import Text.Pandoc.Lua.Marshaling.PandocError (pushPandocError, peekPandocError) +import Text.Pandoc.Lua.Marshal.PandocError (pushPandocError, peekPandocError) import qualified Data.Text as T import qualified HsLua as Lua diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index 9fd0ef32c..ba5a14a0d 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -33,10 +33,9 @@ import Data.String (IsString (fromString)) import HsLua as Lua import Text.Pandoc.Definition import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Marshaling.AST -import Text.Pandoc.Lua.Marshaling.List (List (..), peekList') -import Text.Pandoc.Lua.Walk (SingletonsList (..)) +import Text.Pandoc.Lua.Marshal.AST +import Text.Pandoc.Lua.Orphans () +import Text.Pandoc.Lua.Walk (List (..), SingletonsList (..)) import Text.Pandoc.Walk (Walkable (walkM)) import qualified Data.Map.Strict as Map @@ -196,7 +195,8 @@ walkInlineLists :: Walkable (List Inline) a => LuaFilter -> a -> LuaE PandocError a walkInlineLists lf = let f :: List Inline -> LuaE PandocError (List Inline) - f = runOnValue listOfInlinesFilterName (peekList' peekInline) lf + f = runOnValue listOfInlinesFilterName peekListOfInlines lf + peekListOfInlines idx = List <$!> (peekInlinesFuzzy idx) in if lf `contains` listOfInlinesFilterName then walkM f else return @@ -214,7 +214,8 @@ walkBlockLists :: Walkable (List Block) a => LuaFilter -> a -> LuaE PandocError a walkBlockLists lf = let f :: List Block -> LuaE PandocError (List Block) - f = runOnValue listOfBlocksFilterName (peekList' peekBlock) lf + f = runOnValue listOfBlocksFilterName peekListOfBlocks lf + peekListOfBlocks idx = List <$!> (peekBlocksFuzzy idx) in if lf `contains` listOfBlocksFilterName then walkM f else return diff --git a/src/Text/Pandoc/Lua/Global.hs b/src/Text/Pandoc/Lua/Global.hs index 05510f45d..c7b50a25f 100644 --- a/src/Text/Pandoc/Lua/Global.hs +++ b/src/Text/Pandoc/Lua/Global.hs @@ -20,9 +20,9 @@ import Paths_pandoc (version) import Text.Pandoc.Class.CommonState (CommonState) import Text.Pandoc.Definition (Pandoc (Pandoc), pandocTypesVersion) import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Marshaling.CommonState (pushCommonState) -import Text.Pandoc.Lua.Marshaling.ReaderOptions (pushReaderOptionsReadonly) +import Text.Pandoc.Lua.Marshal.CommonState (pushCommonState) +import Text.Pandoc.Lua.Marshal.ReaderOptions (pushReaderOptionsReadonly) +import Text.Pandoc.Lua.Orphans () import Text.Pandoc.Options (ReaderOptions) import qualified Data.Text as Text diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs index 2f113bff2..835da1fc9 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -17,7 +17,6 @@ module Text.Pandoc.Lua.Init import Control.Monad (forM, forM_, when) import Control.Monad.Catch (throwM, try) import Control.Monad.Trans (MonadIO (..)) -import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) import Data.Maybe (catMaybes) import HsLua as Lua hiding (status, try) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) @@ -27,7 +26,6 @@ import Text.Pandoc.Lua.Packages (installPandocPackageSearcher) import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua) import qualified Data.Text as T import qualified Lua.LPeg as LPeg -import qualified Text.Pandoc.Definition as Pandoc import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc -- | Run the lua interpreter, using pandoc's default way of environment @@ -42,6 +40,19 @@ runLua luaOp = do liftIO $ setForeignEncoding enc return res +-- | Modules that are loaded at startup and assigned to fields in the +-- pandoc module. +loadedModules :: [(Name, Name)] +loadedModules = + [ ("pandoc.List", "List") + , ("pandoc.mediabag", "mediabag") + , ("pandoc.path", "path") + , ("pandoc.system", "system") + , ("pandoc.types", "types") + , ("pandoc.utils", "utils") + , ("text", "text") + ] + -- | Initialize the lua state with all required values initLuaState :: PandocLua () initLuaState = do @@ -61,9 +72,13 @@ initLuaState = do Lua.getfield Lua.registryindex Lua.loaded Lua.pushvalue (Lua.nth 2) Lua.setfield (Lua.nth 2) "pandoc" - Lua.pop 1 - -- copy constructors into registry - putConstructorsInRegistry + Lua.pop 1 -- remove LOADED table + -- load modules and add them to the `pandoc` module table. + liftPandocLua $ forM_ loadedModules $ \(pkgname, fieldname) -> do + Lua.getglobal "require" + Lua.pushName pkgname + Lua.call 1 1 + Lua.setfield (nth 2) fieldname -- assign module to global variable liftPandocLua $ Lua.setglobal "pandoc" @@ -122,28 +137,3 @@ initLuaState = do Lua.pushHaskellFunction $ Lua.state >>= liftIO . LPeg.lpeg_searcher Lua.rawseti (Lua.nth 2) . (+1) . fromIntegral =<< Lua.rawlen (Lua.nth 2) Lua.pop 1 -- remove 'package.searchers' from stack - --- | AST elements are marshaled via normal constructor functions in the --- @pandoc@ module. However, accessing Lua globals from Haskell is --- expensive (due to error handling). Accessing the Lua registry is much --- cheaper, which is why the constructor functions are copied into the --- Lua registry and called from there. --- --- This function expects the @pandoc@ module to be at the top of the --- stack. -putConstructorsInRegistry :: PandocLua () -putConstructorsInRegistry = liftPandocLua $ do - constrsToReg $ Pandoc.Meta mempty - constrsToReg $ Pandoc.MetaList mempty - putInReg "List" -- pandoc.List - putInReg "SimpleTable" -- helper for backward-compatible table handling - where - constrsToReg :: Data a => a -> LuaE PandocError () - constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf - - putInReg :: String -> LuaE PandocError () - putInReg name = do - Lua.push ("pandoc." ++ name) -- name in registry - Lua.push name -- in pandoc module - Lua.rawget (Lua.nth 3) - Lua.rawset Lua.registryindex diff --git a/src/Text/Pandoc/Lua/Marshal/CommonState.hs b/src/Text/Pandoc/Lua/Marshal/CommonState.hs new file mode 100644 index 000000000..a8c0e28d2 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/CommonState.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Lua.Marshal.CommonState + Copyright : © 2012-2021 John MacFarlane + © 2017-2021 Albert Krewinkel + License : GNU GPL, version 2 or above + Maintainer : Albert Krewinkel + Stability : alpha + +Instances to marshal (push) and unmarshal (peek) the common state. +-} +module Text.Pandoc.Lua.Marshal.CommonState + ( typeCommonState + , peekCommonState + , pushCommonState + ) where + +import HsLua.Core +import HsLua.Marshalling +import HsLua.Packaging +import Text.Pandoc.Class (CommonState (..)) +import Text.Pandoc.Logging (LogMessage, showLogMessage) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) + +-- | 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) + + , readonly "output_file" "the file to which pandoc will write" + (maybe pushnil pushString, stOutputFile) + + , readonly "log" "list of log messages" + (pushPandocList (pushUD typeLogMessage), stLog) + + , readonly "request_headers" "headers to add for HTTP requests" + (pushPandocList (pushPair pushText pushText), stRequestHeaders) + + , readonly "resource_path" + "path to search for resources like included images" + (pushPandocList pushString, stResourcePath) + + , readonly "source_url" "absolute URL + dir of 1st source file" + (maybe pushnil pushText, stSourceURL) + + , readonly "user_data_dir" "directory to search for data files" + (maybe pushnil pushString, stUserDataDir) + + , readonly "trace" "controls whether tracing messages are issued" + (pushBool, stTrace) + + , readonly "verbosity" "verbosity level" + (pushString . show, stVerbosity) + ] + +peekCommonState :: LuaError e => Peeker e CommonState +peekCommonState = peekUD typeCommonState + +pushCommonState :: LuaError e => Pusher e CommonState +pushCommonState = pushUD typeCommonState + +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/Marshal/Context.hs b/src/Text/Pandoc/Lua/Marshal/Context.hs new file mode 100644 index 000000000..17af936e1 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/Context.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.Context + Copyright : © 2012-2021 John MacFarlane + © 2017-2021 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Marshaling instance for doctemplates Context and its components. +-} +module Text.Pandoc.Lua.Marshal.Context () where + +import qualified HsLua as Lua +import HsLua (Pushable) +import Text.DocTemplates (Context(..), Val(..), TemplateTarget) +import Text.DocLayout (render) + +instance (TemplateTarget a, Pushable a) => Pushable (Context a) where + push (Context m) = Lua.push m + +instance (TemplateTarget a, Pushable a) => Pushable (Val a) where + push NullVal = Lua.push () + push (BoolVal b) = Lua.push b + push (MapVal ctx) = Lua.push ctx + push (ListVal xs) = Lua.push xs + push (SimpleVal d) = Lua.push $ render Nothing d diff --git a/src/Text/Pandoc/Lua/Marshal/PandocError.hs b/src/Text/Pandoc/Lua/Marshal/PandocError.hs new file mode 100644 index 000000000..d1c0ad4f4 --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/PandocError.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{- | + Module : Text.Pandoc.Lua.Marshal.PandocError + Copyright : © 2020-2021 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Marshal of @'PandocError'@ values. +-} +module Text.Pandoc.Lua.Marshal.PandocError + ( peekPandocError + , pushPandocError + , typePandocError + ) + where + +import HsLua.Core (LuaError) +import HsLua.Marshalling (Peeker, Pusher, pushString, liftLua) +import HsLua.Packaging +import Text.Pandoc.Error (PandocError (PandocLuaError)) + +import qualified HsLua as Lua +import qualified Text.Pandoc.UTF8 as UTF8 + +-- | 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 :: LuaError e => Pusher e PandocError +pushPandocError = pushUD typePandocError + +-- | Retrieve a @'PandocError'@ from the Lua stack. +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/Marshal/ReaderOptions.hs b/src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs new file mode 100644 index 000000000..c20770dba --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.ReaderOptions + Copyright : © 2012-2021 John MacFarlane + © 2017-2021 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Marshaling instance for ReaderOptions and its components. +-} +module Text.Pandoc.Lua.Marshal.ReaderOptions + ( peekReaderOptions + , pushReaderOptions + , pushReaderOptionsReadonly + ) where + +import Data.Default (def) +import HsLua as Lua +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Options (ReaderOptions (..)) + +-- +-- Reader Options +-- + +-- | Retrieve a ReaderOptions value, either from a normal ReaderOptions +-- value, from a read-only object, or from a table with the same +-- keys as a ReaderOptions object. +peekReaderOptions :: LuaError e => Peeker e ReaderOptions +peekReaderOptions = retrieving "ReaderOptions" . \idx -> + liftLua (ltype idx) >>= \case + TypeUserdata -> choice [ peekUD typeReaderOptions + , peekUD typeReaderOptionsReadonly + ] + idx + TypeTable -> peekReaderOptionsTable idx + _ -> failPeek =<< + typeMismatchMessage "ReaderOptions userdata or table" idx + +-- | Pushes a ReaderOptions value as userdata object. +pushReaderOptions :: LuaError e => Pusher e ReaderOptions +pushReaderOptions = pushUD typeReaderOptions + +-- | Pushes a ReaderOptions object, but makes it read-only. +pushReaderOptionsReadonly :: LuaError e => Pusher e ReaderOptions +pushReaderOptionsReadonly = pushUD typeReaderOptionsReadonly + +-- | ReaderOptions object type for read-only values. +typeReaderOptionsReadonly :: LuaError e => DocumentedType e ReaderOptions +typeReaderOptionsReadonly = deftype "ReaderOptions (read-only)" + [ operation Tostring $ lambda + ### liftPure show + <#> udparam typeReaderOptions "opts" "options to print in native format" + =#> functionResult pushString "string" "Haskell representation" + , operation Newindex $ lambda + ### (failLua "This ReaderOptions value is read-only.") + =?> "Throws an error when called, i.e., an assignment is made." + ] + readerOptionsMembers + +-- | 'ReaderOptions' object type. +typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions +typeReaderOptions = deftype "ReaderOptions" + [ operation Tostring $ lambda + ### liftPure show + <#> udparam typeReaderOptions "opts" "options to print in native format" + =#> functionResult pushString "string" "Haskell representation" + ] + readerOptionsMembers + +-- | Member properties of 'ReaderOptions' Lua values. +readerOptionsMembers :: LuaError e + => [Member e (DocumentedFunction e) ReaderOptions] +readerOptionsMembers = + [ property "abbreviations" "" + (pushSet pushText, readerAbbreviations) + (peekSet peekText, \opts x -> opts{ readerAbbreviations = x }) + , property "columns" "" + (pushIntegral, readerColumns) + (peekIntegral, \opts x -> opts{ readerColumns = x }) + , property "default_image_extension" "" + (pushText, readerDefaultImageExtension) + (peekText, \opts x -> opts{ readerDefaultImageExtension = x }) + , property "extensions" "" + (pushString . show, readerExtensions) + (peekRead, \opts x -> opts{ readerExtensions = x }) + , property "indented_code_classes" "" + (pushPandocList pushText, readerIndentedCodeClasses) + (peekList peekText, \opts x -> opts{ readerIndentedCodeClasses = x }) + , property "strip_comments" "" + (pushBool, readerStripComments) + (peekBool, \opts x -> opts{ readerStripComments = x }) + , property "standalone" "" + (pushBool, readerStandalone) + (peekBool, \opts x -> opts{ readerStandalone = x }) + , property "tab_stop" "" + (pushIntegral, readerTabStop) + (peekIntegral, \opts x -> opts{ readerTabStop = x }) + , property "track_changes" "" + (pushString . show, readerTrackChanges) + (peekRead, \opts x -> opts{ readerTrackChanges = x }) + ] + +-- | Retrieves a 'ReaderOptions' object from a table on the stack, using +-- the default values for all missing fields. +-- +-- Internally, this pushes the default reader options, sets each +-- key/value pair of the table in the userdata value, then retrieves the +-- object again. This will update all fields and complain about unknown +-- keys. +peekReaderOptionsTable :: LuaError e => Peeker e ReaderOptions +peekReaderOptionsTable idx = retrieving "ReaderOptions (table)" $ do + liftLua $ do + absidx <- absindex idx + pushUD typeReaderOptions def + let setFields = do + next absidx >>= \case + False -> return () -- all fields were copied + True -> do + pushvalue (nth 2) *> insert (nth 2) + settable (nth 4) -- set in userdata object + setFields + pushnil -- first key + setFields + peekUD typeReaderOptions top + +instance Pushable ReaderOptions where + push = pushReaderOptions diff --git a/src/Text/Pandoc/Lua/Marshaling.hs b/src/Text/Pandoc/Lua/Marshaling.hs deleted file mode 100644 index e217b8852..000000000 --- a/src/Text/Pandoc/Lua/Marshaling.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- | - Module : Text.Pandoc.Lua.Marshaling - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Lua marshaling (pushing) and unmarshaling (peeking) instances. --} -module Text.Pandoc.Lua.Marshaling () where - -import Text.Pandoc.Lua.Marshaling.AST () -import Text.Pandoc.Lua.Marshaling.CommonState () -import Text.Pandoc.Lua.Marshaling.Context () -import Text.Pandoc.Lua.Marshaling.PandocError() -import Text.Pandoc.Lua.Marshaling.ReaderOptions () -import Text.Pandoc.Lua.ErrorConversion () diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs deleted file mode 100644 index 6a0e5d077..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/AST.hs +++ /dev/null @@ -1,868 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.AST - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -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 - , peekMeta - , peekMetaValue - , peekPandoc - , peekMathType - , peekQuoteType - , peekTableBody - , peekTableHead - , peekTableFoot - - , pushAttr - , pushBlock - , pushCitation - , pushInline - , pushInlines - , pushListAttributes - , pushMeta - , pushMetaValue - , pushPandoc - ) where - -import Control.Applicative ((<|>), optional) -import Control.Monad.Catch (throwM) -import Control.Monad ((<$!>)) -import Data.Data (showConstr, toConstr) -import Data.Text (Text) -import Data.Version (Version) -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') -import Text.Pandoc.Lua.Marshaling.Attr (peekAttr, pushAttr) -import Text.Pandoc.Lua.Marshaling.List (pushPandocList) -import Text.Pandoc.Lua.Marshaling.ListAttributes - (peekListAttributes, pushListAttributes) - -import qualified HsLua as Lua -import qualified Text.Pandoc.Builder as B -import qualified Text.Pandoc.Lua.Util as LuaUtil - -instance Pushable Pandoc where - push = pushPandoc - -pushPandoc :: LuaError e => Pusher e Pandoc -pushPandoc = pushUD typePandoc - -peekPandoc :: LuaError e => Peeker e Pandoc -peekPandoc = retrieving "Pandoc value" . peekUD typePandoc - -typePandoc :: LuaError e => DocumentedType e Pandoc -typePandoc = deftype "Pandoc" - [ operation Eq $ defun "__eq" - ### liftPure2 (==) - <#> parameter (optional . peekPandoc) "doc1" "pandoc" "" - <#> parameter (optional . peekPandoc) "doc2" "pandoc" "" - =#> functionResult pushBool "boolean" "true iff the two values are equal" - , operation Tostring $ lambda - ### liftPure show - <#> parameter peekPandoc "Pandoc" "doc" "" - =#> functionResult pushString "string" "native Haskell representation" - ] - [ property "blocks" "list of blocks" - (pushPandocList pushBlock, \(Pandoc _ blks) -> blks) - (peekList peekBlock, \(Pandoc m _) blks -> Pandoc m blks) - , property "meta" "document metadata" - (pushMeta, \(Pandoc meta _) -> meta) - (peekMeta, \(Pandoc _ blks) meta -> Pandoc meta blks) - ] - -instance Pushable Meta where - push = pushMeta - -pushMeta :: LuaError e => Pusher e Meta -pushMeta (Meta mmap) = 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 Pushable Block where - push = pushBlock - -typeCitation :: LuaError e => DocumentedType e Citation -typeCitation = deftype "Citation" - [ operation Eq $ lambda - ### liftPure2 (==) - <#> parameter (optional . peekCitation) "Citation" "a" "" - <#> parameter (optional . peekCitation) "Citation" "b" "" - =#> functionResult pushBool "boolean" "true iff the citations are equal" - - , operation Tostring $ lambda - ### liftPure show - <#> parameter peekCitation "Citation" "citation" "" - =#> functionResult pushString "string" "native Haskell representation" - ] - [ property "id" "citation ID / key" - (pushText, citationId) - (peekText, \citation cid -> citation{ citationId = cid }) - , property "mode" "citation mode" - (pushString . show, citationMode) - (peekRead, \citation mode -> citation{ citationMode = mode }) - , property "prefix" "citation prefix" - (pushInlines, citationPrefix) - (peekInlines, \citation prefix -> citation{ citationPrefix = prefix }) - , property "suffix" "citation suffix" - (pushInlines, citationSuffix) - (peekInlines, \citation suffix -> citation{ citationPrefix = suffix }) - , property "note_num" "note number" - (pushIntegral, citationNoteNum) - (peekIntegral, \citation noteNum -> citation{ citationNoteNum = noteNum }) - , property "hash" "hash number" - (pushIntegral, citationHash) - (peekIntegral, \citation hash -> citation{ citationHash = hash }) - , method $ defun "clone" ### return <#> udparam typeCitation "obj" "" - =#> functionResult pushCitation "Citation" "copy of obj" - ] - -pushCitation :: LuaError e => Pusher e Citation -pushCitation = pushUD typeCitation - -peekCitation :: LuaError e => Peeker e Citation -peekCitation = peekUD typeCitation - -instance Pushable Alignment where - push = Lua.pushString . show - -instance Pushable CitationMode where - push = Lua.push . show - -instance Pushable Format where - push = pushFormat - -pushFormat :: LuaError e => Pusher e Format -pushFormat (Format f) = pushText f - -peekFormat :: LuaError e => Peeker e Format -peekFormat idx = Format <$!> peekText idx - -instance Pushable ListNumberDelim where - push = Lua.push . show - -instance Pushable ListNumberStyle where - push = Lua.push . show - -instance Pushable MathType where - push = Lua.push . show - -instance Pushable QuoteType where - push = pushQuoteType - -pushMathType :: LuaError e => Pusher e MathType -pushMathType = pushString . show - -peekMathType :: LuaError e => Peeker e MathType -peekMathType = peekRead - -pushQuoteType :: LuaError e => Pusher e QuoteType -pushQuoteType = pushString . show - -peekQuoteType :: LuaError e => Peeker e QuoteType -peekQuoteType = peekRead - --- | Push an meta value element to the top of the lua stack. -pushMetaValue :: LuaError e => MetaValue -> LuaE e () -pushMetaValue = \case - MetaBlocks blcks -> pushViaConstr' "MetaBlocks" [pushList pushBlock blcks] - MetaBool bool -> Lua.push bool - 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 :: forall e. LuaError e => Peeker e MetaValue -peekMetaValue = retrieving "MetaValue $ " . \idx -> do - -- Get the contents of an AST element. - 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 <$!> peekBool idx - Lua.TypeString -> MetaString <$!> peekText idx - Lua.TypeTable -> do - optional (LuaUtil.getTag idx) >>= \case - Just tag -> peekTagged tag - Nothing -> peekUntagged - Lua.TypeUserdata -> -- Allow singleton Inline or Block elements - (MetaInlines . (:[]) <$!> peekInline idx) <|> - (MetaBlocks . (:[]) <$!> peekBlock idx) - _ -> 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 - Header _ _ 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 - Header attr lvl _ -> Actual . Header attr lvl . 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 = pushUD typeBlock - --- | Return the value at the given index as block if possible. -peekBlock :: forall e. LuaError e => Peeker e Block -peekBlock = retrieving "Block" . peekUD typeBlock - --- | Retrieves a list of Block elements. -peekBlocks :: LuaError e => Peeker e [Block] -peekBlocks = peekList peekBlock - -peekInlines :: LuaError e => Peeker e [Inline] -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 - Lua.newtable - LuaUtil.addField "short" (Lua.Optional shortCaption) - LuaUtil.addField "long" longCaption - --- | Peek Caption element -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 - --- | 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 - -peekColWidth :: LuaError e => Peeker e ColWidth -peekColWidth = retrieving "ColWidth" . \idx -> do - maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx) - --- | 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 - --- | 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) - --- | 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 - $ \idx -> TableBody - <$!> peekFieldRaw peekAttr "attr" idx - <*> peekFieldRaw ((fmap RowHeadColumns) . peekIntegral) "row_head_columns" idx - <*> peekFieldRaw (peekList peekRow) "head" idx - <*> peekFieldRaw (peekList peekRow) "body" idx - --- | 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) - --- | 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" - . peekPair peekAttr (peekList peekRow) - -instance Pushable Cell where - push = pushCell - -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 - LuaUtil.addField "attr" attr - LuaUtil.addField "alignment" align - LuaUtil.addField "row_span" rowSpan - LuaUtil.addField "col_span" colSpan - LuaUtil.addField "contents" 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 - -getInlineText :: Inline -> Possible Text -getInlineText = \case - Code _ lst -> Actual lst - Math _ str -> Actual str - RawInline _ raw -> Actual raw - Str s -> Actual s - _ -> Absent - -setInlineText :: Inline -> Text -> Possible Inline -setInlineText = \case - Code attr _ -> Actual . Code attr - Math mt _ -> Actual . Math mt - RawInline f _ -> Actual . RawInline f - 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 - -- inline content - Cite cs _ -> Actual . Cite cs . inlineContent - Emph _ -> Actual . Emph . inlineContent - Link a _ tgt -> Actual . (\inlns -> Link a inlns tgt) . inlineContent - Quoted qt _ -> Actual . Quoted qt . inlineContent - SmallCaps _ -> Actual . SmallCaps . inlineContent - Span attr _ -> Actual . Span attr . inlineContent - Strikeout _ -> Actual . Strikeout . inlineContent - Strong _ -> Actual . Strong . inlineContent - Subscript _ -> Actual . Subscript . inlineContent - Superscript _ -> Actual . Superscript . inlineContent - Underline _ -> Actual . Underline . inlineContent - -- block content - Note _ -> Actual . Note . blockContent - _ -> const Absent - where - inlineContent = \case - ContentInlines inlns -> inlns - c -> throwM . PandocLuaError $ "expected Inlines, got " <> - contentTypeDescription c - blockContent = \case - ContentBlocks blks -> blks - ContentInlines [] -> [] - c -> throwM . PandocLuaError $ "expected Blocks, got " <> - contentTypeDescription c - -getInlineContent :: Inline -> Possible Content -getInlineContent = \case - Cite _ inlns -> Actual $ ContentInlines inlns - Emph inlns -> Actual $ ContentInlines inlns - Link _ inlns _ -> Actual $ ContentInlines inlns - Quoted _ inlns -> Actual $ ContentInlines inlns - SmallCaps inlns -> Actual $ ContentInlines inlns - Span _ inlns -> Actual $ ContentInlines inlns - Strikeout inlns -> Actual $ ContentInlines inlns - Strong inlns -> Actual $ ContentInlines inlns - Subscript inlns -> Actual $ ContentInlines inlns - Superscript inlns -> Actual $ ContentInlines inlns - Underline inlns -> Actual $ ContentInlines inlns - Note blks -> Actual $ ContentBlocks blks - _ -> Absent - --- title -getInlineTitle :: Inline -> Possible Text -getInlineTitle = \case - Image _ _ (_, tit) -> Actual tit - Link _ _ (_, tit) -> Actual tit - _ -> Absent - -setInlineTitle :: Inline -> Text -> Possible Inline -setInlineTitle = \case - Image attr capt (src, _) -> Actual . Image attr capt . (src,) - Link attr capt (src, _) -> Actual . Link attr capt . (src,) - _ -> const Absent - --- attr -getInlineAttr :: Inline -> Possible Attr -getInlineAttr = \case - Code attr _ -> Actual attr - Image attr _ _ -> Actual attr - Link attr _ _ -> Actual attr - Span attr _ -> Actual attr - _ -> Absent - -setInlineAttr :: Inline -> Attr -> Possible Inline -setInlineAttr = \case - Code _ cs -> Actual . (`Code` cs) - Image _ cpt tgt -> Actual . \attr -> Image attr cpt tgt - Link _ cpt tgt -> Actual . \attr -> Link attr cpt tgt - Span _ inlns -> Actual . (`Span` inlns) - _ -> const Absent - -showInline :: LuaError e => DocumentedFunction e -showInline = defun "show" - ### liftPure (show @Inline) - <#> parameter peekInline "inline" "Inline" "Object" - =#> functionResult pushString "string" "stringified Inline" - -typeInline :: LuaError e => DocumentedType e Inline -typeInline = deftype "Inline" - [ operation Tostring showInline - , operation Eq $ defun "__eq" - ### liftPure2 (==) - <#> parameter peekInline "a" "Inline" "" - <#> parameter peekInline "b" "Inline" "" - =#> functionResult pushBool "boolean" "whether the two are equal" - ] - [ possibleProperty "attr" "element attributes" - (pushAttr, getInlineAttr) - (peekAttr, setInlineAttr) - , possibleProperty "caption" "image caption" - (pushPandocList pushInline, \case - Image _ capt _ -> Actual capt - _ -> Absent) - (peekInlinesFuzzy, \case - Image attr _ target -> Actual . (\capt -> Image attr capt target) - _ -> const Absent) - , possibleProperty "citations" "list of citations" - (pushPandocList pushCitation, \case {Cite cs _ -> Actual cs; _ -> Absent}) - (peekList peekCitation, \case - Cite _ inlns -> Actual . (`Cite` inlns) - _ -> const Absent) - , possibleProperty "content" "element contents" - (pushContent, getInlineContent) - (peekContent, setInlineContent) - , possibleProperty "format" "format of raw text" - (pushFormat, \case {RawInline fmt _ -> Actual fmt; _ -> Absent}) - (peekFormat, \case - RawInline _ txt -> Actual . (`RawInline` txt) - _ -> const Absent) - , possibleProperty "mathtype" "math rendering method" - (pushMathType, \case {Math mt _ -> Actual mt; _ -> Absent}) - (peekMathType, \case - Math _ txt -> Actual . (`Math` txt) - _ -> const Absent) - , possibleProperty "quotetype" "type of quotes (single or double)" - (pushQuoteType, \case {Quoted qt _ -> Actual qt; _ -> Absent}) - (peekQuoteType, \case - Quoted _ inlns -> Actual . (`Quoted` inlns) - _ -> const Absent) - , possibleProperty "src" "image source" - (pushText, \case - Image _ _ (src, _) -> Actual src - _ -> Absent) - (peekText, \case - Image attr capt (_, title) -> Actual . Image attr capt . (,title) - _ -> const Absent) - , possibleProperty "target" "link target URL" - (pushText, \case - Link _ _ (tgt, _) -> Actual tgt - _ -> Absent) - (peekText, \case - Link attr capt (_, title) -> Actual . Link attr capt . (,title) - _ -> const Absent) - , possibleProperty "title" "title text" - (pushText, getInlineTitle) - (peekText, setInlineTitle) - , possibleProperty "text" "text contents" - (pushText, getInlineText) - (peekText, setInlineText) - , readonly "tag" "type of Inline" - (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"] - - , method $ defun "clone" - ### return - <#> parameter peekInline "inline" "Inline" "self" - =#> functionResult pushInline "Inline" "cloned Inline" - ] - --- | Push an inline element to the top of the lua stack. -pushInline :: forall e. LuaError e => Inline -> LuaE e () -pushInline = pushUD typeInline - --- | Return the value at the given index as inline if possible. -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. -peekInlinesFuzzy :: LuaError e => Peeker e [Inline] -peekInlinesFuzzy idx = liftLua (ltype idx) >>= \case - TypeString -> B.toList . B.text <$> peekText idx - _ -> choice - [ peekList peekInlineFuzzy - , fmap pure . peekInlineFuzzy - ] 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 - ] - --- * 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 - peek = forcePeek . peekInline - -instance Peekable Block where - peek = forcePeek . peekBlock - -instance Peekable Meta where - peek = forcePeek . peekMeta - -instance Peekable Pandoc where - peek = forcePeek . peekPandoc - -instance Peekable Row where - peek = forcePeek . peekRow - -instance Peekable Version where - peek = forcePeek . peekVersionFuzzy - -instance {-# OVERLAPPING #-} Peekable Attr where - peek = forcePeek . peekAttr diff --git a/src/Text/Pandoc/Lua/Marshaling/Attr.hs b/src/Text/Pandoc/Lua/Marshaling/Attr.hs deleted file mode 100644 index 97e702e35..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/Attr.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{- | -Module : Text.Pandoc.Lua.Marshaling.Attr -Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel -License : GNU GPL, version 2 or above - -Maintainer : Albert Krewinkel -Stability : alpha - -Marshaling/unmarshaling instances for document AST elements. --} -module Text.Pandoc.Lua.Marshaling.Attr - ( typeAttr - , peekAttr - , pushAttr - , mkAttr - , mkAttributeList - ) where - -import Control.Applicative ((<|>), optional) -import Control.Monad ((<$!>)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import HsLua -import HsLua.Marshalling.Peekers (peekIndexRaw) -import Safe (atMay) -import Text.Pandoc.Definition (Attr, nullAttr) -import Text.Pandoc.Lua.Marshaling.List (pushPandocList) - -import qualified Data.Text as T - -typeAttr :: LuaError e => DocumentedType e Attr -typeAttr = deftype "Attr" - [ operation Eq $ lambda - ### liftPure2 (==) - <#> parameter peekAttr "a1" "Attr" "" - <#> parameter peekAttr "a2" "Attr" "" - =#> functionResult pushBool "boolean" "whether the two are equal" - , operation Tostring $ lambda - ### liftPure show - <#> parameter peekAttr "Attr" "attr" "" - =#> functionResult pushString "string" "native Haskell representation" - ] - [ property "identifier" "element identifier" - (pushText, \(ident,_,_) -> ident) - (peekText, \(_,cls,kv) -> (,cls,kv)) - , property "classes" "element classes" - (pushPandocList pushText, \(_,classes,_) -> classes) - (peekList peekText, \(ident,_,kv) -> (ident,,kv)) - , property "attributes" "various element attributes" - (pushAttribs, \(_,_,attribs) -> attribs) - (peekAttribs, \(ident,cls,_) -> (ident,cls,)) - , method $ defun "clone" - ### return - <#> parameter peekAttr "attr" "Attr" "" - =#> functionResult pushAttr "Attr" "new Attr element" - , readonly "tag" "element type tag (always 'Attr')" - (pushText, const "Attr") - - , alias "t" "alias for `tag`" ["tag"] - ] - -pushAttr :: LuaError e => Pusher e Attr -pushAttr = pushUD typeAttr - -peekAttribs :: LuaError e => Peeker e [(Text,Text)] -peekAttribs idx = liftLua (ltype idx) >>= \case - TypeUserdata -> peekUD typeAttributeList idx - TypeTable -> liftLua (rawlen idx) >>= \case - 0 -> peekKeyValuePairs peekText peekText idx - _ -> peekList (peekPair peekText peekText) idx - _ -> failPeek "unsupported type" - -pushAttribs :: LuaError e => Pusher e [(Text, Text)] -pushAttribs = pushUD typeAttributeList - -typeAttributeList :: LuaError e => DocumentedType e [(Text, Text)] -typeAttributeList = deftype "AttributeList" - [ operation Eq $ lambda - ### liftPure2 (==) - <#> parameter peekAttribs "a1" "AttributeList" "" - <#> parameter peekAttribs "a2" "AttributeList" "" - =#> functionResult pushBool "boolean" "whether the two are equal" - - , operation Index $ lambda - ### liftPure2 lookupKey - <#> udparam typeAttributeList "t" "attributes list" - <#> parameter peekKey "string|integer" "key" "lookup key" - =#> functionResult (maybe pushnil pushAttribute) "string|table" - "attribute value" - - , operation Newindex $ lambda - ### setKey - <#> udparam typeAttributeList "t" "attributes list" - <#> parameter peekKey "string|integer" "key" "lookup key" - <#> optionalParameter peekAttribute "string|nil" "value" "new value" - =#> [] - - , operation Len $ lambda - ### liftPure length - <#> udparam typeAttributeList "t" "attributes list" - =#> functionResult pushIntegral "integer" "number of attributes in list" - - , operation Pairs $ lambda - ### pushIterator (\(k, v) -> 2 <$ pushText k <* pushText v) - <#> udparam typeAttributeList "t" "attributes list" - =?> "iterator triple" - - , operation Tostring $ lambda - ### liftPure show - <#> udparam typeAttributeList "t" "attributes list" - =#> functionResult pushString "string" "" - ] - [] - -data Key = StringKey Text | IntKey Int - -peekKey :: LuaError e => Peeker e (Maybe Key) -peekKey idx = liftLua (ltype idx) >>= \case - TypeNumber -> Just . IntKey <$!> peekIntegral idx - TypeString -> Just . StringKey <$!> peekText idx - _ -> return Nothing - -data Attribute - = AttributePair (Text, Text) - | AttributeValue Text - -pushAttribute :: LuaError e => Pusher e Attribute -pushAttribute = \case - (AttributePair kv) -> pushPair pushText pushText kv - (AttributeValue v) -> pushText v - --- | Retrieve an 'Attribute'. -peekAttribute :: LuaError e => Peeker e Attribute -peekAttribute idx = (AttributeValue <$!> peekText idx) - <|> (AttributePair <$!> peekPair peekText peekText idx) - -lookupKey :: [(Text,Text)] -> Maybe Key -> Maybe Attribute -lookupKey !kvs = \case - Just (StringKey str) -> AttributeValue <$!> lookup str kvs - Just (IntKey n) -> AttributePair <$!> atMay kvs (n - 1) - Nothing -> Nothing - -setKey :: forall e. LuaError e - => [(Text, Text)] -> Maybe Key -> Maybe Attribute - -> LuaE e () -setKey kvs mbKey mbValue = case mbKey of - Just (StringKey str) -> - case break ((== str) . fst) kvs of - (prefix, _:suffix) -> case mbValue of - Nothing -> setNew $ prefix ++ suffix - Just (AttributeValue value) -> setNew $ prefix ++ (str, value):suffix - _ -> failLua "invalid attribute value" - _ -> case mbValue of - Nothing -> return () - Just (AttributeValue value) -> setNew (kvs ++ [(str, value)]) - _ -> failLua "invalid attribute value" - Just (IntKey idx) -> - case splitAt (idx - 1) kvs of - (prefix, (k,_):suffix) -> setNew $ case mbValue of - Nothing -> prefix ++ suffix - Just (AttributePair kv) -> prefix ++ kv : suffix - Just (AttributeValue v) -> prefix ++ (k, v) : suffix - (prefix, []) -> case mbValue of - Nothing -> setNew prefix - Just (AttributePair kv) -> setNew $ prefix ++ [kv] - _ -> failLua $ "trying to set an attribute key-value pair, " - ++ "but got a single string instead." - - _ -> failLua "invalid attribute key" - where - setNew :: [(Text, Text)] -> LuaE e () - setNew new = - putuserdata (nthBottom 1) (udName @e typeAttributeList) new >>= \case - True -> return () - False -> failLua "failed to modify attributes list" - -peekAttr :: LuaError e => Peeker e Attr -peekAttr idx = retrieving "Attr" $ liftLua (ltype idx) >>= \case - TypeString -> (,[],[]) <$!> peekText idx -- treat string as ID - TypeUserdata -> peekUD typeAttr idx - TypeTable -> peekAttrTable idx - x -> liftLua . failLua $ "Cannot get Attr from " ++ show x - --- | Helper function which gets an Attr from a Lua table. -peekAttrTable :: LuaError e => Peeker e Attr -peekAttrTable idx = do - len' <- liftLua $ rawlen idx - let peekClasses = peekList peekText - if len' > 0 - then do - ident <- peekIndexRaw 1 peekText idx - classes <- fromMaybe [] <$!> optional (peekIndexRaw 2 peekClasses idx) - attribs <- fromMaybe [] <$!> optional (peekIndexRaw 3 peekAttribs idx) - return $ ident `seq` classes `seq` attribs `seq` - (ident, classes, attribs) - else retrieving "HTML-like attributes" $ do - kvs <- peekKeyValuePairs peekText peekText idx - let ident = fromMaybe "" $ lookup "id" kvs - let classes = maybe [] T.words $ lookup "class" kvs - let attribs = filter ((`notElem` ["id", "class"]) . fst) kvs - return $ ident `seq` classes `seq` attribs `seq` - (ident, classes, attribs) - --- | Constructor for 'Attr'. -mkAttr :: LuaError e => DocumentedFunction e -mkAttr = defun "Attr" - ### (ltype (nthBottom 1) >>= \case - TypeString -> forcePeek $ do - mident <- optional (peekText (nthBottom 1)) - mclass <- optional (peekList peekText (nthBottom 2)) - mattribs <- optional (peekAttribs (nthBottom 3)) - return ( fromMaybe "" mident - , fromMaybe [] mclass - , fromMaybe [] mattribs) - TypeTable -> forcePeek $ peekAttrTable (nthBottom 1) - TypeUserdata -> forcePeek $ peekUD typeAttr (nthBottom 1) <|> do - attrList <- peekUD typeAttributeList (nthBottom 1) - return ("", [], attrList) - TypeNil -> pure nullAttr - TypeNone -> pure nullAttr - x -> failLua $ "Cannot create Attr from " ++ show x) - =#> functionResult pushAttr "Attr" "new Attr object" - --- | Constructor for 'AttributeList'. -mkAttributeList :: LuaError e => DocumentedFunction e -mkAttributeList = defun "AttributeList" - ### return - <#> parameter peekAttribs "table|AttributeList" "attribs" "an attribute list" - =#> functionResult (pushUD typeAttributeList) "AttributeList" - "new AttributeList object" diff --git a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs deleted file mode 100644 index 857551598..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.CommonState - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel - Stability : alpha - -Instances to marshal (push) and unmarshal (peek) the common state. --} -module Text.Pandoc.Lua.Marshaling.CommonState - ( typeCommonState - , peekCommonState - , pushCommonState - ) where - -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.List (pushPandocList) - --- | 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) - - , readonly "output_file" "the file to which pandoc will write" - (maybe pushnil pushString, stOutputFile) - - , readonly "log" "list of log messages" - (pushPandocList (pushUD typeLogMessage), stLog) - - , readonly "request_headers" "headers to add for HTTP requests" - (pushPandocList (pushPair pushText pushText), stRequestHeaders) - - , readonly "resource_path" - "path to search for resources like included images" - (pushPandocList pushString, stResourcePath) - - , readonly "source_url" "absolute URL + dir of 1st source file" - (maybe pushnil pushText, stSourceURL) - - , readonly "user_data_dir" "directory to search for data files" - (maybe pushnil pushString, stUserDataDir) - - , readonly "trace" "controls whether tracing messages are issued" - (pushBool, stTrace) - - , readonly "verbosity" "verbosity level" - (pushString . show, stVerbosity) - ] - -peekCommonState :: LuaError e => Peeker e CommonState -peekCommonState = peekUD typeCommonState - -pushCommonState :: LuaError e => Pusher e CommonState -pushCommonState = pushUD typeCommonState - -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 deleted file mode 100644 index 8ee25565e..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/Context.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.Context - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling instance for doctemplates Context and its components. --} -module Text.Pandoc.Lua.Marshaling.Context () where - -import qualified HsLua as Lua -import HsLua (Pushable) -import Text.DocTemplates (Context(..), Val(..), TemplateTarget) -import Text.DocLayout (render) - -instance (TemplateTarget a, Pushable a) => Pushable (Context a) where - push (Context m) = Lua.push m - -instance (TemplateTarget a, Pushable a) => Pushable (Val a) where - push NullVal = Lua.push () - push (BoolVal b) = Lua.push b - push (MapVal ctx) = Lua.push ctx - push (ListVal xs) = Lua.push xs - push (SimpleVal d) = Lua.push $ render Nothing d diff --git a/src/Text/Pandoc/Lua/Marshaling/List.hs b/src/Text/Pandoc/Lua/Marshaling/List.hs deleted file mode 100644 index 0b145d3a1..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/List.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{- | -Module : Text.Pandoc.Lua.Marshaling.List -Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel -License : GNU GPL, version 2 or above -Maintainer : Albert Krewinkel -Stability : alpha - -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 HsLua (LuaError, Peeker, Pusher, Pushable (push), peekList, pushList) -import Text.Pandoc.Walk (Walkable (..)) -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) = 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] - -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. -instance Walkable [a] b => Walkable (List a) b where - walkM f = walkM (fmap fromList . f . List) - query f = query (f . List) diff --git a/src/Text/Pandoc/Lua/Marshaling/ListAttributes.hs b/src/Text/Pandoc/Lua/Marshaling/ListAttributes.hs deleted file mode 100644 index 5a6608644..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/ListAttributes.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{- | -Module : Text.Pandoc.Lua.Marshaling.ListAttributes -Copyright : © 2021 Albert Krewinkel -License : GNU GPL, version 2 or above -Maintainer : Albert Krewinkel - -Marshaling/unmarshaling functions and constructor for 'ListAttributes' -values. --} -module Text.Pandoc.Lua.Marshaling.ListAttributes - ( typeListAttributes - , peekListAttributes - , pushListAttributes - , mkListAttributes - ) where - -import Data.Maybe (fromMaybe) -import HsLua -import Text.Pandoc.Definition ( ListAttributes, ListNumberStyle (DefaultStyle) - , ListNumberDelim (DefaultDelim)) - -typeListAttributes :: LuaError e => DocumentedType e ListAttributes -typeListAttributes = deftype "ListAttributes" - [ operation Eq $ lambda - ### liftPure2 (==) - <#> parameter peekListAttributes "a" "ListAttributes" "" - <#> parameter peekListAttributes "b" "ListAttributes" "" - =#> functionResult pushBool "boolean" "whether the two are equal" - ] - [ property "start" "number of the first list item" - (pushIntegral, \(start,_,_) -> start) - (peekIntegral, \(_,style,delim) -> (,style,delim)) - , property "style" "style used for list numbering" - (pushString . show, \(_,classes,_) -> classes) - (peekRead, \(start,_,delim) -> (start,,delim)) - , property "delimiter" "delimiter of list numbers" - (pushString . show, \(_,_,delim) -> delim) - (peekRead, \(start,style,_) -> (start,style,)) - , method $ defun "clone" - ### return - <#> udparam typeListAttributes "a" "" - =#> functionResult (pushUD typeListAttributes) "ListAttributes" - "cloned ListAttributes value" - ] - --- | Pushes a 'ListAttributes' value as userdata object. -pushListAttributes :: LuaError e => Pusher e ListAttributes -pushListAttributes = pushUD typeListAttributes - --- | Retrieve a 'ListAttributes' triple, either from userdata or from a --- Lua tuple. -peekListAttributes :: LuaError e => Peeker e ListAttributes -peekListAttributes = retrieving "ListAttributes" . choice - [ peekUD typeListAttributes - , peekTriple peekIntegral peekRead peekRead - ] - --- | Constructor for a new 'ListAttributes' value. -mkListAttributes :: LuaError e => DocumentedFunction e -mkListAttributes = defun "ListAttributes" - ### liftPure3 (\mstart mstyle mdelim -> - ( fromMaybe 1 mstart - , fromMaybe DefaultStyle mstyle - , fromMaybe DefaultDelim mdelim - )) - <#> optionalParameter peekIntegral "integer" "start" "number of first item" - <#> optionalParameter peekRead "string" "style" "list numbering style" - <#> optionalParameter peekRead "string" "delimiter" "list number delimiter" - =#> functionResult pushListAttributes "ListAttributes" "new ListAttributes" - #? "Creates a new ListAttributes object." diff --git a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs deleted file mode 100644 index 6f29a5c89..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.PandocError - Copyright : © 2020-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling of @'PandocError'@ values. --} -module Text.Pandoc.Lua.Marshaling.PandocError - ( peekPandocError - , pushPandocError - , typePandocError - ) - where - -import HsLua.Core (LuaError) -import HsLua.Marshalling (Peeker, Pusher, pushString, liftLua) -import HsLua.Packaging -import Text.Pandoc.Error (PandocError (PandocLuaError)) - -import qualified HsLua as Lua -import qualified Text.Pandoc.UTF8 as UTF8 - --- | 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 :: LuaError e => Pusher e PandocError -pushPandocError = pushUD typePandocError - --- | Retrieve a @'PandocError'@ from the Lua stack. -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 deleted file mode 100644 index 91eb22ae9..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.ReaderOptions - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling instance for ReaderOptions and its components. --} -module Text.Pandoc.Lua.Marshaling.ReaderOptions - ( peekReaderOptions - , pushReaderOptions - , pushReaderOptionsReadonly - ) where - -import Data.Default (def) -import HsLua as Lua -import Text.Pandoc.Lua.Marshaling.List (pushPandocList) -import Text.Pandoc.Options (ReaderOptions (..)) - --- --- Reader Options --- - --- | Retrieve a ReaderOptions value, either from a normal ReaderOptions --- value, from a read-only object, or from a table with the same --- keys as a ReaderOptions object. -peekReaderOptions :: LuaError e => Peeker e ReaderOptions -peekReaderOptions = retrieving "ReaderOptions" . \idx -> - liftLua (ltype idx) >>= \case - TypeUserdata -> choice [ peekUD typeReaderOptions - , peekUD typeReaderOptionsReadonly - ] - idx - TypeTable -> peekReaderOptionsTable idx - _ -> failPeek =<< - typeMismatchMessage "ReaderOptions userdata or table" idx - --- | Pushes a ReaderOptions value as userdata object. -pushReaderOptions :: LuaError e => Pusher e ReaderOptions -pushReaderOptions = pushUD typeReaderOptions - --- | Pushes a ReaderOptions object, but makes it read-only. -pushReaderOptionsReadonly :: LuaError e => Pusher e ReaderOptions -pushReaderOptionsReadonly = pushUD typeReaderOptionsReadonly - --- | ReaderOptions object type for read-only values. -typeReaderOptionsReadonly :: LuaError e => DocumentedType e ReaderOptions -typeReaderOptionsReadonly = deftype "ReaderOptions (read-only)" - [ operation Tostring $ lambda - ### liftPure show - <#> udparam typeReaderOptions "opts" "options to print in native format" - =#> functionResult pushString "string" "Haskell representation" - , operation Newindex $ lambda - ### (failLua "This ReaderOptions value is read-only.") - =?> "Throws an error when called, i.e., an assignment is made." - ] - readerOptionsMembers - --- | 'ReaderOptions' object type. -typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions -typeReaderOptions = deftype "ReaderOptions" - [ operation Tostring $ lambda - ### liftPure show - <#> udparam typeReaderOptions "opts" "options to print in native format" - =#> functionResult pushString "string" "Haskell representation" - ] - readerOptionsMembers - --- | Member properties of 'ReaderOptions' Lua values. -readerOptionsMembers :: LuaError e - => [Member e (DocumentedFunction e) ReaderOptions] -readerOptionsMembers = - [ property "abbreviations" "" - (pushSet pushText, readerAbbreviations) - (peekSet peekText, \opts x -> opts{ readerAbbreviations = x }) - , property "columns" "" - (pushIntegral, readerColumns) - (peekIntegral, \opts x -> opts{ readerColumns = x }) - , property "default_image_extension" "" - (pushText, readerDefaultImageExtension) - (peekText, \opts x -> opts{ readerDefaultImageExtension = x }) - , property "extensions" "" - (pushString . show, readerExtensions) - (peekRead, \opts x -> opts{ readerExtensions = x }) - , property "indented_code_classes" "" - (pushPandocList pushText, readerIndentedCodeClasses) - (peekList peekText, \opts x -> opts{ readerIndentedCodeClasses = x }) - , property "strip_comments" "" - (pushBool, readerStripComments) - (peekBool, \opts x -> opts{ readerStripComments = x }) - , property "standalone" "" - (pushBool, readerStandalone) - (peekBool, \opts x -> opts{ readerStandalone = x }) - , property "tab_stop" "" - (pushIntegral, readerTabStop) - (peekIntegral, \opts x -> opts{ readerTabStop = x }) - , property "track_changes" "" - (pushString . show, readerTrackChanges) - (peekRead, \opts x -> opts{ readerTrackChanges = x }) - ] - --- | Retrieves a 'ReaderOptions' object from a table on the stack, using --- the default values for all missing fields. --- --- Internally, this pushes the default reader options, sets each --- key/value pair of the table in the userdata value, then retrieves the --- object again. This will update all fields and complain about unknown --- keys. -peekReaderOptionsTable :: LuaError e => Peeker e ReaderOptions -peekReaderOptionsTable idx = retrieving "ReaderOptions (table)" $ do - liftLua $ do - absidx <- absindex idx - pushUD typeReaderOptions def - let setFields = do - next absidx >>= \case - False -> return () -- all fields were copied - True -> do - pushvalue (nth 2) *> insert (nth 2) - settable (nth 4) -- set in userdata object - setFields - pushnil -- first key - setFields - peekUD typeReaderOptions top - -instance Pushable ReaderOptions where - push = pushReaderOptions diff --git a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs b/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs deleted file mode 100644 index 65f5aec8b..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.SimpleTable - Copyright : © 2020-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel - -Definition and marshaling of the 'SimpleTable' data type used as a -convenience type when dealing with tables. --} -module Text.Pandoc.Lua.Marshaling.SimpleTable - ( SimpleTable (..) - , peekSimpleTable - , pushSimpleTable - , mkSimpleTable - ) - where - -import HsLua as Lua -import Text.Pandoc.Definition -import Text.Pandoc.Lua.Marshaling.AST -import Text.Pandoc.Lua.Marshaling.List - --- | A simple (legacy-style) table. -data SimpleTable = SimpleTable - { simpleTableCaption :: [Inline] - , simpleTableAlignments :: [Alignment] - , simpleTableColumnWidths :: [Double] - , simpleTableHeader :: [[Block]] - , simpleTableBody :: [[[Block]]] - } deriving (Eq, Show) - -typeSimpleTable :: LuaError e => DocumentedType e SimpleTable -typeSimpleTable = deftype "SimpleTable" - [ operation Eq $ lambda - ### liftPure2 (==) - <#> udparam typeSimpleTable "a" "" - <#> udparam typeSimpleTable "b" "" - =#> functionResult pushBool "boolean" "whether the two objects are equal" - , operation Tostring $ lambda - ### liftPure show - <#> udparam typeSimpleTable "self" "" - =#> functionResult pushString "string" "Haskell string representation" - ] - [ property "caption" "table caption" - (pushPandocList pushInline, simpleTableCaption) - (peekInlinesFuzzy, \t capt -> t {simpleTableCaption = capt}) - , property "aligns" "column alignments" - (pushPandocList (pushString . show), simpleTableAlignments) - (peekList peekRead, \t aligns -> t{simpleTableAlignments = aligns}) - , property "widths" "relative column widths" - (pushPandocList pushRealFloat, simpleTableColumnWidths) - (peekList peekRealFloat, \t ws -> t{simpleTableColumnWidths = ws}) - , property "headers" "table header" - (pushRow, simpleTableHeader) - (peekRow, \t h -> t{simpleTableHeader = h}) - , property "rows" "table body rows" - (pushPandocList pushRow, simpleTableBody) - (peekList peekRow, \t bs -> t{simpleTableBody = bs}) - - , readonly "t" "type tag (always 'SimpleTable')" - (pushText, const "SimpleTable") - - , alias "header" "alias for `headers`" ["headers"] - ] - where - pushRow = pushPandocList (pushPandocList pushBlock) - -peekRow :: LuaError e => Peeker e [[Block]] -peekRow = peekList peekBlocksFuzzy - --- | Push a simple table to the stack by calling the --- @pandoc.SimpleTable@ constructor. -pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e () -pushSimpleTable = pushUD typeSimpleTable - --- | Retrieve a simple table from the stack. -peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable -peekSimpleTable = retrieving "SimpleTable" . peekUD typeSimpleTable - --- | Constructor for the 'SimpleTable' type. -mkSimpleTable :: LuaError e => DocumentedFunction e -mkSimpleTable = defun "SimpleTable" - ### liftPure5 SimpleTable - <#> parameter peekInlinesFuzzy "Inlines" "caption" "table caption" - <#> parameter (peekList peekRead) "{Alignment,...}" "align" "column alignments" - <#> parameter (peekList peekRealFloat) "{number,...}" "widths" - "relative column widths" - <#> parameter peekRow "{Blocks,...}" "header" "table header row" - <#> parameter (peekList peekRow) "{{Blocks,...},...}" "body" "table body rows" - =#> functionResult pushSimpleTable "SimpleTable" "new SimpleTable object" diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index 6e595f9e4..fb055101e 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -21,8 +21,8 @@ import Text.Pandoc.Class.CommonState (CommonState (..)) import Text.Pandoc.Class.PandocMonad (fetchItem, getMediaBag, modifyCommonState, setMediaBag) import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Marshaling.List (pushPandocList) +import Text.Pandoc.Lua.Marshal.List (pushPandocList) +import Text.Pandoc.Lua.Orphans () import Text.Pandoc.Lua.PandocLua (unPandocLua) import Text.Pandoc.MIME (MimeType) diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index a8b111092..085d904cf 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -19,35 +19,28 @@ module Text.Pandoc.Lua.Module.Pandoc ) where import Prelude hiding (read) -import Control.Applicative ((<|>)) -import Control.Monad ((<$!>), forM_, when) +import Control.Monad (forM_, when) import Control.Monad.Catch (catch, throwM) import Control.Monad.Except (throwError) import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) import Data.Default (Default (..)) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) -import Data.Text (Text) -import HsLua hiding (Div, pushModule) +import HsLua hiding (pushModule) import HsLua.Class.Peekable (PeekError) import System.Exit (ExitCode (..)) import Text.Pandoc.Class.PandocIO (runIO) import Text.Pandoc.Definition -import Text.Pandoc.Lua.Filter (SingletonsList (..), LuaFilter, peekLuaFilter, +import Text.Pandoc.Lua.Filter (List (..), SingletonsList (..), LuaFilter, + peekLuaFilter, walkInlines, walkInlineLists, walkBlocks, walkBlockLists) -import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Marshaling.AST -import Text.Pandoc.Lua.Marshaling.Attr (mkAttr, mkAttributeList) -import Text.Pandoc.Lua.Marshaling.List (List (..)) -import Text.Pandoc.Lua.Marshaling.ListAttributes ( mkListAttributes - , peekListAttributes) -import Text.Pandoc.Lua.Marshaling.ReaderOptions ( peekReaderOptions +import Text.Pandoc.Lua.Orphans () +import Text.Pandoc.Lua.Marshal.AST +import Text.Pandoc.Lua.Marshal.ReaderOptions ( peekReaderOptions , pushReaderOptions) -import Text.Pandoc.Lua.Marshaling.SimpleTable (mkSimpleTable) import Text.Pandoc.Lua.Module.Utils (sha1) -import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, - loadDefaultModule) +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) import Text.Pandoc.Readers (Reader (..), getReader) @@ -65,21 +58,6 @@ import Text.Pandoc.Error pushModule :: PandocLua NumResults pushModule = do liftPandocLua $ Lua.pushModule documentedModule - loadDefaultModule "pandoc" - let copyNext = do - hasNext <- next (nth 2) - if not hasNext - then return () - else do - pushvalue (nth 2) - insert (nth 2) - rawset (nth 5) -- pandoc module - copyNext - liftPandocLua $ do - pushnil -- initial key - copyNext - pop 1 - return 1 documentedModule :: Module PandocError @@ -97,6 +75,7 @@ documentedModule = Module , otherConstructors , blockConstructors , inlineConstructors + , metaValueConstructors ] } @@ -132,229 +111,13 @@ pushWithConstructorsSubtable constructors = do rawset (nth 3) pop 1 -- pop constructor table -inlineConstructors :: LuaError e => [DocumentedFunction e] -inlineConstructors = - [ defun "Cite" - ### liftPure2 (flip Cite) - <#> parameter peekInlinesFuzzy "content" "Inline" "placeholder content" - <#> parameter (peekList peekCitation) "citations" "list of Citations" "" - =#> functionResult pushInline "Inline" "cite element" - , defun "Code" - ### liftPure2 (\text mattr -> Code (fromMaybe nullAttr mattr) text) - <#> parameter peekText "code" "string" "code string" - <#> optionalParameter peekAttr "attr" "Attr" "additional attributes" - =#> functionResult pushInline "Inline" "code element" - , mkInlinesConstr "Emph" Emph - , defun "Image" - ### liftPure4 (\caption src mtitle mattr -> - let attr = fromMaybe nullAttr mattr - title = fromMaybe mempty mtitle - in Image attr caption (src, title)) - <#> 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" - =#> functionResult pushInline "Inline" "image element" - , defun "LineBreak" - ### return LineBreak - =#> functionResult pushInline "Inline" "line break" - , defun "Link" - ### liftPure4 (\content target mtitle mattr -> - let attr = fromMaybe nullAttr mattr - title = fromMaybe mempty mtitle - in Link attr content (target, title)) - <#> 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" - =#> functionResult pushInline "Inline" "link element" - , defun "Math" - ### liftPure2 Math - <#> parameter peekMathType "quotetype" "Math" "rendering method" - <#> parameter peekText "text" "string" "math content" - =#> functionResult pushInline "Inline" "math element" - , defun "Note" - ### liftPure Note - <#> parameter peekBlocksFuzzy "content" "Blocks" "note content" - =#> functionResult pushInline "Inline" "note" - , defun "Quoted" - ### liftPure2 Quoted - <#> parameter peekQuoteType "quotetype" "QuoteType" "type of quotes" - <#> parameter peekInlinesFuzzy "content" "Inlines" "inlines in quotes" - =#> functionResult pushInline "Inline" "quoted element" - , defun "RawInline" - ### liftPure2 RawInline - <#> parameter peekFormat "format" "Format" "format of content" - <#> parameter peekText "text" "string" "string content" - =#> functionResult pushInline "Inline" "raw inline element" - , mkInlinesConstr "SmallCaps" SmallCaps - , defun "SoftBreak" - ### return SoftBreak - =#> functionResult pushInline "Inline" "soft break" - , defun "Space" - ### return Space - =#> functionResult pushInline "Inline" "new space" - , defun "Span" - ### liftPure2 (\inlns mattr -> Span (fromMaybe nullAttr mattr) inlns) - <#> parameter peekInlinesFuzzy "content" "Inlines" "inline content" - <#> optionalParameter peekAttr "attr" "Attr" "additional attributes" - =#> functionResult pushInline "Inline" "span element" - , defun "Str" - ### liftPure Str - <#> parameter peekText "text" "string" "" - =#> functionResult pushInline "Inline" "new Str object" - , mkInlinesConstr "Strong" Strong - , mkInlinesConstr "Strikeout" Strikeout - , mkInlinesConstr "Subscript" Subscript - , mkInlinesConstr "Superscript" Superscript - , 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 peekInlinesFuzzy "content" "Inlines" "" - =#> functionResult pushInline "Inline" "new object" - otherConstructors :: LuaError e => [DocumentedFunction e] otherConstructors = - [ defun "Pandoc" - ### liftPure2 (\blocks mMeta -> Pandoc (fromMaybe nullMeta mMeta) blocks) - <#> parameter peekBlocksFuzzy "Blocks" "blocks" "document contents" - <#> optionalParameter peekMeta "Meta" "meta" "document metadata" - =#> functionResult pushPandoc "Pandoc" "new Pandoc document" - - , defun "Citation" - ### (\cid mode mprefix msuffix mnote_num mhash -> - cid `seq` mode `seq` mprefix `seq` msuffix `seq` - mnote_num `seq` mhash `seq` return $! Citation - { citationId = cid - , citationMode = mode - , citationPrefix = fromMaybe mempty mprefix - , citationSuffix = fromMaybe mempty msuffix - , citationNoteNum = fromMaybe 0 mnote_num - , citationHash = fromMaybe 0 mhash - }) - <#> parameter peekText "string" "cid" "citation ID (e.g. bibtex key)" - <#> parameter peekRead "citation mode" "mode" "citation rendering mode" - <#> 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" - #? "Creates a single citation." - + [ mkPandoc + , mkMeta , mkAttr , mkAttributeList + , mkCitation , mkListAttributes , mkSimpleTable diff --git a/src/Text/Pandoc/Lua/Module/Types.hs b/src/Text/Pandoc/Lua/Module/Types.hs index 4b37dafd9..f16737f63 100644 --- a/src/Text/Pandoc/Lua/Module/Types.hs +++ b/src/Text/Pandoc/Lua/Module/Types.hs @@ -13,14 +13,11 @@ module Text.Pandoc.Lua.Module.Types ( documentedModule ) where -import HsLua ( LuaE, NumResults, Peeker, Pusher, Module (..), Field (..) - , defun, functionResult, parameter, (###), (<#>), (=#>)) +import HsLua ( Module (..), (###), (<#>), (=#>) + , defun, functionResult, parameter) import HsLua.Module.Version (peekVersionFuzzy, pushVersion) import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.ErrorConversion () -import Text.Pandoc.Lua.Marshaling.AST - -import qualified HsLua as Lua -- | Push the pandoc.types module on the Lua stack. documentedModule :: Module PandocError @@ -28,16 +25,7 @@ documentedModule = Module { moduleName = "pandoc.types" , moduleDescription = "Constructors for types that are not part of the pandoc AST." - , moduleFields = - [ Field - { fieldName = "clone" - , fieldDescription = "DEPRECATED! Helper functions for element cloning." - , fieldPushValue = do - Lua.newtable - addFunction "Meta" $ cloneWith peekMeta pushMeta - addFunction "MetaValue" $ cloneWith peekMetaValue pushMetaValue - } - ] + , moduleFields = [] , moduleFunctions = [ defun "Version" ### return @@ -52,15 +40,3 @@ documentedModule = Module ] , moduleOperations = [] } - where addFunction name fn = do - Lua.pushName name - Lua.pushHaskellFunction fn - Lua.rawset (Lua.nth 3) - -cloneWith :: Peeker PandocError a - -> Pusher PandocError a - -> LuaE PandocError NumResults -cloneWith peeker pusher = do - x <- Lua.forcePeek $ peeker (Lua.nthBottom 1) - pusher x - return (Lua.NumResults 1) diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index 6fd707bf8..917f2e627 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -27,14 +27,7 @@ import HsLua.Class.Peekable (PeekError) import HsLua.Module.Version (peekVersionFuzzy, pushVersion) import Text.Pandoc.Definition import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Marshaling.AST - ( peekBlock, peekInline, peekPandoc, pushBlock, pushInline, pushInlines - , pushPandoc, peekAttr, peekMeta, peekMetaValue) -import Text.Pandoc.Lua.Marshaling.ListAttributes (peekListAttributes) -import Text.Pandoc.Lua.Marshaling.List (pushPandocList) -import Text.Pandoc.Lua.Marshaling.SimpleTable - ( SimpleTable (..), peekSimpleTable, pushSimpleTable ) +import Text.Pandoc.Lua.Marshal.AST import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua)) import qualified Data.Digest.Pure.SHA as SHA diff --git a/src/Text/Pandoc/Lua/Orphans.hs b/src/Text/Pandoc/Lua/Orphans.hs new file mode 100644 index 000000000..eef05bd27 --- /dev/null +++ b/src/Text/Pandoc/Lua/Orphans.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{- | + Module : Text.Pandoc.Lua.Orphans + Copyright : © 2012-2021 John MacFarlane + © 2017-2021 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Orphan instances for Lua's Pushable and Peekable type classes. +-} +module Text.Pandoc.Lua.Orphans () where + +import Data.Version (Version) +import HsLua +import HsLua.Module.Version (peekVersionFuzzy) +import Text.Pandoc.Definition +import Text.Pandoc.Lua.Marshal.AST +import Text.Pandoc.Lua.Marshal.CommonState () +import Text.Pandoc.Lua.Marshal.Context () +import Text.Pandoc.Lua.Marshal.PandocError() +import Text.Pandoc.Lua.Marshal.ReaderOptions () +import Text.Pandoc.Lua.ErrorConversion () + +instance Pushable Pandoc where + push = pushPandoc + +instance Pushable Meta where + push = pushMeta + +instance Pushable MetaValue where + push = pushMetaValue + +instance Pushable Block where + push = pushBlock + +instance {-# OVERLAPPING #-} Pushable [Block] where + push = pushBlocks + +instance Pushable Alignment where + push = pushString . show + +instance Pushable CitationMode where + push = pushCitationMode + +instance Pushable Format where + push = pushFormat + +instance Pushable ListNumberDelim where + push = pushString . show + +instance Pushable ListNumberStyle where + push = pushString . show + +instance Pushable MathType where + push = pushMathType + +instance Pushable QuoteType where + push = pushQuoteType + +instance Pushable Cell where + push = pushCell + +instance Peekable Cell where + peek = forcePeek . peekCell + +instance Pushable Inline where + push = pushInline + +instance {-# OVERLAPPING #-} Pushable [Inline] where + push = pushInlines + +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 + peek = forcePeek . peekInline + +instance Peekable Block where + peek = forcePeek . peekBlock + +instance Peekable Meta where + peek = forcePeek . peekMeta + +instance Peekable Pandoc where + peek = forcePeek . peekPandoc + +instance Peekable Row where + peek = forcePeek . peekRow + +instance Peekable Version where + peek = forcePeek . peekVersionFuzzy + +instance {-# OVERLAPPING #-} Peekable Attr where + peek = forcePeek . peekAttr diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index 3a481886a..c36c3c670 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -17,7 +17,8 @@ module Text.Pandoc.Lua.Packages import Control.Monad (forM_) import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, loadDefaultModule) +import Text.Pandoc.Lua.Marshal.List (pushListModule) +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua) import qualified HsLua as Lua import qualified HsLua.Module.Path as Path @@ -45,7 +46,7 @@ installPandocPackageSearcher = liftPandocLua $ do pandocPackageSearcher :: String -> PandocLua Lua.NumResults pandocPackageSearcher pkgName = case pkgName of - "pandoc" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Pandoc.pushModule + "pandoc" -> pushModuleLoader Pandoc.documentedModule "pandoc.mediabag" -> pushModuleLoader MediaBag.documentedModule "pandoc.path" -> pushModuleLoader Path.documentedModule "pandoc.system" -> pushModuleLoader System.documentedModule @@ -53,7 +54,7 @@ pandocPackageSearcher pkgName = "pandoc.utils" -> pushModuleLoader Utils.documentedModule "text" -> pushModuleLoader Text.documentedModule "pandoc.List" -> pushWrappedHsFun . Lua.toHaskellFunction @PandocError $ - loadDefaultModule pkgName + (Lua.NumResults 1 <$ pushListModule @PandocError) _ -> reportPandocSearcherFailure where pushModuleLoader mdl = liftPandocLua $ do diff --git a/src/Text/Pandoc/Lua/PandocLua.hs b/src/Text/Pandoc/Lua/PandocLua.hs index 6c2ebc622..71fdf8d5c 100644 --- a/src/Text/Pandoc/Lua/PandocLua.hs +++ b/src/Text/Pandoc/Lua/PandocLua.hs @@ -22,20 +22,18 @@ module Text.Pandoc.Lua.PandocLua ( PandocLua (..) , runPandocLua , liftPandocLua - , loadDefaultModule ) where import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Except (MonadError (catchError, throwError)) import Control.Monad.IO.Class (MonadIO) import HsLua as Lua -import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDefaultDataFile) -import Text.Pandoc.Error (PandocError (PandocLuaError)) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) +import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.Marshaling.CommonState (peekCommonState) +import Text.Pandoc.Lua.Marshal.CommonState (peekCommonState) import qualified Control.Monad.Catch as Catch -import qualified Data.Text as T import qualified Text.Pandoc.Class.IO as IO -- | Type providing access to both, pandoc and Lua operations. @@ -75,23 +73,6 @@ instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where instance Pushable a => Exposable PandocError (PandocLua a) where partialApply _narg x = 1 <$ (unPandocLua x >>= Lua.push) --- | Load a pure Lua module included with pandoc. Leaves the result on --- the stack and returns @NumResults 1@. --- --- The script is loaded from the default data directory. We do not load --- from data directories supplied via command line, as this could cause --- scripts to be executed even though they had not been passed explicitly. -loadDefaultModule :: String -> PandocLua NumResults -loadDefaultModule name = do - script <- readDefaultDataFile (name <> ".lua") - result <- liftPandocLua $ Lua.dostring script - if result == Lua.OK - then return (1 :: NumResults) - else do - msg <- liftPandocLua Lua.popValue - let err = "Error while loading `" <> name <> "`.\n" <> msg - throwError $ PandocLuaError (T.pack err) - -- | Global variables which should always be set. defaultGlobals :: PandocMonad m => m [Global] defaultGlobals = do diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index f35201db0..6d67d340d 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Util Copyright : © 2012-2021 John MacFarlane, @@ -16,14 +11,12 @@ Lua utility functions. -} module Text.Pandoc.Lua.Util - ( getTag - , addField + ( addField , callWithTraceback , dofileWithTraceback - , pushViaConstr' ) where -import Control.Monad (unless, when) +import Control.Monad (when) import HsLua import qualified HsLua as Lua @@ -34,26 +27,6 @@ addField key value = do Lua.push value Lua.rawset (Lua.nth 3) --- | Get the tag of a value. This is an optimized and specialized version of --- @Lua.getfield idx "tag"@. It only checks for the field on the table at index --- @idx@ and on its metatable, also ignoring any @__index@ value on the --- metatable. -getTag :: LuaError e => Peeker e Name -getTag idx = do - -- push metatable or just the table - liftLua $ do - Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx) - Lua.pushName "tag" - Lua.rawget (Lua.nth 2) - Lua.peekName Lua.top `lastly` Lua.pop 2 -- table/metatable and `tag` field - -pushViaConstr' :: forall e. LuaError e => Name -> [LuaE e ()] -> LuaE e () -pushViaConstr' fnname pushArgs = do - pushName @e ("pandoc." <> fnname) - rawget @e registryindex - sequence_ pushArgs - call @e (fromIntegral (length pushArgs)) 1 - -- | Like @'Lua.pcall'@, but uses a predefined error handler which adds a -- traceback on error. pcallWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e Status diff --git a/src/Text/Pandoc/Lua/Walk.hs b/src/Text/Pandoc/Lua/Walk.hs index d6d973496..75ed1f471 100644 --- a/src/Text/Pandoc/Lua/Walk.hs +++ b/src/Text/Pandoc/Lua/Walk.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : Text.Pandoc.Lua.Walk Copyright : © 2012-2021 John MacFarlane, @@ -14,13 +16,18 @@ Walking documents in a filter-suitable way. -} module Text.Pandoc.Lua.Walk ( SingletonsList (..) + , List (..) ) where import Control.Monad ((<=<)) +import Data.Data (Data) +import HsLua (Pushable (push)) +import Text.Pandoc.Lua.Marshal.AST (pushBlocks, pushInlines) import Text.Pandoc.Definition import Text.Pandoc.Walk + -- | Helper type which allows to traverse trees in order, while splicing in -- trees. -- @@ -156,3 +163,21 @@ querySingletonsList :: (Monoid c, Walkable (SingletonsList a) a) querySingletonsList f = let f' x = f (SingletonsList [x]) `mappend` query f x in mconcat . map f' + + +-- | List wrapper where each list is processed as a whole, but special +-- pushed to Lua in type-dependent ways. +-- +-- The walk instance is basically that of unwrapped Haskell lists. +newtype List a = List { fromList :: [a] } + deriving (Data, Eq, Show) + +instance Pushable (List Block) where + push (List xs) = pushBlocks xs + +instance Pushable (List Inline) where + push (List xs) = pushInlines xs + +instance Walkable [a] b => Walkable (List a) b where + walkM f = walkM (fmap fromList . f . List) + query f = query (f . List) -- cgit v1.2.3