{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, DataKinds #-}

-- | To catch GError exceptions use the
-- catchGError* or handleGError* functions. They work in a similar
-- way to the standard 'Control.Exception.catch' and
-- 'Control.Exception.handle' functions.
--
-- To catch just a single specific error use 'catchGErrorJust' \/
-- 'handleGErrorJust'. To catch any error in a particular error domain
-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'
--
-- For convenience, generated code also includes specialized variants
-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For
-- example, for errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> one could
-- invoke <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#v:catchPixbufError catchPixbufError> \/
-- <https://hackage.haskell.org/package/gi-gdkpixbuf-2.0.14/docs/GI-GdkPixbuf-Enums.html#v:handlePixbufError handlePixbufError>. The definition is simply
--
-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a
-- > catchPixbufError = catchGErrorJustDomain
--
-- Notice that the type is suitably specialized, so only
-- errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> will be caught.
module Data.GI.Base.GError
    (
    -- * Unpacking GError
    --
      GError(..)
    , gerrorDomain
    , gerrorCode
    , gerrorMessage

    , GErrorDomain
    , GErrorCode
    , GErrorMessage

    -- * Catching GError exceptions
    , catchGErrorJust
    , catchGErrorJustDomain

    , handleGErrorJust
    , handleGErrorJustDomain

    -- * Creating new 'GError's
    , gerrorNew

    -- * Implementation specific details
    -- | The following are used in the implementation
    -- of the bindings, and are in general not necessary for using the
    -- API.
    , GErrorClass(..)

    , propagateGError
    , checkGError
    , maybePokeGError
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

import Foreign (poke, peek)
import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C
import Control.Exception
import Data.Text (Text)
import qualified Data.Text as T

import System.IO.Unsafe (unsafePerformIO)

import Data.GI.Base.BasicTypes (GType(..), ManagedPtr, TypedObject(..),
                                GBoxed)
import Data.GI.Base.BasicConversions (withTextCString, cstringToText)
import Data.GI.Base.ManagedPtr (withManagedPtr, wrapBoxed, copyBoxed)
import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)
import Data.GI.Base.Utils (allocMem, freeMem)

import Data.GI.Base.Internal.CTypes (GQuark, C_gint, gerror_domain_offset,
                                     gerror_code_offset, gerror_message_offset)

-- | A GError, consisting of a domain, code and a human readable
-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and
-- 'gerrorMessage' below.
newtype GError = GError (ManagedPtr GError)

instance Show GError where
    show :: GError -> String
show GError
gerror = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
                       code <- GError -> IO GErrorCode
gerrorCode GError
gerror
                       message <- gerrorMessage gerror
                       return $ T.unpack message ++ " (" ++ show code ++ ")"

instance Exception GError

-- | There are no types in the bindings that a `GError` can be safely
-- cast to.
type instance ParentTypes GError = '[]
instance HasParentTypes GError

foreign import ccall "g_error_get_type" g_error_get_type :: IO GType

instance TypedObject GError where
  glibType :: IO GType
glibType = IO GType
g_error_get_type

-- | `GError`s are registered as boxed in the GLib type system.
instance GBoxed GError

-- | A code used to identify the "namespace" of the error. Within each error
--   domain all the error codes are defined in an enumeration. Each gtk\/gnome
--   module that uses GErrors has its own error domain. The rationale behind
--   using error domains is so that each module can organise its own error codes
--   without having to coordinate on a global error code list.
type GErrorDomain  = GQuark

-- | A code to identify a specific error within a given 'GErrorDomain'. Most of
--   time you will not need to deal with this raw code since there is an
--   enumeration type for each error domain. Of course which enumeration to use
--   depends on the error domain, but if you use 'catchGErrorJustDomain' or
--   'handleGErrorJustDomain', this is worked out for you automatically.
type GErrorCode = C_gint

-- | A human readable error message.
type GErrorMessage = Text

foreign import ccall "g_error_new_literal" g_error_new_literal ::
    GQuark -> GErrorCode -> CString -> IO (Ptr GError)

-- | Create a new 'GError'.
gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew :: GQuark -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew GQuark
domain GErrorCode
code GErrorMessage
message =
    GErrorMessage -> (CString -> IO GError) -> IO GError
forall a. GErrorMessage -> (CString -> IO a) -> IO a
withTextCString GErrorMessage
message ((CString -> IO GError) -> IO GError)
-> (CString -> IO GError) -> IO GError
forall a b. (a -> b) -> a -> b
$ \CString
cstring ->
        GQuark -> GErrorCode -> CString -> IO (Ptr GError)
g_error_new_literal GQuark
domain GErrorCode
code CString
cstring IO (Ptr GError) -> (Ptr GError -> IO GError) -> IO GError
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ManagedPtr GError -> GError) -> Ptr GError -> IO GError
forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr GError -> GError
GError

-- | Return the domain for the given `GError`. This is a GQuark, a
-- textual representation can be obtained with
-- `GI.GLib.quarkToString`.
gerrorDomain :: GError -> IO GQuark
gerrorDomain :: GError -> IO GQuark
gerrorDomain GError
gerror =
    GError -> (Ptr GError -> IO GQuark) -> IO GQuark
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror ((Ptr GError -> IO GQuark) -> IO GQuark)
-> (Ptr GError -> IO GQuark) -> IO GQuark
forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
      Ptr GQuark -> IO GQuark
forall a. Storable a => Ptr a -> IO a
peek (Ptr GQuark -> IO GQuark) -> Ptr GQuark -> IO GQuark
forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr Ptr GError -> Int -> Ptr GQuark
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_domain_offset

-- | The numeric code for the given `GError`.
gerrorCode :: GError -> IO GErrorCode
gerrorCode :: GError -> IO GErrorCode
gerrorCode GError
gerror =
    GError -> (Ptr GError -> IO GErrorCode) -> IO GErrorCode
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror ((Ptr GError -> IO GErrorCode) -> IO GErrorCode)
-> (Ptr GError -> IO GErrorCode) -> IO GErrorCode
forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
        Ptr GErrorCode -> IO GErrorCode
forall a. Storable a => Ptr a -> IO a
peek (Ptr GErrorCode -> IO GErrorCode)
-> Ptr GErrorCode -> IO GErrorCode
forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr Ptr GError -> Int -> Ptr GErrorCode
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_code_offset

-- | A text message describing the `GError`.
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage GError
gerror =
    GError -> (Ptr GError -> IO GErrorMessage) -> IO GErrorMessage
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror ((Ptr GError -> IO GErrorMessage) -> IO GErrorMessage)
-> (Ptr GError -> IO GErrorMessage) -> IO GErrorMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
      (Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek (Ptr CString -> IO CString) -> Ptr CString -> IO CString
forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr Ptr GError -> Int -> Ptr CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_message_offset) IO CString -> (CString -> IO GErrorMessage) -> IO GErrorMessage
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO GErrorMessage
CString -> IO GErrorMessage
cstringToText

-- | Each error domain's error enumeration type should be an instance of this
--   class. This class helps to hide the raw error and domain codes from the
--   user.
--
-- Example for <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError>:
--
-- > instance GErrorClass PixbufError where
-- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"
--
class Enum err => GErrorClass err where
  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its
                                     -- parameter so that it is safe to pass
                                     -- 'undefined'.

foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::
    CString -> IO GQuark

-- | Given the string representation of an error domain returns the
--   corresponding error quark.
gErrorQuarkFromDomain :: Text -> IO GQuark
gErrorQuarkFromDomain :: GErrorMessage -> IO GQuark
gErrorQuarkFromDomain GErrorMessage
domain = GErrorMessage -> (CString -> IO GQuark) -> IO GQuark
forall a. GErrorMessage -> (CString -> IO a) -> IO a
withTextCString GErrorMessage
domain CString -> IO GQuark
g_quark_try_string

-- | This will catch just a specific GError exception. If you need to catch a
--   range of related errors, 'catchGErrorJustDomain' is probably more
--   appropriate. Example:
--
-- > do image <- catchGErrorJust PixbufErrorCorruptImage
-- >               loadImage
-- >               (\errorMessage -> do log errorMessage
-- >                                    return mssingImagePlaceholder)
--
catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch
                -> IO a                    -- ^ The computation to run
                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if
                                           -- an exception is raised
                -> IO a
catchGErrorJust :: forall err a.
GErrorClass err =>
err -> IO a -> (GErrorMessage -> IO a) -> IO a
catchGErrorJust err
code IO a
action GErrorMessage -> IO a
handler = IO a -> (GError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
action GError -> IO a
handler'
  where handler' :: GError -> IO a
handler' GError
gerror = do
          quark <- GErrorMessage -> IO GQuark
gErrorQuarkFromDomain (err -> GErrorMessage
forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain err
code)
          domain <- gerrorDomain gerror
          code' <- gerrorCode gerror
          if domain == quark && code' == (fromIntegral . fromEnum) code
          then gerrorMessage gerror >>= handler
          else throw gerror -- Pass it on

-- | Catch all GErrors from a particular error domain. The handler function
--   should just deal with one error enumeration type. If you need to catch
--   errors from more than one error domain, use this function twice with an
--   appropriate handler functions for each.
--
-- > catchGErrorJustDomain
-- >   loadImage
-- >   (\err message -> case err of
-- >       PixbufErrorCorruptImage -> ...
-- >       PixbufErrorInsufficientMemory -> ...
-- >       PixbufErrorUnknownType -> ...
-- >       _ -> ...)
--
catchGErrorJustDomain :: forall err a. GErrorClass err =>
                         IO a        -- ^ The computation to run
                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                      -> IO a
catchGErrorJustDomain :: forall err a.
GErrorClass err =>
IO a -> (err -> GErrorMessage -> IO a) -> IO a
catchGErrorJustDomain IO a
action err -> GErrorMessage -> IO a
handler = IO a -> (GError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
action GError -> IO a
handler'
  where handler' :: GError -> IO a
handler' GError
gerror = do
          quark <- GErrorMessage -> IO GQuark
gErrorQuarkFromDomain (err -> GErrorMessage
forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain (err
forall a. HasCallStack => a
undefined :: err))
          domain <- gerrorDomain gerror
          if domain == quark
          then do
            code <- (toEnum . fromIntegral) <$> gerrorCode gerror
            msg <- gerrorMessage gerror
            handler code msg
          else throw gerror

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust :: forall err a.
GErrorClass err =>
err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust err
code = (IO a -> (GErrorMessage -> IO a) -> IO a)
-> (GErrorMessage -> IO a) -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (err -> IO a -> (GErrorMessage -> IO a) -> IO a
forall err a.
GErrorClass err =>
err -> IO a -> (GErrorMessage -> IO a) -> IO a
catchGErrorJust err
code)

-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.
handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain :: forall err a.
GErrorClass err =>
(err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain = (IO a -> (err -> GErrorMessage -> IO a) -> IO a)
-> (err -> GErrorMessage -> IO a) -> IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO a -> (err -> GErrorMessage -> IO a) -> IO a
forall err a.
GErrorClass err =>
IO a -> (err -> GErrorMessage -> IO a) -> IO a
catchGErrorJustDomain

-- | Run the given function catching possible 'GError's in its
-- execution. If a 'GError' is emitted this throws the corresponding
-- exception.
propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a
propagateGError :: forall a. (Ptr (Ptr GError) -> IO a) -> IO a
propagateGError Ptr (Ptr GError) -> IO a
f = (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
forall a. (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError Ptr (Ptr GError) -> IO a
f GError -> IO a
forall a e. (HasCallStack, Exception e) => e -> a
throw

-- | Like 'propagateGError', but allows to specify a custom handler
-- instead of just throwing the exception.
checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError :: forall a. (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError Ptr (Ptr GError) -> IO a
f GError -> IO a
handler = do
  gerrorPtr <- IO (Ptr (Ptr GError))
forall a. Storable a => IO (Ptr a)
allocMem
  poke gerrorPtr nullPtr
  result <- f gerrorPtr
  gerror <- peek gerrorPtr
  freeMem gerrorPtr
  if gerror /= nullPtr
  then wrapBoxed GError gerror >>= handler
  else return result

-- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a
-- copy in the passed in pointer, unless the pointer is `nullPtr`.
maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()
maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()
maybePokeGError Ptr (Ptr GError)
_ Maybe GError
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybePokeGError Ptr (Ptr GError)
ptrPtr (Just GError
gerror)
  | Ptr (Ptr GError)
ptrPtr Ptr (Ptr GError) -> Ptr (Ptr GError) -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr (Ptr GError)
forall a. Ptr a
nullPtr = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = GError -> IO (Ptr GError)
forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a)
copyBoxed GError
gerror IO (Ptr GError) -> (Ptr GError -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr (Ptr GError) -> Ptr GError -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr GError)
ptrPtr