{-# 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 = 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
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 =
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
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
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
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
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 = GErrorMessage -> (CString -> IO GQuark) -> IO GQuark
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 = 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
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 = 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
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)
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
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
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
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