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 | |
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
24 files changed, 704 insertions, 444 deletions
diff --git a/pandoc.cabal b/pandoc.cabal index 7c74a26f0..43a3eac56 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -412,9 +412,9 @@ library blaze-markup >= 0.8 && < 0.9, vector >= 0.10 && < 0.13, jira-wiki-markup >= 1.3 && < 1.4, - hslua >= 1.0.1 && < 1.2, + hslua >= 1.1 && < 1.2, hslua-module-system >= 0.2 && < 0.3, - hslua-module-text >= 0.2 && < 0.3, + hslua-module-text >= 0.2.1 && < 0.3, binary >= 0.5 && < 0.11, SHA >= 1.6 && < 1.7, haddock-library >= 1.8 && < 1.10, @@ -571,6 +571,7 @@ library Text.Pandoc.App.Opt, Text.Pandoc.App.OutputSettings, Text.Pandoc.Class.CommonState, + Text.Pandoc.Class.IO, Text.Pandoc.Class.PandocMonad, Text.Pandoc.Class.PandocIO, Text.Pandoc.Class.PandocPure, @@ -611,6 +612,7 @@ library Text.Pandoc.Writers.Roff, Text.Pandoc.Writers.Powerpoint.Presentation, Text.Pandoc.Writers.Powerpoint.Output, + Text.Pandoc.Lua.ErrorConversion, Text.Pandoc.Lua.Filter, Text.Pandoc.Lua.Global, Text.Pandoc.Lua.Init, @@ -621,6 +623,7 @@ library 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.Version, Text.Pandoc.Lua.Module.MediaBag, @@ -629,6 +632,7 @@ library Text.Pandoc.Lua.Module.Types, Text.Pandoc.Lua.Module.Utils, Text.Pandoc.Lua.Packages, + Text.Pandoc.Lua.PandocLua, Text.Pandoc.Lua.Util, Text.Pandoc.Lua.Walk, Text.Pandoc.CSS, @@ -733,11 +737,13 @@ test-suite test-pandoc mtl >= 2.2 && < 2.3, bytestring >= 0.9 && < 0.11, base64-bytestring >= 0.1 && < 1.1, + exceptions >= 0.8 && < 0.11, text >= 1.1.1.0 && < 1.3, time >= 1.5 && < 1.10, directory >= 1.2.3 && < 1.4, + exceptions >= 0.8 && < 0.11, filepath >= 1.1 && < 1.5, - hslua >= 1.0 && < 1.2, + hslua >= 1.1 && < 1.2, process >= 1.2.3 && < 1.7, temporary >= 1.1 && < 1.4, Diff >= 0.2 && < 0.5, diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs new file mode 100644 index 000000000..c38a37844 --- /dev/null +++ b/src/Text/Pandoc/Class/IO.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{- | +Module : Text.Pandoc.Class.IO +Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane +License : GNU GPL, version 2 or above + +Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> +Stability : alpha +Portability : portable + +Default ways to perform @'PandocMonad'@ actions in a @'MonadIO'@ type. + +These functions are used to make the @'PandocIO'@ type an instance of +@'PandocMonad'@, but can be reused for any other MonadIO-conforming +types. +-} +module Text.Pandoc.Class.IO + ( fileExists + , getCurrentTime + , getCurrentTimeZone + , getDataFileName + , getModificationTime + , glob + , logOutput + , logIOError + , lookupEnv + , newStdGen + , newUniqueHash + , openURL + , readFileLazy + , readFileStrict + , extractMedia + ) where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString.Base64 (decodeLenient) +import Data.ByteString.Lazy (toChunks) +import Data.Text (Text, pack, unpack) +import Data.Time (TimeZone, UTCTime) +import Data.Unique (hashUnique) +import Network.Connection (TLSSettings (TLSSettingsSimple)) +import Network.HTTP.Client + (httpLbs, responseBody, responseHeaders, + Request(port, host, requestHeaders), parseRequest, newManager) +import Network.HTTP.Client.Internal (addProxy) +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.HTTP.Types.Header ( hContentType ) +import Network.Socket (withSocketsDo) +import Network.URI (unEscapeString) +import System.Directory (createDirectoryIfMissing) +import System.Environment (getEnv) +import System.FilePath ((</>), takeDirectory, normalise) +import System.IO (stderr) +import System.IO.Error +import System.Random (StdGen) +import Text.Pandoc.Class.CommonState (CommonState (..)) +import Text.Pandoc.Class.PandocMonad + (PandocMonad, getsCommonState, getMediaBag, report) +import Text.Pandoc.Definition (Pandoc, Inline (Image)) +import Text.Pandoc.Error (PandocError (..)) +import Text.Pandoc.Logging (LogMessage (..), messageVerbosity, showLogMessage) +import Text.Pandoc.MIME (MimeType) +import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory) +import Text.Pandoc.Walk (walk) +import qualified Control.Exception as E +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import qualified Data.Time +import qualified Data.Time.LocalTime +import qualified Data.Unique +import qualified System.Directory +import qualified System.Environment as Env +import qualified System.FilePath.Glob +import qualified System.Random +import qualified Text.Pandoc.UTF8 as UTF8 +#ifndef EMBED_DATA_FILES +import qualified Paths_pandoc as Paths +#endif + +-- | Utility function to lift IO errors into 'PandocError's. +liftIOError :: (PandocMonad m, MonadIO m) => (String -> IO a) -> String -> m a +liftIOError f u = do + res <- liftIO $ tryIOError $ f u + case res of + Left e -> throwError $ PandocIOError (pack u) e + Right r -> return r + +-- | Show potential IO errors to the user continuing execution anyway +logIOError :: (PandocMonad m, MonadIO m) => IO () -> m () +logIOError f = do + res <- liftIO $ tryIOError f + case res of + Left e -> report $ IgnoredIOError $ pack $ E.displayException e + Right _ -> pure () + +-- | Lookup an environment variable in the programs environment. +lookupEnv :: MonadIO m => Text -> m (Maybe Text) +lookupEnv = fmap (fmap pack) . liftIO . Env.lookupEnv . unpack + +-- | Get the current (UTC) time. +getCurrentTime :: MonadIO m => m UTCTime +getCurrentTime = liftIO Data.Time.getCurrentTime + +-- | Get the locale's time zone. +getCurrentTimeZone :: MonadIO m => m TimeZone +getCurrentTimeZone = liftIO Data.Time.LocalTime.getCurrentTimeZone + +-- | Return a new generator for random numbers. +newStdGen :: MonadIO m => m StdGen +newStdGen = liftIO System.Random.newStdGen + +-- | Return a new unique integer. +newUniqueHash :: MonadIO m => m Int +newUniqueHash = hashUnique <$> liftIO Data.Unique.newUnique + +openURL :: (PandocMonad m, MonadIO m) => Text -> m (B.ByteString, Maybe MimeType) +openURL u + | Just u'' <- T.stripPrefix "data:" u = do + let mime = T.takeWhile (/=',') u'' + let contents = UTF8.fromString $ + unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u'' + return (decodeLenient contents, Just mime) + | otherwise = do + let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v) + customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders + disableCertificateValidation <- getsCommonState stNoCheckCertificate + report $ Fetching u + res <- liftIO $ E.try $ withSocketsDo $ do + let parseReq = parseRequest + proxy <- tryIOError (getEnv "http_proxy") + let addProxy' x = case proxy of + Left _ -> return x + Right pr -> parseReq pr >>= \r -> + return (addProxy (host r) (port r) x) + req <- parseReq (unpack u) >>= addProxy' + let req' = req{requestHeaders = customHeaders ++ requestHeaders req} + let tlsSimple = TLSSettingsSimple disableCertificateValidation False False + let tlsManagerSettings = mkManagerSettings tlsSimple Nothing + resp <- newManager tlsManagerSettings >>= httpLbs req' + return (B.concat $ toChunks $ responseBody resp, + UTF8.toText `fmap` lookup hContentType (responseHeaders resp)) + + case res of + Right r -> return r + Left e -> throwError $ PandocHttpError u e + +-- | Read the lazy ByteString contents from a file path, raising an error on +-- failure. +readFileLazy :: (PandocMonad m, MonadIO m) => FilePath -> m BL.ByteString +readFileLazy s = liftIOError BL.readFile s + +-- | Read the strict ByteString contents from a file path, +-- raising an error on failure. +readFileStrict :: (PandocMonad m, MonadIO m) => FilePath -> m B.ByteString +readFileStrict s = liftIOError B.readFile s + +-- | Return a list of paths that match a glob, relative to the working +-- directory. See 'System.FilePath.Glob' for the glob syntax. +glob :: (PandocMonad m, MonadIO m) => String -> m [FilePath] +glob = liftIOError System.FilePath.Glob.glob + +-- | Returns True if file exists. +fileExists :: (PandocMonad m, MonadIO m) => FilePath -> m Bool +fileExists = liftIOError System.Directory.doesFileExist + +-- | Returns the path of data file. +getDataFileName :: (PandocMonad m, MonadIO m) => FilePath -> m FilePath +#ifdef EMBED_DATA_FILES +getDataFileName = return +#else +getDataFileName = liftIOError Paths.getDataFileName +#endif + +-- | Return the modification time of a file. +getModificationTime :: (PandocMonad m, MonadIO m) => FilePath -> m UTCTime +getModificationTime = liftIOError System.Directory.getModificationTime + +-- | Output a log message. +logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m () +logOutput msg = liftIO $ do + UTF8.hPutStr stderr $ + "[" ++ show (messageVerbosity msg) ++ "] " + alertIndent $ T.lines $ showLogMessage msg + +-- | Prints the list of lines to @stderr@, indenting every but the first +-- line by two spaces. +alertIndent :: [Text] -> IO () +alertIndent [] = return () +alertIndent (l:ls) = do + UTF8.hPutStrLn stderr $ unpack l + mapM_ go ls + where go l' = do UTF8.hPutStr stderr " " + UTF8.hPutStrLn stderr $ unpack l' + +-- | Extract media from the mediabag into a directory. +extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc +extractMedia dir d = do + media <- getMediaBag + case [fp | (fp, _, _) <- mediaDirectory media] of + [] -> return d + fps -> do + mapM_ (writeMedia dir media) fps + return $ walk (adjustImagePath dir fps) d + +-- | Write the contents of a media bag to a path. +writeMedia :: (PandocMonad m, MonadIO m) + => FilePath -> MediaBag -> FilePath + -> m () +writeMedia dir mediabag subpath = do + -- we join and split to convert a/b/c to a\b\c on Windows; + -- in zip containers all paths use / + let fullpath = dir </> unEscapeString (normalise subpath) + let mbcontents = lookupMedia subpath mediabag + case mbcontents of + Nothing -> throwError $ PandocResourceNotFound $ pack subpath + Just (_, bs) -> do + report $ Extracting $ pack fullpath + liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath) + logIOError $ BL.writeFile fullpath bs + +-- | If the given Inline element is an image with a @src@ path equal to +-- one in the list of @paths@, then prepends @dir@ to the image source; +-- returns the element unchanged otherwise. +adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline +adjustImagePath dir paths (Image attr lab (src, tit)) + | unpack src `elem` paths = Image attr lab (pack dir <> "/" <> src, tit) +adjustImagePath _ _ x = x diff --git a/src/Text/Pandoc/Class/PandocIO.hs b/src/Text/Pandoc/Class/PandocIO.hs index ee6a041ba..63cb94155 100644 --- a/src/Text/Pandoc/Class/PandocIO.hs +++ b/src/Text/Pandoc/Class/PandocIO.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Class.PandocIO Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane @@ -16,79 +14,21 @@ This module defines @'PandocIO'@, an IO-based instance of the using IO operators. -} module Text.Pandoc.Class.PandocIO - ( getPOSIXTime - , getZonedTime - , readFileFromDirs - , report - , setTrace - , setRequestHeader - , getLog - , setVerbosity - , getVerbosity - , getMediaBag - , setMediaBag - , insertMedia - , setUserDataDir - , getUserDataDir - , fetchItem - , getInputFiles - , setInputFiles - , getOutputFile - , setOutputFile - , setResourcePath - , getResourcePath - , PandocIO(..) + ( PandocIO(..) , runIO , runIOorExplode , extractMedia ) where -import Control.Monad.Except -import Control.Monad.State.Strict -import Data.ByteString.Base64 (decodeLenient) -import Data.ByteString.Lazy (toChunks) -import Data.Default -import Data.Text (Text) -import Data.Unique (hashUnique) -import Network.HTTP.Client - (httpLbs, responseBody, responseHeaders, - Request(port, host, requestHeaders), parseRequest, newManager) -import Network.HTTP.Client.Internal (addProxy) -import Network.HTTP.Client.TLS (mkManagerSettings) -import Network.Connection (TLSSettings (..)) -import Network.HTTP.Types.Header ( hContentType ) -import Network.Socket (withSocketsDo) -import Network.URI ( unEscapeString ) -import Prelude -import System.Directory (createDirectoryIfMissing) -import System.Environment (getEnv) -import System.FilePath ((</>), takeDirectory, normalise) -import System.IO (stderr) -import System.IO.Error +import Control.Monad.Except (ExceptT, MonadError, runExceptT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State (StateT, evalStateT, lift, get, put) +import Data.Default (Default (def)) import Text.Pandoc.Class.CommonState (CommonState (..)) import Text.Pandoc.Class.PandocMonad import Text.Pandoc.Definition import Text.Pandoc.Error -import Text.Pandoc.Logging -import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory) -import Text.Pandoc.Walk (walk) -import qualified Control.Exception as E -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.Text as T -import qualified Data.Time as IO (getCurrentTime) -import qualified Data.Time.LocalTime as IO (getCurrentTimeZone) -import qualified Data.Unique as IO (newUnique) -import qualified System.Directory as Directory -import qualified System.Directory as IO (getModificationTime) -import qualified System.Environment as IO (lookupEnv) -import qualified System.FilePath.Glob as IO (glob) -import qualified System.Random as IO (newStdGen) -import qualified Text.Pandoc.UTF8 as UTF8 -#ifndef EMBED_DATA_FILES -import qualified Paths_pandoc as Paths -#endif +import qualified Text.Pandoc.Class.IO as IO -- | Evaluate a 'PandocIO' operation. runIO :: PandocIO a -> IO (Either PandocError a) @@ -108,113 +48,27 @@ newtype PandocIO a = PandocIO { , MonadError PandocError ) --- | Utility function to lift IO errors into 'PandocError's. -liftIOError :: (String -> IO a) -> String -> PandocIO a -liftIOError f u = do - res <- liftIO $ tryIOError $ f u - case res of - Left e -> throwError $ PandocIOError (T.pack u) e - Right r -> return r - --- | Show potential IO errors to the user continuing execution anyway -logIOError :: IO () -> PandocIO () -logIOError f = do - res <- liftIO $ tryIOError f - case res of - Left e -> report $ IgnoredIOError $ T.pack $ E.displayException e - Right _ -> pure () - instance PandocMonad PandocIO where - lookupEnv = fmap (fmap T.pack) . liftIO . IO.lookupEnv . T.unpack - getCurrentTime = liftIO IO.getCurrentTime - getCurrentTimeZone = liftIO IO.getCurrentTimeZone - newStdGen = liftIO IO.newStdGen - newUniqueHash = hashUnique <$> liftIO IO.newUnique - - openURL u - | Just u'' <- T.stripPrefix "data:" u = do - let mime = T.takeWhile (/=',') u'' - let contents = UTF8.fromString $ - unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u'' - return (decodeLenient contents, Just mime) - | otherwise = do - let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v) - customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders - disableCertificateValidation <- getsCommonState stNoCheckCertificate - report $ Fetching u - res <- liftIO $ E.try $ withSocketsDo $ do - let parseReq = parseRequest - proxy <- tryIOError (getEnv "http_proxy") - let addProxy' x = case proxy of - Left _ -> return x - Right pr -> parseReq pr >>= \r -> - return (addProxy (host r) (port r) x) - req <- parseReq (T.unpack u) >>= addProxy' - let req' = req{requestHeaders = customHeaders ++ requestHeaders req} - resp <- newManager (mkManagerSettings (TLSSettingsSimple disableCertificateValidation False False) Nothing) >>= httpLbs req' - return (B.concat $ toChunks $ responseBody resp, - UTF8.toText `fmap` lookup hContentType (responseHeaders resp)) + lookupEnv = IO.lookupEnv + getCurrentTime = IO.getCurrentTime + getCurrentTimeZone = IO.getCurrentTimeZone + newStdGen = IO.newStdGen + newUniqueHash = IO.newUniqueHash - case res of - Right r -> return r - Left e -> throwError $ PandocHttpError u e + openURL = IO.openURL + readFileLazy = IO.readFileLazy + readFileStrict = IO.readFileStrict - readFileLazy s = liftIOError BL.readFile s - readFileStrict s = liftIOError B.readFile s + glob = IO.glob + fileExists = IO.fileExists + getDataFileName = IO.getDataFileName + getModificationTime = IO.getModificationTime - glob = liftIOError IO.glob - fileExists = liftIOError Directory.doesFileExist -#ifdef EMBED_DATA_FILES - getDataFileName = return -#else - getDataFileName = liftIOError Paths.getDataFileName -#endif - getModificationTime = liftIOError IO.getModificationTime getCommonState = PandocIO $ lift get - putCommonState x = PandocIO $ lift $ put x - logOutput msg = liftIO $ do - UTF8.hPutStr stderr $ - "[" ++ show (messageVerbosity msg) ++ "] " - alertIndent $ T.lines $ showLogMessage msg + putCommonState = PandocIO . lift . put --- | Prints the list of lines to @stderr@, indenting every but the first --- line by two spaces. -alertIndent :: [Text] -> IO () -alertIndent [] = return () -alertIndent (l:ls) = do - UTF8.hPutStrLn stderr $ T.unpack l - mapM_ go ls - where go l' = do UTF8.hPutStr stderr " " - UTF8.hPutStrLn stderr $ T.unpack l' + logOutput = IO.logOutput -- | Extract media from the mediabag into a directory. extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc -extractMedia dir d = do - media <- getMediaBag - case [fp | (fp, _, _) <- mediaDirectory media] of - [] -> return d - fps -> do - mapM_ (writeMedia dir media) fps - return $ walk (adjustImagePath dir fps) d - --- | Write the contents of a media bag to a path. -writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO () -writeMedia dir mediabag subpath = do - -- we join and split to convert a/b/c to a\b\c on Windows; - -- in zip containers all paths use / - let fullpath = dir </> unEscapeString (normalise subpath) - let mbcontents = lookupMedia subpath mediabag - case mbcontents of - Nothing -> throwError $ PandocResourceNotFound $ T.pack subpath - Just (_, bs) -> do - report $ Extracting $ T.pack fullpath - liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath) - logIOError $ BL.writeFile fullpath bs - --- | If the given Inline element is an image with a @src@ path equal to --- one in the list of @paths@, then prepends @dir@ to the image source; --- returns the element unchanged otherwise. -adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline -adjustImagePath dir paths (Image attr lab (src, tit)) - | T.unpack src `elem` paths = Image attr lab (T.pack dir <> "/" <> src, tit) -adjustImagePath _ _ x = x +extractMedia = IO.extractMedia diff --git a/src/Text/Pandoc/Error.hs b/src/Text/Pandoc/Error.hs index 977875907..4c3c1af79 100644 --- a/src/Text/Pandoc/Error.hs +++ b/src/Text/Pandoc/Error.hs @@ -47,6 +47,7 @@ data PandocError = PandocIOError Text IOError | PandocPDFProgramNotFoundError Text | PandocPDFError Text | PandocFilterError Text Text + | PandocLuaError Text | PandocCouldNotFindDataFileError Text | PandocResourceNotFound Text | PandocTemplateError Text @@ -100,6 +101,7 @@ handleError (Left e) = PandocPDFError logmsg -> err 43 $ "Error producing PDF.\n" <> logmsg PandocFilterError filtername msg -> err 83 $ "Error running filter " <> filtername <> ":\n" <> msg + PandocLuaError msg -> err 84 $ "Error running Lua:\n" <> msg PandocCouldNotFindDataFileError fn -> err 97 $ "Could not find data file " <> fn PandocResourceNotFound fn -> err 99 $ diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs index 7e27f7d94..83ec9a97c 100644 --- a/src/Text/Pandoc/Filter/JSON.hs +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -23,7 +23,6 @@ import System.Directory (executable, doesFileExist, findExecutable, import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) import System.FilePath ((</>), takeExtension) -import Text.Pandoc.Class.PandocIO (PandocIO) import Text.Pandoc.Error (PandocError (PandocFilterError)) import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Options (ReaderOptions) @@ -32,11 +31,12 @@ import Text.Pandoc.Shared (pandocVersion, tshow) import qualified Control.Exception as E import qualified Text.Pandoc.UTF8 as UTF8 -apply :: ReaderOptions +apply :: MonadIO m + => ReaderOptions -> [String] -> FilePath -> Pandoc - -> PandocIO Pandoc + -> m Pandoc apply ropts args f = liftIO . externalFilter ropts f args externalFilter :: MonadIO m diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs index a50e5217d..8df057bfa 100644 --- a/src/Text/Pandoc/Filter/Lua.hs +++ b/src/Text/Pandoc/Filter/Lua.hs @@ -17,8 +17,7 @@ import qualified Data.Text as T import Text.Pandoc.Class.PandocIO (PandocIO) import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Error (PandocError (PandocFilterError)) -import Text.Pandoc.Lua (Global (..), LuaException (..), - runLua, runFilterFile, setGlobals) +import Text.Pandoc.Lua (Global (..), runLua, runFilterFile, setGlobals) import Text.Pandoc.Options (ReaderOptions) -- | Run the Lua filter in @filterPath@ for a transformation to the @@ -40,7 +39,7 @@ apply ropts args fp doc = do ] runFilterFile fp doc -forceResult :: FilePath -> Either LuaException Pandoc -> PandocIO Pandoc +forceResult :: FilePath -> Either PandocError Pandoc -> PandocIO Pandoc forceResult fp eitherResult = case eitherResult of - Right x -> return x - Left (LuaException s) -> throw (PandocFilterError (T.pack fp) s) + Right x -> return x + Left err -> throw (PandocFilterError (T.pack fp) (T.pack $ show err)) diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index 63a49596d..39db0074a 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -10,7 +10,6 @@ Running pandoc Lua filters. -} module Text.Pandoc.Lua ( runLua - , LuaException (..) -- * Lua globals , Global (..) , setGlobals @@ -20,5 +19,5 @@ module Text.Pandoc.Lua import Text.Pandoc.Lua.Filter (runFilterFile) import Text.Pandoc.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.Init (LuaException (..), runLua) +import Text.Pandoc.Lua.Init (runLua) import Text.Pandoc.Lua.Marshaling () 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. diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 2be64d56f..50a013dfd 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -20,17 +20,14 @@ import Data.List (intersperse) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text, pack) -import Data.Typeable import Foreign.Lua (Lua, Pushable) import Text.DocLayout (render, literal) import Text.Pandoc.Class.PandocIO (PandocIO) import Text.Pandoc.Definition -import Text.Pandoc.Lua (Global (..), LuaException (LuaException), - runLua, setGlobals) +import Text.Pandoc.Lua (Global (..), runLua, setGlobals) import Text.Pandoc.Lua.Util (addField, dofileWithTraceback) import Text.Pandoc.Options import Text.Pandoc.Templates (renderTemplate) -import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Writers.Shared import qualified Foreign.Lua as Lua @@ -81,11 +78,6 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where Lua.push v Lua.rawset (Lua.nthFromTop 3) -data PandocLuaException = PandocLuaException Text - deriving (Show, Typeable) - -instance Exception PandocLuaException - -- | Convert Pandoc to custom markup. writeCustom :: FilePath -> WriterOptions -> Pandoc -> PandocIO Text writeCustom luaFile opts doc@(Pandoc meta _) = do @@ -97,21 +89,20 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do stat <- dofileWithTraceback luaFile -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): - when (stat /= Lua.OK) $ - Lua.tostring' (-1) >>= throw . PandocLuaException . UTF8.toText + when (stat /= Lua.OK) + Lua.throwTopMessage rendered <- docToCustom opts doc context <- metaToContext opts (fmap (literal . pack) . blockListToCustom) (fmap (literal . pack) . inlineListToCustom) meta return (pack rendered, context) - let (body, context) = case res of - Left (LuaException msg) -> throw (PandocLuaException msg) - Right x -> x - return $ - case writerTemplate opts of - Nothing -> body - Just tpl -> render Nothing $ + case res of + Left msg -> throw msg + Right (body, context) -> return $ + case writerTemplate opts of + Nothing -> body + Just tpl -> render Nothing $ renderTemplate tpl $ setField "body" body context docToCustom :: WriterOptions -> Pandoc -> Lua String diff --git a/stack.yaml b/stack.yaml index d6ae4eee7..9a94de053 100644 --- a/stack.yaml +++ b/stack.yaml @@ -23,6 +23,7 @@ extra-deps: - regex-pcre-builtin-0.95.0.8.8.35 - doclayout-0.3 - emojis-0.1 +- hslua-1.1.0 - jira-wiki-markup-1.3.0 - HsYAML-0.2.0.0 - HsYAML-aeson-0.2.0.0 diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs index 0943b17aa..14800f7bb 100644 --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Tests.Lua Copyright : © 2017-2020 Albert Krewinkel @@ -28,11 +29,13 @@ import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith, import Text.Pandoc.Class (runIOorExplode, setUserDataDir) import Text.Pandoc.Definition (Block (BlockQuote, Div, Para), Inline (Emph, Str), Attr, Meta, Pandoc, pandocTypesVersion) +import Text.Pandoc.Error (PandocError (PandocLuaError)) import Text.Pandoc.Filter (Filter (LuaFilter), applyFilters) import Text.Pandoc.Lua (runLua) 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 @@ -197,12 +200,13 @@ tests = map (localOption (QuickCheckTests 20)) , testCase "informative error messages" . runLuaTest $ do Lua.pushboolean True - err <- Lua.peekEither Lua.stackTop - case (err :: Either String Pandoc) of - Left msg -> do + eitherPandoc <- Catch.try (Lua.peek Lua.stackTop :: Lua.Lua Pandoc) + case eitherPandoc of + Left (PandocLuaError msg) -> do let expectedMsg = "Could not get Pandoc value: " <> "table expected, got boolean" 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." ] @@ -223,10 +227,7 @@ roundtripEqual x = (x ==) <$> roundtripped size <- Lua.gettop when (size - oldSize /= 1) $ error ("not exactly one additional element on the stack: " ++ show size) - res <- Lua.peekEither (-1) - case res of - Left e -> error (show e) - Right y -> return y + Lua.peek (-1) runLuaTest :: Lua.Lua a -> IO a runLuaTest op = runIOorExplode $ do diff --git a/test/lua/module/pandoc-types.lua b/test/lua/module/pandoc-types.lua index 880dd567e..d4e063a5c 100644 --- a/test/lua/module/pandoc-types.lua +++ b/test/lua/module/pandoc-types.lua @@ -26,10 +26,9 @@ return { ) end), test('non-version string is rejected', function () - assert.error_matches( - function () Version '11friends' end, - '11friends' - ) + local success, msg = pcall(function () Version '11friends' end) + assert.is_falsy(success) + assert.is_truthy(tostring(msg):match('11friends')) end) }, |