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, 50 insertions, 70 deletions

diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs
index 70a8a6d47..50157189f 100644
--- a/src/Text/Pandoc/Lua/Util.hs
+++ b/src/Text/Pandoc/Lua/Util.hs
@@ -1,6 +1,9 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
 {- |
    Module      : Text.Pandoc.Lua.Util
    Copyright   : © 2012-2021 John MacFarlane,
@@ -14,114 +17,91 @@ Lua utility functions.
 -}
 module Text.Pandoc.Lua.Util
   ( getTag
-  , rawField
   , addField
   , addFunction
-  , addValue
   , pushViaConstructor
-  , defineHowTo
-  , throwTopMessageAsError'
   , callWithTraceback
   , dofileWithTraceback
+  , pushViaConstr'
   ) where
 
 import Control.Monad (unless, when)
-import Data.Text (Text)
-import Foreign.Lua ( Lua, NumArgs, NumResults, Peekable, Pushable, StackIndex
-                   , Status, ToHaskellFunction )
-import qualified Foreign.Lua as Lua
-import qualified Text.Pandoc.UTF8 as UTF8
-
--- | Get value behind key from table at given index.
-rawField :: Peekable a => StackIndex -> String -> Lua a
-rawField idx key = do
-  absidx <- Lua.absindex idx
-  Lua.push key
-  Lua.rawget absidx
-  Lua.popValue
+import HsLua
+import qualified HsLua as Lua
 
 -- | Add a value to the table at the top of the stack at a string-index.
-addField :: Pushable a => String -> a -> Lua ()
-addField = addValue
-
--- | Add a key-value pair to the table at the top of the stack.
-addValue :: (Pushable a, Pushable b) => a -> b -> Lua ()
-addValue key value = do
+addField :: (LuaError e, Pushable a) => String -> a -> LuaE e ()
+addField key value = do
   Lua.push key
   Lua.push value
-  Lua.rawset (Lua.nthFromTop 3)
+  Lua.rawset (Lua.nth 3)
 
--- | Add a function to the table at the top of the stack, using the given name.
-addFunction :: ToHaskellFunction a => String -> a -> Lua ()
+-- | Add a function to the table at the top of the stack, using the
+-- given name.
+addFunction :: Exposable e a => String -> a -> LuaE e ()
 addFunction name fn = do
   Lua.push name
-  Lua.pushHaskellFunction fn
+  Lua.pushHaskellFunction $ toHaskellFunction fn
   Lua.rawset (-3)
 
--- | Helper class for pushing a single value to the stack via a lua function.
--- See @pushViaCall@.
-class PushViaCall a where
-  pushViaCall' :: String -> Lua () -> NumArgs -> a
+-- | Helper class for pushing a single value to the stack via a lua
+-- function. See @pushViaCall@.
+class LuaError e => PushViaCall e a where
+  pushViaCall' :: LuaError e => Name -> LuaE e () -> NumArgs -> a
 
-instance PushViaCall (Lua ()) where
+instance LuaError e => PushViaCall e (LuaE e ()) where
   pushViaCall' fn pushArgs num = do
-    Lua.push fn
+    Lua.pushName @e fn
     Lua.rawget Lua.registryindex
     pushArgs
     Lua.call num 1
 
-instance (Pushable a, PushViaCall b) => PushViaCall (a -> b) where
+instance (LuaError e, Pushable a, PushViaCall e b) =>
+         PushViaCall e (a -> b) where
   pushViaCall' fn pushArgs num x =
-    pushViaCall' fn (pushArgs *> Lua.push x) (num + 1)
+    pushViaCall' @e fn (pushArgs *> Lua.push x) (num + 1)
 
 -- | Push an value to the stack via a lua function. The lua function is called
 -- with all arguments that are passed to this function and is expected to return
 -- a single value.
-pushViaCall :: PushViaCall a => String -> a
-pushViaCall fn = pushViaCall' fn (return ()) 0
+pushViaCall :: forall e a. LuaError e => PushViaCall e a => Name -> a
+pushViaCall fn = pushViaCall' @e fn (return ()) 0
 
 -- | Call a pandoc element constructor within Lua, passing all given arguments.
-pushViaConstructor :: PushViaCall a => String -> a
-pushViaConstructor pandocFn = pushViaCall ("pandoc." ++ pandocFn)
+pushViaConstructor :: forall e a. LuaError e => PushViaCall e a => Name -> a
+pushViaConstructor pandocFn = pushViaCall @e ("pandoc." <> pandocFn)
 
 -- | 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
 -- metatable.
-getTag :: StackIndex -> Lua String
+getTag :: LuaError e => Peeker e Name
 getTag idx = do
   -- push metatable or just the table
-  Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx)
-  Lua.push ("tag" :: Text)
-  Lua.rawget (Lua.nthFromTop 2)
-  Lua.tostring Lua.stackTop <* Lua.pop 2 >>= \case
-    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
--- Exception.
-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.throwMessage (modifier (UTF8.toString msg))
-
--- | Mark the context of a Lua computation for better error reporting.
-defineHowTo :: String -> Lua a -> Lua a
-defineHowTo ctx op = Lua.errorConversion >>= \ec ->
-  Lua.addContextToException ec ("Could not " <> ctx <> ": ") op
+  liftLua $ do
+    Lua.getmetatable idx >>= \hasMT -> unless hasMT (Lua.pushvalue idx)
+    Lua.pushName "tag"
+    Lua.rawget (Lua.nth 2)
+  Lua.peekName Lua.top `lastly` Lua.pop 2  -- table/metatable and `tag` field
+
+pushViaConstr' :: forall e. LuaError e => Name -> [LuaE e ()] -> LuaE e ()
+pushViaConstr' fnname pushArgs = do
+  pushName @e ("pandoc." <> fnname)
+  rawget @e registryindex
+  sequence_ pushArgs
+  call @e (fromIntegral (length pushArgs)) 1
 
 -- | Like @'Lua.pcall'@, but uses a predefined error handler which adds a
 -- traceback on error.
-pcallWithTraceback :: NumArgs -> NumResults -> Lua Status
+pcallWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e Status
 pcallWithTraceback nargs nresults = do
-  let traceback' :: Lua NumResults
+  let traceback' :: LuaError e => LuaE e NumResults
       traceback' = do
         l <- Lua.state
-        msg <- Lua.tostring' (Lua.nthFromBottom 1)
-        Lua.traceback l (Just (UTF8.toString msg)) 2
+        msg <- Lua.tostring' (Lua.nthBottom 1)
+        Lua.traceback l (Just msg) 2
         return 1
-  tracebackIdx <- Lua.absindex (Lua.nthFromTop (Lua.fromNumArgs nargs + 1))
+  tracebackIdx <- Lua.absindex (Lua.nth (Lua.fromNumArgs nargs + 1))
   Lua.pushHaskellFunction traceback'
   Lua.insert tracebackIdx
   result <- Lua.pcall nargs nresults (Just tracebackIdx)
@@ -129,15 +109,15 @@ pcallWithTraceback nargs nresults = do
   return result
 
 -- | Like @'Lua.call'@, but adds a traceback to the error message (if any).
-callWithTraceback :: NumArgs -> NumResults -> Lua ()
+callWithTraceback :: LuaError e => NumArgs -> NumResults -> LuaE e ()
 callWithTraceback nargs nresults = do
   result <- pcallWithTraceback nargs nresults
   when (result /= Lua.OK)
-    Lua.throwTopMessage
+    Lua.throwErrorAsException
 
 -- | Run the given string as a Lua program, while also adding a traceback to the
 -- error message if an error occurs.
-dofileWithTraceback :: FilePath -> Lua Status
+dofileWithTraceback :: LuaError e => FilePath -> LuaE e Status
 dofileWithTraceback fp = do
   loadRes <- Lua.loadfile fp
   case loadRes of