{-# LANGUAGE DeriveDataTypeable, 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 Data.Typeable (Typeable)

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

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
                       GErrorCode
code <- GError -> IO GErrorCode
gerrorCode GError
gerror
                       GErrorMessage
message <- GError -> IO GErrorMessage
gerrorMessage GError
gerror
                       String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ GErrorMessage -> String
T.unpack GErrorMessage
message String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GErrorCode -> String
forall a. Show a => a -> String
show GErrorCode
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

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 :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew GErrorDomain
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 ->
        GErrorDomain -> GErrorCode -> CString -> IO (Ptr GError)
g_error_new_literal GErrorDomain
domain GErrorCode
code CString
cstring IO (Ptr GError) -> (Ptr GError -> IO GError) -> IO GError
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 GErrorDomain
gerrorDomain GError
gerror =
    GError -> (Ptr GError -> IO GErrorDomain) -> IO GErrorDomain
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror ((Ptr GError -> IO GErrorDomain) -> IO GErrorDomain)
-> (Ptr GError -> IO GErrorDomain) -> IO GErrorDomain
forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
      Ptr GErrorDomain -> IO GErrorDomain
forall a. Storable a => Ptr a -> IO a
peek (Ptr GErrorDomain -> IO GErrorDomain)
-> Ptr GErrorDomain -> IO GErrorDomain
forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr Ptr GError -> Int -> Ptr GErrorDomain
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 (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 GErrorDomain
gErrorQuarkFromDomain GErrorMessage
domain = GErrorMessage -> (CString -> IO GErrorDomain) -> IO GErrorDomain
forall a. GErrorMessage -> (CString -> IO a) -> IO a
withTextCString GErrorMessage
domain CString -> IO GErrorDomain
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 :: 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
          GErrorDomain
quark <- GErrorMessage -> IO GErrorDomain
gErrorQuarkFromDomain (err -> GErrorMessage
forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain err
code)
          GErrorDomain
domain <- GError -> IO GErrorDomain
gerrorDomain GError
gerror
          GErrorCode
code' <- GError -> IO GErrorCode
gerrorCode GError
gerror
          if GErrorDomain
domain GErrorDomain -> GErrorDomain -> Bool
forall a. Eq a => a -> a -> Bool
== GErrorDomain
quark Bool -> Bool -> Bool
&& GErrorCode
code' GErrorCode -> GErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> GErrorCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GErrorCode) -> (err -> Int) -> err -> GErrorCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Int
forall a. Enum a => a -> Int
fromEnum) err
code
          then GError -> IO GErrorMessage
gerrorMessage GError
gerror IO GErrorMessage -> (GErrorMessage -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GErrorMessage -> IO a
handler
          else GError -> IO a
forall a e. Exception e => e -> a
throw GError
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 :: 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
          GErrorDomain
quark <- GErrorMessage -> IO GErrorDomain
gErrorQuarkFromDomain (err -> GErrorMessage
forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain (err
forall a. HasCallStack => a
undefined :: err))
          GErrorDomain
domain <- GError -> IO GErrorDomain
gerrorDomain GError
gerror
          if GErrorDomain
domain GErrorDomain -> GErrorDomain -> Bool
forall a. Eq a => a -> a -> Bool
== GErrorDomain
quark
          then do
            err
code <- (Int -> err
forall a. Enum a => Int -> a
toEnum (Int -> err) -> (GErrorCode -> Int) -> GErrorCode -> err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GErrorCode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (GErrorCode -> err) -> IO GErrorCode -> IO err
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GError -> IO GErrorCode
gerrorCode GError
gerror
            GErrorMessage
msg <- GError -> IO GErrorMessage
gerrorMessage GError
gerror
            err -> GErrorMessage -> IO a
handler err
code GErrorMessage
msg
          else GError -> IO a
forall a e. Exception e => e -> a
throw GError
gerror

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust :: 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 :: (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 :: (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. 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 :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError Ptr (Ptr GError) -> IO a
f GError -> IO a
handler = do
  Ptr (Ptr GError)
gerrorPtr <- IO (Ptr (Ptr GError))
forall a. Storable a => IO (Ptr a)
allocMem
  Ptr (Ptr GError) -> Ptr GError -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr GError)
gerrorPtr Ptr GError
forall a. Ptr a
nullPtr
  a
result <- Ptr (Ptr GError) -> IO a
f Ptr (Ptr GError)
gerrorPtr
  Ptr GError
gerror <- Ptr (Ptr GError) -> IO (Ptr GError)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr GError)
gerrorPtr
  Ptr (Ptr GError) -> IO ()
forall a. Ptr a -> IO ()
freeMem Ptr (Ptr GError)
gerrorPtr
  if Ptr GError
gerror Ptr GError -> Ptr GError -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr GError
forall a. Ptr a
nullPtr
  then (ManagedPtr GError -> GError) -> Ptr GError -> IO GError
forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr GError -> GError
GError Ptr GError
gerror IO GError -> (GError -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GError -> IO a
handler
  else a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 (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 (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 (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