{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# OPTIONS_GHC -fno-warn-orphans       #-}
{-|
Module      : Foreign.Lua.Core.Error
Copyright   : © 2017-2020 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : DeriveDataTypeable

Lua exceptions and exception handling.
-}
module Foreign.Lua.Core.Error
  ( Exception (..)
  , catchException
  , throwException
  , withExceptionMessage
  , throwErrorAsException
  , throwTopMessage
  , throwTopMessageWithState
  , errorMessage
  , try
    -- * Helpers for hslua C wrapper functions.
  , Failable (..)
  , fromFailable
  , throwOnError
  , throwMessage
  , boolFromFailable
    -- * Signaling errors to Lua
  , hsluaErrorRegistryField
  ) where

import Control.Applicative (Alternative (..))
import Data.Typeable (Typeable)
import Foreign.C (CChar, CInt (CInt), CSize (CSize))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Lua.Core.Types (Lua, StackIndex, fromLuaBool)

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 Foreign.Lua.Core.Types as Lua
import qualified Foreign.Lua.Utf8 as Utf8

-- | Exceptions raised by Lua-related operations.
newtype Exception = Exception { Exception -> String
exceptionMessage :: String}
  deriving (Exception -> Exception -> Bool
(Exception -> Exception -> Bool)
-> (Exception -> Exception -> Bool) -> Eq Exception
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exception -> Exception -> Bool
$c/= :: Exception -> Exception -> Bool
== :: Exception -> Exception -> Bool
$c== :: Exception -> Exception -> Bool
Eq, Typeable)

instance Show Exception where
  show :: Exception -> String
show (Exception msg :: String
msg) = "Lua exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

instance E.Exception Exception

-- | Raise a Lua @'Exception'@ containing the given error message.
throwException :: String -> Lua a
throwException :: String -> Lua a
throwException = Exception -> Lua a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM (Exception -> Lua a) -> (String -> Exception) -> String -> Lua a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Exception
{-# INLINABLE throwException #-}

-- | Catch a Lua @'Exception'@.
catchException :: Lua a -> (Exception -> Lua a) -> Lua a
catchException :: Lua a -> (Exception -> Lua a) -> Lua a
catchException = Lua a -> (Exception -> Lua a) -> Lua a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Catch.catch
{-# INLINABLE catchException #-}

-- | Catch Lua @'Exception'@, alter the message and rethrow.
withExceptionMessage :: (String -> String) -> Lua a -> Lua a
withExceptionMessage :: ShowS -> Lua a -> Lua a
withExceptionMessage modifier :: ShowS
modifier luaOp :: Lua a
luaOp =
  Lua a
luaOp Lua a -> (Exception -> Lua a) -> Lua a
forall a. Lua a -> (Exception -> Lua a) -> Lua a
`catchException` \(Exception msg :: String
msg) -> String -> Lua a
forall a. String -> Lua a
throwException (ShowS
modifier String
msg)
{-# INLINABLE withExceptionMessage #-}

-- | Return either the result of a Lua computation or, if an exception was
-- thrown, the error.
try :: Lua a -> Lua (Either Exception a)
try :: Lua a -> Lua (Either Exception a)
try = Lua a -> Lua (Either Exception a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try
{-# INLINABLE try #-}

-- | Convert a Lua error into a Haskell exception. The error message is
-- expected to be at the top of the stack.
throwErrorAsException :: Lua a
throwErrorAsException :: Lua a
throwErrorAsException = do
  State -> IO a
f <- ErrorConversion -> State -> IO a
ErrorConversion -> forall a. State -> IO a
Lua.errorToException (ErrorConversion -> State -> IO a)
-> Lua ErrorConversion -> Lua (State -> IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lua ErrorConversion
Lua.errorConversion
  State
l <- Lua State
Lua.state
  IO a -> Lua a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (State -> IO a
f State
l)

-- | Alias for `throwErrorAsException`; will be deprecated in the next
-- mayor release.
throwTopMessage :: Lua a
throwTopMessage :: Lua a
throwTopMessage = Lua a
forall a. Lua a
throwErrorAsException

instance Alternative Lua where
  empty :: Lua a
empty = String -> Lua a
forall a. String -> Lua a
throwMessage "empty"
  x :: Lua a
x <|> :: Lua a -> Lua a -> Lua a
<|> y :: Lua a
y = do
    Lua a -> Lua a -> Lua a
alt <- ErrorConversion -> Lua a -> Lua a -> Lua a
ErrorConversion -> forall a. Lua a -> Lua a -> Lua a
Lua.alternative (ErrorConversion -> Lua a -> Lua a -> Lua a)
-> Lua ErrorConversion -> Lua (Lua a -> Lua a -> Lua a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lua ErrorConversion
Lua.errorConversion
    Lua a
x Lua a -> Lua a -> Lua a
`alt` Lua a
y

-- | Convert the object at the top of the stack into a string and throw
-- it as a HsLua @'Exception'@.
--
-- This function serves as the default to convert Lua errors to Haskell
-- exceptions.
throwTopMessageWithState :: Lua.State -> IO a
throwTopMessageWithState :: State -> IO a
throwTopMessageWithState l :: State
l = do
  ByteString
msg <- IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (State -> IO ByteString
errorMessage State
l)
  Exception -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM (Exception -> IO a) -> Exception -> IO a
forall a b. (a -> b) -> a -> b
$ String -> Exception
Exception (ByteString -> String
Utf8.toString ByteString
msg)

-- | Helper function which uses proper error-handling to throw an
-- exception with the given message.
throwMessage :: String -> Lua a
throwMessage :: String -> Lua a
throwMessage msg :: String
msg = do
  (State -> IO ()) -> Lua ()
forall a. (State -> IO a) -> Lua a
Lua.liftLua ((State -> IO ()) -> Lua ()) -> (State -> IO ()) -> Lua ()
forall a b. (a -> b) -> a -> b
$ \l :: State
l ->
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen (String -> ByteString
Utf8.fromString String
msg) ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(msgPtr :: Ptr CChar
msgPtr, z :: Int
z) ->
      State -> Ptr CChar -> CSize -> IO ()
lua_pushlstring State
l Ptr CChar
msgPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
z)
  Lua ErrorConversion
Lua.errorConversion Lua ErrorConversion -> (ErrorConversion -> Lua a) -> Lua a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (State -> IO a) -> Lua a
forall a. (State -> IO a) -> Lua a
Lua.liftLua ((State -> IO a) -> Lua a)
-> (ErrorConversion -> State -> IO a) -> ErrorConversion -> Lua a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorConversion -> State -> IO a
ErrorConversion -> forall a. State -> IO a
Lua.errorToException

-- | Retrieve and pop the top object as an error message. This is very similar
-- to tostring', but ensures that we don't recurse if getting the message
-- failed.
errorMessage :: Lua.State -> IO B.ByteString
errorMessage :: State -> IO ByteString
errorMessage l :: State
l = (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO ByteString) -> IO ByteString)
-> (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \lenPtr :: Ptr CSize
lenPtr -> do
  Ptr CChar
cstr <- State -> StackIndex -> Ptr CSize -> IO (Ptr CChar)
hsluaL_tolstring State
l StackIndex
Lua.stackTop Ptr CSize
lenPtr
  if Ptr CChar
cstr Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr
    then ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
Char8.pack ("An error occurred, but the error object " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                              "cannot be converted into a string.")
    else do
      CSize
cstrLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
Storable.peek Ptr CSize
lenPtr
      ByteString
msg <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
cstr, CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cstrLen)
      State -> CInt -> IO ()
lua_pop State
l 2
      ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
msg

foreign import ccall safe "error-conversion.h hsluaL_tolstring"
  hsluaL_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar)

foreign import capi unsafe "lua.h lua_pop"
  lua_pop :: Lua.State -> CInt -> IO ()

foreign import capi unsafe "lua.h lua_pushlstring"
  lua_pushlstring :: Lua.State -> Ptr CChar -> CSize -> IO ()

-- | Registry field under which the special HsLua error indicator is stored.
hsluaErrorRegistryField :: String
hsluaErrorRegistryField :: String
hsluaErrorRegistryField = "HSLUA_ERR"

--
-- * Custom protocol to communicate with hslua C wrapper functions.
--

-- | CInt value or an error, using the convention that value below zero indicate
-- an error. Values greater than zero are used verbatim. The phantom type is
-- used for additional type safety and gives the type into which the wrapped
-- CInt should be converted.
newtype Failable a = Failable CInt

-- | Convert from Failable to target type, throwing an error if the value
-- indicates a failure.
fromFailable :: (CInt -> a) -> Failable a -> Lua a
fromFailable :: (CInt -> a) -> Failable a -> Lua a
fromFailable fromCInt :: CInt -> a
fromCInt (Failable x :: CInt
x) =
  if CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0
  then Lua a
forall a. Lua a
throwTopMessage
  else a -> Lua a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> a
fromCInt CInt
x)

-- | Throw a Haskell exception if the computation signaled a failure.
throwOnError :: Failable () -> Lua ()
throwOnError :: Failable () -> Lua ()
throwOnError = (CInt -> ()) -> Failable () -> Lua ()
forall a. (CInt -> a) -> Failable a -> Lua a
fromFailable (() -> CInt -> ()
forall a b. a -> b -> a
const ())

-- | Convert lua boolean to Haskell Bool, throwing an exception if the return
-- value indicates that an error had happened.
boolFromFailable :: Failable Lua.LuaBool -> Lua Bool
boolFromFailable :: Failable LuaBool -> Lua Bool
boolFromFailable = (LuaBool -> Bool) -> Lua LuaBool -> Lua Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LuaBool -> Bool
fromLuaBool (Lua LuaBool -> Lua Bool)
-> (Failable LuaBool -> Lua LuaBool)
-> Failable LuaBool
-> Lua Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CInt -> LuaBool) -> Failable LuaBool -> Lua LuaBool
forall a. (CInt -> a) -> Failable a -> Lua a
fromFailable CInt -> LuaBool
Lua.LuaBool