diff options
author | John MacFarlane <jgm@berkeley.edu> | 2020-04-17 18:02:25 -0700 |
---|---|---|
committer | GitHub <noreply@github.com> | 2020-04-17 18:02:25 -0700 |
commit | 0d2b8e3fe1d6a27aac082be7711b7156783b3051 (patch) | |
tree | 459122371d6b88a7756eee954b81f2bba4bdfdca /src/Text/Pandoc/Lua | |
parent | 8f40b4ba14fce10199a059a281c9bd10c884241d (diff) | |
parent | 62cf21cbaa9ac3fbc2ba7218a3037208364c80a4 (diff) | |
download | pandoc-0d2b8e3fe1d6a27aac082be7711b7156783b3051.tar.gz |
Merge pull request #6211 from tarleb/lua-pandocerror
API change: create PandocLua type, use PandocError for exceptions
Diffstat (limited to 'src/Text/Pandoc/Lua')
-rw-r--r-- | src/Text/Pandoc/Lua/ErrorConversion.hs | 61 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Filter.hs | 20 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Init.hs | 91 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Marshaling.hs | 3 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/AST.hs | 15 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/PandocError.hs | 65 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Marshaling/Version.hs | 4 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Module/MediaBag.hs | 77 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Module/Pandoc.hs | 32 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Module/Utils.hs | 57 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Packages.hs | 64 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/PandocLua.hs | 134 | ||||
-rw-r--r-- | src/Text/Pandoc/Lua/Util.hs | 24 |
13 files changed, 412 insertions, 235 deletions
diff --git a/src/Text/Pandoc/Lua/ErrorConversion.hs b/src/Text/Pandoc/Lua/ErrorConversion.hs new file mode 100644 index 000000000..59c962723 --- /dev/null +++ b/src/Text/Pandoc/Lua/ErrorConversion.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | + Module : Text.Pandoc.Lua.ErrorConversion + Copyright : © 2020 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + Stability : alpha + +Define how Lua errors are converted into @'PandocError'@ Haskell +exceptions, and /vice versa/. +-} +module Text.Pandoc.Lua.ErrorConversion + ( errorConversion + ) where + +import Foreign.Lua (Lua (..), NumResults) +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 diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index f6a0aea5b..e626356d5 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -18,14 +18,15 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction ) where import Control.Applicative ((<|>)) import Control.Monad (mplus, (>=>)) -import Control.Monad.Catch (finally) +import Control.Monad.Catch (finally, try) import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf, showConstr, toConstr, tyconUQname) import Data.Foldable (foldrM) import Data.Map (Map) import Data.Maybe (fromMaybe) -import Foreign.Lua (Lua, Peekable, Pushable) +import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) 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.Walk (SingletonsList (..)) @@ -102,7 +103,7 @@ elementOrList x = do if elementUnchanged then [x] <$ Lua.pop 1 else do - mbres <- Lua.peekEither topOfStack + mbres <- peekEither topOfStack case mbres of Right res -> [res] <$ Lua.pop 1 Left _ -> Lua.peekList topOfStack `finally` Lua.pop 1 @@ -234,11 +235,16 @@ singleElement x = do if elementUnchanged then x <$ Lua.pop 1 else do - mbres <- Lua.peekEither (-1) + mbres <- peekEither (-1) case mbres of Right res -> res <$ Lua.pop 1 Left err -> do Lua.pop 1 - Lua.throwException $ - "Error while trying to get a filter's return " ++ - "value from lua stack.\n" ++ err + 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/Init.hs b/src/Text/Pandoc/Lua/Init.hs index 757d32898..a5e513a1f 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -9,96 +9,57 @@ Functions to initialize the Lua interpreter. -} module Text.Pandoc.Lua.Init - ( LuaException (..) - , LuaPackageParams (..) - , runLua - , luaPackageParams + ( runLua ) where +import Control.Monad.Catch (try) import Control.Monad.Trans (MonadIO (..)) import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) import Foreign.Lua (Lua) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) import Text.Pandoc.Class.PandocIO (PandocIO) -import Text.Pandoc.Class.PandocMonad (getCommonState, getUserDataDir, - putCommonState) -import Text.Pandoc.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.Packages (LuaPackageParams (..), - installPandocPackageSearcher) -import Text.Pandoc.Lua.Util (loadScriptFromDataDir) +import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Lua.Packages (installPandocPackageSearcher) +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, + loadScriptFromDataDir, runPandocLua) -import qualified Data.Text as Text import qualified Foreign.Lua as Lua -import qualified Foreign.Lua.Module.Text as Lua import qualified Text.Pandoc.Definition as Pandoc import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc --- | Lua error message -newtype LuaException = LuaException Text.Text deriving (Show) - -- | Run the lua interpreter, using pandoc's default way of environment -- initialization. -runLua :: Lua a -> PandocIO (Either LuaException a) +runLua :: Lua a -> PandocIO (Either PandocError a) runLua luaOp = do - luaPkgParams <- luaPackageParams - globals <- defaultGlobals enc <- liftIO $ getForeignEncoding <* setForeignEncoding utf8 - res <- liftIO . Lua.runEither $ do - setGlobals globals - initLuaState luaPkgParams - -- run the given Lua operation - opResult <- luaOp - -- get the (possibly modified) state back - Lua.getglobal "PANDOC_STATE" - st <- Lua.peek Lua.stackTop - Lua.pop 1 - -- done - return (opResult, st) + res <- runPandocLua . try $ do + initLuaState + liftPandocLua luaOp liftIO $ setForeignEncoding enc - case res of - Left (Lua.Exception msg) -> return $ Left (LuaException $ Text.pack msg) - Right (x, newState) -> do - putCommonState newState - return $ Right x - --- | Global variables which should always be set. -defaultGlobals :: PandocIO [Global] -defaultGlobals = do - commonState <- getCommonState - return - [ PANDOC_API_VERSION - , PANDOC_STATE commonState - , PANDOC_VERSION - ] - --- | Generate parameters required to setup pandoc's lua environment. -luaPackageParams :: PandocIO LuaPackageParams -luaPackageParams = do - datadir <- getUserDataDir - return LuaPackageParams { luaPkgDataDir = datadir } + return res -- | Initialize the lua state with all required values -initLuaState :: LuaPackageParams -> Lua () -initLuaState pkgParams = do - Lua.openlibs - Lua.preloadTextModule "text" - installPandocPackageSearcher pkgParams +initLuaState :: PandocLua () +initLuaState = do + liftPandocLua Lua.openlibs + installPandocPackageSearcher initPandocModule - loadScriptFromDataDir (luaPkgDataDir pkgParams) "init.lua" + loadScriptFromDataDir "init.lua" where - initPandocModule :: Lua () + initPandocModule :: PandocLua () initPandocModule = do -- Push module table - ModulePandoc.pushModule (luaPkgDataDir pkgParams) + ModulePandoc.pushModule -- register as loaded module - Lua.pushvalue Lua.stackTop - Lua.getfield Lua.registryindex Lua.loadedTableRegistryField - Lua.setfield (Lua.nthFromTop 2) "pandoc" - Lua.pop 1 + liftPandocLua $ do + Lua.pushvalue Lua.stackTop + Lua.getfield Lua.registryindex Lua.loadedTableRegistryField + Lua.setfield (Lua.nthFromTop 2) "pandoc" + Lua.pop 1 -- copy constructors into registry putConstructorsInRegistry -- assign module to global variable - Lua.setglobal "pandoc" + liftPandocLua $ Lua.setglobal "pandoc" -- | AST elements are marshaled via normal constructor functions in the -- @pandoc@ module. However, accessing Lua globals from Haskell is @@ -108,8 +69,8 @@ initLuaState pkgParams = do -- -- This function expects the @pandoc@ module to be at the top of the -- stack. -putConstructorsInRegistry :: Lua () -putConstructorsInRegistry = do +putConstructorsInRegistry :: PandocLua () +putConstructorsInRegistry = liftPandocLua $ do constrsToReg $ Pandoc.Pandoc mempty mempty constrsToReg $ Pandoc.Str mempty constrsToReg $ Pandoc.Para mempty diff --git a/src/Text/Pandoc/Lua/Marshaling.hs b/src/Text/Pandoc/Lua/Marshaling.hs index 624f8b917..1254402b6 100644 --- a/src/Text/Pandoc/Lua/Marshaling.hs +++ b/src/Text/Pandoc/Lua/Marshaling.hs @@ -13,6 +13,7 @@ module Text.Pandoc.Lua.Marshaling () where import Text.Pandoc.Lua.Marshaling.AST () import Text.Pandoc.Lua.Marshaling.CommonState () -import Text.Pandoc.Lua.Marshaling.ReaderOptions () import Text.Pandoc.Lua.Marshaling.Context () +import Text.Pandoc.Lua.Marshaling.PandocError() +import Text.Pandoc.Lua.Marshaling.ReaderOptions () import Text.Pandoc.Lua.Marshaling.Version () diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs index 81b206f67..8d7e83dc1 100644 --- a/src/Text/Pandoc/Lua/Marshaling/AST.hs +++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs @@ -19,9 +19,11 @@ module Text.Pandoc.Lua.Marshaling.AST import Control.Applicative ((<|>)) import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) import Text.Pandoc.Definition +import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.Util (defineHowTo, pushViaConstructor) import Text.Pandoc.Lua.Marshaling.CommonState () +import qualified Control.Monad.Catch as Catch import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Lua.Util as LuaUtil @@ -131,7 +133,7 @@ peekMetaValue idx = defineHowTo "get MetaValue" $ do Lua.TypeBoolean -> MetaBool <$> Lua.peek idx Lua.TypeString -> MetaString <$> Lua.peek idx Lua.TypeTable -> do - tag <- Lua.try $ LuaUtil.getTag idx + tag <- try $ LuaUtil.getTag idx case tag of Right "MetaBlocks" -> MetaBlocks <$> elementContent Right "MetaBool" -> MetaBool <$> elementContent @@ -139,7 +141,7 @@ peekMetaValue idx = defineHowTo "get MetaValue" $ do Right "MetaInlines" -> MetaInlines <$> elementContent Right "MetaList" -> MetaList <$> elementContent Right "MetaString" -> MetaString <$> elementContent - Right t -> Lua.throwException ("Unknown meta tag: " <> t) + Right t -> Lua.throwMessage ("Unknown meta tag: " <> t) Left _ -> do -- no meta value tag given, try to guess. len <- Lua.rawlen idx @@ -148,7 +150,7 @@ peekMetaValue idx = defineHowTo "get MetaValue" $ do else (MetaInlines <$> Lua.peek idx) <|> (MetaBlocks <$> Lua.peek idx) <|> (MetaList <$> Lua.peek idx) - _ -> Lua.throwException "could not get meta value" + _ -> Lua.throwMessage "could not get meta value" -- | Push a block element to the top of the Lua stack. pushBlock :: Block -> Lua () @@ -199,7 +201,7 @@ peekBlock idx = defineHowTo "get Block value" $ do tbodies tfoot) <$> elementContent - _ -> Lua.throwException ("Unknown block type: " <> tag) + _ -> Lua.throwMessage ("Unknown block type: " <> tag) where -- Get the contents of an AST element. elementContent :: Peekable a => Lua a @@ -344,12 +346,15 @@ peekInline idx = defineHowTo "get Inline value" $ do "Strong" -> Strong <$> elementContent "Subscript" -> Subscript <$> elementContent "Superscript"-> Superscript <$> elementContent - _ -> Lua.throwException ("Unknown inline type: " <> tag) + _ -> 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 diff --git a/src/Text/Pandoc/Lua/Marshaling/PandocError.hs b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs new file mode 100644 index 000000000..74537a1dd --- /dev/null +++ b/src/Text/Pandoc/Lua/Marshaling/PandocError.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | + Module : Text.Pandoc.Lua.Marshaling.PandocError + Copyright : © 2020 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + Stability : alpha + +Marshaling of @'PandocError'@ values. +-} +module Text.Pandoc.Lua.Marshaling.PandocError + ( peekPandocError + , pushPandocError + ) + where + +import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) +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 Text.Pandoc.UTF8 as UTF8 + +-- | Userdata name used by Lua for the @PandocError@ type. +pandocErrorName :: String +pandocErrorName = "pandoc error" + +-- | Peek a @'PandocError'@ element to the Lua stack. +pushPandocError :: PandocError -> Lua () +pushPandocError = Lua.pushAnyWithMetatable pushPandocErrorMT + where + pushPandocErrorMT = Lua.ensureUserdataMetatable pandocErrorName $ + LuaUtil.addFunction "__tostring" __tostring + +-- | 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 diff --git a/src/Text/Pandoc/Lua/Marshaling/Version.hs b/src/Text/Pandoc/Lua/Marshaling/Version.hs index 090725afc..9adb1b763 100644 --- a/src/Text/Pandoc/Lua/Marshaling/Version.hs +++ b/src/Text/Pandoc/Lua/Marshaling/Version.hs @@ -57,7 +57,7 @@ peekVersion idx = Lua.ltype idx >>= \case let parses = readP_to_S parseVersion versionStr case lastMay parses of Just (v, "") -> return v - _ -> Lua.throwException $ "could not parse as Version: " ++ versionStr + _ -> Lua.throwMessage $ "could not parse as Version: " ++ versionStr Lua.TypeUserdata -> reportValueOnFailure versionTypeName @@ -71,7 +71,7 @@ peekVersion idx = Lua.ltype idx >>= \case makeVersion <$> Lua.peek idx _ -> - Lua.throwException "could not peek Version" + Lua.throwMessage "could not peek Version" instance Peekable Version where peek = peekVersion diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index 3a296ef46..e5a10217a 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -14,13 +14,13 @@ module Text.Pandoc.Lua.Module.MediaBag ) where import Control.Monad (zipWithM_) -import Foreign.Lua (Lua, NumResults, Optional, liftIO) +import Foreign.Lua (Lua, NumResults, Optional) import Text.Pandoc.Class.CommonState (CommonState (..)) -import Text.Pandoc.Class.PandocIO (runIOorExplode) -import Text.Pandoc.Class.PandocMonad (fetchItem, putCommonState, setMediaBag) +import Text.Pandoc.Class.PandocMonad (fetchItem, getMediaBag, modifyCommonState, + setMediaBag) import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.Marshaling.MediaBag (pushIterator) -import Text.Pandoc.Lua.Util (addFunction) +import Text.Pandoc.Lua.PandocLua (PandocLua (..), liftPandocLua, addFunction) import Text.Pandoc.MIME (MimeType) import qualified Data.ByteString.Lazy as BL @@ -31,9 +31,9 @@ import qualified Text.Pandoc.MediaBag as MB -- -- MediaBag submodule -- -pushModule :: Lua NumResults +pushModule :: PandocLua NumResults pushModule = do - Lua.newtable + liftPandocLua Lua.newtable addFunction "delete" delete addFunction "empty" empty addFunction "insert" insertMediaFn @@ -43,66 +43,46 @@ pushModule = do addFunction "fetch" fetch return 1 --- --- Port functions from Text.Pandoc.Class to the Lua monad. --- TODO: reuse existing functions. - --- Get the current CommonState. -getCommonState :: Lua CommonState -getCommonState = do - Lua.getglobal "PANDOC_STATE" - Lua.peek Lua.stackTop - --- Replace MediaBag in CommonState. -setCommonState :: CommonState -> Lua () -setCommonState st = do - Lua.push st - Lua.setglobal "PANDOC_STATE" - -modifyCommonState :: (CommonState -> CommonState) -> Lua () -modifyCommonState f = getCommonState >>= setCommonState . f - -- | Delete a single item from the media bag. -delete :: FilePath -> Lua NumResults +delete :: FilePath -> PandocLua NumResults delete fp = 0 <$ modifyCommonState (\st -> st { stMediaBag = MB.deleteMedia fp (stMediaBag st) }) -- | Delete all items from the media bag. -empty :: Lua NumResults +empty :: PandocLua NumResults empty = 0 <$ modifyCommonState (\st -> st { stMediaBag = mempty }) -- | Insert a new item into the media bag. insertMediaFn :: FilePath -> Optional MimeType -> BL.ByteString - -> Lua NumResults + -> PandocLua NumResults insertMediaFn fp optionalMime contents = do - modifyCommonState $ \st -> - let mb = MB.insertMedia fp (Lua.fromOptional optionalMime) contents - (stMediaBag st) - in st { stMediaBag = mb } - return 0 + mb <- getMediaBag + setMediaBag $ MB.insertMedia fp (Lua.fromOptional optionalMime) contents mb + return (Lua.NumResults 0) -- | Returns iterator values to be used with a Lua @for@ loop. -items :: Lua NumResults -items = getCommonState >>= pushIterator . stMediaBag +items :: PandocLua NumResults +items = getMediaBag >>= liftPandocLua . pushIterator lookupMediaFn :: FilePath - -> Lua NumResults + -> PandocLua NumResults lookupMediaFn fp = do - res <- MB.lookupMedia fp . stMediaBag <$> getCommonState - case res of + res <- MB.lookupMedia fp <$> getMediaBag + liftPandocLua $ case res of Nothing -> 1 <$ Lua.pushnil Just (mimeType, contents) -> do Lua.push mimeType Lua.push contents return 2 -mediaDirectoryFn :: Lua NumResults +mediaDirectoryFn :: PandocLua NumResults mediaDirectoryFn = do - dirContents <- MB.mediaDirectory . stMediaBag <$> getCommonState - Lua.newtable - zipWithM_ addEntry [1..] dirContents + dirContents <- MB.mediaDirectory <$> getMediaBag + liftPandocLua $ do + Lua.newtable + zipWithM_ addEntry [1..] dirContents return 1 where addEntry :: Lua.Integer -> (FilePath, MimeType, Int) -> Lua () @@ -114,14 +94,9 @@ mediaDirectoryFn = do Lua.rawseti (-2) idx fetch :: T.Text - -> Lua NumResults + -> PandocLua NumResults fetch src = do - commonState <- getCommonState - let mediaBag = stMediaBag commonState - (bs, mimeType) <- liftIO . runIOorExplode $ do - putCommonState commonState - setMediaBag mediaBag - fetchItem src - Lua.push $ maybe "" T.unpack mimeType - Lua.push bs + (bs, mimeType) <- fetchItem src + liftPandocLua . Lua.push $ maybe "" T.unpack mimeType + liftPandocLua $ Lua.push bs return 2 -- returns 2 values: contents, mimetype diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index f376d0044..3886568b7 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -24,6 +24,8 @@ import Text.Pandoc.Class.PandocIO (runIO) import Text.Pandoc.Definition (Block, Inline) import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter, SingletonsList (..)) import Text.Pandoc.Lua.Marshaling () +import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua, + loadScriptFromDataDir) import Text.Pandoc.Walk (Walkable) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) @@ -38,28 +40,28 @@ import Text.Pandoc.Error -- | Push the "pandoc" on the lua stack. Requires the `list` module to be -- loaded. -pushModule :: Maybe FilePath -> Lua NumResults -pushModule datadir = do - LuaUtil.loadScriptFromDataDir datadir "pandoc.lua" - LuaUtil.addFunction "read" readDoc - LuaUtil.addFunction "pipe" pipeFn - LuaUtil.addFunction "walk_block" walkBlock - LuaUtil.addFunction "walk_inline" walkInline +pushModule :: PandocLua NumResults +pushModule = do + loadScriptFromDataDir "pandoc.lua" + addFunction "read" readDoc + addFunction "pipe" pipeFn + addFunction "walk_block" walkBlock + addFunction "walk_inline" walkInline return 1 walkElement :: (Walkable (SingletonsList Inline) a, Walkable (SingletonsList Block) a) - => a -> LuaFilter -> Lua a -walkElement x f = walkInlines f x >>= walkBlocks f + => a -> LuaFilter -> PandocLua a +walkElement x f = liftPandocLua $ walkInlines f x >>= walkBlocks f -walkInline :: Inline -> LuaFilter -> Lua Inline +walkInline :: Inline -> LuaFilter -> PandocLua Inline walkInline = walkElement -walkBlock :: Block -> LuaFilter -> Lua Block +walkBlock :: Block -> LuaFilter -> PandocLua Block walkBlock = walkElement -readDoc :: T.Text -> Optional T.Text -> Lua NumResults -readDoc content formatSpecOrNil = do +readDoc :: T.Text -> Optional T.Text -> PandocLua NumResults +readDoc content formatSpecOrNil = liftPandocLua $ do let formatSpec = fromMaybe "markdown" (Lua.fromOptional formatSpecOrNil) res <- Lua.liftIO . runIO $ getReader formatSpec >>= \(rdr,es) -> @@ -80,8 +82,8 @@ readDoc content formatSpecOrNil = do pipeFn :: String -> [String] -> BL.ByteString - -> Lua NumResults -pipeFn command args input = do + -> PandocLua NumResults +pipeFn command args input = liftPandocLua $ do (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input case ec of ExitSuccess -> 1 <$ Lua.push output diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index 11a0bda84..4fe5e255d 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Lua.Module.Utils Copyright : Copyright © 2017-2020 Albert Krewinkel @@ -13,15 +14,15 @@ module Text.Pandoc.Lua.Module.Utils ) where import Control.Applicative ((<|>)) +import Control.Monad.Catch (try) import Data.Default (def) import Data.Version (Version) import Foreign.Lua (Peekable, Lua, NumResults) -import Text.Pandoc.Class.PandocIO (runIO) -import Text.Pandoc.Class.PandocMonad (setUserDataDir) import Text.Pandoc.Definition ( Pandoc, Meta, MetaValue (..), Block, Inline , Citation, Attr, ListAttributes) +import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.Marshaling () -import Text.Pandoc.Lua.Util (addFunction) +import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua) import qualified Data.Digest.Pure.SHA as SHA import qualified Data.ByteString.Lazy as BSL @@ -32,14 +33,14 @@ import qualified Text.Pandoc.Filter.JSON as JSONFilter import qualified Text.Pandoc.Shared as Shared -- | Push the "pandoc.utils" module to the lua stack. -pushModule :: Maybe FilePath -> Lua NumResults -pushModule mbDatadir = do - Lua.newtable +pushModule :: PandocLua NumResults +pushModule = do + liftPandocLua Lua.newtable addFunction "blocks_to_inlines" blocksToInlines addFunction "equals" equals addFunction "make_sections" makeSections addFunction "normalize_date" normalizeDate - addFunction "run_json_filter" (runJSONFilter mbDatadir) + addFunction "run_json_filter" runJSONFilter addFunction "sha1" sha1 addFunction "stringify" stringify addFunction "to_roman_numeral" toRomanNumeral @@ -47,8 +48,8 @@ pushModule mbDatadir = do return 1 -- | Squashes a list of blocks into inlines. -blocksToInlines :: [Block] -> Lua.Optional [Inline] -> Lua [Inline] -blocksToInlines blks optSep = do +blocksToInlines :: [Block] -> Lua.Optional [Inline] -> PandocLua [Inline] +blocksToInlines blks optSep = liftPandocLua $ do let sep = case Lua.fromOptional optSep of Just x -> B.fromList x Nothing -> Shared.defaultBlocksSeparator @@ -67,23 +68,17 @@ normalizeDate :: T.Text -> Lua (Lua.Optional T.Text) normalizeDate = return . Lua.Optional . Shared.normalizeDate -- | Run a JSON filter on the given document. -runJSONFilter :: Maybe FilePath - -> Pandoc +runJSONFilter :: Pandoc -> FilePath -> Lua.Optional [String] - -> Lua NumResults -runJSONFilter mbDatadir doc filterFile optArgs = do + -> PandocLua Pandoc +runJSONFilter doc filterFile optArgs = do args <- case Lua.fromOptional optArgs of Just x -> return x - Nothing -> do + Nothing -> liftPandocLua $ do Lua.getglobal "FORMAT" (:[]) <$> Lua.popValue - filterRes <- Lua.liftIO . runIO $ do - setUserDataDir mbDatadir - JSONFilter.apply def args filterFile doc - case filterRes of - Left err -> Lua.raiseError (show err) - Right d -> (1 :: NumResults) <$ Lua.push d + JSONFilter.apply def args filterFile doc -- | Calculate the hash of the given contents. sha1 :: BSL.ByteString @@ -93,7 +88,7 @@ sha1 = return . T.pack . SHA.showDigest . SHA.sha1 -- | Convert pandoc structure to a string with formatting removed. -- Footnotes are skipped (since we don't want their contents in link -- labels). -stringify :: AstElement -> Lua T.Text +stringify :: AstElement -> PandocLua T.Text stringify el = return $ case el of PandocElement pd -> Shared.stringify pd InlineElement i -> Shared.stringify i @@ -109,7 +104,7 @@ stringifyMetaValue mv = case mv of MetaString s -> s _ -> Shared.stringify mv -equals :: AstElement -> AstElement -> Lua Bool +equals :: AstElement -> AstElement -> PandocLua Bool equals e1 e2 = return (e1 == e2) data AstElement @@ -125,18 +120,18 @@ data AstElement instance Peekable AstElement where peek idx = do - res <- Lua.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) + 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 _ -> Lua.throwException + Left (_ :: PandocError) -> Lua.throwMessage "Expected an AST element, but could not parse value as such." -- | Convert a number < 4000 to uppercase roman numeral. -toRomanNumeral :: Lua.Integer -> Lua T.Text +toRomanNumeral :: Lua.Integer -> PandocLua T.Text toRomanNumeral = return . Shared.toRomanNumeral . fromIntegral diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index ad338f4bd..79d42a6d7 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -8,37 +8,32 @@ Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> Stability : alpha -Pandoc module for lua. +Pandoc module for Lua. -} module Text.Pandoc.Lua.Packages - ( LuaPackageParams (..) - , installPandocPackageSearcher + ( installPandocPackageSearcher ) where import Control.Monad (forM_) import Data.ByteString (ByteString) -import Foreign.Lua (Lua, NumResults, liftIO) -import Text.Pandoc.Class.PandocIO (runIO) -import Text.Pandoc.Class.PandocMonad (readDataFile, setUserDataDir) +import Foreign.Lua (Lua, NumResults) +import Text.Pandoc.Class.PandocMonad (readDataFile) +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua) import qualified Foreign.Lua as Lua -import Text.Pandoc.Lua.Module.Pandoc as Pandoc -import Text.Pandoc.Lua.Module.MediaBag as MediaBag -import Text.Pandoc.Lua.Module.System as System -import Text.Pandoc.Lua.Module.Types as Types -import Text.Pandoc.Lua.Module.Utils as Utils - --- | Parameters used to create lua packages/modules. -data LuaPackageParams = LuaPackageParams - { luaPkgDataDir :: Maybe FilePath - } +import qualified Foreign.Lua.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 +import qualified Text.Pandoc.Lua.Module.Types as Types +import qualified Text.Pandoc.Lua.Module.Utils as Utils -- | Insert pandoc's package loader as the first loader, making it the default. -installPandocPackageSearcher :: LuaPackageParams -> Lua () -installPandocPackageSearcher luaPkgParams = do +installPandocPackageSearcher :: PandocLua () +installPandocPackageSearcher = liftPandocLua $ do Lua.getglobal' "package.searchers" shiftArray - Lua.pushHaskellFunction (pandocPackageSearcher luaPkgParams) + Lua.pushHaskellFunction pandocPackageSearcher Lua.rawseti (Lua.nthFromTop 2) 1 Lua.pop 1 -- remove 'package.searchers' from stack where @@ -47,29 +42,24 @@ installPandocPackageSearcher luaPkgParams = do Lua.rawseti (-2) (i + 1) -- | Load a pandoc module. -pandocPackageSearcher :: LuaPackageParams -> String -> Lua NumResults -pandocPackageSearcher pkgParams pkgName = +pandocPackageSearcher :: String -> PandocLua NumResults +pandocPackageSearcher pkgName = case pkgName of - "pandoc" -> let datadir = luaPkgDataDir pkgParams - in pushWrappedHsFun (Pandoc.pushModule datadir) + "pandoc" -> pushWrappedHsFun Pandoc.pushModule "pandoc.mediabag" -> pushWrappedHsFun MediaBag.pushModule "pandoc.system" -> pushWrappedHsFun System.pushModule "pandoc.types" -> pushWrappedHsFun Types.pushModule - "pandoc.utils" -> let datadir = luaPkgDataDir pkgParams - in pushWrappedHsFun (Utils.pushModule datadir) - _ -> searchPureLuaLoader + "pandoc.utils" -> pushWrappedHsFun Utils.pushModule + "text" -> pushWrappedHsFun Text.pushModule + _ -> searchPureLuaLoader where - pushWrappedHsFun f = do + pushWrappedHsFun f = liftPandocLua $ do Lua.pushHaskellFunction f return 1 searchPureLuaLoader = do let filename = pkgName ++ ".lua" - modScript <- liftIO (dataDirScript (luaPkgDataDir pkgParams) filename) - case modScript of - Just script -> pushWrappedHsFun (loadStringAsPackage pkgName script) - Nothing -> do - Lua.push ("\n\tno file '" ++ filename ++ "' in pandoc's datadir") - return 1 + script <- readDataFile filename + pushWrappedHsFun (loadStringAsPackage pkgName script) loadStringAsPackage :: String -> ByteString -> Lua NumResults loadStringAsPackage pkgName script = do @@ -79,11 +69,3 @@ loadStringAsPackage pkgName script = do else do msg <- Lua.popValue Lua.raiseError ("Error while loading `" <> pkgName <> "`.\n" <> msg) - --- | Get the ByteString representation of the pandoc module. -dataDirScript :: Maybe FilePath -> FilePath -> IO (Maybe ByteString) -dataDirScript datadir moduleFile = do - res <- runIO $ setUserDataDir datadir >> readDataFile moduleFile - return $ case res of - Left _ -> Nothing - Right s -> Just s diff --git a/src/Text/Pandoc/Lua/PandocLua.hs b/src/Text/Pandoc/Lua/PandocLua.hs new file mode 100644 index 000000000..6c3b410dd --- /dev/null +++ b/src/Text/Pandoc/Lua/PandocLua.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | + Module : Text.Pandoc.Lua.PandocLua + Copyright : Copyright © 2020 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + Stability : alpha + +PandocMonad instance which allows execution of Lua operations and which +uses Lua to handle state. +-} +module Text.Pandoc.Lua.PandocLua + ( PandocLua (..) + , runPandocLua + , liftPandocLua + , addFunction + , loadScriptFromDataDir + ) where + +import Control.Monad (when) +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 Text.Pandoc.Class.PandocIO (PandocIO) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDataFile) +import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Lua.Global (Global (..), setGlobals) +import Text.Pandoc.Lua.ErrorConversion (errorConversion) + +import qualified Control.Monad.Catch as Catch +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Class.IO as IO +import qualified Text.Pandoc.Lua.Util as LuaUtil + +-- | Type providing access to both, pandoc and Lua operations. +newtype PandocLua a = PandocLua { unPandocLua :: Lua a } + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadIO + , MonadMask + , MonadThrow + ) + +-- | Lift a @'Lua'@ operation into the @'PandocLua'@ type. +liftPandocLua :: Lua a -> PandocLua a +liftPandocLua = PandocLua + +-- | Evaluate a @'PandocLua'@ computation, running all contained Lua +-- operations.. +runPandocLua :: PandocLua a -> PandocIO a +runPandocLua pLua = do + origState <- getCommonState + globals <- defaultGlobals + (result, newState) <- liftIO . Lua.run' errorConversion . unPandocLua $ do + putCommonState origState + liftPandocLua $ setGlobals globals + r <- pLua + c <- getCommonState + return (r, c) + putCommonState newState + return result + +instance {-# OVERLAPPING #-} ToHaskellFunction (PandocLua NumResults) where + toHsFun _narg = unPandocLua + +instance Pushable a => ToHaskellFunction (PandocLua a) where + toHsFun _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 name fn = liftPandocLua $ do + Lua.push name + Lua.pushHaskellFunction fn + Lua.rawset (-3) + +-- | Load a file from pandoc's data directory. +loadScriptFromDataDir :: FilePath -> PandocLua () +loadScriptFromDataDir scriptFile = do + script <- readDataFile scriptFile + status <- liftPandocLua $ Lua.dostring script + when (status /= Lua.OK) . liftPandocLua $ + LuaUtil.throwTopMessageAsError' + (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) + +-- | Global variables which should always be set. +defaultGlobals :: PandocIO [Global] +defaultGlobals = do + commonState <- getCommonState + return + [ PANDOC_API_VERSION + , PANDOC_STATE commonState + , PANDOC_VERSION + ] + +instance MonadError PandocError PandocLua where + catchError = Catch.catch + throwError = Catch.throwM + +instance PandocMonad PandocLua where + lookupEnv = IO.lookupEnv + getCurrentTime = IO.getCurrentTime + getCurrentTimeZone = IO.getCurrentTimeZone + newStdGen = IO.newStdGen + newUniqueHash = IO.newUniqueHash + + openURL = IO.openURL + + readFileLazy = IO.readFileLazy + readFileStrict = IO.readFileStrict + + glob = IO.glob + fileExists = IO.fileExists + getDataFileName = IO.getDataFileName + getModificationTime = IO.getModificationTime + + getCommonState = PandocLua $ do + Lua.getglobal "PANDOC_STATE" + Lua.peek Lua.stackTop + 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 d79fbb085..c6639e94c 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -19,7 +19,6 @@ module Text.Pandoc.Lua.Util , addFunction , addValue , pushViaConstructor - , loadScriptFromDataDir , defineHowTo , throwTopMessageAsError' , callWithTraceback @@ -27,13 +26,11 @@ module Text.Pandoc.Lua.Util ) where import Control.Monad (unless, when) +import Data.Text (Text) import Foreign.Lua ( Lua, NumArgs, NumResults, Peekable, Pushable, StackIndex , Status, ToHaskellFunction ) -import Text.Pandoc.Class.PandocIO (runIOorExplode) -import Text.Pandoc.Class.PandocMonad (readDataFile, setUserDataDir) import qualified Foreign.Lua as Lua import qualified Text.Pandoc.UTF8 as UTF8 -import Data.Text (Text) -- | Get value behind key from table at given index. rawField :: Peekable a => StackIndex -> String -> Lua a @@ -87,15 +84,6 @@ pushViaCall fn = pushViaCall' fn (return ()) 0 pushViaConstructor :: PushViaCall a => String -> a pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn) --- | Load a file from pandoc's data directory. -loadScriptFromDataDir :: Maybe FilePath -> FilePath -> Lua () -loadScriptFromDataDir datadir scriptFile = do - script <- Lua.liftIO . runIOorExplode $ - setUserDataDir datadir >> readDataFile scriptFile - status <- Lua.dostring script - when (status /= Lua.OK) $ - throwTopMessageAsError' (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) - -- | 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 @@ -107,7 +95,7 @@ getTag idx = do Lua.push ("tag" :: Text) Lua.rawget (Lua.nthFromTop 2) Lua.tostring Lua.stackTop <* Lua.pop 2 >>= \case - Nothing -> Lua.throwException "untagged value" + 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 @@ -116,11 +104,12 @@ 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.throwException (modifier (UTF8.toString msg)) + 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 = Lua.withExceptionMessage (("Could not " <> ctx <> ": ") <>) +defineHowTo ctx op = Lua.errorConversion >>= \ec -> + Lua.addContextToException ec ("Could not " <> ctx <> ": ") op -- | Like @'Lua.pcall'@, but uses a predefined error handler which adds a -- traceback on error. @@ -143,7 +132,8 @@ pcallWithTraceback nargs nresults = do callWithTraceback :: NumArgs -> NumResults -> Lua () callWithTraceback nargs nresults = do result <- pcallWithTraceback nargs nresults - when (result /= Lua.OK) Lua.throwTopMessage + when (result /= Lua.OK) + Lua.throwTopMessage -- | Run the given string as a Lua program, while also adding a traceback to the -- error message if an error occurs. |