diff options
| author | Albert Krewinkel <albert@zeitkraut.de> | 2021-10-20 21:40:07 +0200 |
|---|---|---|
| committer | John MacFarlane <jgm@berkeley.edu> | 2021-10-22 11:16:51 -0700 |
| commit | 9e74826ba9ce4139bfdd3f057a79efa8b644e85a (patch) | |
| tree | 954692554bfc024b6927de385923ab5c69a4b5df | |
| parent | e10f495a0163738a09c3fd18fce11788832c82b7 (diff) | |
| download | pandoc-9e74826ba9ce4139bfdd3f057a79efa8b644e85a.tar.gz | |
Switch to hslua-2.0
The new HsLua version takes a somewhat different approach to marshalling
and unmarshalling, relying less on typeclasses and more on specialized
types. This allows for better performance and improved error messages.
Furthermore, new abstractions allow to document the code and exposed
functions.
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' |