{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# OPTIONS_GHC -fno-warn-orphans       #-}
{-|
Module      : Foreign.Lua.Core.Error
Copyright   : © 2017-2019 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
  , throwTopMessage
  , try
    -- * Helpers for hslua C wrapper functions.
  , Failable (..)
  , fromFailable
  , throwOnError
  , boolFromFailable
    -- * Signaling errors to Lua
  , hsluaErrorRegistryField
  ) where

import Control.Applicative (Alternative (..))
import Data.Typeable (Typeable)
import Foreign.C (CChar, CInt (CInt), 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 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 #-}

instance Alternative Lua where
  empty :: Lua a
empty = String -> Lua a
forall a. String -> Lua a
throwException "empty"
  x :: Lua a
x <|> :: Lua a -> Lua a -> Lua a
<|> y :: Lua a
y = (Exception -> Lua a) -> (a -> Lua a) -> Either Exception a -> Lua a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Lua a -> Exception -> Lua a
forall a b. a -> b -> a
const Lua a
y) a -> Lua a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Exception a -> Lua a) -> Lua (Either Exception a) -> Lua a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Lua a -> Lua (Either Exception a)
forall a. Lua a -> Lua (Either Exception a)
try Lua a
x

-- | Convert the object at the top of the stack into a string and throw it as
-- an @'Exception'@.
throwTopMessage :: Lua a
throwTopMessage :: Lua a
throwTopMessage = do
  State
l <- Lua State
Lua.state
  ByteString
msg <- IO ByteString -> Lua ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (State -> IO ByteString
errorMessage State
l)
  String -> Lua a
forall a. String -> Lua a
throwException (ByteString -> String
Utf8.toString ByteString
msg)

-- | 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 ()

-- | 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