Lua modules: turn pipe, read into full Haskell functions

The `pipe` and `read` utility functions are converted from hybrid
lua/haskell functions into full Haskell functions. This avoids the need
for intermediate `_pipe`/`_read` helper functions, which have dropped.

data/pandoc.lua

@@ -874,53 +874,6 @@ M.UpperAlpha = "UpperAlpha"
 -- Helper Functions
 -- @section helpers
 
---- Parse the given string into a Pandoc document.
--- The method used to interpret input is specified by *format*. Acceptable
--- values for this parameter are equal to those that can be given to the
--- `--from` command line option.
--- @tparam      string markup the markup to be parsed
--- @tparam[opt] string format format specification, defaults to "markdown".
--- @treturn Pandoc pandoc document
--- @usage
--- local org_markup = "/emphasis/"  -- Input to be read
--- local document = pandoc.read(org_markup, "org")
--- -- Get the first block of the document
--- local block = document.blocks[1]
--- -- The inline element in that block is an `Emph`
--- assert(block.content[1].t == "Emph")
-function M.read(markup, format)
-  format = format or "markdown"
-  local pd = pandoc._read(format, markup)
-  if type(pd) == "string" then
-    error(pd)
-  else
-    return pd
-  end
-end
-
---- Runs command with arguments, passing it some input, and returns the output.
--- @treturn string Output of command.
--- @raise A table containing the keys `command`, `error_code`, and `output` is
--- thrown if the command exits with a non-zero error code.
--- @usage
--- local ec, output = pandoc.pipe("sed", {"-e","s/a/b/"}, "abc")
-function M.pipe (command, args, input)
-  local ec, output = pandoc._pipe(command, args, input)
-  if ec ~= 0 then
-    err = setmetatable(
-      { command = command, error_code = ec, output = output},
-      { __tostring = function(e)
-          return "Error running " .. e.command
-            .. " (error code " .. e.error_code .. "): "
-            .. e.output
-        end
-      }
-    )
-    error(err)
-  end
-  return output
-end
-
 --- Use functions defined in the global namespace to create a pandoc filter.
 -- All globally defined functions which have names of pandoc elements are
 -- collected into a new table.

src/Text/Pandoc/Lua/PandocModule.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-
 Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
 
@@ -17,7 +15,7 @@ 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 CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {- |
    Module      : Text.Pandoc.Lua.PandocModule
    Copyright   : Copyright © 2017 Albert Krewinkel
@@ -33,21 +31,20 @@ module Text.Pandoc.Lua.PandocModule
   , pushMediaBagModule
   ) where
 
-import Control.Monad (zipWithM_)
+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 Foreign.Lua.FunctionCalling (ToHaskellFunction)
 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 (loadScriptFromDataDir)
+import Text.Pandoc.Lua.Util (addFunction, addValue, loadScriptFromDataDir)
 import Text.Pandoc.Walk (Walkable)
 import Text.Pandoc.MIME (MimeType)
 import Text.Pandoc.Options (ReaderOptions (readerExtensions))
@@ -55,6 +52,7 @@ 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
 
@@ -63,8 +61,8 @@ import qualified Text.Pandoc.MediaBag as MB
 pushPandocModule :: Maybe FilePath -> Lua NumResults
 pushPandocModule datadir = do
   loadScriptFromDataDir datadir "pandoc.lua"
-  addFunction "_pipe" pipeFn
-  addFunction "_read" readDoc
+  addFunction "read" readDoc
+  addFunction "pipe" pipeFn
   addFunction "sha1" sha1HashFn
   addFunction "walk_block" walkBlock
   addFunction "walk_inline" walkInline
@@ -80,19 +78,23 @@ walkInline = walkElement
 walkBlock :: Block -> LuaFilter -> Lua Block
 walkBlock = walkElement
 
-readDoc :: String -> String -> Lua NumResults
-readDoc formatSpec content = do
+readDoc :: String -> OrNil String -> Lua NumResults
+readDoc content formatSpecOrNil = do
+  let formatSpec = fromMaybe "markdown" (toMaybe formatSpecOrNil)
   case getReader formatSpec of
-    Left  s      -> Lua.push s -- Unknown reader
+    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
-            Left s   -> Lua.push $ show s -- error while reading
-            Right pd -> Lua.push pd       -- success, push Pandoc
-        _  -> Lua.push "Only string formats are supported at the moment."
-  return 1
+            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
@@ -106,29 +108,64 @@ pushMediaBagModule commonState mediaBagRef = do
   addFunction "fetch" (fetch commonState mediaBagRef)
   return 1
 
-addFunction :: ToHaskellFunction a => String -> a -> Lua ()
-addFunction name fn = do
-  Lua.push name
-  Lua.pushHaskellFunction fn
-  Lua.rawset (-3)
-
 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
-  Lua.push $ case ec of
-                  ExitSuccess   -> 0
-                  ExitFailure n -> n
+  case ec of
+    ExitSuccess -> do
       Lua.push output
-  return 2
+      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 "<no output>" else output
+          ]
+-- end: pipe
 
 insertMediaFn :: IORef MB.MediaBag
               -> FilePath
@@ -183,14 +220,14 @@ fetch commonState mbRef src = do
   return 2 -- returns 2 values: contents, mimetype
 
 --
--- Helper types and orphan instances
+-- Helper types
 --
 
 newtype OrNil a = OrNil { toMaybe :: Maybe a }
 
 instance FromLuaStack a => FromLuaStack (OrNil a) where
   peek idx = do
-    noValue <- Lua.isnil idx
+    noValue <- Lua.isnoneornil idx
     if noValue
       then return (OrNil Nothing)
       else OrNil . Just <$> Lua.peek idx

src/Text/Pandoc/Lua/Util.hs

@@ -32,6 +32,7 @@ module Text.Pandoc.Lua.Util
   ( adjustIndexBy
   , getTable
   , addValue
+  , addFunction
   , getRawInt
   , setRawInt
   , addRawInt
@@ -44,8 +45,8 @@ module Text.Pandoc.Lua.Util
 
 import Control.Monad (when)
 import Data.ByteString.Char8 (unpack)
-import Foreign.Lua (FromLuaStack (..), Lua, NumArgs, StackIndex,
-                    ToLuaStack (..), getglobal')
+import Foreign.Lua (FromLuaStack (..), ToHaskellFunction, Lua, NumArgs,
+                    StackIndex, ToLuaStack (..), getglobal')
 import Foreign.Lua.Api (Status, call, pop, rawget, rawgeti, rawset, rawseti)
 import Text.Pandoc.Class (readDataFile, runIOorExplode, setUserDataDir)
 
@@ -66,13 +67,21 @@ getTable idx key = do
   rawget (idx `adjustIndexBy` 1)
   peek (-1) <* pop 1
 
--- | Add a key-value pair to the table at the top of the stack
+-- | Add a key-value pair to the table at the top of the stack.
 addValue :: (ToLuaStack a, ToLuaStack b) => a -> b -> Lua ()
 addValue key value = do
   push key
   push value
   rawset (-3)
 
+-- | Add a function to the table at the top of the stack, using the given name.
+addFunction :: ToHaskellFunction a => String -> a -> Lua ()
+addFunction name fn = do
+  Lua.push name
+  Lua.pushHaskellFunction fn
+  Lua.wrapHaskellFunction
+  Lua.rawset (-3)
+
 -- | Get value behind key from table at given index.
 getRawInt :: FromLuaStack a => StackIndex -> Int -> Lua a
 getRawInt idx key =