From ab3c5065847f60f0c3f3b097331a28d27716dc8d Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Thu, 21 Dec 2017 21:37:40 +0100 Subject: Lua modules: move to dedicated submodule The Haskell module defining the Lua `pandoc` module is moved to Text.Pandoc.Lua.Module.Pandoc. Change: minor --- src/Text/Pandoc/Lua.hs | 6 +- src/Text/Pandoc/Lua/Module/Pandoc.hs | 213 ++++++++++++++++++++++++++++++++ src/Text/Pandoc/Lua/Packages.hs | 5 +- src/Text/Pandoc/Lua/PandocModule.hs | 233 ----------------------------------- src/Text/Pandoc/Lua/Util.hs | 22 +++- 5 files changed, 241 insertions(+), 238 deletions(-) create mode 100644 src/Text/Pandoc/Lua/Module/Pandoc.hs delete mode 100644 src/Text/Pandoc/Lua/PandocModule.hs (limited to 'src/Text') diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index a56e89511..ee259e3fd 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -39,7 +39,7 @@ import Text.Pandoc.Class (PandocIO) import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Lua.Filter (LuaFilter, walkMWithLuaFilter) import Text.Pandoc.Lua.Init (runPandocLua) -import Text.Pandoc.Lua.PandocModule (pushPandocModule) -- TODO: remove +import Text.Pandoc.Lua.Module.Pandoc (pushModule) -- TODO: remove import qualified Foreign.Lua as Lua -- | Run the Lua filter in @filterPath@ for a transformation to target @@ -81,3 +81,7 @@ pushGlobalFilter = do runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return + +-- | DEPRECATED: Push the pandoc module to the Lua Stack. +pushPandocModule :: Maybe FilePath -> Lua Lua.NumResults +pushPandocModule = pushModule diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs new file mode 100644 index 000000000..5e00a9252 --- /dev/null +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -0,0 +1,213 @@ +{- +Copyright © 2017 Albert Krewinkel + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +{-# LANGUAGE FlexibleContexts #-} +{- | + Module : Text.Pandoc.Lua.Module.Pandoc + Copyright : Copyright © 2017 Albert Krewinkel + License : GNU GPL, version 2 or above + + Maintainer : Albert Krewinkel + Stability : alpha + +Pandoc module for lua. +-} +module Text.Pandoc.Lua.Module.Pandoc + ( pushModule + , pushMediaBagModule + ) where + +import Control.Monad (when, zipWithM_) +import Data.Default (Default (..)) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.IORef (IORef, modifyIORef', readIORef) +import Data.Maybe (fromMaybe) +import Data.Text (pack) +import Foreign.Lua (ToLuaStack, FromLuaStack, Lua, NumResults, liftIO) +import System.Exit (ExitCode (..)) +import Text.Pandoc.Class (CommonState (..), fetchItem, putCommonState, + runIO, runIOorExplode, setMediaBag) +import Text.Pandoc.Definition (Block, Inline) +import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter) +import Text.Pandoc.Lua.StackInstances () +import Text.Pandoc.Lua.Util (OrNil (toMaybe), addFunction, addValue, + loadScriptFromDataDir, raiseError) +import Text.Pandoc.Walk (Walkable) +import Text.Pandoc.MIME (MimeType) +import Text.Pandoc.Options (ReaderOptions (readerExtensions)) +import Text.Pandoc.Process (pipeProcess) +import Text.Pandoc.Readers (Reader (..), getReader) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.MediaBag as MB + +-- | Push the "pandoc" on the lua stack. Requires the `list` module to be +-- loaded. +pushModule :: Maybe FilePath -> Lua NumResults +pushModule datadir = do + loadScriptFromDataDir datadir "pandoc.lua" + addFunction "read" readDoc + addFunction "pipe" pipeFn + addFunction "sha1" sha1HashFn + addFunction "walk_block" walkBlock + addFunction "walk_inline" walkInline + return 1 + +walkElement :: (ToLuaStack a, Walkable [Inline] a, Walkable [Block] a) + => a -> LuaFilter -> Lua a +walkElement x f = walkInlines f x >>= walkBlocks f + +walkInline :: Inline -> LuaFilter -> Lua Inline +walkInline = walkElement + +walkBlock :: Block -> LuaFilter -> Lua Block +walkBlock = walkElement + +readDoc :: String -> OrNil String -> Lua NumResults +readDoc content formatSpecOrNil = do + let formatSpec = fromMaybe "markdown" (toMaybe formatSpecOrNil) + case getReader formatSpec of + Left s -> raiseError s -- Unknown reader + Right (reader, es) -> + case reader of + TextReader r -> do + res <- liftIO $ runIO $ r def{ readerExtensions = es } (pack content) + case res of + Right pd -> (1 :: NumResults) <$ Lua.push pd -- success, push Pandoc + Left s -> raiseError (show s) -- error while reading + _ -> raiseError "Only string formats are supported at the moment." + +-- +-- MediaBag submodule +-- +pushMediaBagModule :: CommonState -> IORef MB.MediaBag -> Lua NumResults +pushMediaBagModule commonState mediaBagRef = do + Lua.newtable + addFunction "insert" (insertMediaFn mediaBagRef) + addFunction "lookup" (lookupMediaFn mediaBagRef) + addFunction "list" (mediaDirectoryFn mediaBagRef) + addFunction "fetch" (fetch commonState mediaBagRef) + return 1 + +sha1HashFn :: BL.ByteString + -> Lua NumResults +sha1HashFn contents = do + Lua.push $ showDigest (sha1 contents) + return 1 + +-- | Pipes input through a command. +pipeFn :: String + -> [String] + -> BL.ByteString + -> Lua NumResults +pipeFn command args input = do + (ec, output) <- liftIO $ pipeProcess Nothing command args input + case ec of + ExitSuccess -> 1 <$ Lua.push output + ExitFailure n -> raiseError (PipeError command n output) + +data PipeError = PipeError + { pipeErrorCommand :: String + , pipeErrorCode :: Int + , pipeErrorOutput :: BL.ByteString + } + +instance FromLuaStack PipeError where + peek idx = + PipeError + <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) + <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1) + <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1) + +instance ToLuaStack PipeError where + push pipeErr = do + Lua.newtable + addValue "command" (pipeErrorCommand pipeErr) + addValue "error_code" (pipeErrorCode pipeErr) + addValue "output" (pipeErrorOutput pipeErr) + pushPipeErrorMetaTable + Lua.setmetatable (-2) + where + pushPipeErrorMetaTable :: Lua () + pushPipeErrorMetaTable = do + v <- Lua.newmetatable "pandoc pipe error" + when v $ addFunction "__tostring" pipeErrorMessage + + pipeErrorMessage :: PipeError -> Lua BL.ByteString + pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat + [ BSL.pack "Error running " + , BSL.pack cmd + , BSL.pack " (error code " + , BSL.pack $ show errorCode + , BSL.pack "): " + , if output == mempty then BSL.pack "" else output + ] +-- end: pipe + +insertMediaFn :: IORef MB.MediaBag + -> FilePath + -> OrNil MimeType + -> BL.ByteString + -> Lua NumResults +insertMediaFn mbRef fp nilOrMime contents = do + liftIO . modifyIORef' mbRef $ + MB.insertMedia fp (toMaybe nilOrMime) contents + return 0 + +lookupMediaFn :: IORef MB.MediaBag + -> FilePath + -> Lua NumResults +lookupMediaFn mbRef fp = do + res <- MB.lookupMedia fp <$> liftIO (readIORef mbRef) + case res of + Nothing -> Lua.pushnil *> return 1 + Just (mimeType, contents) -> do + Lua.push mimeType + Lua.push contents + return 2 + +mediaDirectoryFn :: IORef MB.MediaBag + -> Lua NumResults +mediaDirectoryFn mbRef = do + dirContents <- MB.mediaDirectory <$> liftIO (readIORef mbRef) + Lua.newtable + zipWithM_ addEntry [1..] dirContents + return 1 + where + addEntry :: Int -> (FilePath, MimeType, Int) -> Lua () + addEntry idx (fp, mimeType, contentLength) = do + Lua.newtable + Lua.push "path" *> Lua.push fp *> Lua.rawset (-3) + Lua.push "type" *> Lua.push mimeType *> Lua.rawset (-3) + Lua.push "length" *> Lua.push contentLength *> Lua.rawset (-3) + Lua.rawseti (-2) idx + +fetch :: CommonState + -> IORef MB.MediaBag + -> String + -> Lua NumResults +fetch commonState mbRef src = do + mediaBag <- liftIO $ readIORef mbRef + (bs, mimeType) <- liftIO . runIOorExplode $ do + putCommonState commonState + setMediaBag mediaBag + fetchItem src + Lua.push $ fromMaybe "" mimeType + Lua.push bs + return 2 -- returns 2 values: contents, mimetype diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index b2dbff496..e9173739f 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -38,10 +38,11 @@ import Data.IORef (IORef) import Foreign.Lua (Lua, NumResults, liftIO) import Text.Pandoc.Class (CommonState, readDataFile, runIO, setUserDataDir) import Text.Pandoc.MediaBag (MediaBag) -import Text.Pandoc.Lua.PandocModule (pushPandocModule, pushMediaBagModule) +import Text.Pandoc.Lua.Module.Pandoc (pushMediaBagModule) import Text.Pandoc.Lua.Util (dostring') import qualified Foreign.Lua as Lua +import Text.Pandoc.Lua.Module.Pandoc as Pandoc -- | Parameters used to create lua packages/modules. data LuaPackageParams = LuaPackageParams @@ -72,7 +73,7 @@ pandocPackageSearcher :: LuaPackageParams -> String -> Lua NumResults pandocPackageSearcher luaPkgParams pkgName = case pkgName of "pandoc" -> let datadir = luaPkgDataDir luaPkgParams - in pushWrappedHsFun (pushPandocModule datadir) + in pushWrappedHsFun (Pandoc.pushModule datadir) "pandoc.mediabag" -> let st = luaPkgCommonState luaPkgParams mbRef = luaPkgMediaBag luaPkgParams in pushWrappedHsFun (pushMediaBagModule st mbRef) diff --git a/src/Text/Pandoc/Lua/PandocModule.hs b/src/Text/Pandoc/Lua/PandocModule.hs deleted file mode 100644 index 4a3e4d354..000000000 --- a/src/Text/Pandoc/Lua/PandocModule.hs +++ /dev/null @@ -1,233 +0,0 @@ -{- -Copyright © 2017 Albert Krewinkel - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -{-# LANGUAGE FlexibleContexts #-} -{- | - Module : Text.Pandoc.Lua.PandocModule - Copyright : Copyright © 2017 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Pandoc module for lua. --} -module Text.Pandoc.Lua.PandocModule - ( pushPandocModule - , pushMediaBagModule - ) where - -import Control.Monad (when, zipWithM_) -import Data.Default (Default (..)) -import Data.Digest.Pure.SHA (sha1, showDigest) -import Data.IORef (IORef, modifyIORef', readIORef) -import Data.Maybe (fromMaybe) -import Data.Text (pack) -import Foreign.Lua (ToLuaStack, FromLuaStack, Lua, NumResults, liftIO) -import System.Exit (ExitCode (..)) -import Text.Pandoc.Class (CommonState (..), fetchItem, putCommonState, - runIO, runIOorExplode, setMediaBag) -import Text.Pandoc.Definition (Block, Inline) -import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter) -import Text.Pandoc.Lua.StackInstances () -import Text.Pandoc.Lua.Util (addFunction, addValue, loadScriptFromDataDir) -import Text.Pandoc.Walk (Walkable) -import Text.Pandoc.MIME (MimeType) -import Text.Pandoc.Options (ReaderOptions (readerExtensions)) -import Text.Pandoc.Process (pipeProcess) -import Text.Pandoc.Readers (Reader (..), getReader) - -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Foreign.Lua as Lua -import qualified Text.Pandoc.MediaBag as MB - --- | Push the "pandoc" on the lua stack. Requires the `list` module to be --- loaded. -pushPandocModule :: Maybe FilePath -> Lua NumResults -pushPandocModule datadir = do - loadScriptFromDataDir datadir "pandoc.lua" - addFunction "read" readDoc - addFunction "pipe" pipeFn - addFunction "sha1" sha1HashFn - addFunction "walk_block" walkBlock - addFunction "walk_inline" walkInline - return 1 - -walkElement :: (ToLuaStack a, Walkable [Inline] a, Walkable [Block] a) - => a -> LuaFilter -> Lua a -walkElement x f = walkInlines f x >>= walkBlocks f - -walkInline :: Inline -> LuaFilter -> Lua Inline -walkInline = walkElement - -walkBlock :: Block -> LuaFilter -> Lua Block -walkBlock = walkElement - -readDoc :: String -> OrNil String -> Lua NumResults -readDoc content formatSpecOrNil = do - let formatSpec = fromMaybe "markdown" (toMaybe formatSpecOrNil) - case getReader formatSpec of - Left s -> raiseError s -- Unknown reader - Right (reader, es) -> - case reader of - TextReader r -> do - res <- liftIO $ runIO $ r def{ readerExtensions = es } (pack content) - case res of - Right pd -> (1 :: NumResults) <$ Lua.push pd -- success, push Pandoc - Left s -> raiseError (show s) -- error while reading - _ -> raiseError "Only string formats are supported at the moment." - where - raiseError s = do - Lua.push s - fromIntegral <$> Lua.lerror - --- --- MediaBag submodule --- -pushMediaBagModule :: CommonState -> IORef MB.MediaBag -> Lua NumResults -pushMediaBagModule commonState mediaBagRef = do - Lua.newtable - addFunction "insert" (insertMediaFn mediaBagRef) - addFunction "lookup" (lookupMediaFn mediaBagRef) - addFunction "list" (mediaDirectoryFn mediaBagRef) - addFunction "fetch" (fetch commonState mediaBagRef) - return 1 - -sha1HashFn :: BL.ByteString - -> Lua NumResults -sha1HashFn contents = do - Lua.push $ showDigest (sha1 contents) - return 1 - --- | Pipes input through a command. -pipeFn :: String - -> [String] - -> BL.ByteString - -> Lua NumResults -pipeFn command args input = do - (ec, output) <- liftIO $ pipeProcess Nothing command args input - case ec of - ExitSuccess -> do - Lua.push output - return 1 - ExitFailure n -> do - Lua.push (PipeError command n output) - fromIntegral <$> Lua.lerror - -data PipeError = PipeError - { pipeErrorCommand :: String - , pipeErrorCode :: Int - , pipeErrorOutput :: BL.ByteString - } - -instance FromLuaStack PipeError where - peek idx = - PipeError - <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1) - -instance ToLuaStack PipeError where - push pipeErr = do - Lua.newtable - addValue "command" (pipeErrorCommand pipeErr) - addValue "error_code" (pipeErrorCode pipeErr) - addValue "output" (pipeErrorOutput pipeErr) - pushPipeErrorMetaTable - Lua.setmetatable (-2) - where - pushPipeErrorMetaTable :: Lua () - pushPipeErrorMetaTable = do - v <- Lua.newmetatable "pandoc pipe error" - when v $ addFunction "__tostring" pipeErrorMessage - - pipeErrorMessage :: PipeError -> Lua BL.ByteString - pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat - [ BSL.pack "Error running " - , BSL.pack cmd - , BSL.pack " (error code " - , BSL.pack $ show errorCode - , BSL.pack "): " - , if output == mempty then BSL.pack "" else output - ] --- end: pipe - -insertMediaFn :: IORef MB.MediaBag - -> FilePath - -> OrNil MimeType - -> BL.ByteString - -> Lua NumResults -insertMediaFn mbRef fp nilOrMime contents = do - liftIO . modifyIORef' mbRef $ - MB.insertMedia fp (toMaybe nilOrMime) contents - return 0 - -lookupMediaFn :: IORef MB.MediaBag - -> FilePath - -> Lua NumResults -lookupMediaFn mbRef fp = do - res <- MB.lookupMedia fp <$> liftIO (readIORef mbRef) - case res of - Nothing -> Lua.pushnil *> return 1 - Just (mimeType, contents) -> do - Lua.push mimeType - Lua.push contents - return 2 - -mediaDirectoryFn :: IORef MB.MediaBag - -> Lua NumResults -mediaDirectoryFn mbRef = do - dirContents <- MB.mediaDirectory <$> liftIO (readIORef mbRef) - Lua.newtable - zipWithM_ addEntry [1..] dirContents - return 1 - where - addEntry :: Int -> (FilePath, MimeType, Int) -> Lua () - addEntry idx (fp, mimeType, contentLength) = do - Lua.newtable - Lua.push "path" *> Lua.push fp *> Lua.rawset (-3) - Lua.push "type" *> Lua.push mimeType *> Lua.rawset (-3) - Lua.push "length" *> Lua.push contentLength *> Lua.rawset (-3) - Lua.rawseti (-2) idx - -fetch :: CommonState - -> IORef MB.MediaBag - -> String - -> Lua NumResults -fetch commonState mbRef src = do - mediaBag <- liftIO $ readIORef mbRef - (bs, mimeType) <- liftIO . runIOorExplode $ do - putCommonState commonState - setMediaBag mediaBag - fetchItem src - Lua.push $ fromMaybe "" mimeType - Lua.push bs - return 2 -- returns 2 values: contents, mimetype - --- --- Helper types --- - -newtype OrNil a = OrNil { toMaybe :: Maybe a } - -instance FromLuaStack a => FromLuaStack (OrNil a) where - peek idx = do - noValue <- Lua.isnoneornil idx - if noValue - then return (OrNil Nothing) - else OrNil . Just <$> Lua.peek idx diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index f72ccd7f9..e688ad255 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -36,6 +36,8 @@ module Text.Pandoc.Lua.Util , getRawInt , setRawInt , addRawInt + , raiseError + , OrNil (..) , PushViaCall , pushViaCall , pushViaConstructor @@ -45,8 +47,8 @@ module Text.Pandoc.Lua.Util import Control.Monad (when) import Data.ByteString.Char8 (unpack) -import Foreign.Lua (FromLuaStack (..), ToHaskellFunction, Lua, NumArgs, - StackIndex, ToLuaStack (..), getglobal') +import Foreign.Lua (FromLuaStack (..), NumResults, Lua, NumArgs, StackIndex, + ToLuaStack (..), ToHaskellFunction, getglobal') import Foreign.Lua.Api (Status, call, pop, rawget, rawgeti, rawset, rawseti) import Text.Pandoc.Class (readDataFile, runIOorExplode, setUserDataDir) @@ -99,6 +101,22 @@ setRawInt idx key value = do addRawInt :: ToLuaStack a => Int -> a -> Lua () addRawInt = setRawInt (-1) +raiseError :: ToLuaStack a => a -> Lua NumResults +raiseError e = do + Lua.push e + fromIntegral <$> Lua.lerror + +-- | Newtype wrapper intended to be used for optional Lua values. Nesting this +-- type is strongly discouraged and will likely lead to a wrong result. +newtype OrNil a = OrNil { toMaybe :: Maybe a } + +instance FromLuaStack a => FromLuaStack (OrNil a) where + peek idx = do + noValue <- Lua.isnoneornil idx + if noValue + then return (OrNil Nothing) + else OrNil . Just <$> Lua.peek idx + -- | Helper class for pushing a single value to the stack via a lua function. -- See @pushViaCall@. class PushViaCall a where -- cgit v1.2.3