{-# 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.
  , throwMessage
  , liftLuaThrow
  ) where

import Control.Applicative (Alternative (..))
import Data.Typeable (Typeable)
import Foreign.Lua.Core.Types (Lua)
import Foreign.Lua.Raw.Error (errorMessage)
import Foreign.Lua.Raw.Functions (lua_pushlstring)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr

import qualified Data.ByteString.Unsafe as B
import qualified Control.Exception as E
import qualified Control.Monad.Catch as Catch
import qualified Foreign.Lua.Core.Types as Lua
import qualified Foreign.Lua.Utf8 as Utf8
import qualified Foreign.Storable as F

-- | 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 String
msg) = String
"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 ShowS
modifier Lua a
luaOp =
  Lua a
luaOp Lua a -> (Exception -> Lua a) -> Lua a
forall a. Lua a -> (Exception -> Lua a) -> Lua a
`catchException` \(Exception 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
  ErrorConversion
e <- 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 (ErrorConversion -> State -> IO a
ErrorConversion -> forall a. State -> IO a
Lua.errorToException ErrorConversion
e 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

-- | Helper function which uses proper error-handling to throw an
-- exception with the given message.
throwMessage :: String -> Lua a
throwMessage :: String -> Lua a
throwMessage 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
$ \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
$ \(Ptr CChar
msgPtr, 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)
  ErrorConversion
e <- Lua ErrorConversion
Lua.errorConversion
  (State -> IO a) -> Lua a
forall a. (State -> IO a) -> Lua a
Lua.liftLua (ErrorConversion -> forall a. State -> IO a
Lua.errorToException ErrorConversion
e)

instance Alternative Lua where
  empty :: Lua a
empty = String -> Lua a
forall a. String -> Lua a
throwMessage String
"empty"
  Lua a
x <|> :: Lua a -> Lua a -> Lua a
<|> Lua a
y = do
    ErrorConversion
e <- Lua ErrorConversion
Lua.errorConversion
    ErrorConversion -> Lua a -> Lua a -> Lua a
ErrorConversion -> forall a. Lua a -> Lua a -> Lua a
Lua.alternative ErrorConversion
e Lua a
x 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 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)

-- | Takes a failable HsLua function and transforms it into a
-- monadic 'Lua' operation. Throws an exception if an error
-- occured.
liftLuaThrow :: (Lua.State -> Ptr Lua.StatusCode -> IO a) -> Lua a
liftLuaThrow :: (State -> Ptr StatusCode -> IO a) -> Lua a
liftLuaThrow State -> Ptr StatusCode -> IO a
f = do
  (a
result, Status
status) <- (State -> IO (a, Status)) -> Lua (a, Status)
forall a. (State -> IO a) -> Lua a
Lua.liftLua ((State -> IO (a, Status)) -> Lua (a, Status))
-> (State -> IO (a, Status)) -> Lua (a, Status)
forall a b. (a -> b) -> a -> b
$ \State
l -> (Ptr StatusCode -> IO (a, Status)) -> IO (a, Status)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr StatusCode -> IO (a, Status)) -> IO (a, Status))
-> (Ptr StatusCode -> IO (a, Status)) -> IO (a, Status)
forall a b. (a -> b) -> a -> b
$ \Ptr StatusCode
statusPtr -> do
    a
result <- State -> Ptr StatusCode -> IO a
f State
l Ptr StatusCode
statusPtr
    Status
status <- StatusCode -> Status
Lua.toStatus (StatusCode -> Status) -> IO StatusCode -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr StatusCode -> IO StatusCode
forall a. Storable a => Ptr a -> IO a
F.peek Ptr StatusCode
statusPtr
    (a, Status) -> IO (a, Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Status
status)
  if Status
status Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Lua.OK
    then a -> Lua a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
    else Lua a
forall a. Lua a
throwTopMessage