Use LuaStatus type for status and return values

There are only a couple of possible values that can be returned by
`status` and other functions. The names of the LuaStatus constructors is
based on the names of the respective C constants.

src/Foreign/Lua/Api.hs

@@ -168,14 +168,14 @@ copy fromidx toidx = do
 -- stack. All values returned by func are discarded.
 --
 -- See <https://www.lua.org/manual/5.1/manual.html#lua_cpcall lua_cpcall>.
-cpcall :: FunPtr LuaCFunction -> Ptr a -> Lua Int
+cpcall :: FunPtr LuaCFunction -> Ptr a -> Lua LuaStatus
 #if LUA_VERSION_NUMBER >= 502
 cpcall a c = do
   pushcfunction a
   pushlightuserdata c
-  pcall 1 0 0
+  pcall 1 0 Nothing
 #else
-cpcall a c = liftLua $ \l -> fmap fromIntegral (lua_cpcall l a c)
+cpcall a c = liftLua $ \l -> fmap toLuaStatus (lua_cpcall l a c)
 #endif
 
 -- | Creates a new empty table and pushes it onto the stack. Parameter narr is a
@@ -434,10 +434,10 @@ loadfile f = liftLua $ \l ->
 #endif
 
 -- | See <https://www.lua.org/manual/5.3/manual.html#luaL_loadstring luaL_loadstring>.
-loadstring :: String -> Lua Int
+loadstring :: String -> Lua LuaStatus
 loadstring str = liftLua $ \l ->
   withCString str $ \strPtr ->
-  fromIntegral <$> luaL_loadstring l strPtr
+  toLuaStatus <$> luaL_loadstring l strPtr
 
 -- | See <https://www.lua.org/manual/5.3/manual.html#lua_type lua_type>.
 ltype :: StackIndex -> Lua LTYPE
@@ -568,24 +568,43 @@ openstring = pushcfunction lua_open_string_ptr *> call 0 multret
 opentable :: Lua ()
 opentable = pushcfunction lua_open_table_ptr *> call 0 multret
 
+-- | Calls a function in protected mode.
+--
+-- Both @nargs@ and @nresults@ have the same meaning as in @'call'@. If there are
+-- no errors during the call, @pcall@ behaves exactly like @'call'@. However, if
+-- there is any error, @'pcall'@ catches it, pushes a single value on the stack
+-- (the error object), and returns an error code. Like @'call'@, @'pcall'@
+-- always removes the function and its arguments from the stack.
+--
+-- If @msgh@ is @Nothing@, then the error object returned on the stack is
+-- exactly the original error object. Otherwise, when @msgh@ is @Just idx@, the
+-- stack index @idx@ is the location of a message handler. (This index cannot be
+-- a pseudo-index.) In case of runtime errors, this function will be called with
+-- the error object and its return value will be the object returned on the
+-- stack by @'pcall'@.
+--
+-- Typically, the message handler is used to add more debug information to the
+-- error object, such as a stack traceback. Such information cannot be gathered
+-- after the return of @'pcall'@, since by then the stack has unwound.
+--
 -- | See <https://www.lua.org/manual/5.3/manual.html#lua_pcall lua_pcall>.
-pcall :: NumArgs -> NumResults -> Int -> Lua Int
+pcall :: NumArgs -> NumResults -> Maybe StackIndex -> Lua LuaStatus
 #if LUA_VERSION_NUMBER >= 502
-pcall nargs nresults errfunc = liftLua $ \l ->
-  fromIntegral <$>
+pcall nargs nresults msgh = liftLua $ \l ->
+  toLuaStatus <$>
   lua_pcallk l
     (fromNumArgs nargs)
     (fromNumResults nresults)
-    (fromIntegral errfunc)
+    (maybe 0 fromStackIndex msgh)
     0
     nullPtr
 #else
-pcall nargs nresults errfunc = liftLua $ \l ->
-  fromIntegral <$>
+pcall nargs nresults msgh = liftLua $ \l ->
+  toLuaStatus <$>
   lua_pcall l
     (fromNumArgs nargs)
     (fromNumResults nresults)
-    (fromIntegral errfunc)
+    (maybe 0 fromStackIndex msgh)
 #endif
 
 -- | Pops @n@ elements from the stack.
@@ -840,19 +859,19 @@ settable index = liftLua $ \l -> lua_settable l (fromIntegral index)
 settop :: StackIndex -> Lua ()
 settop = liftLua1 lua_settop . fromStackIndex
 
--- |  Returns the status of the thread L.
+-- |  Returns the status of this Lua thread.
 --
--- The status can be 0 (LUA_OK) for a normal thread, an error code if the thread
--- finished the execution of a lua_resume with an error, or LUA_YIELD if the
--- thread is suspended.
+-- The status can be @'LuaOK'@ for a normal thread, an error value if the thread
+-- finished the execution of a @'lua_resume'@ with an error, or @'LuaYield'@ if
+-- the thread is suspended.
 --
--- You can only call functions in threads with status LUA_OK. You can resume
--- threads with status LUA_OK (to start a new coroutine) or LUA_YIELD (to resume
--- a coroutine).
+-- You can only call functions in threads with status @'LuaOK'@. You can resume
+-- threads with status @'LuaOK'@ (to start a new coroutine) or @'LuaYield'@ (to
+-- resume a coroutine).
 --
 -- See also: <https://www.lua.org/manual/5.3/manual.html#lua_status lua_status>.
-status :: Lua Int
-status = liftLua $ fmap fromIntegral . lua_status
+status :: Lua LuaStatus
+status = liftLua $ fmap toLuaStatus . lua_status
 
 {-# DEPRECATED strlen "Use rawlen instead." #-}
 -- | Compatibility alias for rawlen

src/Foreign/Lua/Api/Types.hsc

@@ -52,6 +52,8 @@ module Foreign.Lua.Api.Types
   , LuaInteger
   , LuaNumber
   , LuaComparerOp (..)
+  , LuaStatus (..)
+  , toLuaStatus
   , StackIndex (..)
   , NumArgs (..)
   , NumResults (..)
@@ -171,6 +173,34 @@ instance Enum LuaComparerOp where
 deriving instance Enum LuaComparerOp
 #endif
 
+-- | Lua status values.
+data LuaStatus
+  = LuaOK        -- ^ success
+  | LuaYield     -- ^ yielding / suspended coroutine
+  | LuaErrRun    -- ^ a runtime rror
+  | LuaErrSyntax -- ^ syntax error during precompilation
+  | LuaErrMem    -- ^ memory allocation (out-of-memory) error.
+  | LuaErrErr    -- ^ error while running the message handler.
+  | LuaErrGcmm   -- ^ error while running a @__gc@ metamethod.
+  deriving (Eq, Show)
+
+toLuaStatus :: CInt -> LuaStatus
+-- LUA_OK is not defined in Lua 5.1
+toLuaStatus 0                        = LuaOK
+toLuaStatus (#{const LUA_YIELD})     = LuaYield
+toLuaStatus (#{const LUA_ERRRUN})    = LuaErrRun
+toLuaStatus (#{const LUA_ERRSYNTAX}) = LuaErrSyntax
+toLuaStatus (#{const LUA_ERRMEM})    = LuaErrMem
+-- LUA_ERRGCMM did not exist in Lua 5.1; comes before LUA_ERRERR when defined
+#if LUA_VERSION_NUMBER >= 502
+toLuaStatus (#{const LUA_ERRGCMM})   = LuaErrGcmm
+toLuaStatus (#{const LUA_ERRERR})    = LuaErrErr
+#else
+toLuaStatus (#{const LUA_ERRERR})    = LuaErrErr
+toLuaStatus 6                        = LuaErrGcmm
+#endif
+toLuaStatus n = error $ "Cannot convert (" ++ show n ++ ") to LuaStatus"
+
 -- | Enumeration used by @gc@ function.
 data GCCONTROL
   = GCSTOP

src/Foreign/Lua/Interop.hs

@@ -114,8 +114,8 @@ instance (FromLuaStack a) => LuaCallFunc (Lua a) where
   callfunc' fnName x nargs = do
     getglobal' fnName
     x
-    z <- pcall nargs 1 0
-    if z /= 0
+    z <- pcall nargs 1 Nothing
+    if z /= LuaOK
       then tostring (-1) >>= throwLuaError . unpack
       else peek (-1) <* pop 1
 

test/Foreign/Lua/ApiTest.hs

@@ -43,7 +43,7 @@ import Test.QuickCheck (Property, (.&&.))
 import Test.QuickCheck.Arbitrary (Arbitrary (..), arbitraryBoundedEnum)
 import Test.QuickCheck.Monadic (assert, monadicIO, run)
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (assertBool, testCase)
+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)
 import Test.Tasty.QuickCheck (testProperty)
 
 import qualified Prelude
@@ -125,6 +125,32 @@ tests = testGroup "Haskell version of the C API"
       luaSt2 <- newstate
       assertBool "different lua threads are equal in haskell" (luaSt1 /= luaSt2)
 
+  , testCase "thread status" . runLua $ do
+      status >>= liftIO . assertEqual "base status should be OK" LuaOK
+      openlibs
+      getglobal' "coroutine.resume"
+      pushLuaExpr "coroutine.create(function() coroutine.yield(9) end)"
+      co <- tothread (-1)
+      call 1 0
+      liftIO . runLuaWith co $ do
+        liftIO . assertEqual "yielding will put thread status to Yield" LuaYield
+          =<< status
+      liftIO . print =<< ltype (-1)
+
+  , testCase "loadstring status" . runLua $ do
+      liftIO . assertEqual "loading a valid string doesn't return LuaOK"
+        LuaOK =<< loadstring "return 1"
+      liftIO . assertEqual "loading an invalid string doesn't return LuaErrSyntax"
+        LuaErrSyntax =<< loadstring "marzipan"
+
+  , testCase "pcall status" . runLua $ do
+      liftIO . assertEqual "calling error did not lead to an error status"
+        LuaErrRun =<< (loadstring "error \"this fails\"" *> pcall 0 0 Nothing)
+      liftIO . assertEqual "calling error did not lead to an error status"
+        LuaErrErr =<< do
+          pushLuaExpr "function () error 'error in error handler' end"
+          loadstring "error 'this fails'" *> pcall 0 0 (Just (-2))
+
   , testGroup "compare"
     [ testProperty "identifies strictly smaller values" $ compareWith (<) OpLT
     , testProperty "identifies smaller or equal values" $ compareWith (<=) OpLE