{-# LANGUAGE CPP #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# OPTIONS_GHC -Wno-warnings-deprecations #-}

module HsLua.Core.Error

( Exception (..)

, LuaError (..)

, Lua

, try

, failLua

, throwErrorAsException

, throwTypeMismatchError

, changeErrorType

-- * Helpers for hslua C wrapper functions.

, liftLuaThrow

, popErrorMessage

, pushTypeMismatchError

) where

import Control.Applicative (Alternative (..))

import Control.Monad ((<$!>), void)

import Data.ByteString (ByteString)

import Data.Proxy (Proxy (Proxy))

import Data.Typeable (Typeable)

import Foreign.Marshal.Alloc (alloca)

import Foreign.Ptr

import HsLua.Core.Types (LuaE, liftLua)

import Lua

import qualified Control.Exception as E

import qualified Control.Monad.Catch as Catch

import qualified Data.ByteString as B

import qualified Data.ByteString.Char8 as Char8

import qualified Data.ByteString.Unsafe as B

import qualified Foreign.Storable as Storable

import qualified HsLua.Core.Types as Lua

import qualified HsLua.Core.Utf8 as Utf8

#if !MIN_VERSION_base(4,13,0)

import Control.Monad.Fail (MonadFail (..))

-- | A Lua operation.

type Lua a = LuaE Exception a

-- | Any type that you wish to use for error handling in HsLua must be

class E.Exception e => LuaError e where

-- | Converts the error at the top of the stack into an exception and

-- pops the error off the stack.

--

-- This function is expected to produce a valid result for any Lua

-- value; neither a Haskell exception nor a Lua error may result when

-- this is called.

popException :: LuaE e e

-- | Pushes an exception to the top of the Lua stack. The pushed Lua

-- object is used as an error object, and it is recommended that

-- calling @tostring()@ on the object produces an informative message.

pushException :: e -> LuaE e ()

-- | Creates a new exception with the given message.

luaException :: String -> e

-- | Default Lua error type. Exceptions raised by Lua-related operations.

newtype Exception = Exception { exceptionMessage :: String}

deriving (Eq, Typeable)

instance Show Exception where

show (Exception msg) = "Lua exception: " ++ msg

instance E.Exception Exception

instance LuaError Exception where

popException = do

Exception . Utf8.toString <$!> liftLua popErrorMessage

{-# INLINABLE popException #-}

pushException (Exception msg) = Lua.liftLua $ \l ->

B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) ->

lua_pushlstring l msgPtr (fromIntegral z)

{-# INLINABLE pushException #-}

luaException = Exception

{-# INLINABLE luaException #-}

-- | Return either the result of a Lua computation or, if an exception was

try :: Catch.Exception e => LuaE e a -> LuaE e (Either e a)

try = Catch.try

{-# INLINABLE try #-}

-- | Raises an exception in the Lua monad.

failLua :: forall e a. LuaError e => String -> LuaE e a

failLua msg = Catch.throwM (luaException @e msg)

{-# INLINABLE failLua #-}

-- | Converts a Lua error at the top of the stack into a Haskell

throwErrorAsException :: LuaError e => LuaE e a

throwErrorAsException = do

err <- popException

Catch.throwM $! err

{-# INLINABLE throwErrorAsException #-}

-- | Raises an exception that's appropriate when the type of a Lua

throwTypeMismatchError :: forall e a. LuaError e

=> ByteString -> StackIndex -> LuaE e a

throwTypeMismatchError expected idx = do

pushTypeMismatchError expected idx

throwErrorAsException

{-# INLINABLE throwTypeMismatchError #-}

-- | Change the error type of a computation.

changeErrorType :: forall old new a. LuaE old a -> LuaE new a

changeErrorType op = Lua.liftLua $ \l -> do

x <- Lua.runWith l op

return $! x

{-# INLINABLE changeErrorType #-}

instance LuaError e => Alternative (LuaE e) where

empty = failLua "empty"

x <|> y = x `Catch.catch` (\(_ :: e) -> y)

instance LuaError e => MonadFail (LuaE e) where

fail = failLua

-- | Takes a failable HsLua function and transforms it into a

liftLuaThrow :: forall e a. LuaError e

=> (Lua.State -> Ptr Lua.StatusCode -> IO a)

-> LuaE e a

liftLuaThrow f = Lua.liftLua (throwOnError (Proxy @e) f)

-- | Helper function which takes an ersatz function and checks for

throwOnError :: forall e a. LuaError e

=> Proxy e

-> (Lua.State -> Ptr Lua.StatusCode -> IO a)

-> Lua.State

-> IO a

throwOnError _errProxy f l = alloca $ \statusPtr -> do

result <- f l statusPtr

status <- Storable.peek statusPtr

if status == LUA_OK

then return $! result

else Lua.runWith l (throwErrorAsException @e)

-- | Retrieve and pop the top object as an error message. This is very

popErrorMessage :: Lua.State -> IO ByteString

popErrorMessage l = alloca $ \lenPtr -> do

cstr <- hsluaL_tolstring l (-1) lenPtr

if cstr == nullPtr

then do

lua_pop l 1

return $ Char8.pack

"An error occurred, but the error object could not be retrieved."

else do

cstrLen <- Storable.peek lenPtr

msg <- B.packCStringLen (cstr, fromIntegral cstrLen)

lua_pop l 2 -- pop original msg and product of hsluaL_tolstring

return msg

-- | Creates an error to notify about a Lua type mismatch and pushes it

pushTypeMismatchError :: ByteString -- ^ name or description of expected type

-> StackIndex -- ^ stack index of mismatching object

-> LuaE e ()

pushTypeMismatchError expected idx = liftLua $ \l -> do

let pushtype = lua_type l idx >>= lua_typename l >>= lua_pushstring l

B.unsafeUseAsCString "__name" (luaL_getmetafield l idx) >>= \case

LUA_TSTRING -> return () -- pushed the name

LUA_TNIL -> void pushtype

_ -> lua_pop l 1 <* pushtype

let pushstring str = B.unsafeUseAsCStringLen str $ \(cstr, cstrLen) ->

lua_pushlstring l cstr (fromIntegral cstrLen)

pushstring expected

pushstring " expected, got "

lua_rotate l (-3) (-1) -- move actual type to the end

lua_concat l 3