{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, DataKinds #-}
module Data.GI.Base.GError
(
GError(..)
, gerrorDomain
, gerrorCode
, gerrorMessage
, GErrorDomain
, GErrorCode
, GErrorMessage
, catchGErrorJust
, catchGErrorJustDomain
, handleGErrorJust
, handleGErrorJustDomain
, gerrorNew
, 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)
newtype GError = GError (ManagedPtr GError)
deriving (Typeable)
instance Show GError where
show :: GError -> String
show GError
gerror = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
GErrorCode
code <- GError -> IO GErrorCode
gerrorCode GError
gerror
GErrorMessage
message <- GError -> IO GErrorMessage
gerrorMessage GError
gerror
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GErrorMessage -> String
T.unpack GErrorMessage
message forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GErrorCode
code forall a. [a] -> [a] -> [a]
++ String
")"
instance Exception GError
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
instance GBoxed GError
type GErrorDomain = GQuark
type GErrorCode = C_gint
type GErrorMessage = Text
foreign import ccall "g_error_new_literal" g_error_new_literal ::
GQuark -> GErrorCode -> CString -> IO (Ptr GError)
gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew :: GQuark -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew GQuark
domain GErrorCode
code GErrorMessage
message =
forall a. GErrorMessage -> (CString -> IO a) -> IO a
withTextCString GErrorMessage
message 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr GError -> GError
GError
gerrorDomain :: GError -> IO GQuark
gerrorDomain :: GError -> IO GQuark
gerrorDomain GError
gerror =
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_domain_offset
gerrorCode :: GError -> IO GErrorCode
gerrorCode :: GError -> IO GErrorCode
gerrorCode GError
gerror =
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_code_offset
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage GError
gerror =
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr GError
gerror forall a b. (a -> b) -> a -> b
$ \Ptr GError
ptr ->
(forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Ptr GError
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
gerror_message_offset) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO GErrorMessage
cstringToText
class Enum err => GErrorClass err where
gerrorClassDomain :: err -> Text
foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::
CString -> IO GQuark
gErrorQuarkFromDomain :: Text -> IO GQuark
gErrorQuarkFromDomain :: GErrorMessage -> IO GQuark
gErrorQuarkFromDomain GErrorMessage
domain = forall a. GErrorMessage -> (CString -> IO a) -> IO a
withTextCString GErrorMessage
domain CString -> IO GQuark
g_quark_try_string
catchGErrorJust :: GErrorClass err => err
-> IO a
-> (GErrorMessage -> IO a)
-> 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 = 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
GQuark
quark <- GErrorMessage -> IO GQuark
gErrorQuarkFromDomain (forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain err
code)
GQuark
domain <- GError -> IO GQuark
gerrorDomain GError
gerror
GErrorCode
code' <- GError -> IO GErrorCode
gerrorCode GError
gerror
if GQuark
domain forall a. Eq a => a -> a -> Bool
== GQuark
quark Bool -> Bool -> Bool
&& GErrorCode
code' forall a. Eq a => a -> a -> Bool
== (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) err
code
then GError -> IO GErrorMessage
gerrorMessage GError
gerror forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GErrorMessage -> IO a
handler
else forall a e. Exception e => e -> a
throw GError
gerror
catchGErrorJustDomain :: forall err a. GErrorClass err =>
IO a
-> (err -> GErrorMessage -> IO a)
-> 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 = 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
GQuark
quark <- GErrorMessage -> IO GQuark
gErrorQuarkFromDomain (forall err. GErrorClass err => err -> GErrorMessage
gerrorClassDomain (forall a. HasCallStack => a
undefined :: err))
GQuark
domain <- GError -> IO GQuark
gerrorDomain GError
gerror
if GQuark
domain forall a. Eq a => a -> a -> Bool
== GQuark
quark
then do
err
code <- (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) 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 forall a e. Exception e => e -> a
throw GError
gerror
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall err a.
GErrorClass err =>
err -> IO a -> (GErrorMessage -> IO a) -> IO a
catchGErrorJust err
code)
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall err a.
GErrorClass err =>
IO a -> (err -> GErrorMessage -> IO a) -> IO a
catchGErrorJustDomain
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 = forall a. (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError Ptr (Ptr GError) -> IO a
f forall a e. Exception e => e -> a
throw
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
Ptr (Ptr GError)
gerrorPtr <- forall a. Storable a => IO (Ptr a)
allocMem
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr GError)
gerrorPtr forall a. Ptr a
nullPtr
a
result <- Ptr (Ptr GError) -> IO a
f Ptr (Ptr GError)
gerrorPtr
Ptr GError
gerror <- forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr GError)
gerrorPtr
forall a. Ptr a -> IO ()
freeMem Ptr (Ptr GError)
gerrorPtr
if Ptr GError
gerror forall a. Eq a => a -> a -> Bool
/= forall a. Ptr a
nullPtr
then forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr GError -> GError
GError Ptr GError
gerror forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GError -> IO a
handler
else forall (m :: * -> *) a. Monad m => a -> m a
return a
result
maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()
maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()
maybePokeGError Ptr (Ptr GError)
_ Maybe GError
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybePokeGError Ptr (Ptr GError)
ptrPtr (Just GError
gerror)
| Ptr (Ptr GError)
ptrPtr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a)
copyBoxed GError
gerror forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr GError)
ptrPtr