diff options
29 files changed, 1152 insertions, 1249 deletions
diff --git a/cabal.project b/cabal.project index 2b19ad28e..b5cef10cb 100644 --- a/cabal.project +++ b/cabal.project @@ -41,4 +41,3 @@ source-repository-package -- type: git -- location: https://github.com/jgm/ipynb.git -- tag: 1f1ddb29227335091a3a158b9aeeeb47a372c683 - diff --git a/pandoc.cabal b/pandoc.cabal index ac6cb8121..886d3fa9d 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -551,10 +551,11 @@ library file-embed >= 0.0 && < 0.1, filepath >= 1.1 && < 1.5, haddock-library >= 1.10 && < 1.11, - hslua >= 1.1 && < 1.4, - hslua-module-path >= 0.1.0 && < 0.2.0, - hslua-module-system >= 0.2 && < 0.3, - hslua-module-text >= 0.2.1 && < 0.4, + hslua >= 2.0 && < 2.1, + hslua-marshalling >= 2.0 && < 2.1, + hslua-module-path >= 1.0 && < 1.1, + hslua-module-system >= 1.0 && < 1.1, + hslua-module-text >= 1.0 && < 1.1, http-client >= 0.4.30 && < 0.8, http-client-tls >= 0.2.4 && < 0.4, http-types >= 0.8 && < 0.13, @@ -775,11 +776,9 @@ library Text.Pandoc.Lua.Init, Text.Pandoc.Lua.Marshaling, Text.Pandoc.Lua.Marshaling.AST, - Text.Pandoc.Lua.Marshaling.AnyValue, Text.Pandoc.Lua.Marshaling.CommonState, Text.Pandoc.Lua.Marshaling.Context, Text.Pandoc.Lua.Marshaling.List, - Text.Pandoc.Lua.Marshaling.MediaBag, Text.Pandoc.Lua.Marshaling.PandocError, Text.Pandoc.Lua.Marshaling.ReaderOptions, Text.Pandoc.Lua.Marshaling.SimpleTable, @@ -847,14 +846,14 @@ test-suite test-pandoc doctemplates >= 0.10 && < 0.11, exceptions >= 0.8 && < 0.11, filepath >= 1.1 && < 1.5, - hslua >= 1.1 && < 1.4, + hslua >= 2.0 && < 2.1, mtl >= 2.2 && < 2.3, pandoc-types >= 1.22 && < 1.23, process >= 1.2.3 && < 1.7, tasty >= 0.11 && < 1.5, tasty-golden >= 2.3 && < 2.4, tasty-hunit >= 0.9 && < 0.11, - tasty-lua >= 0.2 && < 0.3, + tasty-lua >= 1.0 && < 1.1, tasty-quickcheck >= 0.8 && < 0.11, text >= 1.1.1.0 && < 1.3, time >= 1.5 && < 1.13, diff --git a/src/Text/Pandoc/Lua/ErrorConversion.hs b/src/Text/Pandoc/Lua/ErrorConversion.hs index 4e6880722..9c4c990a3 100644 --- a/src/Text/Pandoc/Lua/ErrorConversion.hs +++ b/src/Text/Pandoc/Lua/ErrorConversion.hs @@ -1,6 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Lua.ErrorConversion Copyright : © 2020-2021 Albert Krewinkel @@ -13,49 +12,37 @@ Define how Lua errors are converted into @'PandocError'@ Haskell exceptions, and /vice versa/. -} module Text.Pandoc.Lua.ErrorConversion - ( errorConversion + ( addContextToException ) where -import Foreign.Lua (Lua (..), NumResults) +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 qualified Control.Monad.Catch as Catch import qualified Data.Text as T -import qualified Foreign.Lua as Lua - --- | Conversions between Lua errors and Haskell exceptions, assuming --- that all exceptions are of type @'PandocError'@. -errorConversion :: Lua.ErrorConversion -errorConversion = Lua.ErrorConversion - { Lua.addContextToException = addContextToException - , Lua.alternative = alternative - , Lua.errorToException = errorToException - , Lua.exceptionToError = exceptionToError - } - --- | Convert a Lua error, which must be at the top of the stack, into a --- @'PandocError'@, popping the value from the stack. -errorToException :: forall a . Lua.State -> IO a -errorToException l = Lua.unsafeRunWith l $ do - err <- peekPandocError Lua.stackTop - Lua.pop 1 - Catch.throwM err - --- | Try the first op -- if it doesn't succeed, run the second. -alternative :: forall a . Lua a -> Lua a -> Lua a -alternative x y = Catch.try x >>= \case - Left (_ :: PandocError) -> y - Right x' -> return x' - --- | Add more context to an error -addContextToException :: forall a . String -> Lua a -> Lua a -addContextToException ctx op = op `Catch.catch` \case - PandocLuaError msg -> Catch.throwM $ PandocLuaError (T.pack ctx <> msg) - e -> Catch.throwM e - --- | Catch a @'PandocError'@ exception and raise it as a Lua error. -exceptionToError :: Lua NumResults -> Lua NumResults -exceptionToError op = op `Catch.catch` \e -> do - pushPandocError e - Lua.error +import qualified HsLua as Lua + +addContextToException :: () +addContextToException = undefined + +-- | Retrieve a @'PandocError'@ from the Lua stack. +popPandocError :: LuaE PandocError PandocError +popPandocError = do + errResult <- runPeek $ peekPandocError top + case resultToEither errResult of + Right x -> return x + Left err -> return $ PandocLuaError (T.pack err) + +-- Ensure conversions between Lua errors and 'PandocError' exceptions +-- are possible. +instance LuaError PandocError where + popException = popPandocError + pushException = pushPandocError + luaException = PandocLuaError . T.pack + +instance PeekError PandocError where + messageFromException = \case + PandocLuaError m -> T.unpack m + err -> show err diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index 01bf90efa..9a06dcac6 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Lua.Filter Copyright : © 2012-2021 John MacFarlane, @@ -19,43 +22,42 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction , module Text.Pandoc.Lua.Walk ) where import Control.Applicative ((<|>)) -import Control.Monad (mplus, (>=>)) -import Control.Monad.Catch (finally, try) +import Control.Monad (mplus, (>=>), (<$!>)) import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf, showConstr, toConstr, tyconUQname) import Data.Foldable (foldrM) import Data.List (foldl') import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +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.List (List (..)) +import Text.Pandoc.Lua.Marshaling.AST +import Text.Pandoc.Lua.Marshaling.List (List (..), peekList') import Text.Pandoc.Lua.Walk (SingletonsList (..)) import Text.Pandoc.Walk (Walkable (walkM)) import qualified Data.Map.Strict as Map -import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Lua.Util as LuaUtil -- | Transform document using the filter defined in the given file. -runFilterFile :: FilePath -> Pandoc -> Lua Pandoc +runFilterFile :: FilePath -> Pandoc -> LuaE PandocError Pandoc runFilterFile filterPath doc = do - top <- Lua.gettop + oldtop <- Lua.gettop stat <- LuaUtil.dofileWithTraceback filterPath if stat /= Lua.OK - then Lua.throwTopMessage + then Lua.throwErrorAsException else do newtop <- Lua.gettop -- Use the returned filters, or the implicitly defined global -- filter if nothing was returned. - luaFilters <- if newtop - top >= 1 - then Lua.peek Lua.stackTop + luaFilters <- if newtop - oldtop >= 1 + then Lua.peek Lua.top else Lua.pushglobaltable *> fmap (:[]) Lua.popValue runAll luaFilters doc -runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc +runAll :: [LuaFilter] -> Pandoc -> LuaE PandocError Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return -- | Filter function stored in the registry @@ -63,7 +65,7 @@ newtype LuaFilterFunction = LuaFilterFunction Lua.Reference -- | Collection of filter functions (at most one function per element -- constructor) -newtype LuaFilter = LuaFilter (Map String LuaFilterFunction) +newtype LuaFilter = LuaFilter (Map Name LuaFilterFunction) instance Peekable LuaFilter where peek idx = do @@ -79,19 +81,19 @@ instance Peekable LuaFilter where return $ case filterFn of Nothing -> acc Just fn -> Map.insert constr fn acc - LuaFilter <$> foldrM go Map.empty constrs + LuaFilter <$!> foldrM go Map.empty constrs -- | Register the function at the top of the stack as a filter function in the -- registry. -registerFilterFunction :: Lua (Maybe LuaFilterFunction) +registerFilterFunction :: LuaError e => LuaE e (Maybe LuaFilterFunction) registerFilterFunction = do - isFn <- Lua.isfunction Lua.stackTop + isFn <- Lua.isfunction Lua.top if isFn then Just . LuaFilterFunction <$> Lua.ref Lua.registryindex else Nothing <$ Lua.pop 1 -- | Retrieve filter function from registry and push it to the top of the stack. -pushFilterFunction :: LuaFilterFunction -> Lua () +pushFilterFunction :: LuaFilterFunction -> LuaE PandocError () pushFilterFunction (LuaFilterFunction fnRef) = Lua.getref Lua.registryindex fnRef @@ -99,58 +101,66 @@ pushFilterFunction (LuaFilterFunction fnRef) = -- element instead of a list, fetch that element as a singleton list. If the top -- of the stack is nil, return the default element that was passed to this -- function. If none of these apply, raise an error. -elementOrList :: Peekable a => a -> Lua [a] -elementOrList x = do - let topOfStack = Lua.stackTop - elementUnchanged <- Lua.isnil topOfStack +elementOrList :: Peeker PandocError a -> a -> LuaE PandocError [a] +elementOrList p x = do + elementUnchanged <- Lua.isnil top if elementUnchanged - then [x] <$ Lua.pop 1 - else do - mbres <- peekEither topOfStack - case mbres of - Right res -> [res] <$ Lua.pop 1 - Left _ -> Lua.peekList topOfStack `finally` Lua.pop 1 + then [x] <$ pop 1 + else forcePeek . (`lastly` pop 1) $ (((:[]) <$!> p top) <|> peekList p top) + +-- | Fetches a single element; returns the fallback if the value is @nil@. +singleElement :: forall a e. (LuaError e) => Peeker e a -> a -> LuaE e a +singleElement p x = do + elementUnchanged <- Lua.isnil top + if elementUnchanged + then x <$ Lua.pop 1 + else forcePeek $ p top `lastly` pop 1 -- | Pop and return a value from the stack; if the value at the top of -- the stack is @nil@, return the fallback element. -popOption :: Peekable a => a -> Lua a -popOption fallback = fromMaybe fallback . Lua.fromOptional <$> Lua.popValue +popOption :: Peeker PandocError a -> a -> LuaE PandocError a +popOption peeker fallback = forcePeek . (`lastly` pop 1) $ + (fallback <$ peekNil top) <|> peeker top -- | Apply filter on a sequence of AST elements. Both lists and single -- value are accepted as filter function return values. -runOnSequence :: (Data a, Peekable a, Pushable a) - => LuaFilter -> SingletonsList a -> Lua (SingletonsList a) -runOnSequence (LuaFilter fnMap) (SingletonsList xs) = +runOnSequence :: forall a. (Data a, Pushable a) + => Peeker PandocError a -> LuaFilter -> SingletonsList a + -> LuaE PandocError (SingletonsList a) +runOnSequence peeker (LuaFilter fnMap) (SingletonsList xs) = SingletonsList <$> mconcatMapM tryFilter xs where - tryFilter :: (Data a, Peekable a, Pushable a) => a -> Lua [a] + tryFilter :: a -> LuaE PandocError [a] tryFilter x = - let filterFnName = showConstr (toConstr x) - catchAllName = tyconUQname $ dataTypeName (dataTypeOf x) + let filterFnName = fromString $ showConstr (toConstr x) + catchAllName = fromString . tyconUQname $ dataTypeName (dataTypeOf x) in case Map.lookup filterFnName fnMap <|> Map.lookup catchAllName fnMap of - Just fn -> runFilterFunction fn x *> elementOrList x + Just fn -> runFilterFunction fn x *> elementOrList peeker x Nothing -> return [x] -- | Try filtering the given value without type error corrections on -- the return value. -runOnValue :: (Data a, Peekable a, Pushable a) - => String -> LuaFilter -> a -> Lua a -runOnValue filterFnName (LuaFilter fnMap) x = +runOnValue :: (Data a, Pushable a) + => Name -> Peeker PandocError a + -> LuaFilter -> a + -> LuaE PandocError a +runOnValue filterFnName peeker (LuaFilter fnMap) x = case Map.lookup filterFnName fnMap of - Just fn -> runFilterFunction fn x *> popOption x + Just fn -> runFilterFunction fn x *> popOption peeker x Nothing -> return x --- | Push a value to the stack via a lua filter function. The filter function is --- called with given element as argument and is expected to return an element. --- Alternatively, the function can return nothing or nil, in which case the --- element is left unchanged. -runFilterFunction :: Pushable a => LuaFilterFunction -> a -> Lua () +-- | Push a value to the stack via a Lua filter function. The filter +-- function is called with the given element as argument and is expected +-- to return an element. Alternatively, the function can return nothing +-- or nil, in which case the element is left unchanged. +runFilterFunction :: Pushable a + => LuaFilterFunction -> a -> LuaE PandocError () runFilterFunction lf x = do pushFilterFunction lf Lua.push x LuaUtil.callWithTraceback 1 1 -walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc +walkMWithLuaFilter :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc walkMWithLuaFilter f = walkInlines f >=> walkInlineLists f @@ -162,92 +172,76 @@ walkMWithLuaFilter f = mconcatMapM :: (Monad m) => (a -> m [a]) -> [a] -> m [a] mconcatMapM f = fmap mconcat . mapM f -hasOneOf :: LuaFilter -> [String] -> Bool +hasOneOf :: LuaFilter -> [Name] -> Bool hasOneOf (LuaFilter fnMap) = any (`Map.member` fnMap) -contains :: LuaFilter -> String -> Bool +contains :: LuaFilter -> Name -> Bool contains (LuaFilter fnMap) = (`Map.member` fnMap) -walkInlines :: Walkable (SingletonsList Inline) a => LuaFilter -> a -> Lua a +walkInlines :: Walkable (SingletonsList Inline) a + => LuaFilter -> a -> LuaE PandocError a walkInlines lf = - let f :: SingletonsList Inline -> Lua (SingletonsList Inline) - f = runOnSequence lf + let f :: SingletonsList Inline -> LuaE PandocError (SingletonsList Inline) + f = runOnSequence peekInline lf in if lf `hasOneOf` inlineElementNames then walkM f else return -walkInlineLists :: Walkable (List Inline) a => LuaFilter -> a -> Lua a +walkInlineLists :: Walkable (List Inline) a + => LuaFilter -> a -> LuaE PandocError a walkInlineLists lf = - let f :: List Inline -> Lua (List Inline) - f = runOnValue listOfInlinesFilterName lf + let f :: List Inline -> LuaE PandocError (List Inline) + f = runOnValue listOfInlinesFilterName (peekList' peekInline) lf in if lf `contains` listOfInlinesFilterName then walkM f else return -walkBlocks :: Walkable (SingletonsList Block) a => LuaFilter -> a -> Lua a +walkBlocks :: Walkable (SingletonsList Block) a + => LuaFilter -> a -> LuaE PandocError a walkBlocks lf = - let f :: SingletonsList Block -> Lua (SingletonsList Block) - f = runOnSequence lf + let f :: SingletonsList Block -> LuaE PandocError (SingletonsList Block) + f = runOnSequence peekBlock lf in if lf `hasOneOf` blockElementNames then walkM f else return -walkBlockLists :: Walkable (List Block) a => LuaFilter -> a -> Lua a +walkBlockLists :: Walkable (List Block) a + => LuaFilter -> a -> LuaE PandocError a walkBlockLists lf = - let f :: List Block -> Lua (List Block) - f = runOnValue listOfBlocksFilterName lf + let f :: List Block -> LuaE PandocError (List Block) + f = runOnValue listOfBlocksFilterName (peekList' peekBlock) lf in if lf `contains` listOfBlocksFilterName then walkM f else return -walkMeta :: LuaFilter -> Pandoc -> Lua Pandoc +walkMeta :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc walkMeta lf (Pandoc m bs) = do - m' <- runOnValue "Meta" lf m + m' <- runOnValue "Meta" peekMeta lf m return $ Pandoc m' bs -walkPandoc :: LuaFilter -> Pandoc -> Lua Pandoc +walkPandoc :: LuaFilter -> Pandoc -> LuaE PandocError Pandoc walkPandoc (LuaFilter fnMap) = case foldl' mplus Nothing (map (`Map.lookup` fnMap) pandocFilterNames) of - Just fn -> \x -> runFilterFunction fn x *> singleElement x + Just fn -> \x -> runFilterFunction fn x *> singleElement peekPandoc x Nothing -> return -constructorsFor :: DataType -> [String] -constructorsFor x = map show (dataTypeConstrs x) +constructorsFor :: DataType -> [Name] +constructorsFor x = map (fromString . show) (dataTypeConstrs x) -inlineElementNames :: [String] +inlineElementNames :: [Name] inlineElementNames = "Inline" : constructorsFor (dataTypeOf (Str mempty)) -blockElementNames :: [String] +blockElementNames :: [Name] blockElementNames = "Block" : constructorsFor (dataTypeOf (Para [])) -listOfInlinesFilterName :: String +listOfInlinesFilterName :: Name listOfInlinesFilterName = "Inlines" -listOfBlocksFilterName :: String +listOfBlocksFilterName :: Name listOfBlocksFilterName = "Blocks" -metaFilterName :: String +metaFilterName :: Name metaFilterName = "Meta" -pandocFilterNames :: [String] +pandocFilterNames :: [Name] pandocFilterNames = ["Pandoc", "Doc"] - -singleElement :: Peekable a => a -> Lua a -singleElement x = do - elementUnchanged <- Lua.isnil (-1) - if elementUnchanged - then x <$ Lua.pop 1 - else do - mbres <- peekEither (-1) - case mbres of - Right res -> res <$ Lua.pop 1 - Left err -> do - Lua.pop 1 - Lua.throwMessage - ("Error while trying to get a filter's return " <> - "value from Lua stack.\n" <> show err) - --- | Try to convert the value at the given stack index to a Haskell value. --- Returns @Left@ with an error message on failure. -peekEither :: Peekable a => StackIndex -> Lua (Either PandocError a) -peekEither = try . Lua.peek diff --git a/src/Text/Pandoc/Lua/Global.hs b/src/Text/Pandoc/Lua/Global.hs index 29b788f04..df300a8c6 100644 --- a/src/Text/Pandoc/Lua/Global.hs +++ b/src/Text/Pandoc/Lua/Global.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua Copyright : Copyright © 2017-2021 Albert Krewinkel @@ -14,19 +14,17 @@ module Text.Pandoc.Lua.Global , setGlobals ) where -import Data.Data (Data) -import Foreign.Lua (Lua, Peekable, Pushable) -import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable - , metatableName) +import HsLua as Lua 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.Util (addFunction) +import Text.Pandoc.Lua.Marshaling.CommonState (pushCommonState) +import Text.Pandoc.Lua.Marshaling.ReaderOptions (pushReaderOptions) import Text.Pandoc.Options (ReaderOptions) import qualified Data.Text as Text -import qualified Foreign.Lua as Lua -- | Permissible global Lua variables. data Global = @@ -40,10 +38,10 @@ data Global = -- Cannot derive instance of Data because of CommonState -- | Set all given globals. -setGlobals :: [Global] -> Lua () +setGlobals :: [Global] -> LuaE PandocError () setGlobals = mapM_ setGlobal -setGlobal :: Global -> Lua () +setGlobal :: Global -> LuaE PandocError () setGlobal global = case global of -- This could be simplified if Global was an instance of Data. FORMAT format -> do @@ -53,37 +51,24 @@ setGlobal global = case global of Lua.push pandocTypesVersion Lua.setglobal "PANDOC_API_VERSION" PANDOC_DOCUMENT doc -> do - Lua.push (LazyPandoc doc) + pushUD typePandocLazy doc Lua.setglobal "PANDOC_DOCUMENT" PANDOC_READER_OPTIONS ropts -> do - Lua.push ropts + pushReaderOptions ropts Lua.setglobal "PANDOC_READER_OPTIONS" PANDOC_SCRIPT_FILE filePath -> do Lua.push filePath Lua.setglobal "PANDOC_SCRIPT_FILE" PANDOC_STATE commonState -> do - Lua.push commonState + pushCommonState commonState Lua.setglobal "PANDOC_STATE" PANDOC_VERSION -> do Lua.push version Lua.setglobal "PANDOC_VERSION" -- | Readonly and lazy pandoc objects. -newtype LazyPandoc = LazyPandoc Pandoc - deriving (Data) - -instance Pushable LazyPandoc where - push lazyDoc = pushAnyWithMetatable pushPandocMetatable lazyDoc - where - pushPandocMetatable = ensureUserdataMetatable (metatableName lazyDoc) $ - addFunction "__index" indexLazyPandoc - -instance Peekable LazyPandoc where - peek = Lua.peekAny - -indexLazyPandoc :: LazyPandoc -> String -> Lua Lua.NumResults -indexLazyPandoc (LazyPandoc (Pandoc meta blks)) field = 1 <$ - case field of - "blocks" -> Lua.push blks - "meta" -> Lua.push meta - _ -> Lua.pushnil +typePandocLazy :: LuaError e => DocumentedType e Pandoc +typePandocLazy = deftype "Pandoc (lazy)" [] + [ readonly "meta" "document metadata" (push, \(Pandoc meta _) -> meta) + , readonly "blocks" "content blocks" (push, \(Pandoc _ blocks) -> blocks) + ] diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs index 94691666c..a9c3695a4 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua Copyright : Copyright © 2017-2021 Albert Krewinkel @@ -13,23 +14,23 @@ module Text.Pandoc.Lua.Init ) where import Control.Monad (when) -import Control.Monad.Catch (try) +import Control.Monad.Catch (throwM, try) import Control.Monad.Trans (MonadIO (..)) import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) -import Foreign.Lua (Lua) +import HsLua as Lua hiding (status, try) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) -import Text.Pandoc.Class.PandocMonad (readDataFile, PandocMonad) -import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Class.PandocMonad (PandocMonad, readDataFile) +import Text.Pandoc.Error (PandocError (PandocLuaError)) import Text.Pandoc.Lua.Packages (installPandocPackageSearcher) import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua) -import Text.Pandoc.Lua.Util (throwTopMessageAsError') -import qualified Foreign.Lua as Lua +import qualified Data.Text as T 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 -- initialization. -runLua :: (PandocMonad m, MonadIO m) => Lua a -> m (Either PandocError a) +runLua :: (PandocMonad m, MonadIO m) + => LuaE PandocError a -> m (Either PandocError a) runLua luaOp = do enc <- liftIO $ getForeignEncoding <* setForeignEncoding utf8 res <- runPandocLua . try $ do @@ -52,9 +53,9 @@ initLuaState = do ModulePandoc.pushModule -- register as loaded module liftPandocLua $ do - Lua.pushvalue Lua.stackTop - Lua.getfield Lua.registryindex Lua.loadedTableRegistryField - Lua.setfield (Lua.nthFromTop 2) "pandoc" + Lua.pushvalue Lua.top + Lua.getfield Lua.registryindex Lua.loaded + Lua.setfield (Lua.nth 2) "pandoc" Lua.pop 1 -- copy constructors into registry putConstructorsInRegistry @@ -65,10 +66,12 @@ initLuaState = do loadInitScript scriptFile = do script <- readDataFile scriptFile status <- liftPandocLua $ Lua.dostring script - when (status /= Lua.OK) . liftPandocLua $ - throwTopMessageAsError' - (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) - + when (status /= Lua.OK) . liftPandocLua $ do + err <- popException + let prefix = "Couldn't load '" <> T.pack scriptFile <> "':\n" + throwM . PandocLuaError . (prefix <>) $ case err of + PandocLuaError msg -> msg + _ -> T.pack $ show err -- | AST elements are marshaled via normal constructor functions in the -- @pandoc@ module. However, accessing Lua globals from Haskell is @@ -91,12 +94,12 @@ putConstructorsInRegistry = liftPandocLua $ do putInReg "List" -- pandoc.List putInReg "SimpleTable" -- helper for backward-compatible table handling where - constrsToReg :: Data a => a -> Lua () + constrsToReg :: Data a => a -> LuaE PandocError () constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf - putInReg :: String -> Lua () + putInReg :: String -> LuaE PandocError () putInReg name = do Lua.push ("pandoc." ++ name) -- name in registry Lua.push name -- in pandoc module - Lua.rawget (Lua.nthFromTop 3) + Lua.rawget (Lua.nth 3) Lua.rawset Lua.registryindex diff --git a/src/Text/Pandoc/Lua/Marshaling.hs b/src/Text/Pandoc/Lua/Marshaling.hs index f517c7c27..8fde94958 100644 --- a/src/Text/Pandoc/Lua/Marshaling.hs +++ b/src/Text/Pandoc/Lua/Marshaling.hs @@ -17,3 +17,4 @@ import Text.Pandoc.Lua.Marshaling.Context () import Text.Pandoc.Lua.Marshaling.PandocError() import Text.Pandoc.Lua.Marshaling.ReaderOptions () import Text.Pandoc.Lua.Marshaling.Version () +import Text.Pandoc.Lua.ErrorConversion () diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs index 8e12d232c..eedf00a94 100644 --- a/src/Text/Pandoc/Lua/Marshaling/AST.hs +++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.AST Copyright : © 2012-2021 John MacFarlane @@ -13,223 +15,254 @@ Marshaling/unmarshaling instances for document AST elements. -} module Text.Pandoc.Lua.Marshaling.AST - ( LuaAttr (..) - , LuaListAttributes (..) + ( peekAttr + , peekBlock + , peekBlocks + , peekCaption + , peekCitation + , peekInline + , peekInlines + , peekListAttributes + , peekMeta + , peekMetaValue + , peekPandoc + + , pushAttr + , pushBlock + , pushInline + , pushListAttributes + , pushMetaValue + , pushPandoc ) where -import Control.Applicative ((<|>)) -import Control.Monad ((<$!>)) -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import Control.Applicative ((<|>), optional) +import Control.Monad ((<$!>), (>=>)) +import HsLua hiding (Operation (Div)) import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) +import Text.Pandoc.Lua.Util (pushViaConstr', pushViaConstructor) import Text.Pandoc.Lua.Marshaling.CommonState () -import qualified Control.Monad.Catch as Catch -import qualified Foreign.Lua as Lua +import qualified HsLua as Lua import qualified Text.Pandoc.Lua.Util as LuaUtil instance Pushable Pandoc where - push (Pandoc meta blocks) = - pushViaConstructor "Pandoc" blocks meta + push = pushPandoc -instance Peekable Pandoc where - peek idx = defineHowTo "get Pandoc value" $! Pandoc - <$!> LuaUtil.rawField idx "meta" - <*> LuaUtil.rawField idx "blocks" +pushPandoc :: LuaError e => Pusher e Pandoc +pushPandoc (Pandoc meta blocks) = + pushViaConstr' "Pandoc" [pushList pushBlock blocks, push meta] + +peekPandoc :: LuaError e => Peeker e Pandoc +peekPandoc = fmap (retrieving "Pandoc value") + . typeChecked "table" Lua.istable $ \idx -> do + meta <- peekFieldRaw peekMeta "meta" idx + blks <- peekFieldRaw peekBlocks "blocks" idx + return $ Pandoc meta blks instance Pushable Meta where push (Meta mmap) = - pushViaConstructor "Meta" mmap -instance Peekable Meta where - peek idx = defineHowTo "get Meta value" $! - Meta <$!> Lua.peek idx + pushViaConstr' "Meta" [push mmap] + +peekMeta :: LuaError e => Peeker e Meta +peekMeta idx = retrieving "Meta" $ + Meta <$!> peekMap peekText peekMetaValue idx instance Pushable MetaValue where push = pushMetaValue -instance Peekable MetaValue where - peek = peekMetaValue instance Pushable Block where push = pushBlock -instance Peekable Block where - peek = peekBlock - -- Inline instance Pushable Inline where push = pushInline -instance Peekable Inline where - peek = peekInline - -- Citation instance Pushable Citation where push (Citation cid prefix suffix mode noteNum hash) = - pushViaConstructor "Citation" cid mode prefix suffix noteNum hash + pushViaConstr' "Citation" + [ push cid, push mode, push prefix, push suffix, push noteNum, push hash + ] + +peekCitation :: LuaError e => Peeker e Citation +peekCitation = fmap (retrieving "Citation") + . typeChecked "table" Lua.istable $ \idx -> do + idx' <- liftLua $ absindex idx + Citation + <$!> peekFieldRaw peekText "id" idx' + <*> peekFieldRaw (peekList peekInline) "prefix" idx' + <*> peekFieldRaw (peekList peekInline) "suffix" idx' + <*> peekFieldRaw peekRead "mode" idx' + <*> peekFieldRaw peekIntegral "note_num" idx' + <*> peekFieldRaw peekIntegral "hash" idx' -instance Peekable Citation where - peek idx = Citation - <$!> LuaUtil.rawField idx "id" - <*> LuaUtil.rawField idx "prefix" - <*> LuaUtil.rawField idx "suffix" - <*> LuaUtil.rawField idx "mode" - <*> LuaUtil.rawField idx "note_num" - <*> LuaUtil.rawField idx "hash" instance Pushable Alignment where - push = Lua.push . show -instance Peekable Alignment where - peek = Lua.peekRead + push = Lua.pushString . show instance Pushable CitationMode where push = Lua.push . show -instance Peekable CitationMode where - peek = Lua.peekRead instance Pushable Format where push (Format f) = Lua.push f -instance Peekable Format where - peek idx = Format <$!> Lua.peek idx + +peekFormat :: LuaError e => Peeker e Format +peekFormat idx = Format <$!> peekText idx instance Pushable ListNumberDelim where push = Lua.push . show -instance Peekable ListNumberDelim where - peek = Lua.peekRead instance Pushable ListNumberStyle where push = Lua.push . show -instance Peekable ListNumberStyle where - peek = Lua.peekRead instance Pushable MathType where push = Lua.push . show -instance Peekable MathType where - peek = Lua.peekRead instance Pushable QuoteType where push = Lua.push . show -instance Peekable QuoteType where - peek = Lua.peekRead -- | Push an meta value element to the top of the lua stack. -pushMetaValue :: MetaValue -> Lua () +pushMetaValue :: LuaError e => MetaValue -> LuaE e () pushMetaValue = \case - MetaBlocks blcks -> pushViaConstructor "MetaBlocks" blcks + MetaBlocks blcks -> pushViaConstr' "MetaBlocks" [pushList pushBlock blcks] MetaBool bool -> Lua.push bool - MetaInlines inlns -> pushViaConstructor "MetaInlines" inlns - MetaList metalist -> pushViaConstructor "MetaList" metalist - MetaMap metamap -> pushViaConstructor "MetaMap" metamap + MetaInlines inlns -> pushViaConstr' "MetaInlines" + [pushList pushInline inlns] + MetaList metalist -> pushViaConstr' "MetaList" + [pushList pushMetaValue metalist] + MetaMap metamap -> pushViaConstr' "MetaMap" + [pushMap pushText pushMetaValue metamap] MetaString str -> Lua.push str -- | Interpret the value at the given stack index as meta value. -peekMetaValue :: StackIndex -> Lua MetaValue -peekMetaValue idx = defineHowTo "get MetaValue" $ do +peekMetaValue :: forall e. LuaError e => Peeker e MetaValue +peekMetaValue = retrieving "MetaValue $ " . \idx -> do -- Get the contents of an AST element. - let elementContent :: Peekable a => Lua a - elementContent = Lua.peek idx - luatype <- Lua.ltype idx + let mkMV :: (a -> MetaValue) -> Peeker e a -> Peek e MetaValue + mkMV f p = f <$!> p idx + + peekTagged = \case + "MetaBlocks" -> mkMV MetaBlocks $ + retrieving "MetaBlocks" . peekBlocks + "MetaBool" -> mkMV MetaBool $ + retrieving "MetaBool" . peekBool + "MetaMap" -> mkMV MetaMap $ + retrieving "MetaMap" . peekMap peekText peekMetaValue + "MetaInlines" -> mkMV MetaInlines $ + retrieving "MetaInlines" . peekInlines + "MetaList" -> mkMV MetaList $ + retrieving "MetaList" . peekList peekMetaValue + "MetaString" -> mkMV MetaString $ + retrieving "MetaString" . peekText + (Name t) -> failPeek ("Unknown meta tag: " <> t) + + peekUntagged = do + -- no meta value tag given, try to guess. + len <- liftLua $ Lua.rawlen idx + if len <= 0 + then MetaMap <$!> peekMap peekText peekMetaValue idx + else (MetaInlines <$!> peekInlines idx) + <|> (MetaBlocks <$!> peekBlocks idx) + <|> (MetaList <$!> peekList peekMetaValue idx) + luatype <- liftLua $ Lua.ltype idx case luatype of - Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx - Lua.TypeString -> MetaString <$!> Lua.peek idx + Lua.TypeBoolean -> MetaBool <$!> peekBool idx + Lua.TypeString -> MetaString <$!> peekText idx Lua.TypeTable -> do - tag <- try $ LuaUtil.getTag idx - case tag of - Right "MetaBlocks" -> MetaBlocks <$!> elementContent - Right "MetaBool" -> MetaBool <$!> elementContent - Right "MetaMap" -> MetaMap <$!> elementContent - Right "MetaInlines" -> MetaInlines <$!> elementContent - Right "MetaList" -> MetaList <$!> elementContent - Right "MetaString" -> MetaString <$!> elementContent - Right t -> Lua.throwMessage ("Unknown meta tag: " <> t) - Left _ -> do - -- no meta value tag given, try to guess. - len <- Lua.rawlen idx - if len <= 0 - then MetaMap <$!> Lua.peek idx - else (MetaInlines <$!> Lua.peek idx) - <|> (MetaBlocks <$!> Lua.peek idx) - <|> (MetaList <$!> Lua.peek idx) - _ -> Lua.throwMessage "could not get meta value" + optional (LuaUtil.getTag idx) >>= \case + Just tag -> peekTagged tag + Nothing -> peekUntagged + _ -> failPeek "could not get meta value" -- | Push a block element to the top of the Lua stack. -pushBlock :: Block -> Lua () +pushBlock :: forall e. LuaError e => Block -> LuaE e () pushBlock = \case - BlockQuote blcks -> pushViaConstructor "BlockQuote" blcks - BulletList items -> pushViaConstructor "BulletList" items - CodeBlock attr code -> pushViaConstructor "CodeBlock" code (LuaAttr attr) - DefinitionList items -> pushViaConstructor "DefinitionList" items - Div attr blcks -> pushViaConstructor "Div" blcks (LuaAttr attr) - Header lvl attr inlns -> pushViaConstructor "Header" lvl inlns (LuaAttr attr) - HorizontalRule -> pushViaConstructor "HorizontalRule" - LineBlock blcks -> pushViaConstructor "LineBlock" blcks - OrderedList lstAttr list -> pushViaConstructor "OrderedList" list - (LuaListAttributes lstAttr) - Null -> pushViaConstructor "Null" - Para blcks -> pushViaConstructor "Para" blcks - Plain blcks -> pushViaConstructor "Plain" blcks - RawBlock f cs -> pushViaConstructor "RawBlock" f cs + BlockQuote blcks -> pushViaConstructor @e "BlockQuote" blcks + BulletList items -> pushViaConstructor @e "BulletList" items + CodeBlock attr code -> pushViaConstr' @e "CodeBlock" + [ push code, pushAttr attr ] + DefinitionList items -> pushViaConstructor @e "DefinitionList" items + Div attr blcks -> pushViaConstr' @e "Div" + [push blcks, pushAttr attr] + Header lvl attr inlns -> pushViaConstr' @e "Header" + [push lvl, push inlns, pushAttr attr] + HorizontalRule -> pushViaConstructor @e "HorizontalRule" + LineBlock blcks -> pushViaConstructor @e "LineBlock" blcks + OrderedList lstAttr list -> pushViaConstr' @e "OrderedList" + [ push list, pushListAttributes @e lstAttr ] + Null -> pushViaConstructor @e "Null" + Para blcks -> pushViaConstructor @e "Para" blcks + Plain blcks -> pushViaConstructor @e "Plain" blcks + RawBlock f cs -> pushViaConstructor @e "RawBlock" f cs Table attr blkCapt specs thead tbody tfoot -> - pushViaConstructor "Table" blkCapt specs thead tbody tfoot attr + pushViaConstr' @e "Table" + [ pushCaption blkCapt, push specs, push thead, push tbody + , push tfoot, pushAttr attr] -- | Return the value at the given index as block if possible. -peekBlock :: StackIndex -> Lua Block -peekBlock idx = defineHowTo "get Block value" $! do - tag <- LuaUtil.getTag idx - case tag of - "BlockQuote" -> BlockQuote <$!> elementContent - "BulletList" -> BulletList <$!> elementContent - "CodeBlock" -> withAttr CodeBlock <$!> elementContent - "DefinitionList" -> DefinitionList <$!> elementContent - "Div" -> withAttr Div <$!> elementContent - "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) - <$!> elementContent +peekBlock :: forall e. LuaError e => Peeker e Block +peekBlock = fmap (retrieving "Block") + . typeChecked "table" Lua.istable + $ \idx -> do + -- Get the contents of an AST element. + let mkBlock :: (a -> Block) -> Peeker e a -> Peek e Block + mkBlock f p = f <$!> peekFieldRaw p "c" idx + LuaUtil.getTag idx >>= \case + "BlockQuote" -> mkBlock BlockQuote peekBlocks + "BulletList" -> mkBlock BulletList (peekList peekBlocks) + "CodeBlock" -> mkBlock (uncurry CodeBlock) + (peekPair peekAttr peekText) + "DefinitionList" -> mkBlock DefinitionList + (peekList (peekPair peekInlines (peekList peekBlocks))) + "Div" -> mkBlock (uncurry Div) (peekPair peekAttr peekBlocks) + "Header" -> mkBlock (\(lvl, attr, lst) -> Header lvl attr lst) + (peekTriple peekIntegral peekAttr peekInlines) "HorizontalRule" -> return HorizontalRule - "LineBlock" -> LineBlock <$!> elementContent - "OrderedList" -> (\(LuaListAttributes lstAttr, lst) -> - OrderedList lstAttr lst) - <$!> elementContent + "LineBlock" -> mkBlock LineBlock (peekList peekInlines) + "OrderedList" -> mkBlock (uncurry OrderedList) + (peekPair peekListAttributes (peekList peekBlocks)) "Null" -> return Null - "Para" -> Para <$!> elementContent - "Plain" -> Plain <$!> elementContent - "RawBlock" -> uncurry RawBlock <$!> elementContent - "Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) -> - Table (fromLuaAttr attr) - capt - colSpecs - thead - tbodies - tfoot) - <$!> elementContent - _ -> Lua.throwMessage ("Unknown block type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - -instance Pushable Caption where - push = pushCaption - -instance Peekable Caption where - peek = peekCaption + "Para" -> mkBlock Para peekInlines + "Plain" -> mkBlock Plain peekInlines + "RawBlock" -> mkBlock (uncurry RawBlock) + (peekPair peekFormat peekText) + "Table" -> mkBlock id + (retrieving "Table" . (liftLua . absindex >=> (\idx' -> cleanup $ do + attr <- liftLua (rawgeti idx' 1) *> peekAttr top + capt <- liftLua (rawgeti idx' 2) *> peekCaption top + cs <- liftLua (rawgeti idx' 3) *> peekList peekColSpec top + thead <- liftLua (rawgeti idx' 4) *> peekTableHead top + tbods <- liftLua (rawgeti idx' 5) *> peekList peekTableBody top + tfoot <- liftLua (rawgeti idx' 6) *> peekTableFoot top + return $! Table attr capt cs thead tbods tfoot))) + Name tag -> failPeek ("Unknown block type: " <> tag) + +peekBlocks :: LuaError e => Peeker e [Block] +peekBlocks = peekList peekBlock + +peekInlines :: LuaError e => Peeker e [Inline] +peekInlines = peekList peekInline -- | Push Caption element -pushCaption :: Caption -> Lua () +pushCaption :: LuaError e => Caption -> LuaE e () pushCaption (Caption shortCaption longCaption) = do Lua.newtable LuaUtil.addField "short" (Lua.Optional shortCaption) LuaUtil.addField "long" longCaption -- | Peek Caption element -peekCaption :: StackIndex -> Lua Caption -peekCaption idx = Caption - <$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short") - <*> LuaUtil.rawField idx "long" +peekCaption :: LuaError e => Peeker e Caption +peekCaption = retrieving "Caption" . \idx -> do + short <- optional $ peekFieldRaw peekInlines "short" idx + long <- peekFieldRaw peekBlocks "long" idx + return $! Caption short long -instance Peekable ColWidth where - peek idx = do - width <- Lua.fromOptional <$!> Lua.peek idx - return $! maybe ColWidthDefault ColWidth width +peekColWidth :: LuaError e => Peeker e ColWidth +peekColWidth = retrieving "ColWidth" . \idx -> do + maybe ColWidthDefault ColWidth <$!> optional (peekRealFloat idx) + +peekColSpec :: LuaError e => Peeker e ColSpec +peekColSpec = peekPair peekRead peekColWidth instance Pushable ColWidth where push = \case @@ -240,7 +273,12 @@ instance Pushable Row where push (Row attr cells) = Lua.push (attr, cells) instance Peekable Row where - peek = fmap (uncurry Row) . Lua.peek + peek = forcePeek . peekRow + +peekRow :: LuaError e => Peeker e Row +peekRow = ((uncurry Row) <$!>) + . retrieving "Row" + . peekPair peekAttr (peekList peekCell) instance Pushable TableBody where push (TableBody attr (RowHeadColumns rowHeadColumns) head' body) = do @@ -250,32 +288,38 @@ instance Pushable TableBody where LuaUtil.addField "head" head' LuaUtil.addField "body" body -instance Peekable TableBody where - peek idx = TableBody - <$!> LuaUtil.rawField idx "attr" - <*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns") - <*> LuaUtil.rawField idx "head" - <*> LuaUtil.rawField idx "body" +peekTableBody :: LuaError e => Peeker e TableBody +peekTableBody = fmap (retrieving "TableBody") + . typeChecked "table" Lua.istable + $ \idx -> TableBody + <$!> peekFieldRaw peekAttr "attr" idx + <*> peekFieldRaw ((fmap RowHeadColumns) . peekIntegral) "row_head_columns" idx + <*> peekFieldRaw (peekList peekRow) "head" idx + <*> peekFieldRaw (peekList peekRow) "body" idx instance Pushable TableHead where push (TableHead attr rows) = Lua.push (attr, rows) -instance Peekable TableHead where - peek = fmap (uncurry TableHead) . Lua.peek +peekTableHead :: LuaError e => Peeker e TableHead +peekTableHead = ((uncurry TableHead) <$!>) + . retrieving "TableHead" + . peekPair peekAttr (peekList peekRow) instance Pushable TableFoot where push (TableFoot attr cells) = Lua.push (attr, cells) -instance Peekable TableFoot where - peek = fmap (uncurry TableFoot) . Lua.peek +peekTableFoot :: LuaError e => Peeker e TableFoot +peekTableFoot = ((uncurry TableFoot) <$!>) + . retrieving "TableFoot" + . peekPair peekAttr (peekList peekRow) instance Pushable Cell where push = pushCell instance Peekable Cell where - peek = peekCell + peek = forcePeek . peekCell -pushCell :: Cell -> Lua () +pushCell :: LuaError e => Cell -> LuaE e () pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do Lua.newtable LuaUtil.addField "attr" attr @@ -284,95 +328,112 @@ pushCell (Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents) = do LuaUtil.addField "col_span" colSpan LuaUtil.addField "contents" contents -peekCell :: StackIndex -> Lua Cell -peekCell idx = Cell - <$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr") - <*> LuaUtil.rawField idx "alignment" - <*> (RowSpan <$!> LuaUtil.rawField idx "row_span") - <*> (ColSpan <$!> LuaUtil.rawField idx "col_span") - <*> LuaUtil.rawField idx "contents" +peekCell :: LuaError e => Peeker e Cell +peekCell = fmap (retrieving "Cell") + . typeChecked "table" Lua.istable + $ \idx -> do + attr <- peekFieldRaw peekAttr "attr" idx + algn <- peekFieldRaw peekRead "alignment" idx + rs <- RowSpan <$!> peekFieldRaw peekIntegral "row_span" idx + cs <- ColSpan <$!> peekFieldRaw peekIntegral "col_span" idx + blks <- peekFieldRaw peekBlocks "contents" idx + return $! Cell attr algn rs cs blks -- | Push an inline element to the top of the lua stack. -pushInline :: Inline -> Lua () +pushInline :: forall e. LuaError e => Inline -> LuaE e () pushInline = \case - Cite citations lst -> pushViaConstructor "Cite" lst citations - Code attr lst -> pushViaConstructor "Code" lst (LuaAttr attr) - Emph inlns -> pushViaConstructor "Emph" inlns - Underline inlns -> pushViaConstructor "Underline" inlns - Image attr alt (src,tit) -> pushViaConstructor "Image" alt src tit (LuaAttr attr) - LineBreak -> pushViaConstructor "LineBreak" - Link attr lst (src,tit) -> pushViaConstructor "Link" lst src tit (LuaAttr attr) - Note blcks -> pushViaConstructor "Note" blcks - Math mty str -> pushViaConstructor "Math" mty str - Quoted qt inlns -> pushViaConstructor "Quoted" qt inlns - RawInline f cs -> pushViaConstructor "RawInline" f cs - SmallCaps inlns -> pushViaConstructor "SmallCaps" inlns - SoftBreak -> pushViaConstructor "SoftBreak" - Space -> pushViaConstructor "Space" - Span attr inlns -> pushViaConstructor "Span" inlns (LuaAttr attr) - Str str -> pushViaConstructor "Str" str - Strikeout inlns -> pushViaConstructor "Strikeout" inlns - Strong inlns -> pushViaConstructor "Strong" inlns - Subscript inlns -> pushViaConstructor "Subscript" inlns - Superscript inlns -> pushViaConstructor "Superscript" inlns + Cite citations lst -> pushViaConstructor @e "Cite" lst citations + Code attr lst -> pushViaConstr' @e "Code" + [push lst, pushAttr attr] + Emph inlns -> pushViaConstructor @e "Emph" inlns + Underline inlns -> pushViaConstructor @e "Underline" inlns + Image attr alt (src,tit) -> pushViaConstr' @e "Image" + [push alt, push src, push tit, pushAttr attr] + LineBreak -> pushViaConstructor @e "LineBreak" + Link attr lst (src,tit) -> pushViaConstr' @e "Link" + [push lst, push src, push tit, pushAttr attr] + Note blcks -> pushViaConstructor @e "Note" blcks + Math mty str -> pushViaConstructor @e "Math" mty str + Quoted qt inlns -> pushViaConstructor @e "Quoted" qt inlns + RawInline f cs -> pushViaConstructor @e "RawInline" f cs + SmallCaps inlns -> pushViaConstructor @e "SmallCaps" inlns + SoftBreak -> pushViaConstructor @e "SoftBreak" + Space -> pushViaConstructor @e "Space" + Span attr inlns -> pushViaConstr' @e "Span" + [push inlns, pushAttr attr] + Str str -> pushViaConstructor @e "Str" str + Strikeout inlns -> pushViaConstructor @e "Strikeout" inlns + Strong inlns -> pushViaConstructor @e "Strong" inlns + Subscript inlns -> pushViaConstructor @e "Subscript" inlns + Superscript inlns -> pushViaConstructor @e "Superscript" inlns -- | Return the value at the given index as inline if possible. -peekInline :: StackIndex -> Lua Inline -peekInline idx = defineHowTo "get Inline value" $ do - tag <- LuaUtil.getTag idx - case tag of - "Cite" -> uncurry Cite <$!> elementContent - "Code" -> withAttr Code <$!> elementContent - "Emph" -> Emph <$!> elementContent - "Underline" -> Underline <$!> elementContent - "Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt) - <$!> elementContent - "Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt) - <$!> elementContent +peekInline :: forall e. LuaError e => Peeker e Inline +peekInline = retrieving "Inline" . \idx -> do + -- Get the contents of an AST element. + let mkBlock :: (a -> Inline) -> Peeker e a -> Peek e Inline + mkBlock f p = f <$!> peekFieldRaw p "c" idx + LuaUtil.getTag idx >>= \case + "Cite" -> mkBlock (uncurry Cite) $ + peekPair (peekList peekCitation) peekInlines + "Code" -> mkBlock (uncurry Code) (peekPair peekAttr peekText) + "Emph" -> mkBlock Emph peekInlines + "Underline" -> mkBlock Underline peekInlines + "Image" -> mkBlock (\(attr, lst, tgt) -> Image attr lst tgt) + $ peekTriple peekAttr peekInlines + (peekPair peekText peekText) + "Link" -> mkBlock (\(attr, lst, tgt) -> Link attr lst tgt) $ + peekTriple peekAttr peekInlines (peekPair peekText peekText) "LineBreak" -> return LineBreak - "Note" -> Note <$!> elementContent - "Math" -> uncurry Math <$!> elementContent - "Quoted" -> uncurry Quoted <$!> elementContent - "RawInline" -> uncurry RawInline <$!> elementContent - "SmallCaps" -> SmallCaps <$!> elementContent + "Note" -> mkBlock Note peekBlocks + "Math" -> mkBlock (uncurry Math) (peekPair peekRead peekText) + "Quoted" -> mkBlock (uncurry Quoted) (peekPair peekRead peekInlines) + "RawInline" -> mkBlock (uncurry RawInline) (peekPair peekFormat peekText) + "SmallCaps" -> mkBlock SmallCaps peekInlines "SoftBreak" -> return SoftBreak "Space" -> return Space - "Span" -> withAttr Span <$!> elementContent - -- strict to Lua string is copied before gc - "Str" -> Str <$!> elementContent - "Strikeout" -> Strikeout <$!> elementContent - "Strong" -> Strong <$!> elementContent - "Subscript" -> Subscript <$!> elementContent - "Superscript"-> Superscript <$!> elementContent - _ -> Lua.throwMessage ("Unknown inline type: " <> tag) - where - -- Get the contents of an AST element. - elementContent :: Peekable a => Lua a - elementContent = LuaUtil.rawField idx "c" - -try :: Lua a -> Lua (Either PandocError a) -try = Catch.try - -withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b -withAttr f (attributes, x) = f (fromLuaAttr attributes) x - --- | Wrapper for Attr -newtype LuaAttr = LuaAttr { fromLuaAttr :: Attr } - -instance Pushable LuaAttr where - push (LuaAttr (id', classes, kv)) = - pushViaConstructor "Attr" id' classes kv - -instance Peekable LuaAttr where - peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx) - --- | Wrapper for ListAttributes -newtype LuaListAttributes = LuaListAttributes ListAttributes - -instance Pushable LuaListAttributes where - push (LuaListAttributes (start, style, delimiter)) = - pushViaConstructor "ListAttributes" start style delimiter - -instance Peekable LuaListAttributes where - peek = defineHowTo "get ListAttributes value" . - fmap LuaListAttributes . Lua.peek + "Span" -> mkBlock (uncurry Span) (peekPair peekAttr peekInlines) + "Str" -> mkBlock Str peekText + "Strikeout" -> mkBlock Strikeout peekInlines + "Strong" -> mkBlock Strong peekInlines + "Subscript" -> mkBlock Subscript peekInlines + "Superscript"-> mkBlock Superscript peekInlines + Name tag -> Lua.failPeek ("Unknown inline type: " <> tag) + +pushAttr :: forall e. LuaError e => Attr -> LuaE e () +pushAttr (id', classes, kv) = pushViaConstr' @e "Attr" + [ pushText id' + , pushList pushText classes + , pushList (pushPair pushText pushText) kv + ] + +peekAttr :: LuaError e => Peeker e Attr +peekAttr = retrieving "Attr" . peekTriple + peekText + (peekList peekText) + (peekList (peekPair peekText peekText)) + +pushListAttributes :: forall e. LuaError e => ListAttributes -> LuaE e () +pushListAttributes (start, style, delimiter) = + pushViaConstr' "ListAttributes" + [ push start, push style, push delimiter ] + +peekListAttributes :: LuaError e => Peeker e ListAttributes +peekListAttributes = retrieving "ListAttributes" . peekTriple + peekIntegral + peekRead + peekRead + +-- These instances exist only for testing. It's a hack to avoid making +-- the marshalling modules public. +instance Peekable Inline where + peek = forcePeek . peekInline + +instance Peekable Block where + peek = forcePeek . peekBlock + +instance Peekable Meta where + peek = forcePeek . peekMeta + +instance Peekable Pandoc where + peek = forcePeek . peekPandoc diff --git a/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs b/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs deleted file mode 100644 index 82e26b963..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/AnyValue.hs +++ /dev/null @@ -1,24 +0,0 @@ -{- | - Module : Text.Pandoc.Lua.Marshaling.AnyValue - Copyright : © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> - Stability : alpha - -Helper type to work with raw Lua stack indices instead of unmarshaled -values. - -TODO: Most of this module should be abstracted, factored out, and go -into HsLua. --} -module Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) where - -import Foreign.Lua (Peekable (peek), StackIndex) - --- | Dummy type to allow values of arbitrary Lua type. This just wraps --- stack indices, using it requires extra care. -newtype AnyValue = AnyValue StackIndex - -instance Peekable AnyValue where - peek = return . AnyValue diff --git a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs index 147197c5d..857551598 100644 --- a/src/Text/Pandoc/Lua/Marshaling/CommonState.hs +++ b/src/Text/Pandoc/Lua/Marshaling/CommonState.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua.Marshaling.CommonState @@ -11,92 +9,62 @@ Instances to marshal (push) and unmarshal (peek) the common state. -} -module Text.Pandoc.Lua.Marshaling.CommonState () where +module Text.Pandoc.Lua.Marshaling.CommonState + ( typeCommonState + , peekCommonState + , pushCommonState + ) where -import Foreign.Lua (Lua, Peekable, Pushable) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) +import HsLua.Core +import HsLua.Marshalling +import HsLua.Packaging import Text.Pandoc.Class (CommonState (..)) import Text.Pandoc.Logging (LogMessage, showLogMessage) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import Text.Pandoc.Lua.Marshaling.List (pushPandocList) -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +-- | Lua type used for the @CommonState@ object. +typeCommonState :: LuaError e => DocumentedType e CommonState +typeCommonState = deftype "pandoc CommonState" [] + [ readonly "input_files" "input files passed to pandoc" + (pushPandocList pushString, stInputFiles) --- | Name used by Lua for the @CommonState@ type. -commonStateTypeName :: String -commonStateTypeName = "Pandoc CommonState" + , readonly "output_file" "the file to which pandoc will write" + (maybe pushnil pushString, stOutputFile) -instance Peekable CommonState where - peek idx = reportValueOnFailure commonStateTypeName - (`toAnyWithName` commonStateTypeName) idx + , readonly "log" "list of log messages" + (pushPandocList (pushUD typeLogMessage), stLog) -instance Pushable CommonState where - push st = pushAnyWithMetatable pushCommonStateMetatable st - where - pushCommonStateMetatable = ensureUserdataMetatable commonStateTypeName $ do - LuaUtil.addFunction "__index" indexCommonState - LuaUtil.addFunction "__pairs" pairsCommonState + , readonly "request_headers" "headers to add for HTTP requests" + (pushPandocList (pushPair pushText pushText), stRequestHeaders) -indexCommonState :: CommonState -> AnyValue -> Lua Lua.NumResults -indexCommonState st (AnyValue idx) = Lua.ltype idx >>= \case - Lua.TypeString -> 1 <$ (Lua.peek idx >>= pushField) - _ -> 1 <$ Lua.pushnil - where - pushField :: Text.Text -> Lua () - pushField name = case lookup name commonStateFields of - Just pushValue -> pushValue st - Nothing -> Lua.pushnil + , readonly "resource_path" + "path to search for resources like included images" + (pushPandocList pushString, stResourcePath) -pairsCommonState :: CommonState -> Lua Lua.NumResults -pairsCommonState st = do - Lua.pushHaskellFunction nextFn - Lua.pushnil - Lua.pushnil - return 3 - where - nextFn :: AnyValue -> AnyValue -> Lua Lua.NumResults - nextFn _ (AnyValue idx) = - Lua.ltype idx >>= \case - Lua.TypeNil -> case commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (key, pushValue):_ -> 2 <$ (Lua.push key *> pushValue st) - Lua.TypeString -> do - key <- Lua.peek idx - case tail $ dropWhile ((/= key) . fst) commonStateFields of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (nextKey, pushValue):_ -> 2 <$ (Lua.push nextKey *> pushValue st) - _ -> 2 <$ (Lua.pushnil *> Lua.pushnil) + , readonly "source_url" "absolute URL + dir of 1st source file" + (maybe pushnil pushText, stSourceURL) -commonStateFields :: [(Text.Text, CommonState -> Lua ())] -commonStateFields = - [ ("input_files", Lua.push . stInputFiles) - , ("output_file", Lua.push . Lua.Optional . stOutputFile) - , ("log", Lua.push . stLog) - , ("request_headers", Lua.push . Map.fromList . stRequestHeaders) - , ("resource_path", Lua.push . stResourcePath) - , ("source_url", Lua.push . Lua.Optional . stSourceURL) - , ("user_data_dir", Lua.push . Lua.Optional . stUserDataDir) - , ("trace", Lua.push . stTrace) - , ("verbosity", Lua.push . show . stVerbosity) - ] + , readonly "user_data_dir" "directory to search for data files" + (maybe pushnil pushString, stUserDataDir) + + , readonly "trace" "controls whether tracing messages are issued" + (pushBool, stTrace) --- | Name used by Lua for the @CommonState@ type. -logMessageTypeName :: String -logMessageTypeName = "Pandoc LogMessage" + , readonly "verbosity" "verbosity level" + (pushString . show, stVerbosity) + ] -instance Peekable LogMessage where - peek idx = reportValueOnFailure logMessageTypeName - (`toAnyWithName` logMessageTypeName) idx +peekCommonState :: LuaError e => Peeker e CommonState +peekCommonState = peekUD typeCommonState -instance Pushable LogMessage where - push msg = pushAnyWithMetatable pushLogMessageMetatable msg - where - pushLogMessageMetatable = ensureUserdataMetatable logMessageTypeName $ - LuaUtil.addFunction "__tostring" tostringLogMessage +pushCommonState :: LuaError e => Pusher e CommonState +pushCommonState = pushUD typeCommonState -tostringLogMessage :: LogMessage -> Lua Text.Text -tostringLogMessage = return . showLogMessage +typeLogMessage :: LuaError e => DocumentedType e LogMessage +typeLogMessage = deftype "pandoc LogMessage" + [ operation Index $ defun "__tostring" + ### liftPure showLogMessage + <#> udparam typeLogMessage "msg" "object" + =#> functionResult pushText "string" "stringified log message" + ] + mempty -- no members diff --git a/src/Text/Pandoc/Lua/Marshaling/Context.hs b/src/Text/Pandoc/Lua/Marshaling/Context.hs index 606bdcfb2..8ee25565e 100644 --- a/src/Text/Pandoc/Lua/Marshaling/Context.hs +++ b/src/Text/Pandoc/Lua/Marshaling/Context.hs @@ -12,8 +12,8 @@ Marshaling instance for doctemplates Context and its components. -} module Text.Pandoc.Lua.Marshaling.Context () where -import qualified Foreign.Lua as Lua -import Foreign.Lua (Pushable) +import qualified HsLua as Lua +import HsLua (Pushable) import Text.DocTemplates (Context(..), Val(..), TemplateTarget) import Text.DocLayout (render) diff --git a/src/Text/Pandoc/Lua/Marshaling/List.hs b/src/Text/Pandoc/Lua/Marshaling/List.hs index 0446302a1..57ccd4501 100644 --- a/src/Text/Pandoc/Lua/Marshaling/List.hs +++ b/src/Text/Pandoc/Lua/Marshaling/List.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : Text.Pandoc.Lua.Marshaling.List Copyright : © 2012-2021 John MacFarlane @@ -14,27 +15,30 @@ Marshaling/unmarshaling instances for @pandoc.List@s. -} module Text.Pandoc.Lua.Marshaling.List ( List (..) + , peekList' + , pushPandocList ) where +import Control.Monad ((<$!>)) import Data.Data (Data) -import Foreign.Lua (Peekable, Pushable) +import HsLua (LuaError, Peeker, Pusher, Pushable (push), peekList, pushList) import Text.Pandoc.Walk (Walkable (..)) -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) - -import qualified Foreign.Lua as Lua +import Text.Pandoc.Lua.Util (pushViaConstr') -- | List wrapper which is marshalled as @pandoc.List@. newtype List a = List { fromList :: [a] } deriving (Data, Eq, Show) instance Pushable a => Pushable (List a) where - push (List xs) = - pushViaConstructor "List" xs + push (List xs) = pushPandocList push xs + +-- | Pushes a list as a numerical Lua table, setting a metatable that offers a +-- number of convenience functions. +pushPandocList :: LuaError e => Pusher e a -> Pusher e [a] +pushPandocList pushItem xs = pushViaConstr' "List" [pushList pushItem xs] -instance Peekable a => Peekable (List a) where - peek idx = defineHowTo "get List" $ do - xs <- Lua.peek idx - return $ List xs +peekList' :: LuaError e => Peeker e a -> Peeker e (List a) +peekList' p = (List <$!>) . peekList p -- List is just a wrapper, so we can reuse the walk instance for -- unwrapped Hasekll lists. diff --git a/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs b/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs deleted file mode 100644 index 70bd010a0..000000000 --- a/src/Text/Pandoc/Lua/Marshaling/MediaBag.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- | - Module : Text.Pandoc.Lua.Marshaling.MediaBag - Copyright : © 2012-2021 John MacFarlane - © 2017-2021 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> - Stability : alpha - -Instances to marshal (push) and unmarshal (peek) media data. --} -module Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator) where - -import Foreign.Ptr (Ptr) -import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr) -import Foreign.Lua (Lua, NumResults, Peekable, Pushable, StackIndex) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) -import Text.Pandoc.MediaBag (MediaBag, mediaItems) -import Text.Pandoc.MIME (MimeType) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) - -import qualified Data.ByteString.Lazy as BL -import qualified Foreign.Lua as Lua -import qualified Foreign.Storable as Storable - --- | A list of 'MediaBag' items. -newtype MediaItems = MediaItems [(String, MimeType, BL.ByteString)] - -instance Pushable MediaItems where - push = pushMediaItems - -instance Peekable MediaItems where - peek = peekMediaItems - --- | Push an iterator triple to be used with Lua's @for@ loop construct. --- Each iterator invocation returns a triple containing the item's --- filename, MIME type, and content. -pushIterator :: MediaBag -> Lua NumResults -pushIterator mb = do - Lua.pushHaskellFunction nextItem - Lua.push (MediaItems $ mediaItems mb) - Lua.pushnil - return 3 - --- | Lua type name for @'MediaItems'@. -mediaItemsTypeName :: String -mediaItemsTypeName = "pandoc MediaItems" - --- | Push a @MediaItems@ element to the stack. -pushMediaItems :: MediaItems -> Lua () -pushMediaItems xs = pushAnyWithMetatable pushMT xs - where - pushMT = ensureUserdataMetatable mediaItemsTypeName (return ()) - --- | Retrieve a @MediaItems@ element from the stack. -peekMediaItems :: StackIndex -> Lua MediaItems -peekMediaItems = reportValueOnFailure mediaItemsTypeName - (`toAnyWithName` mediaItemsTypeName) - --- | Retrieve a list of items from an iterator state, return the first --- item (if present), and advance the state. -nextItem :: Ptr (StablePtr MediaItems) -> AnyValue -> Lua NumResults -nextItem ptr _ = do - (MediaItems items) <- Lua.liftIO $ deRefStablePtr =<< Storable.peek ptr - case items of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - (key, mt, content):xs -> do - Lua.liftIO $ Storable.poke ptr =<< newStablePtr (MediaItems xs) - Lua.push key - Lua.push mt - Lua.push content - return 3 diff --git a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs index f698704e0..6f29a5c89 100644 --- a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs +++ b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs @@ -1,7 +1,7 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.PandocError Copyright : © 2020-2021 Albert Krewinkel @@ -15,51 +15,37 @@ Marshaling of @'PandocError'@ values. module Text.Pandoc.Lua.Marshaling.PandocError ( peekPandocError , pushPandocError + , typePandocError ) where -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import HsLua.Core (LuaError) +import HsLua.Marshalling (Peeker, Pusher, pushString, liftLua) +import HsLua.Packaging import Text.Pandoc.Error (PandocError (PandocLuaError)) -import qualified Foreign.Lua as Lua -import qualified Foreign.Lua.Userdata as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +import qualified HsLua as Lua import qualified Text.Pandoc.UTF8 as UTF8 --- | Userdata name used by Lua for the @PandocError@ type. -pandocErrorName :: String -pandocErrorName = "pandoc error" +-- | Lua userdata type definition for PandocError. +typePandocError :: LuaError e => DocumentedType e PandocError +typePandocError = deftype "PandocError" + [ operation Tostring $ defun "__tostring" + ### liftPure (show @PandocError) + <#> udparam typePandocError "obj" "PandocError object" + =#> functionResult pushString "string" "string representation of error." + ] + mempty -- no members -- | Peek a @'PandocError'@ element to the Lua stack. -pushPandocError :: PandocError -> Lua () -pushPandocError = Lua.pushAnyWithMetatable pushPandocErrorMT - where - pushPandocErrorMT = Lua.ensureUserdataMetatable pandocErrorName $ - LuaUtil.addFunction "__tostring" __tostring +pushPandocError :: LuaError e => Pusher e PandocError +pushPandocError = pushUD typePandocError -- | Retrieve a @'PandocError'@ from the Lua stack. -peekPandocError :: StackIndex -> Lua PandocError -peekPandocError idx = Lua.ltype idx >>= \case - Lua.TypeUserdata -> do - errMb <- Lua.toAnyWithName idx pandocErrorName - return $ case errMb of - Just err -> err - Nothing -> PandocLuaError "could not retrieve original error" - _ -> do - Lua.pushvalue idx - msg <- Lua.state >>= \l -> Lua.liftIO (Lua.errorMessage l) - return $ PandocLuaError (UTF8.toText msg) - --- | Convert to string. -__tostring :: PandocError -> Lua String -__tostring = return . show - --- --- Instances --- - -instance Pushable PandocError where - push = pushPandocError - -instance Peekable PandocError where - peek = peekPandocError +peekPandocError :: LuaError e => Peeker e PandocError +peekPandocError idx = Lua.retrieving "PandocError" $ + liftLua (Lua.ltype idx) >>= \case + Lua.TypeUserdata -> peekUD typePandocError idx + _ -> do + msg <- liftLua $ Lua.state >>= \l -> Lua.liftIO (Lua.popErrorMessage l) + return $ PandocLuaError (UTF8.toText msg) diff --git a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs index dd7bf2e61..2cc39ee3a 100644 --- a/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs +++ b/src/Text/Pandoc/Lua/Marshaling/ReaderOptions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,67 +12,60 @@ Marshaling instance for ReaderOptions and its components. -} -module Text.Pandoc.Lua.Marshaling.ReaderOptions () where +module Text.Pandoc.Lua.Marshaling.ReaderOptions + ( peekReaderOptions + , pushReaderOptions + ) where -import Data.Data (showConstr, toConstr) -import Foreign.Lua (Lua, Pushable) -import Text.Pandoc.Extensions (Extensions) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) -import Text.Pandoc.Lua.Marshaling.CommonState () -import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) - -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil +import HsLua as Lua +import Text.Pandoc.Lua.Marshaling.List (pushPandocList) +import Text.Pandoc.Options (ReaderOptions (..)) -- -- Reader Options -- -instance Pushable Extensions where - push exts = Lua.push (show exts) -instance Pushable TrackChanges where - push = Lua.push . showConstr . toConstr +peekReaderOptions :: LuaError e => Peeker e ReaderOptions +peekReaderOptions = peekUD typeReaderOptions + +pushReaderOptions :: LuaError e => Pusher e ReaderOptions +pushReaderOptions = pushUD typeReaderOptions -instance Pushable ReaderOptions where - push ro = do - let ReaderOptions - (extensions :: Extensions) - (standalone :: Bool) - (columns :: Int) - (tabStop :: Int) - (indentedCodeClasses :: [Text.Text]) - (abbreviations :: Set.Set Text.Text) - (defaultImageExtension :: Text.Text) - (trackChanges :: TrackChanges) - (stripComments :: Bool) - = ro - Lua.newtable - LuaUtil.addField "extensions" extensions - LuaUtil.addField "standalone" standalone - LuaUtil.addField "columns" columns - LuaUtil.addField "tab_stop" tabStop - LuaUtil.addField "indented_code_classes" indentedCodeClasses - LuaUtil.addField "abbreviations" abbreviations - LuaUtil.addField "default_image_extension" defaultImageExtension - LuaUtil.addField "track_changes" trackChanges - LuaUtil.addField "strip_comments" stripComments +typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions +typeReaderOptions = deftype "pandoc ReaderOptions" + [ operation Tostring luaShow + ] + [ readonly "extensions" "" + ( pushString . show + , readerExtensions) + , readonly "standalone" "" + ( pushBool + , readerStandalone) + , readonly "columns" "" + ( pushIntegral + , readerColumns) + , readonly "tab_stop" "" + ( pushIntegral + , readerTabStop) + , readonly "indented_code_classes" "" + ( pushPandocList pushText + , readerIndentedCodeClasses) + , readonly "abbreviations" "" + ( pushSet pushText + , readerAbbreviations) + , readonly "track_changes" "" + ( pushString . show + , readerTrackChanges) + , readonly "strip_comments" "" + ( pushBool + , readerStripComments) + , readonly "default_image_extension" "" + ( pushText + , readerDefaultImageExtension) + ] - -- add metatable - let indexReaderOptions :: AnyValue -> AnyValue -> Lua Lua.NumResults - indexReaderOptions _tbl (AnyValue key) = do - Lua.ltype key >>= \case - Lua.TypeString -> Lua.peek key >>= \case - ("defaultImageExtension" :: Text.Text) - -> Lua.push defaultImageExtension - "indentedCodeClasses" -> Lua.push indentedCodeClasses - "stripComments" -> Lua.push stripComments - "tabStop" -> Lua.push tabStop - "trackChanges" -> Lua.push trackChanges - _ -> Lua.pushnil - _ -> Lua.pushnil - return 1 - Lua.newtable - LuaUtil.addFunction "__index" indexReaderOptions - Lua.setmetatable (Lua.nthFromTop 2) +luaShow :: LuaError e => DocumentedFunction e +luaShow = defun "__tostring" + ### liftPure show + <#> udparam typeReaderOptions "state" "object to print in native format" + =#> functionResult pushString "string" "Haskell representation" diff --git a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs b/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs index 6d43039fa..e9c169dc0 100644 --- a/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs +++ b/src/Text/Pandoc/Lua/Marshaling/SimpleTable.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Marshaling.SimpleTable Copyright : © 2020-2021 Albert Krewinkel @@ -16,12 +19,11 @@ module Text.Pandoc.Lua.Marshaling.SimpleTable ) where -import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +import Control.Monad ((<$!>)) +import HsLua as Lua import Text.Pandoc.Definition -import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor, rawField) -import Text.Pandoc.Lua.Marshaling.AST () - -import qualified Foreign.Lua as Lua +import Text.Pandoc.Lua.Util (pushViaConstructor) +import Text.Pandoc.Lua.Marshaling.AST -- | A simple (legacy-style) table. data SimpleTable = SimpleTable @@ -32,16 +34,10 @@ data SimpleTable = SimpleTable , simpleTableBody :: [[[Block]]] } -instance Pushable SimpleTable where - push = pushSimpleTable - -instance Peekable SimpleTable where - peek = peekSimpleTable - -- | Push a simple table to the stack by calling the -- @pandoc.SimpleTable@ constructor. -pushSimpleTable :: SimpleTable -> Lua () -pushSimpleTable tbl = pushViaConstructor "SimpleTable" +pushSimpleTable :: forall e. LuaError e => SimpleTable -> LuaE e () +pushSimpleTable tbl = pushViaConstructor @e "SimpleTable" (simpleTableCaption tbl) (simpleTableAlignments tbl) (simpleTableColumnWidths tbl) @@ -49,11 +45,10 @@ pushSimpleTable tbl = pushViaConstructor "SimpleTable" (simpleTableBody tbl) -- | Retrieve a simple table from the stack. -peekSimpleTable :: StackIndex -> Lua SimpleTable -peekSimpleTable idx = defineHowTo "get SimpleTable" $ - SimpleTable - <$> rawField idx "caption" - <*> rawField idx "aligns" - <*> rawField idx "widths" - <*> rawField idx "headers" - <*> rawField idx "rows" +peekSimpleTable :: forall e. LuaError e => Peeker e SimpleTable +peekSimpleTable idx = retrieving "SimpleTable" $ SimpleTable + <$!> peekFieldRaw peekInlines "caption" idx + <*> peekFieldRaw (peekList peekRead) "aligns" idx + <*> peekFieldRaw (peekList peekRealFloat) "widths" idx + <*> peekFieldRaw (peekList peekBlocks) "headers" idx + <*> peekFieldRaw (peekList (peekList peekBlocks)) "rows" idx diff --git a/src/Text/Pandoc/Lua/Marshaling/Version.hs b/src/Text/Pandoc/Lua/Marshaling/Version.hs index 4f4ffac51..2af36e5c8 100644 --- a/src/Text/Pandoc/Lua/Marshaling/Version.hs +++ b/src/Text/Pandoc/Lua/Marshaling/Version.hs @@ -16,133 +16,92 @@ default comparison operators (like @>@ and @<=@). module Text.Pandoc.Lua.Marshaling.Version ( peekVersion , pushVersion + , peekVersionFuzzy ) where -import Data.Text (Text) import Data.Maybe (fromMaybe) import Data.Version (Version (..), makeVersion, parseVersion, showVersion) -import Foreign.Lua (Lua, Optional (..), NumResults, - Peekable, Pushable, StackIndex) -import Foreign.Lua.Types.Peekable (reportValueOnFailure) -import Foreign.Lua.Userdata (ensureUserdataMetatable, pushAnyWithMetatable, - toAnyWithName) -import Safe (atMay, lastMay) -import Text.Pandoc.Lua.Marshaling.AnyValue (AnyValue (..)) +import HsLua as Lua +import Safe (lastMay) import Text.ParserCombinators.ReadP (readP_to_S) +import qualified Text.Pandoc.UTF8 as UTF8 -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.Lua.Util as LuaUtil - --- | Push a @'Version'@ element to the Lua stack. -pushVersion :: Version -> Lua () -pushVersion version = pushAnyWithMetatable pushVersionMT version - where - pushVersionMT = ensureUserdataMetatable versionTypeName $ do - LuaUtil.addFunction "__eq" __eq - LuaUtil.addFunction "__le" __le - LuaUtil.addFunction "__lt" __lt - LuaUtil.addFunction "__len" __len - LuaUtil.addFunction "__index" __index - LuaUtil.addFunction "__pairs" __pairs - LuaUtil.addFunction "__tostring" __tostring +instance Peekable Version where + peek = forcePeek . peekVersionFuzzy instance Pushable Version where push = pushVersion -peekVersion :: StackIndex -> Lua Version -peekVersion idx = Lua.ltype idx >>= \case +-- | Push a @'Version'@ element to the Lua stack. +pushVersion :: LuaError e => Pusher e Version +pushVersion = pushUD typeVersion + +peekVersionFuzzy :: LuaError e => Peeker e Version +peekVersionFuzzy idx = retrieving "Version" $ liftLua (Lua.ltype idx) >>= \case + Lua.TypeUserdata -> peekVersion idx Lua.TypeString -> do - versionStr <- Lua.peek idx + versionStr <- peekString idx let parses = readP_to_S parseVersion versionStr case lastMay parses of Just (v, "") -> return v - _ -> Lua.throwMessage $ "could not parse as Version: " ++ versionStr + _ -> Lua.failPeek $ + UTF8.fromString $ "could not parse as Version: " ++ versionStr - Lua.TypeUserdata -> - reportValueOnFailure versionTypeName - (`toAnyWithName` versionTypeName) - idx Lua.TypeNumber -> do - n <- Lua.peek idx - return (makeVersion [n]) + (makeVersion . (:[])) <$> peekIntegral idx Lua.TypeTable -> - makeVersion <$> Lua.peek idx + makeVersion <$> peekList peekIntegral idx _ -> - Lua.throwMessage "could not peek Version" - -instance Peekable Version where - peek = peekVersion - --- | Name used by Lua for the @CommonState@ type. -versionTypeName :: String -versionTypeName = "HsLua Version" - -__eq :: Version -> Version -> Lua Bool -__eq v1 v2 = return (v1 == v2) - -__le :: Version -> Version -> Lua Bool -__le v1 v2 = return (v1 <= v2) - -__lt :: Version -> Version -> Lua Bool -__lt v1 v2 = return (v1 < v2) - --- | Get number of version components. -__len :: Version -> Lua Int -__len = return . length . versionBranch - --- | Access fields. -__index :: Version -> AnyValue -> Lua NumResults -__index v (AnyValue k) = do - ty <- Lua.ltype k - case ty of - Lua.TypeNumber -> do - n <- Lua.peek k - let versionPart = atMay (versionBranch v) (n - 1) - Lua.push (Lua.Optional versionPart) - return 1 - Lua.TypeString -> do - (str :: Text) <- Lua.peek k - if str == "must_be_at_least" - then 1 <$ Lua.pushHaskellFunction must_be_at_least - else 1 <$ Lua.pushnil - _ -> 1 <$ Lua.pushnil - --- | Create iterator. -__pairs :: Version -> Lua NumResults -__pairs v = do - Lua.pushHaskellFunction nextFn - Lua.pushnil - Lua.pushnil - return 3 - where - nextFn :: AnyValue -> Optional Int -> Lua Lua.NumResults - nextFn _ (Optional key) = - case key of - Nothing -> case versionBranch v of - [] -> 2 <$ (Lua.pushnil *> Lua.pushnil) - n:_ -> 2 <$ (Lua.push (1 :: Int) *> Lua.push n) - Just n -> case atMay (versionBranch v) n of - Nothing -> 2 <$ (Lua.pushnil *> Lua.pushnil) - Just b -> 2 <$ (Lua.push (n + 1) *> Lua.push b) - --- | Convert to string. -__tostring :: Version -> Lua String -__tostring v = return (showVersion v) - --- | Default error message when a version is too old. This message is --- formatted in Lua with the expected and actual versions as arguments. -versionTooOldMessage :: String -versionTooOldMessage = "expected version %s or newer, got %s" + Lua.failPeek "could not peek Version" + +peekVersion :: LuaError e => Peeker e Version +peekVersion = peekUD typeVersion + +typeVersion :: LuaError e => DocumentedType e Version +typeVersion = deftype "Version" + [ operation Eq $ defun "__eq" + ### liftPure2 (==) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 == v2" + , operation Lt $ defun "__lt" + ### liftPure2 (<) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 < v2" + , operation Le $ defun "__le" + ### liftPure2 (<=) + <#> parameter peekVersionFuzzy "Version" "v1" "" + <#> parameter peekVersionFuzzy "Version" "v2" "" + =#> functionResult pushBool "boolean" "true iff v1 <= v2" + , operation Len $ defun "__len" + ### liftPure (length . versionBranch) + <#> parameter peekVersionFuzzy "Version" "v1" "" + =#> functionResult pushIntegral "integer" "number of version components" + , operation Tostring $ defun "__tostring" + ### liftPure showVersion + <#> parameter peekVersionFuzzy "Version" "version" "" + =#> functionResult pushString "string" "stringified version" + ] + [ method $ defun "must_be_at_least" + ### must_be_at_least + <#> parameter peekVersionFuzzy "Version" "self" "version to check" + <#> parameter peekVersionFuzzy "Version" "reference" "minimum version" + <#> optionalParameter peekString "string" "msg" "alternative message" + =?> "Returns no result, and throws an error if this version is older than reference" + ] -- | Throw an error if this version is older than the given version. -- FIXME: This function currently requires the string library to be -- loaded. -must_be_at_least :: Version -> Version -> Optional String -> Lua NumResults -must_be_at_least actual expected optMsg = do - let msg = fromMaybe versionTooOldMessage (fromOptional optMsg) +must_be_at_least :: LuaError e + => Version -> Version -> Maybe String + -> LuaE e NumResults +must_be_at_least actual expected mMsg = do + let msg = fromMaybe versionTooOldMessage mMsg if expected <= actual then return 0 else do @@ -152,3 +111,8 @@ must_be_at_least actual expected optMsg = do Lua.push (showVersion actual) Lua.call 3 1 Lua.error + +-- | Default error message when a version is too old. This message is +-- formatted in Lua with the expected and actual versions as arguments. +versionTooOldMessage :: String +versionTooOldMessage = "expected version %s or newer, got %s" diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index 3eed50fca..a1fc40732 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -15,18 +15,19 @@ module Text.Pandoc.Lua.Module.MediaBag import Prelude hiding (lookup) import Control.Monad (zipWithM_) -import Foreign.Lua (Lua, NumResults, Optional) +import HsLua (LuaE, NumResults, Optional) +import HsLua.Marshalling (pushIterator) 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.MediaBag (pushIterator) import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua, addFunction) import Text.Pandoc.MIME (MimeType) import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T -import qualified Foreign.Lua as Lua +import qualified HsLua as Lua import qualified Text.Pandoc.MediaBag as MB -- @@ -65,7 +66,15 @@ insert fp optionalMime contents = do -- | Returns iterator values to be used with a Lua @for@ loop. items :: PandocLua NumResults -items = getMediaBag >>= liftPandocLua . pushIterator +items = do + mb <- getMediaBag + liftPandocLua $ do + let pushItem (fp, mimetype, contents) = do + Lua.pushString fp + Lua.pushText mimetype + Lua.pushByteString $ BL.toStrict contents + return (Lua.NumResults 3) + pushIterator pushItem (MB.mediaItems mb) lookup :: FilePath -> PandocLua NumResults @@ -86,7 +95,7 @@ list = do zipWithM_ addEntry [1..] dirContents return 1 where - addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> Lua () + addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> LuaE PandocError () addEntry idx (fp, mimeType, contentLength) = do Lua.newtable Lua.push ("path" :: T.Text) *> Lua.push fp *> Lua.rawset (-3) diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index 5c14b3a30..0a9ebaec5 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -15,29 +15,30 @@ module Text.Pandoc.Lua.Module.Pandoc ) where import Prelude hiding (read) -import Control.Monad (when) +import Control.Monad ((>=>), when) import Control.Monad.Except (throwError) import Data.Default (Default (..)) import Data.Maybe (fromMaybe) -import Foreign.Lua (Lua, NumResults, Optional, Peekable, Pushable) +import HsLua as Lua hiding (pushModule) +import HsLua.Class.Peekable (PeekError) import System.Exit (ExitCode (..)) import Text.Pandoc.Class.PandocIO (runIO) import Text.Pandoc.Definition (Block, Inline) -import Text.Pandoc.Lua.Filter (LuaFilter, SingletonsList (..), walkInlines, +import Text.Pandoc.Lua.Filter (SingletonsList (..), walkInlines, walkInlineLists, walkBlocks, walkBlockLists) import Text.Pandoc.Lua.Marshaling () +import Text.Pandoc.Lua.Marshaling.AST import Text.Pandoc.Lua.Marshaling.List (List (..)) import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua, loadDefaultModule) -import Text.Pandoc.Walk (Walkable) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) import Text.Pandoc.Readers (Reader (..), getReader) +import Text.Pandoc.Walk (Walkable) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T -import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Lua.Util as LuaUtil import Text.Pandoc.Error @@ -48,23 +49,25 @@ pushModule = do loadDefaultModule "pandoc" addFunction "read" read addFunction "pipe" pipe - addFunction "walk_block" walk_block - addFunction "walk_inline" walk_inline + addFunction "walk_block" (walkElement peekBlock pushBlock) + addFunction "walk_inline" (walkElement peekInline pushInline) return 1 walkElement :: (Walkable (SingletonsList Inline) a, Walkable (SingletonsList Block) a, Walkable (List Inline) a, Walkable (List Block) a) - => a -> LuaFilter -> PandocLua a -walkElement x f = liftPandocLua $ - walkInlines f x >>= walkInlineLists f >>= walkBlocks f >>= walkBlockLists f - -walk_inline :: Inline -> LuaFilter -> PandocLua Inline -walk_inline = walkElement - -walk_block :: Block -> LuaFilter -> PandocLua Block -walk_block = walkElement + => Peeker PandocError a -> Pusher PandocError a + -> LuaE PandocError NumResults +walkElement peek' push' = do + x <- forcePeek $ peek' (nthBottom 1) + f <- peek (nthBottom 2) + let walk' = walkInlines f + >=> walkInlineLists f + >=> walkBlocks f + >=> walkBlockLists f + walk' x >>= push' + return (NumResults 1) read :: T.Text -> Optional T.Text -> PandocLua NumResults read content formatSpecOrNil = liftPandocLua $ do @@ -93,7 +96,9 @@ pipe command args input = liftPandocLua $ do (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input case ec of ExitSuccess -> 1 <$ Lua.push output - ExitFailure n -> Lua.raiseError (PipeError (T.pack command) n output) + ExitFailure n -> do + pushPipeError (PipeError (T.pack command) n output) + Lua.error data PipeError = PipeError { pipeErrorCommand :: T.Text @@ -101,29 +106,34 @@ data PipeError = PipeError , pipeErrorOutput :: BL.ByteString } -instance Peekable PipeError where - peek idx = - PipeError - <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1) +peekPipeError :: PeekError e => StackIndex -> LuaE e PipeError +peekPipeError idx = + PipeError + <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) + <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1) + <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1) -instance Pushable PipeError where - push pipeErr = do - Lua.newtable - LuaUtil.addField "command" (pipeErrorCommand pipeErr) - LuaUtil.addField "error_code" (pipeErrorCode pipeErr) - LuaUtil.addField "output" (pipeErrorOutput pipeErr) - pushPipeErrorMetaTable - Lua.setmetatable (-2) - where - pushPipeErrorMetaTable :: Lua () - pushPipeErrorMetaTable = do - v <- Lua.newmetatable "pandoc pipe error" - when v $ LuaUtil.addFunction "__tostring" pipeErrorMessage +pushPipeError :: PeekError e => Pusher e PipeError +pushPipeError pipeErr = do + Lua.newtable + LuaUtil.addField "command" (pipeErrorCommand pipeErr) + LuaUtil.addField "error_code" (pipeErrorCode pipeErr) + LuaUtil.addField "output" (pipeErrorOutput pipeErr) + pushPipeErrorMetaTable + Lua.setmetatable (-2) + where + pushPipeErrorMetaTable :: PeekError e => LuaE e () + pushPipeErrorMetaTable = do + v <- Lua.newmetatable "pandoc pipe error" + when v $ do + pushName "__tostring" + pushHaskellFunction pipeErrorMessage + rawset (nth 3) - pipeErrorMessage :: PipeError -> Lua BL.ByteString - pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat + pipeErrorMessage :: PeekError e => LuaE e NumResults + pipeErrorMessage = do + (PipeError cmd errorCode output) <- peekPipeError (nthBottom 1) + pushByteString . BSL.toStrict . BSL.concat $ [ BSL.pack "Error running " , BSL.pack $ T.unpack cmd , BSL.pack " (error code " @@ -131,3 +141,4 @@ instance Pushable PipeError where , BSL.pack "): " , if output == mempty then BSL.pack "<no output>" else output ] + return (NumResults 1) diff --git a/src/Text/Pandoc/Lua/Module/System.hs b/src/Text/Pandoc/Lua/Module/System.hs index bd35babaf..8589f672c 100644 --- a/src/Text/Pandoc/Lua/Module/System.hs +++ b/src/Text/Pandoc/Lua/Module/System.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Lua.Module.System Copyright : © 2019-2021 Albert Krewinkel @@ -12,22 +14,31 @@ module Text.Pandoc.Lua.Module.System ( pushModule ) where -import Foreign.Lua (Lua, NumResults) -import Foreign.Lua.Module.System (arch, env, getwd, os, - with_env, with_tmpdir, with_wd) -import Text.Pandoc.Lua.Util (addFunction, addField) +import HsLua hiding (pushModule) +import HsLua.Module.System + (arch, env, getwd, os, with_env, with_tmpdir, with_wd) +import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Lua.ErrorConversion () -import qualified Foreign.Lua as Lua +import qualified HsLua as Lua -- | Push the pandoc.system module on the Lua stack. -pushModule :: Lua NumResults +pushModule :: LuaE PandocError NumResults pushModule = do - Lua.newtable - addField "arch" arch - addField "os" os - addFunction "environment" env - addFunction "get_working_directory" getwd - addFunction "with_environment" with_env - addFunction "with_temporary_directory" with_tmpdir - addFunction "with_working_directory" with_wd + Lua.pushModule $ Module + { moduleName = "system" + , moduleDescription = "system functions" + , moduleFields = + [ arch + , os + ] + , moduleFunctions = + [ setName "environment" env + , setName "get_working_directory" getwd + , setName "with_environment" with_env + , setName "with_temporary_directory" with_tmpdir + , setName "with_working_directory" with_wd + ] + , moduleOperations = [] + } return 1 diff --git a/src/Text/Pandoc/Lua/Module/Types.hs b/src/Text/Pandoc/Lua/Module/Types.hs index bb4f02c3c..a9ce14ce7 100644 --- a/src/Text/Pandoc/Lua/Module/Types.hs +++ b/src/Text/Pandoc/Lua/Module/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Lua.Module.Types Copyright : © 2019-2021 Albert Krewinkel @@ -13,56 +14,41 @@ module Text.Pandoc.Lua.Module.Types ) where import Data.Version (Version) -import Foreign.Lua (Lua, NumResults) -import Text.Pandoc.Definition -import Text.Pandoc.Lua.Marshaling.AST (LuaAttr, LuaListAttributes) +import HsLua (LuaE, NumResults, Peeker, Pusher) +import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Lua.ErrorConversion () +import Text.Pandoc.Lua.Marshaling.AST import Text.Pandoc.Lua.Marshaling.Version () import Text.Pandoc.Lua.Util (addFunction) -import qualified Foreign.Lua as Lua +import qualified HsLua as Lua --- | Push the pandoc.system module on the Lua stack. -pushModule :: Lua NumResults +-- | Push the pandoc.types module on the Lua stack. +pushModule :: LuaE PandocError NumResults pushModule = do Lua.newtable - addFunction "Version" (return :: Version -> Lua Version) + addFunction "Version" (return :: Version -> LuaE PandocError Version) pushCloneTable - Lua.setfield (Lua.nthFromTop 2) "clone" + Lua.setfield (Lua.nth 2) "clone" return 1 -pushCloneTable :: Lua NumResults +pushCloneTable :: LuaE PandocError NumResults pushCloneTable = do Lua.newtable - addFunction "Attr" cloneAttr - addFunction "Block" cloneBlock - addFunction "Citation" cloneCitation - addFunction "Inline" cloneInline - addFunction "Meta" cloneMeta - addFunction "MetaValue" cloneMetaValue - addFunction "ListAttributes" cloneListAttributes - addFunction "Pandoc" clonePandoc + addFunction "Attr" $ cloneWith peekAttr pushAttr + addFunction "Block" $ cloneWith peekBlock pushBlock + addFunction "Citation" $ cloneWith peekCitation Lua.push + addFunction "Inline" $ cloneWith peekInline pushInline + addFunction "Meta" $ cloneWith peekMeta Lua.push + addFunction "MetaValue" $ cloneWith peekMetaValue pushMetaValue + addFunction "ListAttributes" $ cloneWith peekListAttributes pushListAttributes + addFunction "Pandoc" $ cloneWith peekPandoc pushPandoc return 1 -cloneAttr :: LuaAttr -> Lua LuaAttr -cloneAttr = return - -cloneBlock :: Block -> Lua Block -cloneBlock = return - -cloneCitation :: Citation -> Lua Citation -cloneCitation = return - -cloneInline :: Inline -> Lua Inline -cloneInline = return - -cloneListAttributes :: LuaListAttributes -> Lua LuaListAttributes -cloneListAttributes = return - -cloneMeta :: Meta -> Lua Meta -cloneMeta = return - -cloneMetaValue :: MetaValue -> Lua MetaValue -cloneMetaValue = return - -clonePandoc :: Pandoc -> Lua Pandoc -clonePandoc = return +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 3ec3afc26..8b6e31b43 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Module.Utils Copyright : Copyright © 2017-2021 Albert Krewinkel @@ -15,82 +17,137 @@ module Text.Pandoc.Lua.Module.Utils ) where import Control.Applicative ((<|>)) -import Control.Monad.Catch (try) +import Control.Monad ((<$!>)) import Data.Data (showConstr, toConstr) import Data.Default (def) import Data.Version (Version) -import Foreign.Lua (Peekable, Lua, NumResults (..)) +import HsLua as Lua hiding (pushModule) +import HsLua.Class.Peekable (PeekError) 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, pushPandoc + , peekAttr, peekListAttributes, peekMeta, peekMetaValue) +import Text.Pandoc.Lua.Marshaling.List (pushPandocList) import Text.Pandoc.Lua.Marshaling.SimpleTable - ( SimpleTable (..) - , pushSimpleTable - ) -import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua) + ( SimpleTable (..), peekSimpleTable, pushSimpleTable ) +import Text.Pandoc.Lua.Marshaling.Version (peekVersionFuzzy, pushVersion) +import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua)) import qualified Data.Digest.Pure.SHA as SHA import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T -import qualified Foreign.Lua as Lua +import qualified HsLua.Packaging as Lua import qualified Text.Pandoc.Builder as B import qualified Text.Pandoc.Filter.JSON as JSONFilter import qualified Text.Pandoc.Shared as Shared +import qualified Text.Pandoc.UTF8 as UTF8 import qualified Text.Pandoc.Writers.Shared as Shared -- | Push the "pandoc.utils" module to the Lua stack. -pushModule :: PandocLua NumResults -pushModule = do - liftPandocLua Lua.newtable - addFunction "blocks_to_inlines" blocksToInlines - addFunction "equals" equals - addFunction "from_simple_table" from_simple_table - addFunction "make_sections" makeSections - addFunction "normalize_date" normalizeDate - addFunction "run_json_filter" runJSONFilter - addFunction "sha1" sha1 - addFunction "stringify" stringify - addFunction "to_roman_numeral" toRomanNumeral - addFunction "to_simple_table" to_simple_table - addFunction "Version" (return :: Version -> Lua Version) - return 1 - --- | Squashes a list of blocks into inlines. -blocksToInlines :: [Block] -> Lua.Optional [Inline] -> PandocLua [Inline] -blocksToInlines blks optSep = liftPandocLua $ do - let sep = maybe Shared.defaultBlocksSeparator B.fromList - $ Lua.fromOptional optSep - return $ B.toList (Shared.blocksToInlinesWithSep sep blks) - --- | Convert list of Pandoc blocks into sections using Divs. -makeSections :: Bool -> Lua.Optional Int -> [Block] -> Lua [Block] -makeSections number baselevel = - return . Shared.makeSections number (Lua.fromOptional baselevel) - --- | Parse a date and convert (if possible) to "YYYY-MM-DD" format. We --- limit years to the range 1601-9999 (ISO 8601 accepts greater than --- or equal to 1583, but MS Word only accepts dates starting 1601). --- Returns nil instead of a string if the conversion failed. -normalizeDate :: T.Text -> Lua (Lua.Optional T.Text) -normalizeDate = return . Lua.Optional . Shared.normalizeDate - --- | Run a JSON filter on the given document. -runJSONFilter :: Pandoc - -> FilePath - -> Lua.Optional [String] - -> PandocLua Pandoc -runJSONFilter doc filterFile optArgs = do - args <- case Lua.fromOptional optArgs of - Just x -> return x - Nothing -> liftPandocLua $ do - Lua.getglobal "FORMAT" - (:[]) <$> Lua.popValue - JSONFilter.apply def args filterFile doc - --- | Calculate the hash of the given contents. -sha1 :: BSL.ByteString - -> Lua T.Text -sha1 = return . T.pack . SHA.showDigest . SHA.sha1 +pandocUtilsModule :: Module PandocError +pandocUtilsModule = Module + { moduleName = "pandoc.utils" + , moduleDescription = "pandoc utility functions" + , moduleFields = [] + , moduleOperations = [] + , moduleFunctions = + [ defun "blocks_to_inlines" + ### (\blks mSep -> do + let sep = maybe Shared.defaultBlocksSeparator B.fromList mSep + return $ B.toList (Shared.blocksToInlinesWithSep sep blks)) + <#> parameter (peekList peekBlock) "list of blocks" + "blocks" "" + <#> optionalParameter (peekList peekInline) "list of inlines" + "inline" "" + =#> functionResult (pushPandocList pushInline) "list of inlines" "" + + , defun "equals" + ### liftPure2 (==) + <#> parameter peekAstElement "AST element" "elem1" "" + <#> parameter peekAstElement "AST element" "elem2" "" + =#> functionResult pushBool "boolean" "true iff elem1 == elem2" + + , defun "make_sections" + ### liftPure3 Shared.makeSections + <#> parameter peekBool "boolean" "numbering" "add header numbers" + <#> parameter (\i -> (Nothing <$ peekNil i) <|> (Just <$!> peekIntegral i)) + "integer or nil" "baselevel" "" + <#> parameter (peekList peekBlock) "list of blocks" + "blocks" "document blocks to process" + =#> functionResult (pushPandocList pushBlock) "list of Blocks" + "processes blocks" + + , defun "normalize_date" + ### liftPure Shared.normalizeDate + <#> parameter peekText "string" "date" "the date string" + =#> functionResult (maybe pushnil pushText) "string or nil" + "normalized date, or nil if normalization failed." + #? T.unwords + [ "Parse a date and convert (if possible) to \"YYYY-MM-DD\" format. We" + , "limit years to the range 1601-9999 (ISO 8601 accepts greater than" + , "or equal to 1583, but MS Word only accepts dates starting 1601)." + , "Returns nil instead of a string if the conversion failed." + ] + + , defun "sha1" + ### liftPure (SHA.showDigest . SHA.sha1) + <#> parameter (fmap BSL.fromStrict . peekByteString) "string" + "input" "" + =#> functionResult pushString "string" "hexadecimal hash value" + #? "Compute the hash of the given string value." + + , defun "Version" + ### liftPure (id @Version) + <#> parameter peekVersionFuzzy + "version string, list of integers, or integer" + "v" "version description" + =#> functionResult pushVersion "Version" "new Version object" + #? "Creates a Version object." + + , defun "run_json_filter" + ### (\doc filterPath margs -> do + args <- case margs of + Just xs -> return xs + Nothing -> do + Lua.getglobal "FORMAT" + (forcePeek ((:[]) <$!> peekString top) <* pop 1) + JSONFilter.apply def args filterPath doc + ) + <#> parameter peekPandoc "Pandoc" "doc" "input document" + <#> parameter peekString "filepath" "filter_path" "path to filter" + <#> optionalParameter (peekList peekString) "list of strings" + "args" "arguments to pass to the filter" + =#> functionResult pushPandoc "Pandoc" "filtered document" + + , defun "stringify" + ### unPandocLua . stringify + <#> parameter peekAstElement "AST element" "elem" "some pandoc AST element" + =#> functionResult pushText "string" "stringified element" + + , defun "from_simple_table" + ### from_simple_table + <#> parameter peekSimpleTable "SimpleTable" "simple_tbl" "" + =?> "Simple table" + + , defun "to_roman_numeral" + ### liftPure Shared.toRomanNumeral + <#> parameter (peekIntegral @Int) "integer" "n" "number smaller than 4000" + =#> functionResult pushText "string" "roman numeral" + #? "Converts a number < 4000 to uppercase roman numeral." + + , defun "to_simple_table" + ### to_simple_table + <#> parameter peekTable "Block" "tbl" "a table" + =#> functionResult pushSimpleTable "SimpleTable" "SimpleTable object" + #? "Converts a table into an old/simple table." + ] + } + +pushModule :: LuaE PandocError NumResults +pushModule = 1 <$ Lua.pushModule pandocUtilsModule + -- | Convert pandoc structure to a string with formatting removed. -- Footnotes are skipped (since we don't want their contents in link @@ -111,9 +168,6 @@ stringifyMetaValue mv = case mv of MetaString s -> s _ -> Shared.stringify mv -equals :: AstElement -> AstElement -> PandocLua Bool -equals e1 e2 = return (e1 == e2) - data AstElement = PandocElement Pandoc | MetaElement Meta @@ -125,22 +179,19 @@ data AstElement | CitationElement Citation deriving (Eq, Show) -instance Peekable AstElement where - peek idx = do - res <- try $ (PandocElement <$> Lua.peek idx) - <|> (InlineElement <$> Lua.peek idx) - <|> (BlockElement <$> Lua.peek idx) - <|> (AttrElement <$> Lua.peek idx) - <|> (ListAttributesElement <$> Lua.peek idx) - <|> (MetaElement <$> Lua.peek idx) - <|> (MetaValueElement <$> Lua.peek idx) - case res of - Right x -> return x - Left (_ :: PandocError) -> Lua.throwMessage - "Expected an AST element, but could not parse value as such." +peekAstElement :: PeekError e => Peeker e AstElement +peekAstElement = retrieving "pandoc AST element" . choice + [ (fmap PandocElement . peekPandoc) + , (fmap InlineElement . peekInline) + , (fmap BlockElement . peekBlock) + , (fmap AttrElement . peekAttr) + , (fmap ListAttributesElement . peekListAttributes) + , (fmap MetaElement . peekMeta) + , (fmap MetaValueElement . peekMetaValue) + ] -- | Converts an old/simple table into a normal table block element. -from_simple_table :: SimpleTable -> Lua NumResults +from_simple_table :: SimpleTable -> LuaE PandocError NumResults from_simple_table (SimpleTable capt aligns widths head' body) = do Lua.push $ Table nullAttr @@ -159,17 +210,19 @@ from_simple_table (SimpleTable capt aligns widths head' body) = do toColWidth w = ColWidth w -- | Converts a table into an old/simple table. -to_simple_table :: Block -> Lua NumResults +to_simple_table :: Block -> LuaE PandocError SimpleTable to_simple_table = \case Table _attr caption specs thead tbodies tfoot -> do let (capt, aligns, widths, headers, rows) = Shared.toLegacyTable caption specs thead tbodies tfoot - pushSimpleTable $ SimpleTable capt aligns widths headers rows - return (NumResults 1) - blk -> - Lua.throwMessage $ - "Expected Table, got " <> showConstr (toConstr blk) <> "." - --- | Convert a number < 4000 to uppercase roman numeral. -toRomanNumeral :: Lua.Integer -> PandocLua T.Text -toRomanNumeral = return . Shared.toRomanNumeral . fromIntegral + return $ SimpleTable capt aligns widths headers rows + blk -> Lua.failLua $ mconcat + [ "Expected Table, got ", showConstr (toConstr blk), "." ] + +peekTable :: LuaError e => Peeker e Block +peekTable idx = peekBlock idx >>= \case + t@(Table {}) -> return t + b -> Lua.failPeek $ mconcat + [ "Expected Table, got " + , UTF8.fromString $ showConstr (toConstr b) + , "." ] diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index 2f1c139db..f9bd7abe8 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Packages Copyright : Copyright © 2017-2021 Albert Krewinkel @@ -13,12 +16,13 @@ module Text.Pandoc.Lua.Packages ) where import Control.Monad (forM_) -import Foreign.Lua (NumResults) +import HsLua (NumResults) +import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, loadDefaultModule) -import qualified Foreign.Lua as Lua -import qualified Foreign.Lua.Module.Path as Path -import qualified Foreign.Lua.Module.Text as Text +import qualified HsLua as Lua +import qualified HsLua.Module.Path as Path +import qualified HsLua.Module.Text as Text import qualified Text.Pandoc.Lua.Module.Pandoc as Pandoc import qualified Text.Pandoc.Lua.Module.MediaBag as MediaBag import qualified Text.Pandoc.Lua.Module.System as System @@ -30,8 +34,8 @@ installPandocPackageSearcher :: PandocLua () installPandocPackageSearcher = liftPandocLua $ do Lua.getglobal' "package.searchers" shiftArray - Lua.pushHaskellFunction pandocPackageSearcher - Lua.rawseti (Lua.nthFromTop 2) 1 + Lua.pushHaskellFunction $ Lua.toHaskellFunction pandocPackageSearcher + Lua.rawseti (Lua.nth 2) 1 Lua.pop 1 -- remove 'package.searchers' from stack where shiftArray = forM_ [4, 3, 2, 1] $ \i -> do @@ -42,14 +46,16 @@ installPandocPackageSearcher = liftPandocLua $ do pandocPackageSearcher :: String -> PandocLua NumResults pandocPackageSearcher pkgName = case pkgName of - "pandoc" -> pushWrappedHsFun Pandoc.pushModule - "pandoc.mediabag" -> pushWrappedHsFun MediaBag.pushModule - "pandoc.path" -> pushWrappedHsFun Path.pushModule - "pandoc.system" -> pushWrappedHsFun System.pushModule - "pandoc.types" -> pushWrappedHsFun Types.pushModule - "pandoc.utils" -> pushWrappedHsFun Utils.pushModule - "text" -> pushWrappedHsFun Text.pushModule - "pandoc.List" -> pushWrappedHsFun (loadDefaultModule pkgName) + "pandoc" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Pandoc.pushModule + "pandoc.mediabag" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError MediaBag.pushModule + "pandoc.path" -> pushWrappedHsFun + (Lua.NumResults 1 <$ Lua.pushModule @PandocError Path.documentedModule) + "pandoc.system" -> pushWrappedHsFun $ Lua.toHaskellFunction System.pushModule + "pandoc.types" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Types.pushModule + "pandoc.utils" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError Utils.pushModule + "text" -> pushWrappedHsFun + (Lua.NumResults 1 <$ Lua.pushModule @PandocError Text.documentedModule) + "pandoc.List" -> pushWrappedHsFun $ Lua.toHaskellFunction @PandocError (loadDefaultModule pkgName) _ -> reportPandocSearcherFailure where pushWrappedHsFun f = liftPandocLua $ do diff --git a/src/Text/Pandoc/Lua/PandocLua.hs b/src/Text/Pandoc/Lua/PandocLua.hs index b7f084957..12511d088 100644 --- a/src/Text/Pandoc/Lua/PandocLua.hs +++ b/src/Text/Pandoc/Lua/PandocLua.hs @@ -28,20 +28,19 @@ module Text.Pandoc.Lua.PandocLua import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Except (MonadError (catchError, throwError)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Foreign.Lua (Lua (..), NumResults, Pushable, ToHaskellFunction) +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.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.ErrorConversion (errorConversion) +import Text.Pandoc.Lua.Marshaling.CommonState (peekCommonState) import qualified Control.Monad.Catch as Catch import qualified Data.Text as T -import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Class.IO as IO -- | Type providing access to both, pandoc and Lua operations. -newtype PandocLua a = PandocLua { unPandocLua :: Lua a } +newtype PandocLua a = PandocLua { unPandocLua :: LuaE PandocError a } deriving ( Applicative , Functor @@ -53,7 +52,7 @@ newtype PandocLua a = PandocLua { unPandocLua :: Lua a } ) -- | Lift a @'Lua'@ operation into the @'PandocLua'@ type. -liftPandocLua :: Lua a -> PandocLua a +liftPandocLua :: LuaE PandocError a -> PandocLua a liftPandocLua = PandocLua -- | Evaluate a @'PandocLua'@ computation, running all contained Lua @@ -62,7 +61,7 @@ runPandocLua :: (PandocMonad m, MonadIO m) => PandocLua a -> m a runPandocLua pLua = do origState <- getCommonState globals <- defaultGlobals - (result, newState) <- liftIO . Lua.run' errorConversion . unPandocLua $ do + (result, newState) <- liftIO . Lua.run . unPandocLua $ do putCommonState origState liftPandocLua $ setGlobals globals r <- pLua @@ -71,17 +70,17 @@ runPandocLua pLua = do putCommonState newState return result -instance {-# OVERLAPPING #-} ToHaskellFunction (PandocLua NumResults) where - toHsFun _narg = unPandocLua +instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where + partialApply _narg = unPandocLua -instance Pushable a => ToHaskellFunction (PandocLua a) where - toHsFun _narg x = 1 <$ (unPandocLua x >>= Lua.push) +instance Pushable a => Exposable PandocError (PandocLua a) where + partialApply _narg x = 1 <$ (unPandocLua x >>= Lua.push) -- | Add a function to the table at the top of the stack, using the given name. -addFunction :: ToHaskellFunction a => String -> a -> PandocLua () +addFunction :: Exposable PandocError a => Name -> a -> PandocLua () addFunction name fn = liftPandocLua $ do - Lua.push name - Lua.pushHaskellFunction fn + Lua.pushName name + Lua.pushHaskellFunction $ toHaskellFunction fn Lua.rawset (-3) -- | Load a pure Lua module included with pandoc. Leaves the result on @@ -93,8 +92,8 @@ addFunction name fn = liftPandocLua $ do loadDefaultModule :: String -> PandocLua NumResults loadDefaultModule name = do script <- readDefaultDataFile (name <> ".lua") - status <- liftPandocLua $ Lua.dostring script - if status == Lua.OK + result <- liftPandocLua $ Lua.dostring script + if result == Lua.OK then return (1 :: NumResults) else do msg <- liftPandocLua Lua.popValue @@ -135,7 +134,7 @@ instance PandocMonad PandocLua where getCommonState = PandocLua $ do Lua.getglobal "PANDOC_STATE" - Lua.peek Lua.stackTop + forcePeek $ peekCommonState Lua.top putCommonState = PandocLua . setGlobals . (:[]) . PANDOC_STATE logOutput = IO.logOutput diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index 70a8a6d47..50157189f 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Lua.Util Copyright : © 2012-2021 John MacFarlane, @@ -14,114 +17,91 @@ Lua utility functions. -} module Text.Pandoc.Lua.Util ( getTag - , rawField , addField , addFunction - , addValue , pushViaConstructor - , defineHowTo - , throwTopMessageAsError' , callWithTraceback , dofileWithTraceback + , pushViaConstr' ) where import Control.Monad (unless, when) -import Data.Text (Text) -import Foreign.Lua ( Lua, NumArgs, NumResults, Peekable, Pushable, StackIndex - , Status, ToHaskellFunction ) -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.UTF8 as UTF8 - --- | Get value behind key from table at given index. -rawField :: Peekable a => StackIndex -> String -> Lua a -rawField idx key = do - absidx <- Lua.absindex idx - Lua.push key - Lua.rawget absidx - Lua.popValue +import HsLua +import qualified HsLua as Lua -- | Add a value to the table at the top of the stack at a string-index. -addField :: Pushable a => String -> a -> Lua () -addField = addValue - --- | Add a key-value pair to the table at the top of the stack. -addValue :: (Pushable a, Pushable b) => a -> b -> Lua () -addValue key value = do +addField :: (LuaError e, Pushable a) => String -> a -> LuaE e () +addField key value = do Lua.push key Lua.push value - Lua.rawset (Lua.nthFromTop 3) + Lua.rawset (Lua.nth 3) --- | Add a function to the table at the top of the stack, using the given name. -addFunction :: ToHaskellFunction a => String -> a -> Lua () +-- | Add a function to the table at the top of the stack, using the +-- given name. +addFunction :: Exposable e a => String -> a -> LuaE e () addFunction name fn = do Lua.push name - Lua.pushHaskellFunction fn + Lua.pushHaskellFunction $ toHaskellFunction fn Lua.rawset (-3) --- | Helper class for pushing a single value to the stack via a lua function. --- See @pushViaCall@. -class PushViaCall a where - pushViaCall' :: String -> Lua () -> NumArgs -> a +-- | Helper class for pushing a single value to the stack via a lua +-- function. See @pushViaCall@. +class LuaError e => PushViaCall e a where + pushViaCall' :: LuaError e => Name -> LuaE e () -> NumArgs -> a -instance PushViaCall (Lua ()) where +instance LuaError e => PushViaCall e (LuaE e ()) where pushViaCall' fn pushArgs num = do - Lua.push fn + Lua.pushName @e fn Lua.rawget Lua.registryindex pushArgs Lua.call num 1 -instance (Pushable a, PushViaCall b) => PushViaCall (a -> b) where +instance (LuaError e, Pushable a, PushViaCall e b) => + PushViaCall e (a -> b) where pushViaCall' fn pushArgs num x = - pushViaCall' fn (pushArgs *> Lua.push x) (num + 1) + pushViaCall' @e fn (pushArgs *> Lua.push x) (num + 1) -- | Push an value to the stack via a lua function. The lua function is called -- with all arguments that are passed to this function and is expected to return -- a single value. -pushViaCall :: PushViaCall a => String -> a -pushViaCall fn = pushViaCall' fn (return ()) 0 +pushViaCall :: forall e a. LuaError e => PushViaCall e a => Name -> a +pushViaCall fn = pushViaCall' @e fn (return ()) 0 -- | Call a pandoc element constructor within Lua, passing all given arguments. -pushViaConstructor :: PushViaCall a => String -> a -pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn) +pushViaConstructor :: forall e a. LuaError e => PushViaCall e a => Name -> a +pushViaConstructor pandocFn = pushViaCall @e ("pandoc." <> pandocFn) -- | 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 :: StackIndex -> Lua String +getTag :: LuaError e => Peeker e Name getTag idx = do -- push metatable or just the table - Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx) - Lua.push ("tag" :: Text) - Lua.rawget (Lua.nthFromTop 2) - Lua.tostring Lua.stackTop <* Lua.pop 2 >>= \case - Nothing -> Lua.throwMessage "untagged value" - Just x -> return (UTF8.toString x) - --- | Modify the message at the top of the stack before throwing it as an --- Exception. -throwTopMessageAsError' :: (String -> String) -> Lua a -throwTopMessageAsError' modifier = do - msg <- Lua.tostring' Lua.stackTop - Lua.pop 2 -- remove error and error string pushed by tostring' - Lua.throwMessage (modifier (UTF8.toString msg)) - --- | Mark the context of a Lua computation for better error reporting. -defineHowTo :: String -> Lua a -> Lua a -defineHowTo ctx op = Lua.errorConversion >>= \ec -> - Lua.addContextToException ec ("Could not " <> ctx <> ": ") op + 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 :: NumArgs -> NumResults -> Lua Status +pcallWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e Status pcallWithTraceback nargs nresults = do - let traceback' :: Lua NumResults + let traceback' :: LuaError e => LuaE e NumResults traceback' = do l <- Lua.state - msg <- Lua.tostring' (Lua.nthFromBottom 1) - Lua.traceback l (Just (UTF8.toString msg)) 2 + msg <- Lua.tostring' (Lua.nthBottom 1) + Lua.traceback l (Just msg) 2 return 1 - tracebackIdx <- Lua.absindex (Lua.nthFromTop (Lua.fromNumArgs nargs + 1)) + tracebackIdx <- Lua.absindex (Lua.nth (Lua.fromNumArgs nargs + 1)) Lua.pushHaskellFunction traceback' Lua.insert tracebackIdx result <- Lua.pcall nargs nresults (Just tracebackIdx) @@ -129,15 +109,15 @@ pcallWithTraceback nargs nresults = do return result -- | Like @'Lua.call'@, but adds a traceback to the error message (if any). -callWithTraceback :: NumArgs -> NumResults -> Lua () +callWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e () callWithTraceback nargs nresults = do result <- pcallWithTraceback nargs nresults when (result /= Lua.OK) - Lua.throwTopMessage + Lua.throwErrorAsException -- | Run the given string as a Lua program, while also adding a traceback to the -- error message if an error occurs. -dofileWithTraceback :: FilePath -> Lua Status +dofileWithTraceback :: LuaError e => FilePath -> LuaE e Status dofileWithTraceback fp = do loadRes <- Lua.loadfile fp case loadRes of diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 1e9f37d2f..da212ab4e 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Writers.Custom Copyright : Copyright (C) 2012-2021 John MacFarlane @@ -10,7 +13,7 @@ Portability : portable Conversion of 'Pandoc' documents to custom markup using -a lua writer. +a Lua writer. -} module Text.Pandoc.Writers.Custom ( writeCustom ) where import Control.Arrow ((***)) @@ -20,7 +23,8 @@ import Data.List (intersperse) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text, pack) -import Foreign.Lua (Lua, Pushable) +import HsLua as Lua hiding (Operation (Div), render) +import HsLua.Class.Peekable (PeekError) import Text.DocLayout (render, literal) import Control.Monad.IO.Class (MonadIO) import Text.Pandoc.Definition @@ -31,39 +35,39 @@ import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared -import qualified Foreign.Lua as Lua - attrToMap :: Attr -> M.Map T.Text T.Text attrToMap (id',classes,keyvals) = M.fromList $ ("id", id') : ("class", T.unwords classes) : keyvals -newtype Stringify a = Stringify a +newtype Stringify e a = Stringify a -instance Pushable (Stringify Format) where +instance Pushable (Stringify e Format) where push (Stringify (Format f)) = Lua.push (T.toLower f) -instance Pushable (Stringify [Inline]) where - push (Stringify ils) = Lua.push =<< inlineListToCustom ils +instance PeekError e => Pushable (Stringify e [Inline]) where + push (Stringify ils) = Lua.push =<< + changeErrorType ((inlineListToCustom @e) ils) -instance Pushable (Stringify [Block]) where - push (Stringify blks) = Lua.push =<< blockListToCustom blks +instance PeekError e => Pushable (Stringify e [Block]) where + push (Stringify blks) = Lua.push =<< + changeErrorType ((blockListToCustom @e) blks) -instance Pushable (Stringify MetaValue) where - push (Stringify (MetaMap m)) = Lua.push (fmap Stringify m) - push (Stringify (MetaList xs)) = Lua.push (map Stringify xs) +instance PeekError e => Pushable (Stringify e MetaValue) where + push (Stringify (MetaMap m)) = Lua.push (fmap (Stringify @e) m) + push (Stringify (MetaList xs)) = Lua.push (map (Stringify @e) xs) push (Stringify (MetaBool x)) = Lua.push x push (Stringify (MetaString s)) = Lua.push s - push (Stringify (MetaInlines ils)) = Lua.push (Stringify ils) - push (Stringify (MetaBlocks bs)) = Lua.push (Stringify bs) + push (Stringify (MetaInlines ils)) = Lua.push (Stringify @e ils) + push (Stringify (MetaBlocks bs)) = Lua.push (Stringify @e bs) -instance Pushable (Stringify Citation) where +instance PeekError e => Pushable (Stringify e Citation) where push (Stringify cit) = do Lua.createtable 6 0 addField "citationId" $ citationId cit - addField "citationPrefix" . Stringify $ citationPrefix cit - addField "citationSuffix" . Stringify $ citationSuffix cit + addField "citationPrefix" . Stringify @e $ citationPrefix cit + addField "citationSuffix" . Stringify @e $ citationSuffix cit addField "citationMode" $ show (citationMode cit) addField "citationNoteNum" $ citationNoteNum cit addField "citationHash" $ citationHash cit @@ -77,7 +81,7 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where Lua.newtable Lua.push k Lua.push v - Lua.rawset (Lua.nthFromTop 3) + Lua.rawset (Lua.nth 3) -- | Convert Pandoc to custom markup. writeCustom :: (PandocMonad m, MonadIO m) @@ -92,7 +96,7 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): when (stat /= Lua.OK) - Lua.throwTopMessage + Lua.throwErrorAsException rendered <- docToCustom opts doc context <- metaToContext opts (fmap (literal . pack) . blockListToCustom) @@ -107,126 +111,132 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do Just tpl -> render Nothing $ renderTemplate tpl $ setField "body" body context -docToCustom :: WriterOptions -> Pandoc -> Lua String +docToCustom :: forall e. PeekError e + => WriterOptions -> Pandoc -> LuaE e String docToCustom opts (Pandoc (Meta metamap) blocks) = do body <- blockListToCustom blocks - Lua.callFunc "Doc" body (fmap Stringify metamap) (writerVariables opts) + invoke @e "Doc" body (fmap (Stringify @e) metamap) (writerVariables opts) -- | Convert Pandoc block element to Custom. -blockToCustom :: Block -- ^ Block element - -> Lua String +blockToCustom :: forall e. PeekError e + => Block -- ^ Block element + -> LuaE e String blockToCustom Null = return "" -blockToCustom (Plain inlines) = Lua.callFunc "Plain" (Stringify inlines) +blockToCustom (Plain inlines) = invoke @e "Plain" (Stringify @e inlines) blockToCustom (Para [Image attr txt (src,tit)]) = - Lua.callFunc "CaptionedImage" src tit (Stringify txt) (attrToMap attr) + invoke @e "CaptionedImage" src tit (Stringify @e txt) (attrToMap attr) -blockToCustom (Para inlines) = Lua.callFunc "Para" (Stringify inlines) +blockToCustom (Para inlines) = invoke @e "Para" (Stringify @e inlines) blockToCustom (LineBlock linesList) = - Lua.callFunc "LineBlock" (map Stringify linesList) + invoke @e "LineBlock" (map (Stringify @e) linesList) blockToCustom (RawBlock format str) = - Lua.callFunc "RawBlock" (Stringify format) str + invoke @e "RawBlock" (Stringify @e format) str -blockToCustom HorizontalRule = Lua.callFunc "HorizontalRule" +blockToCustom HorizontalRule = invoke @e "HorizontalRule" blockToCustom (Header level attr inlines) = - Lua.callFunc "Header" level (Stringify inlines) (attrToMap attr) + invoke @e "Header" level (Stringify @e inlines) (attrToMap attr) blockToCustom (CodeBlock attr str) = - Lua.callFunc "CodeBlock" str (attrToMap attr) + invoke @e "CodeBlock" str (attrToMap attr) blockToCustom (BlockQuote blocks) = - Lua.callFunc "BlockQuote" (Stringify blocks) + invoke @e "BlockQuote" (Stringify @e blocks) blockToCustom (Table _ blkCapt specs thead tbody tfoot) = let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot aligns' = map show aligns - capt' = Stringify capt - headers' = map Stringify headers - rows' = map (map Stringify) rows - in Lua.callFunc "Table" capt' aligns' widths headers' rows' + capt' = Stringify @e capt + headers' = map (Stringify @e) headers + rows' = map (map (Stringify @e)) rows + in invoke @e "Table" capt' aligns' widths headers' rows' blockToCustom (BulletList items) = - Lua.callFunc "BulletList" (map Stringify items) + invoke @e "BulletList" (map (Stringify @e) items) blockToCustom (OrderedList (num,sty,delim) items) = - Lua.callFunc "OrderedList" (map Stringify items) num (show sty) (show delim) + invoke @e "OrderedList" (map (Stringify @e) items) num (show sty) (show delim) blockToCustom (DefinitionList items) = - Lua.callFunc "DefinitionList" - (map (KeyValue . (Stringify *** map Stringify)) items) + invoke @e "DefinitionList" + (map (KeyValue . (Stringify @e *** map (Stringify @e))) items) blockToCustom (Div attr items) = - Lua.callFunc "Div" (Stringify items) (attrToMap attr) + invoke @e "Div" (Stringify @e items) (attrToMap attr) -- | Convert list of Pandoc block elements to Custom. -blockListToCustom :: [Block] -- ^ List of block elements - -> Lua String +blockListToCustom :: forall e. PeekError e + => [Block] -- ^ List of block elements + -> LuaE e String blockListToCustom xs = do - blocksep <- Lua.callFunc "Blocksep" + blocksep <- invoke @e "Blocksep" bs <- mapM blockToCustom xs return $ mconcat $ intersperse blocksep bs -- | Convert list of Pandoc inline elements to Custom. -inlineListToCustom :: [Inline] -> Lua String +inlineListToCustom :: forall e. PeekError e => [Inline] -> LuaE e String inlineListToCustom lst = do - xs <- mapM inlineToCustom lst + xs <- mapM (inlineToCustom @e) lst return $ mconcat xs -- | Convert Pandoc inline element to Custom. -inlineToCustom :: Inline -> Lua String +inlineToCustom :: forall e. PeekError e => Inline -> LuaE e String -inlineToCustom (Str str) = Lua.callFunc "Str" str +inlineToCustom (Str str) = invoke @e "Str" str -inlineToCustom Space = Lua.callFunc "Space" +inlineToCustom Space = invoke @e "Space" -inlineToCustom SoftBreak = Lua.callFunc "SoftBreak" +inlineToCustom SoftBreak = invoke @e "SoftBreak" -inlineToCustom (Emph lst) = Lua.callFunc "Emph" (Stringify lst) +inlineToCustom (Emph lst) = invoke @e "Emph" (Stringify @e lst) -inlineToCustom (Underline lst) = Lua.callFunc "Underline" (Stringify lst) +inlineToCustom (Underline lst) = invoke @e "Underline" (Stringify @e lst) -inlineToCustom (Strong lst) = Lua.callFunc "Strong" (Stringify lst) +inlineToCustom (Strong lst) = invoke @e "Strong" (Stringify @e lst) -inlineToCustom (Strikeout lst) = Lua.callFunc "Strikeout" (Stringify lst) +inlineToCustom (Strikeout lst) = invoke @e "Strikeout" (Stringify @e lst) -inlineToCustom (Superscript lst) = Lua.callFunc "Superscript" (Stringify lst) +inlineToCustom (Superscript lst) = invoke @e "Superscript" (Stringify @e lst) -inlineToCustom (Subscript lst) = Lua.callFunc "Subscript" (Stringify lst) +inlineToCustom (Subscript lst) = invoke @e "Subscript" (Stringify @e lst) -inlineToCustom (SmallCaps lst) = Lua.callFunc "SmallCaps" (Stringify lst) +inlineToCustom (SmallCaps lst) = invoke @e "SmallCaps" (Stringify @e lst) -inlineToCustom (Quoted SingleQuote lst) = Lua.callFunc "SingleQuoted" (Stringify lst) +inlineToCustom (Quoted SingleQuote lst) = + invoke @e "SingleQuoted" (Stringify @e lst) -inlineToCustom (Quoted DoubleQuote lst) = Lua.callFunc "DoubleQuoted" (Stringify lst) +inlineToCustom (Quoted DoubleQuote lst) = + invoke @e "DoubleQuoted" (Stringify @e lst) -inlineToCustom (Cite cs lst) = Lua.callFunc "Cite" (Stringify lst) (map Stringify cs) +inlineToCustom (Cite cs lst) = + invoke @e "Cite" (Stringify @e lst) (map (Stringify @e) cs) inlineToCustom (Code attr str) = - Lua.callFunc "Code" str (attrToMap attr) + invoke @e "Code" str (attrToMap attr) inlineToCustom (Math DisplayMath str) = - Lua.callFunc "DisplayMath" str + invoke @e "DisplayMath" str inlineToCustom (Math InlineMath str) = - Lua.callFunc "InlineMath" str + invoke @e "InlineMath" str inlineToCustom (RawInline format str) = - Lua.callFunc "RawInline" (Stringify format) str + invoke @e "RawInline" (Stringify @e format) str -inlineToCustom LineBreak = Lua.callFunc "LineBreak" +inlineToCustom LineBreak = invoke @e "LineBreak" inlineToCustom (Link attr txt (src,tit)) = - Lua.callFunc "Link" (Stringify txt) src tit (attrToMap attr) + invoke @e "Link" (Stringify @e txt) src tit (attrToMap attr) inlineToCustom (Image attr alt (src,tit)) = - Lua.callFunc "Image" (Stringify alt) src tit (attrToMap attr) + invoke @e "Image" (Stringify @e alt) src tit (attrToMap attr) -inlineToCustom (Note contents) = Lua.callFunc "Note" (Stringify contents) +inlineToCustom (Note contents) = invoke @e "Note" (Stringify @e contents) inlineToCustom (Span attr items) = - Lua.callFunc "Span" (Stringify items) (attrToMap attr) + invoke @e "Span" (Stringify @e items) (attrToMap attr) diff --git a/stack.yaml b/stack.yaml index d12ab3587..932f90d34 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,6 +12,19 @@ extra-deps: - doctemplates-0.10 - emojis-0.1.2 - doclayout-0.3.1.1 +- hslua-2.0.0 +- hslua-classes-2.0.0 +- hslua-core-2.0.0 +- hslua-marshalling-2.0.0 +- hslua-module-path-1.0.0 +- hslua-module-system-1.0.0 +- hslua-module-text-1.0.0 +- hslua-module-version-1.0.0 +- hslua-objectorientation-2.0.0 +- hslua-packaging-2.0.0 +- lua-2.0.0 +- tasty-hslua-1.0.0 +- tasty-lua-1.0.0 - git: https://github.com/jgm/pandoc-types.git commit: 99402a46361a3e52805935b1fbe9dfe54f852d6a - git: https://github.com/jgm/texmath.git @@ -26,5 +39,3 @@ ghc-options: resolver: lts-18.10 nix: packages: [zlib] - - diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs index 31c011900..e19f6f9e8 100644 --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Tests.Lua Copyright : © 2017-2021 Albert Krewinkel @@ -14,9 +15,10 @@ Unit and integration tests for pandoc's Lua subsystem. module Tests.Lua ( runLuaTest, tests ) where import Control.Monad (when) +import HsLua as Lua hiding (Operation (Div), error) import System.FilePath ((</>)) import Test.Tasty (TestTree, localOption) -import Test.Tasty.HUnit (Assertion, assertEqual, testCase) +import Test.Tasty.HUnit (Assertion, HasCallStack, assertEqual, testCase) import Test.Tasty.QuickCheck (QuickCheckTests (..), ioProperty, testProperty) import Text.Pandoc.Arbitrary () import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith, @@ -25,8 +27,8 @@ import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith, singleQuoted, space, str, strong, HasMeta (setMeta)) import Text.Pandoc.Class (runIOorExplode, setUserDataDir) -import Text.Pandoc.Definition (Block (BlockQuote, Div, Para), Inline (Emph, Str), - Attr, Meta, Pandoc, pandocTypesVersion) +import Text.Pandoc.Definition (Attr, Block (BlockQuote, Div, Para), Pandoc, + Inline (Emph, Str), Meta, pandocTypesVersion) import Text.Pandoc.Error (PandocError (PandocLuaError)) import Text.Pandoc.Filter (Filter (LuaFilter), applyFilters) import Text.Pandoc.Lua (runLua) @@ -34,23 +36,22 @@ import Text.Pandoc.Options (def) import Text.Pandoc.Shared (pandocVersion) import qualified Control.Monad.Catch as Catch -import qualified Foreign.Lua as Lua import qualified Data.Text as T import qualified Data.Text.Encoding as TE tests :: [TestTree] tests = map (localOption (QuickCheckTests 20)) [ testProperty "inline elements can be round-tripped through the lua stack" $ - \x -> ioProperty (roundtripEqual (x::Inline)) + ioProperty . roundtripEqual @Inline , testProperty "block elements can be round-tripped through the lua stack" $ - \x -> ioProperty (roundtripEqual (x::Block)) + ioProperty . roundtripEqual @Block , testProperty "meta blocks can be round-tripped through the lua stack" $ - \x -> ioProperty (roundtripEqual (x::Meta)) + ioProperty . roundtripEqual @Meta , testProperty "documents can be round-tripped through the lua stack" $ - \x -> ioProperty (roundtripEqual (x::Pandoc)) + ioProperty . roundtripEqual @Pandoc , testCase "macro expansion via filter" $ assertFilterConversion "a '{{helloworld}}' string is expanded" @@ -163,12 +164,12 @@ tests = map (localOption (QuickCheckTests 20)) Lua.getglobal "PANDOC_VERSION" Lua.liftIO . assertEqual "pandoc version is wrong" (TE.encodeUtf8 pandocVersion) - =<< Lua.tostring' Lua.stackTop + =<< Lua.tostring' Lua.top , testCase "Pandoc types version is set" . runLuaTest $ do Lua.getglobal "PANDOC_API_VERSION" Lua.liftIO . assertEqual "pandoc-types version is wrong" pandocTypesVersion - =<< Lua.peek Lua.stackTop + =<< Lua.peek Lua.top , testCase "require file" $ assertFilterConversion "requiring file failed" @@ -177,38 +178,47 @@ tests = map (localOption (QuickCheckTests 20)) (doc $ para (str . T.pack $ "lua" </> "require-file.lua")) , testCase "Allow singleton inline in constructors" . runLuaTest $ do - Lua.liftIO . assertEqual "Not the expected Emph" (Emph [Str "test"]) - =<< Lua.callFunc "pandoc.Emph" (Str "test") - Lua.liftIO . assertEqual "Unexpected element" (Para [Str "test"]) - =<< Lua.callFunc "pandoc.Para" ("test" :: String) + Lua.liftIO . assertEqual "Not the expected Emph" + (Emph [Str "test"]) =<< do + Lua.OK <- Lua.dostring "return pandoc.Emph" + Lua.push @Inline (Str "test") + Lua.call 1 1 + Lua.peek @Inline top + Lua.liftIO . assertEqual "Unexpected element" + (Para [Str "test"]) =<< do + Lua.getglobal' "pandoc.Para" + Lua.pushString "test" + Lua.call 1 1 + Lua.peek @Block top Lua.liftIO . assertEqual "Unexptected element" (BlockQuote [Para [Str "foo"]]) =<< ( do Lua.getglobal' "pandoc.BlockQuote" Lua.push (Para [Str "foo"]) _ <- Lua.call 1 1 - Lua.peek Lua.stackTop + Lua.peek @Block Lua.top ) , testCase "Elements with Attr have `attr` accessor" . runLuaTest $ do Lua.push (Div ("hi", ["moin"], []) [Para [Str "ignored"]]) - Lua.getfield Lua.stackTop "attr" + Lua.getfield Lua.top "attr" Lua.liftIO . assertEqual "no accessor" (("hi", ["moin"], []) :: Attr) - =<< Lua.peek Lua.stackTop + =<< Lua.peek Lua.top , testCase "module `pandoc.system` is present" . runLuaTest $ do Lua.getglobal' "pandoc.system" - ty <- Lua.ltype Lua.stackTop + ty <- Lua.ltype Lua.top Lua.liftIO $ assertEqual "module should be a table" Lua.TypeTable ty , testCase "informative error messages" . runLuaTest $ do Lua.pushboolean True - eitherPandoc <- Catch.try (Lua.peek Lua.stackTop :: Lua.Lua Pandoc) + -- Lua.newtable + eitherPandoc <- Catch.try (peek @Pandoc Lua.top) case eitherPandoc of Left (PandocLuaError msg) -> do - let expectedMsg = "Could not get Pandoc value: " - <> "table expected, got boolean" + let expectedMsg = "table expected, got boolean\n" + <> "\twhile retrieving Pandoc value" Lua.liftIO $ assertEqual "unexpected error message" expectedMsg msg Left e -> error ("Expected a Lua error, but got " <> show e) Right _ -> error "Getting a Pandoc element from a bool should fail." @@ -221,19 +231,20 @@ assertFilterConversion msg filterPath docIn expectedDoc = do applyFilters def [LuaFilter ("lua" </> filterPath)] ["HTML"] docIn assertEqual msg expectedDoc actualDoc -roundtripEqual :: (Eq a, Lua.Peekable a, Lua.Pushable a) => a -> IO Bool +roundtripEqual :: forall a. (Eq a, Lua.Pushable a, Lua.Peekable a) + => a -> IO Bool roundtripEqual x = (x ==) <$> roundtripped where - roundtripped :: Lua.Peekable a => IO a + roundtripped :: IO a roundtripped = runLuaTest $ do oldSize <- Lua.gettop Lua.push x size <- Lua.gettop when (size - oldSize /= 1) $ error ("not exactly one additional element on the stack: " ++ show size) - Lua.peek (-1) + Lua.peek Lua.top -runLuaTest :: Lua.Lua a -> IO a +runLuaTest :: HasCallStack => Lua.LuaE PandocError a -> IO a runLuaTest op = runIOorExplode $ do setUserDataDir (Just "../data") res <- runLua op diff --git a/test/lua/module/pandoc-types.lua b/test/lua/module/pandoc-types.lua index d4e063a5c..d9c9f82ac 100644 --- a/test/lua/module/pandoc-types.lua +++ b/test/lua/module/pandoc-types.lua @@ -55,31 +55,6 @@ return { end), }, - group 'list-like behavior' { - test('can access version component numbers', function () - local version = Version '2.7.3' - assert.is_nil(version[0]) - assert.are_equal(version[1], 2) - assert.are_equal(version[2], 7) - assert.are_equal(version[3], 3) - end), - test('can be iterated over', function () - local version_list = {2, 7, 3} - local final_index = 0 - for i, v in pairs(Version(version_list)) do - assert.are_equal(v, version_list[i]) - final_index = i - end - assert.are_equal(final_index, 3) - end), - test('length is the number of components', function () - assert.are_equal(#(Version '0'), 1) - assert.are_equal(#(Version '1.6'), 2) - assert.are_equal(#(Version '8.7.5'), 3) - assert.are_equal(#(Version '2.9.1.5'), 4) - end) - }, - group 'conversion to string' { test('converting from and to string is a noop', function () local version_string = '1.19.4' |