{-# LANGUAGE TypeApplications #-}
{-|
Module      : HsLua.Core.Trace
Copyright   : © 2017-2024 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>

Helper functions to call Lua functions with tracebacks.
-}
module HsLua.Core.Trace
  ( pcallTrace
  , callTrace
  , dofileTrace
  , dostringTrace
  ) where

import Data.ByteString (ByteString)
import Foreign.C.Types
import HsLua.Core.Auxiliary (loadfile, loadstring, tostring', traceback)
import HsLua.Core.Error (Exception, LuaError, throwErrorAsException)
import HsLua.Core.Primary (gettop, insert, pcall, pushcfunction, remove)
import HsLua.Core.Run (runWith)
import HsLua.Core.Types
  ( CFunction, LuaE, NumArgs (..), NumResults (..), PreCFunction
  , Status (OK), State (..), multret )

-- | Like @'pcall'@, but sets an appropriate message handler function,
-- thereby adding a stack traceback if an error occurs.
pcallTrace :: NumArgs -> NumResults -> LuaE e Status
pcallTrace :: forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace nargs :: NumArgs
nargs@(NumArgs CInt
nargsint) NumResults
nres = do
  StackIndex
curtop <- LuaE e StackIndex
forall e. LuaE e StackIndex
gettop
  let base :: StackIndex
base = StackIndex
curtop StackIndex -> StackIndex -> StackIndex
forall a. Num a => a -> a -> a
- CInt -> StackIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
nargsint -- function index
  CFunction -> LuaE e ()
forall e. CFunction -> LuaE e ()
pushcfunction CFunction
hsluaL_msghandler_ptr
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
insert StackIndex
base  -- insert msghandler below function
  Status
status' <- NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
forall e.
NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status
pcall NumArgs
nargs NumResults
nres (StackIndex -> Maybe StackIndex
forall a. a -> Maybe a
Just StackIndex
base)
  StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
remove StackIndex
base
  Status -> LuaE e Status
forall a. a -> LuaE e a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
status'

-- | Like @'call'@, but adds a traceback if an error occurs.
callTrace :: LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace :: forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
callTrace NumArgs
nargs NumResults
nres = NumArgs -> NumResults -> LuaE e Status
forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
nargs NumResults
nres LuaE e Status -> (Status -> LuaE e ()) -> LuaE e ()
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Status
OK -> () -> LuaE e ()
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Status
_  -> LuaE e ()
forall e a. LuaError e => LuaE e a
throwErrorAsException

-- | Run the given file as a Lua program, while also adding a
-- traceback to the error message if an error occurs.
dofileTrace :: Maybe FilePath -> LuaE e Status
dofileTrace :: forall e. Maybe FilePath -> LuaE e Status
dofileTrace Maybe FilePath
fp = Maybe FilePath -> LuaE e Status
forall e. Maybe FilePath -> LuaE e Status
loadfile Maybe FilePath
fp LuaE e Status -> (Status -> LuaE e Status) -> LuaE e Status
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Status
OK -> NumArgs -> NumResults -> LuaE e Status
forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
0 NumResults
multret
  Status
s  -> Status -> LuaE e Status
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
s

dostringTrace :: ByteString -> LuaE e Status
dostringTrace :: forall e. ByteString -> LuaE e Status
dostringTrace ByteString
s = ByteString -> LuaE e Status
forall e. ByteString -> LuaE e Status
loadstring ByteString
s LuaE e Status -> (Status -> LuaE e Status) -> LuaE e Status
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Status
OK  -> NumArgs -> NumResults -> LuaE e Status
forall e. NumArgs -> NumResults -> LuaE e Status
pcallTrace NumArgs
0 NumResults
multret
  Status
err -> Status -> LuaE e Status
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
err

-- | Helper function used as message handler if the function given to
-- pcall fails.
hsluaL_msghandler :: State -> IO NumResults
hsluaL_msghandler :: State -> IO NumResults
hsluaL_msghandler State
l = State -> LuaE Exception NumResults -> IO NumResults
forall e a. State -> LuaE e a -> IO a
runWith State
l (LuaE Exception NumResults -> IO NumResults)
-> LuaE Exception NumResults -> IO NumResults
forall a b. (a -> b) -> a -> b
$ do
  ByteString
msg <- forall e. LuaError e => StackIndex -> LuaE e ByteString
tostring' @Exception StackIndex
1
  State -> Maybe ByteString -> Int -> LuaE Exception ()
forall e. State -> Maybe ByteString -> Int -> LuaE e ()
traceback State
l (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
msg) Int
2
  NumResults -> LuaE Exception NumResults
forall a. a -> LuaE Exception a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> NumResults
NumResults CInt
1)

-- Turn message handler into a CFunction by exporting it, then importing
-- at pointer to it.
foreign export ccall hsluaL_msghandler :: PreCFunction
foreign import ccall "&hsluaL_msghandler"
  hsluaL_msghandler_ptr:: CFunction