Switch to hslua-2.0

The new HsLua version takes a somewhat different approach to marshalling
and unmarshalling, relying less on typeclasses and more on specialized
types. This allows for better performance and improved error messages.

Furthermore, new abstractions allow to document the code and exposed
functions.

1 files changed, 49 insertions, 38 deletions

diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs
index 5c14b3a30..0a9ebaec5 100644
--- a/src/Text/Pandoc/Lua/Module/Pandoc.hs
+++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs
@@ -15,29 +15,30 @@ module Text.Pandoc.Lua.Module.Pandoc
   ) where
 
 import Prelude hiding (read)
-import Control.Monad (when)
+import Control.Monad ((>=>), when)
 import Control.Monad.Except (throwError)
 import Data.Default (Default (..))
 import Data.Maybe (fromMaybe)
-import Foreign.Lua (Lua, NumResults, Optional, Peekable, Pushable)
+import HsLua as Lua hiding (pushModule)
+import HsLua.Class.Peekable (PeekError)
 import System.Exit (ExitCode (..))
 import Text.Pandoc.Class.PandocIO (runIO)
 import Text.Pandoc.Definition (Block, Inline)
-import Text.Pandoc.Lua.Filter (LuaFilter, SingletonsList (..), walkInlines,
+import Text.Pandoc.Lua.Filter (SingletonsList (..), walkInlines,
                                walkInlineLists, walkBlocks, walkBlockLists)
 import Text.Pandoc.Lua.Marshaling ()
+import Text.Pandoc.Lua.Marshaling.AST
 import Text.Pandoc.Lua.Marshaling.List (List (..))
 import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua,
                                   loadDefaultModule)
-import Text.Pandoc.Walk (Walkable)
 import Text.Pandoc.Options (ReaderOptions (readerExtensions))
 import Text.Pandoc.Process (pipeProcess)
 import Text.Pandoc.Readers (Reader (..), getReader)
+import Text.Pandoc.Walk (Walkable)
 
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import qualified Data.Text as T
-import qualified Foreign.Lua as Lua
 import qualified Text.Pandoc.Lua.Util as LuaUtil
 import Text.Pandoc.Error
 
@@ -48,23 +49,25 @@ pushModule = do
   loadDefaultModule "pandoc"
   addFunction "read" read
   addFunction "pipe" pipe
-  addFunction "walk_block" walk_block
-  addFunction "walk_inline" walk_inline
+  addFunction "walk_block" (walkElement peekBlock pushBlock)
+  addFunction "walk_inline" (walkElement peekInline pushInline)
   return 1
 
 walkElement :: (Walkable (SingletonsList Inline) a,
                 Walkable (SingletonsList Block) a,
                 Walkable (List Inline) a,
                 Walkable (List Block) a)
-            => a -> LuaFilter -> PandocLua a
-walkElement x f = liftPandocLua $
-  walkInlines f x >>= walkInlineLists f >>= walkBlocks f >>= walkBlockLists f
-
-walk_inline :: Inline -> LuaFilter -> PandocLua Inline
-walk_inline = walkElement
-
-walk_block :: Block -> LuaFilter -> PandocLua Block
-walk_block = walkElement
+            => Peeker PandocError a -> Pusher PandocError a
+            -> LuaE PandocError NumResults
+walkElement peek' push' = do
+  x <- forcePeek $ peek' (nthBottom 1)
+  f <- peek (nthBottom 2)
+  let walk' =  walkInlines f
+           >=> walkInlineLists f
+           >=> walkBlocks f
+           >=> walkBlockLists f
+  walk' x >>= push'
+  return (NumResults 1)
 
 read :: T.Text -> Optional T.Text -> PandocLua NumResults
 read content formatSpecOrNil = liftPandocLua $ do
@@ -93,7 +96,9 @@ pipe command args input = liftPandocLua $ do
   (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input
   case ec of
     ExitSuccess -> 1 <$ Lua.push output
-    ExitFailure n -> Lua.raiseError (PipeError (T.pack command) n output)
+    ExitFailure n -> do
+      pushPipeError (PipeError (T.pack command) n output)
+      Lua.error
 
 data PipeError = PipeError
   { pipeErrorCommand :: T.Text
@@ -101,29 +106,34 @@ data PipeError = PipeError
   , pipeErrorOutput :: BL.ByteString
   }
 
-instance Peekable PipeError where
-  peek idx =
-    PipeError
-    <$> (Lua.getfield idx "command"    *> Lua.peek (-1) <* Lua.pop 1)
-    <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1)
-    <*> (Lua.getfield idx "output"     *> Lua.peek (-1) <* Lua.pop 1)
+peekPipeError :: PeekError e => StackIndex -> LuaE e PipeError
+peekPipeError idx =
+  PipeError
+  <$> (Lua.getfield idx "command"    *> Lua.peek (-1) <* Lua.pop 1)
+  <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1)
+  <*> (Lua.getfield idx "output"     *> Lua.peek (-1) <* Lua.pop 1)
 
-instance Pushable PipeError where
-  push pipeErr = do
-    Lua.newtable
-    LuaUtil.addField "command" (pipeErrorCommand pipeErr)
-    LuaUtil.addField "error_code" (pipeErrorCode pipeErr)
-    LuaUtil.addField "output" (pipeErrorOutput pipeErr)
-    pushPipeErrorMetaTable
-    Lua.setmetatable (-2)
-      where
-        pushPipeErrorMetaTable :: Lua ()
-        pushPipeErrorMetaTable = do
-          v <- Lua.newmetatable "pandoc pipe error"
-          when v $ LuaUtil.addFunction "__tostring" pipeErrorMessage
+pushPipeError :: PeekError e => Pusher e PipeError
+pushPipeError pipeErr = do
+  Lua.newtable
+  LuaUtil.addField "command" (pipeErrorCommand pipeErr)
+  LuaUtil.addField "error_code" (pipeErrorCode pipeErr)
+  LuaUtil.addField "output" (pipeErrorOutput pipeErr)
+  pushPipeErrorMetaTable
+  Lua.setmetatable (-2)
+    where
+      pushPipeErrorMetaTable :: PeekError e => LuaE e ()
+      pushPipeErrorMetaTable = do
+        v <- Lua.newmetatable "pandoc pipe error"
+        when v $ do
+          pushName "__tostring"
+          pushHaskellFunction pipeErrorMessage
+          rawset (nth 3)
 
-        pipeErrorMessage :: PipeError -> Lua BL.ByteString
-        pipeErrorMessage (PipeError cmd errorCode output) = return $ mconcat
+      pipeErrorMessage :: PeekError e => LuaE e NumResults
+      pipeErrorMessage = do
+        (PipeError cmd errorCode output) <- peekPipeError (nthBottom 1)
+        pushByteString . BSL.toStrict . BSL.concat $
           [ BSL.pack "Error running "
           , BSL.pack $ T.unpack cmd
           , BSL.pack " (error code "
@@ -131,3 +141,4 @@ instance Pushable PipeError where
           , BSL.pack "): "
           , if output == mempty then BSL.pack "<no output>" else output
           ]
+        return (NumResults 1)