diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +### 0.24.4 + ++ Add a workaround for old hsc2hs versions, so drop the constraint on hsc2hs. + ### 0.24.3 + Require hsc2hs version 0.68.6 or higher diff --git a/Data/GI/Base/BasicTypes.hsc b/Data/GI/Base/BasicTypes.hsc --- a/Data/GI/Base/BasicTypes.hsc +++ b/Data/GI/Base/BasicTypes.hsc @@ -140,8 +140,9 @@ -- on the Haskell side use `GType` below. type CGType = #type GType --- | A newtype for use on the haskell side. +-- | A newtype for use on the Haskell side. newtype GType = GType {gtypeToCGType :: CGType} + deriving (Eq, Show) foreign import ccall "g_type_name" g_type_name :: GType -> IO CString diff --git a/Data/GI/Base/GError.hs b/Data/GI/Base/GError.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GError.hs @@ -0,0 +1,261 @@ +{-# 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 one could +-- invoke \/ +-- . 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 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 = unsafePerformIO $ do + code <- gerrorCode 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 = 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 domain code message = + withTextCString message $ \cstring -> + g_error_new_literal domain code cstring >>= wrapBoxed 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 = + withManagedPtr gerror $ \ptr -> + peek $ ptr `plusPtr` gerror_domain_offset + +-- | The numeric code for the given `GError`. +gerrorCode :: GError -> IO GErrorCode +gerrorCode gerror = + withManagedPtr gerror $ \ptr -> + peek $ ptr `plusPtr` gerror_code_offset + +-- | A text message describing the `GError`. +gerrorMessage :: GError -> IO GErrorMessage +gerrorMessage gerror = + withManagedPtr gerror $ \ptr -> + (peek $ ptr `plusPtr` gerror_message_offset) >>= 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 : +-- +-- > 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 domain = withTextCString domain 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 code action handler = catch action handler' + where handler' gerror = do + quark <- gErrorQuarkFromDomain (gerrorClassDomain 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 action handler = catch action handler' + where handler' gerror = do + quark <- gErrorQuarkFromDomain (gerrorClassDomain (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 code = flip (catchGErrorJust code) + +-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around. +handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a +handleGErrorJustDomain = flip 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 f = checkGError f 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 f handler = do + gerrorPtr <- 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 _ Nothing = return () +maybePokeGError ptrPtr (Just gerror) + | ptrPtr == nullPtr = return () + | otherwise = copyBoxed gerror >>= poke ptrPtr diff --git a/Data/GI/Base/GError.hsc b/Data/GI/Base/GError.hsc deleted file mode 100644 --- a/Data/GI/Base/GError.hsc +++ /dev/null @@ -1,265 +0,0 @@ -{-# 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 one could --- invoke \/ --- . 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 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 Data.Int -import Data.Word - -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) - -#include - --- | 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 = unsafePerformIO $ do - code <- gerrorCode 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 = g_error_get_type - --- | `GError`s are registered as boxed in the GLib type system. -instance GBoxed GError - --- | A GQuark. -type GQuark = #{type GQuark} - --- | 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 = #{type 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 domain code message = - withTextCString message $ \cstring -> - g_error_new_literal domain code cstring >>= wrapBoxed 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 = - withManagedPtr gerror $ \ptr -> - peek $ ptr `plusPtr` #{offset GError, domain} - --- | The numeric code for the given `GError`. -gerrorCode :: GError -> IO GErrorCode -gerrorCode gerror = - withManagedPtr gerror $ \ptr -> - peek $ ptr `plusPtr` #{offset GError, code} - --- | A text message describing the `GError`. -gerrorMessage :: GError -> IO GErrorMessage -gerrorMessage gerror = - withManagedPtr gerror $ \ptr -> - (peek $ ptr `plusPtr` #{offset GError, message}) >>= 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 : --- --- > 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 domain = withTextCString domain 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 code action handler = catch action handler' - where handler' gerror = do - quark <- gErrorQuarkFromDomain (gerrorClassDomain 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 action handler = catch action handler' - where handler' gerror = do - quark <- gErrorQuarkFromDomain (gerrorClassDomain (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 code = flip (catchGErrorJust code) - --- | A verson of 'catchGErrorJustDomain' with the arguments swapped around. -handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a -handleGErrorJustDomain = flip 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 f = checkGError f 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 f handler = do - gerrorPtr <- 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 _ Nothing = return () -maybePokeGError ptrPtr (Just gerror) - | ptrPtr == nullPtr = return () - | otherwise = copyBoxed gerror >>= poke ptrPtr diff --git a/Data/GI/Base/GValue.hs b/Data/GI/Base/GValue.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GValue.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds, TypeFamilies #-} +module Data.GI.Base.GValue + ( + -- * Constructing GValues + GValue(..) + , IsGValue(..) + , GValueConstruct(..) + + , newGValue + , buildGValue + , disownGValue + , noGValue + , newGValueFromPtr + , wrapGValuePtr + , unsetGValue + , gvalueType + + -- * Packing GValues into arrays + , packGValueArray + , unpackGValueArrayWithLength + , mapGValueArrayWithLength + + -- * Setters and getters + , set_string + , get_string + , set_pointer + , get_pointer + , set_int + , get_int + , set_uint + , get_uint + , set_long + , get_long + , set_ulong + , get_ulong + , set_int32 + , get_int32 + , set_uint32 + , get_uint32 + , set_int64 + , get_int64 + , set_uint64 + , get_uint64 + , set_float + , get_float + , set_double + , get_double + , set_boolean + , get_boolean + , set_gtype + , get_gtype + , set_object + , get_object + , set_boxed + , get_boxed + , set_variant + , get_variant + , set_enum + , get_enum + , set_flags + , get_flags + , set_stablePtr + , get_stablePtr + , take_stablePtr + ) where + +import Data.Coerce (coerce) +import Data.Word +import Data.Int +import Data.Text (Text, pack, unpack) + +import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..), + CLong(..), CULong(..)) +import Foreign.C.String (CString) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.BasicConversions (cstringToText, textToCString) +import Data.GI.Base.GType +import Data.GI.Base.ManagedPtr +import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) +import Data.GI.Base.Utils (callocBytes, freeMem) +import Data.GI.Base.Internal.CTypes (cgvalueSize) + +-- | Haskell-side representation of a @GValue@. +newtype GValue = GValue (ManagedPtr GValue) + +-- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@. +noGValue :: Maybe GValue +noGValue = Nothing + +foreign import ccall unsafe "g_value_get_type" c_g_value_get_type :: + IO GType + +-- | There are no types in the bindings that a `GValue` can be safely +-- cast to. +type instance ParentTypes GValue = '[] +instance HasParentTypes GValue + +-- | Find the associated `GType` for `GValue`. +instance TypedObject GValue where + glibType = c_g_value_get_type + +-- | `GValue`s are registered as boxed in the GLib type system. +instance GBoxed GValue + +foreign import ccall "g_value_init" g_value_init :: + Ptr GValue -> CGType -> IO (Ptr GValue) + +-- | A type holding a `GValue` with an associated label. It is +-- parameterized by a phantom type encoding the target type for the +-- `GValue` (useful when constructing properties). +data GValueConstruct o = GValueConstruct String GValue + +-- | Build a new, empty, `GValue` of the given type. +newGValue :: GType -> IO GValue +newGValue (GType gtype) = do + gvptr <- callocBytes cgvalueSize + _ <- g_value_init gvptr gtype + gv <- wrapBoxed GValue gvptr + return $! gv + +-- | Take ownership of a passed in 'Ptr'. +wrapGValuePtr :: Ptr GValue -> IO GValue +wrapGValuePtr ptr = wrapBoxed GValue ptr + +-- | Construct a Haskell wrapper for the given 'GValue', making a +-- copy. +newGValueFromPtr :: Ptr GValue -> IO GValue +newGValueFromPtr ptr = newBoxed GValue ptr + +-- | A convenience function for building a new GValue and setting the +-- initial value. +buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue +buildGValue gtype setter val = do + gv <- newGValue gtype + setter gv val + return gv + +-- | Disown a `GValue`, i.e. do not unref the underlying object when +-- the Haskell object is garbage collected. +disownGValue :: GValue -> IO (Ptr GValue) +disownGValue = disownManagedPtr + +foreign import ccall "_haskell_gi_g_value_get_type" g_value_get_type :: Ptr GValue -> IO CGType + +-- | Return the `GType` contained by a `GValue`. +gvalueType :: GValue -> IO GType +gvalueType gv = withManagedPtr gv $ \gvptr -> do + cgtype <- g_value_get_type gvptr + return (GType cgtype) + +foreign import ccall "g_value_unset" g_value_unset :: Ptr GValue -> IO () + +-- | Unset the `GValue`, freeing all resources associated to it. +unsetGValue :: Ptr GValue -> IO () +unsetGValue = g_value_unset + +-- | A convenience class for marshaling back and forth between Haskell +-- values and `GValue`s. +class IsGValue a where + toGValue :: a -> IO GValue + fromGValue :: GValue -> IO a + +instance IsGValue (Maybe String) where + toGValue = buildGValue gtypeString set_string . fmap pack + fromGValue v = (fmap unpack) <$> get_string v + +instance IsGValue (Maybe Text) where + toGValue = buildGValue gtypeString set_string + fromGValue = get_string + +instance IsGValue (Ptr a) where + toGValue = buildGValue gtypePointer set_pointer + fromGValue = get_pointer + +instance IsGValue Int32 where + toGValue = buildGValue gtypeInt set_int32 + fromGValue = get_int32 + +instance IsGValue Word32 where + toGValue = buildGValue gtypeUInt set_uint32 + fromGValue = get_uint32 + +instance IsGValue CInt where + toGValue = buildGValue gtypeInt set_int + fromGValue = get_int + +instance IsGValue CUInt where + toGValue = buildGValue gtypeUInt set_uint + fromGValue = get_uint + +instance IsGValue CLong where + toGValue = buildGValue gtypeLong set_long + fromGValue = get_long + +instance IsGValue CULong where + toGValue = buildGValue gtypeULong set_ulong + fromGValue = get_ulong + +instance IsGValue Int64 where + toGValue = buildGValue gtypeInt64 set_int64 + fromGValue = get_int64 + +instance IsGValue Word64 where + toGValue = buildGValue gtypeUInt64 set_uint64 + fromGValue = get_uint64 + +instance IsGValue Float where + toGValue = buildGValue gtypeFloat set_float + fromGValue = get_float + +instance IsGValue Double where + toGValue = buildGValue gtypeDouble set_double + fromGValue = get_double + +instance IsGValue Bool where + toGValue = buildGValue gtypeBoolean set_boolean + fromGValue = get_boolean + +instance IsGValue GType where + toGValue = buildGValue gtypeGType set_gtype + fromGValue = get_gtype + +instance IsGValue (StablePtr a) where + toGValue = buildGValue gtypeStablePtr set_stablePtr + fromGValue = get_stablePtr + +foreign import ccall "g_value_set_string" _set_string :: + Ptr GValue -> CString -> IO () +foreign import ccall "g_value_get_string" _get_string :: + Ptr GValue -> IO CString + +set_string :: GValue -> Maybe Text -> IO () +set_string gv maybeStr = + withManagedPtr gv $ \ptr -> do + cstr <- case maybeStr of + Just str -> textToCString str + Nothing -> return nullPtr + _set_string ptr cstr + freeMem cstr + +get_string :: GValue -> IO (Maybe Text) +get_string gv = withManagedPtr gv $ \gvptr -> do + cstr <- _get_string gvptr + if cstr /= nullPtr + then Just <$> cstringToText cstr + else return Nothing + +foreign import ccall unsafe "g_value_set_pointer" _set_pointer :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall unsafe "g_value_get_pointer" _get_pointer :: + Ptr GValue -> IO (Ptr b) + +set_pointer :: GValue -> Ptr a -> IO () +set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr + +get_pointer :: GValue -> IO (Ptr b) +get_pointer gv = withManagedPtr gv _get_pointer + +foreign import ccall unsafe "g_value_set_int" _set_int :: + Ptr GValue -> CInt -> IO () +foreign import ccall unsafe "g_value_get_int" _get_int :: + Ptr GValue -> IO CInt + +set_int32 :: GValue -> Int32 -> IO () +set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n) + +get_int32 :: GValue -> IO Int32 +get_int32 gv = coerce <$> withManagedPtr gv _get_int + +set_int :: GValue -> CInt -> IO () +set_int gv n = withManagedPtr gv $ flip _set_int n + +get_int :: GValue -> IO CInt +get_int gv = withManagedPtr gv _get_int + +foreign import ccall unsafe "g_value_set_uint" _set_uint :: + Ptr GValue -> CUInt -> IO () +foreign import ccall unsafe "g_value_get_uint" _get_uint :: + Ptr GValue -> IO CUInt + +set_uint32 :: GValue -> Word32 -> IO () +set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n) + +get_uint32 :: GValue -> IO Word32 +get_uint32 gv = coerce <$> withManagedPtr gv _get_uint + +set_uint :: GValue -> CUInt -> IO () +set_uint gv n = withManagedPtr gv $ flip _set_uint n + +get_uint :: GValue -> IO CUInt +get_uint gv = withManagedPtr gv _get_uint + +foreign import ccall unsafe "g_value_set_long" _set_long :: + Ptr GValue -> CLong -> IO () +foreign import ccall unsafe "g_value_get_long" _get_long :: + Ptr GValue -> IO CLong + +set_long :: GValue -> CLong -> IO () +set_long gv n = withManagedPtr gv $ flip _set_long n + +get_long :: GValue -> IO CLong +get_long gv = withManagedPtr gv _get_long + +foreign import ccall unsafe "g_value_set_ulong" _set_ulong :: + Ptr GValue -> CULong -> IO () +foreign import ccall unsafe "g_value_get_ulong" _get_ulong :: + Ptr GValue -> IO CULong + +set_ulong :: GValue -> CULong -> IO () +set_ulong gv n = withManagedPtr gv $ flip _set_ulong n + +get_ulong :: GValue -> IO CULong +get_ulong gv = withManagedPtr gv _get_ulong + +foreign import ccall unsafe "g_value_set_int64" _set_int64 :: + Ptr GValue -> Int64 -> IO () +foreign import ccall unsafe "g_value_get_int64" _get_int64 :: + Ptr GValue -> IO Int64 + +set_int64 :: GValue -> Int64 -> IO () +set_int64 gv n = withManagedPtr gv $ flip _set_int64 n + +get_int64 :: GValue -> IO Int64 +get_int64 gv = withManagedPtr gv _get_int64 + +foreign import ccall unsafe "g_value_set_uint64" _set_uint64 :: + Ptr GValue -> Word64 -> IO () +foreign import ccall unsafe "g_value_get_uint64" _get_uint64 :: + Ptr GValue -> IO Word64 + +set_uint64 :: GValue -> Word64 -> IO () +set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n + +get_uint64 :: GValue -> IO Word64 +get_uint64 gv = withManagedPtr gv _get_uint64 + +foreign import ccall unsafe "g_value_set_float" _set_float :: + Ptr GValue -> CFloat -> IO () +foreign import ccall unsafe "g_value_get_float" _get_float :: + Ptr GValue -> IO CFloat + +set_float :: GValue -> Float -> IO () +set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f) + +get_float :: GValue -> IO Float +get_float gv = realToFrac <$> withManagedPtr gv _get_float + +foreign import ccall unsafe "g_value_set_double" _set_double :: + Ptr GValue -> CDouble -> IO () +foreign import ccall unsafe "g_value_get_double" _get_double :: + Ptr GValue -> IO CDouble + +set_double :: GValue -> Double -> IO () +set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d) + +get_double :: GValue -> IO Double +get_double gv = realToFrac <$> withManagedPtr gv _get_double + +foreign import ccall unsafe "g_value_set_boolean" _set_boolean :: + Ptr GValue -> CInt -> IO () +foreign import ccall unsafe "g_value_get_boolean" _get_boolean :: + Ptr GValue -> IO CInt + +set_boolean :: GValue -> Bool -> IO () +set_boolean gv b = withManagedPtr gv $ \ptr -> + _set_boolean ptr (fromIntegral $ fromEnum b) + +get_boolean :: GValue -> IO Bool +get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr + +foreign import ccall unsafe "g_value_set_gtype" _set_gtype :: + Ptr GValue -> CGType -> IO () +foreign import ccall unsafe "g_value_get_gtype" _get_gtype :: + Ptr GValue -> IO CGType + +set_gtype :: GValue -> GType -> IO () +set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g + +get_gtype :: GValue -> IO GType +get_gtype gv = GType <$> withManagedPtr gv _get_gtype + +foreign import ccall "g_value_set_object" _set_object :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall "g_value_get_object" _get_object :: + Ptr GValue -> IO (Ptr a) + +set_object :: GObject a => GValue -> Ptr a -> IO () +set_object gv o = withManagedPtr gv $ flip _set_object o + +get_object :: GObject b => GValue -> IO (Ptr b) +get_object gv = withManagedPtr gv _get_object + +foreign import ccall "g_value_set_boxed" _set_boxed :: + Ptr GValue -> Ptr a -> IO () +foreign import ccall "g_value_get_boxed" _get_boxed :: + Ptr GValue -> IO (Ptr b) + +set_boxed :: GValue -> Ptr a -> IO () +set_boxed gv b = withManagedPtr gv $ flip _set_boxed b + +get_boxed :: GValue -> IO (Ptr b) +get_boxed gv = withManagedPtr gv _get_boxed + +foreign import ccall "g_value_set_variant" _set_variant :: + Ptr GValue -> Ptr GVariant -> IO () +foreign import ccall "g_value_get_variant" _get_variant :: + Ptr GValue -> IO (Ptr GVariant) + +set_variant :: GValue -> Ptr GVariant -> IO () +set_variant gv v = withManagedPtr gv $ flip _set_variant v + +get_variant :: GValue -> IO (Ptr GVariant) +get_variant gv = withManagedPtr gv _get_variant + +foreign import ccall unsafe "g_value_set_enum" _set_enum :: + Ptr GValue -> CUInt -> IO () +foreign import ccall unsafe "g_value_get_enum" _get_enum :: + Ptr GValue -> IO CUInt + +set_enum :: GValue -> CUInt -> IO () +set_enum gv e = withManagedPtr gv $ flip _set_enum e + +get_enum :: GValue -> IO CUInt +get_enum gv = withManagedPtr gv _get_enum + +foreign import ccall unsafe "g_value_set_flags" _set_flags :: + Ptr GValue -> CUInt -> IO () +foreign import ccall unsafe "g_value_get_flags" _get_flags :: + Ptr GValue -> IO CUInt + +set_flags :: GValue -> CUInt -> IO () +set_flags gv f = withManagedPtr gv $ flip _set_flags f + +get_flags :: GValue -> IO CUInt +get_flags gv = withManagedPtr gv _get_flags + +-- | Set the value of `GValue` containing a `StablePtr` +set_stablePtr :: GValue -> StablePtr a -> IO () +set_stablePtr gv ptr = withManagedPtr gv $ flip _set_boxed (castStablePtrToPtr ptr) + +foreign import ccall g_value_take_boxed :: Ptr GValue -> StablePtr a -> IO () + +-- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr` +take_stablePtr :: Ptr GValue -> StablePtr a -> IO () +take_stablePtr = g_value_take_boxed + +-- | Get the value of a `GValue` containing a `StablePtr` +get_stablePtr :: GValue -> IO (StablePtr a) +get_stablePtr gv = castPtrToStablePtr <$> withManagedPtr gv _get_boxed + +foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO () + +-- | Pack the given list of GValues contiguously into a C array +packGValueArray :: [GValue] -> IO (Ptr GValue) +packGValueArray gvalues = withManagedPtrList gvalues $ \ptrs -> do + let nitems = length ptrs + mem <- callocBytes $ cgvalueSize * nitems + fill mem ptrs + return mem + where fill :: Ptr GValue -> [Ptr GValue] -> IO () + fill _ [] = return () + fill ptr (x:xs) = do + gtype <- g_value_get_type x + _ <- g_value_init ptr gtype + g_value_copy x ptr + fill (ptr `plusPtr` cgvalueSize) xs + +-- | Unpack an array of contiguous GValues into a list of GValues. +unpackGValueArrayWithLength :: Integral a => + a -> Ptr GValue -> IO [GValue] +unpackGValueArrayWithLength nitems gvalues = go (fromIntegral nitems) gvalues + where go :: Int -> Ptr GValue -> IO [GValue] + go 0 _ = return [] + go n ptr = do + gv <- callocBytes cgvalueSize + gtype <- g_value_get_type ptr + _ <- g_value_init gv gtype + g_value_copy ptr gv + wrapped <- wrapGValuePtr gv + (wrapped :) <$> go (n-1) (ptr `plusPtr` cgvalueSize) + +-- | Map over the `GValue`s inside a C array. +mapGValueArrayWithLength :: Integral a => + a -> (Ptr GValue -> IO c) -> Ptr GValue -> IO () +mapGValueArrayWithLength nvalues f arrayPtr + | (arrayPtr == nullPtr) = return () + | (nvalues <= 0) = return () + | otherwise = go (fromIntegral nvalues) arrayPtr + where go :: Int -> Ptr GValue -> IO () + go 0 _ = return () + go n ptr = do + _ <- f ptr + go (n-1) (ptr `plusPtr` cgvalueSize) diff --git a/Data/GI/Base/GValue.hsc b/Data/GI/Base/GValue.hsc deleted file mode 100644 --- a/Data/GI/Base/GValue.hsc +++ /dev/null @@ -1,491 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds, TypeFamilies #-} -module Data.GI.Base.GValue - ( - -- * Constructing GValues - GValue(..) - , IsGValue(..) - , GValueConstruct(..) - - , newGValue - , buildGValue - , disownGValue - , noGValue - , newGValueFromPtr - , wrapGValuePtr - , unsetGValue - - -- * Packing GValues into arrays - , packGValueArray - , unpackGValueArrayWithLength - , mapGValueArrayWithLength - - -- * Setters and getters - , set_string - , get_string - , set_pointer - , get_pointer - , set_int - , get_int - , set_uint - , get_uint - , set_long - , get_long - , set_ulong - , get_ulong - , set_int32 - , get_int32 - , set_uint32 - , get_uint32 - , set_int64 - , get_int64 - , set_uint64 - , get_uint64 - , set_float - , get_float - , set_double - , get_double - , set_boolean - , get_boolean - , set_gtype - , get_gtype - , set_object - , get_object - , set_boxed - , get_boxed - , set_variant - , get_variant - , set_enum - , get_enum - , set_flags - , get_flags - , set_stablePtr - , get_stablePtr - , take_stablePtr - ) where - -#include - -import Data.Coerce (coerce) -import Data.Word -import Data.Int -import Data.Text (Text, pack, unpack) - -import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..), - CLong(..), CULong(..)) -import Foreign.C.String (CString) -import Foreign.Ptr (Ptr, nullPtr, plusPtr) -import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr) - -import Data.GI.Base.BasicTypes -import Data.GI.Base.BasicConversions (cstringToText, textToCString) -import Data.GI.Base.GType -import Data.GI.Base.ManagedPtr -import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) -import Data.GI.Base.Utils (callocBytes, freeMem) - --- | Haskell-side representation of a @GValue@. -newtype GValue = GValue (ManagedPtr GValue) - --- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@. -noGValue :: Maybe GValue -noGValue = Nothing - -foreign import ccall unsafe "g_value_get_type" c_g_value_get_type :: - IO GType - --- | There are no types in the bindings that a `GValue` can be safely --- cast to. -type instance ParentTypes GValue = '[] -instance HasParentTypes GValue - --- | Find the associated `GType` for `GValue`. -instance TypedObject GValue where - glibType = c_g_value_get_type - --- | `GValue`s are registered as boxed in the GLib type system. -instance GBoxed GValue - -foreign import ccall "g_value_init" g_value_init :: - Ptr GValue -> CGType -> IO (Ptr GValue) - --- | A type holding a `GValue` with an associated label. It is --- parameterized by a phantom type encoding the target type for the --- `GValue` (useful when constructing properties). -data GValueConstruct o = GValueConstruct String GValue - --- | Build a new, empty, `GValue` of the given type. -newGValue :: GType -> IO GValue -newGValue (GType gtype) = do - gvptr <- callocBytes (#size GValue) - _ <- g_value_init gvptr gtype - gv <- wrapBoxed GValue gvptr - return $! gv - --- | Take ownership of a passed in 'Ptr'. -wrapGValuePtr :: Ptr GValue -> IO GValue -wrapGValuePtr ptr = wrapBoxed GValue ptr - --- | Construct a Haskell wrapper for the given 'GValue', making a --- copy. -newGValueFromPtr :: Ptr GValue -> IO GValue -newGValueFromPtr ptr = newBoxed GValue ptr - --- | A convenience function for building a new GValue and setting the --- initial value. -buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue -buildGValue gtype setter val = do - gv <- newGValue gtype - setter gv val - return gv - --- | Disown a `GValue`, i.e. do not unref the underlying object when --- the Haskell object is garbage collected. -disownGValue :: GValue -> IO (Ptr GValue) -disownGValue = disownManagedPtr - -foreign import ccall "g_value_unset" g_value_unset :: Ptr GValue -> IO () - --- | Unset the `GValue`, freeing all resources associated to it. -unsetGValue :: Ptr GValue -> IO () -unsetGValue = g_value_unset - --- | A convenience class for marshaling back and forth between Haskell --- values and `GValue`s. -class IsGValue a where - toGValue :: a -> IO GValue - fromGValue :: GValue -> IO a - -instance IsGValue (Maybe String) where - toGValue = buildGValue gtypeString set_string . fmap pack - fromGValue v = (fmap unpack) <$> get_string v - -instance IsGValue (Maybe Text) where - toGValue = buildGValue gtypeString set_string - fromGValue = get_string - -instance IsGValue (Ptr a) where - toGValue = buildGValue gtypePointer set_pointer - fromGValue = get_pointer - -instance IsGValue Int32 where - toGValue = buildGValue gtypeInt set_int32 - fromGValue = get_int32 - -instance IsGValue Word32 where - toGValue = buildGValue gtypeUInt set_uint32 - fromGValue = get_uint32 - -instance IsGValue CInt where - toGValue = buildGValue gtypeInt set_int - fromGValue = get_int - -instance IsGValue CUInt where - toGValue = buildGValue gtypeUInt set_uint - fromGValue = get_uint - -instance IsGValue CLong where - toGValue = buildGValue gtypeLong set_long - fromGValue = get_long - -instance IsGValue CULong where - toGValue = buildGValue gtypeULong set_ulong - fromGValue = get_ulong - -instance IsGValue Int64 where - toGValue = buildGValue gtypeInt64 set_int64 - fromGValue = get_int64 - -instance IsGValue Word64 where - toGValue = buildGValue gtypeUInt64 set_uint64 - fromGValue = get_uint64 - -instance IsGValue Float where - toGValue = buildGValue gtypeFloat set_float - fromGValue = get_float - -instance IsGValue Double where - toGValue = buildGValue gtypeDouble set_double - fromGValue = get_double - -instance IsGValue Bool where - toGValue = buildGValue gtypeBoolean set_boolean - fromGValue = get_boolean - -instance IsGValue GType where - toGValue = buildGValue gtypeGType set_gtype - fromGValue = get_gtype - -instance IsGValue (StablePtr a) where - toGValue = buildGValue gtypeStablePtr set_stablePtr - fromGValue = get_stablePtr - -foreign import ccall "g_value_set_string" _set_string :: - Ptr GValue -> CString -> IO () -foreign import ccall "g_value_get_string" _get_string :: - Ptr GValue -> IO CString - -set_string :: GValue -> Maybe Text -> IO () -set_string gv maybeStr = - withManagedPtr gv $ \ptr -> do - cstr <- case maybeStr of - Just str -> textToCString str - Nothing -> return nullPtr - _set_string ptr cstr - freeMem cstr - -get_string :: GValue -> IO (Maybe Text) -get_string gv = withManagedPtr gv $ \gvptr -> do - cstr <- _get_string gvptr - if cstr /= nullPtr - then Just <$> cstringToText cstr - else return Nothing - -foreign import ccall unsafe "g_value_set_pointer" _set_pointer :: - Ptr GValue -> Ptr a -> IO () -foreign import ccall unsafe "g_value_get_pointer" _get_pointer :: - Ptr GValue -> IO (Ptr b) - -set_pointer :: GValue -> Ptr a -> IO () -set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr - -get_pointer :: GValue -> IO (Ptr b) -get_pointer gv = withManagedPtr gv _get_pointer - -foreign import ccall unsafe "g_value_set_int" _set_int :: - Ptr GValue -> CInt -> IO () -foreign import ccall unsafe "g_value_get_int" _get_int :: - Ptr GValue -> IO CInt - -set_int32 :: GValue -> Int32 -> IO () -set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n) - -get_int32 :: GValue -> IO Int32 -get_int32 gv = coerce <$> withManagedPtr gv _get_int - -set_int :: GValue -> CInt -> IO () -set_int gv n = withManagedPtr gv $ flip _set_int n - -get_int :: GValue -> IO CInt -get_int gv = withManagedPtr gv _get_int - -foreign import ccall unsafe "g_value_set_uint" _set_uint :: - Ptr GValue -> CUInt -> IO () -foreign import ccall unsafe "g_value_get_uint" _get_uint :: - Ptr GValue -> IO CUInt - -set_uint32 :: GValue -> Word32 -> IO () -set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n) - -get_uint32 :: GValue -> IO Word32 -get_uint32 gv = coerce <$> withManagedPtr gv _get_uint - -set_uint :: GValue -> CUInt -> IO () -set_uint gv n = withManagedPtr gv $ flip _set_uint n - -get_uint :: GValue -> IO CUInt -get_uint gv = withManagedPtr gv _get_uint - -foreign import ccall unsafe "g_value_set_long" _set_long :: - Ptr GValue -> CLong -> IO () -foreign import ccall unsafe "g_value_get_long" _get_long :: - Ptr GValue -> IO CLong - -set_long :: GValue -> CLong -> IO () -set_long gv n = withManagedPtr gv $ flip _set_long n - -get_long :: GValue -> IO CLong -get_long gv = withManagedPtr gv _get_long - -foreign import ccall unsafe "g_value_set_ulong" _set_ulong :: - Ptr GValue -> CULong -> IO () -foreign import ccall unsafe "g_value_get_ulong" _get_ulong :: - Ptr GValue -> IO CULong - -set_ulong :: GValue -> CULong -> IO () -set_ulong gv n = withManagedPtr gv $ flip _set_ulong n - -get_ulong :: GValue -> IO CULong -get_ulong gv = withManagedPtr gv _get_ulong - -foreign import ccall unsafe "g_value_set_int64" _set_int64 :: - Ptr GValue -> Int64 -> IO () -foreign import ccall unsafe "g_value_get_int64" _get_int64 :: - Ptr GValue -> IO Int64 - -set_int64 :: GValue -> Int64 -> IO () -set_int64 gv n = withManagedPtr gv $ flip _set_int64 n - -get_int64 :: GValue -> IO Int64 -get_int64 gv = withManagedPtr gv _get_int64 - -foreign import ccall unsafe "g_value_set_uint64" _set_uint64 :: - Ptr GValue -> Word64 -> IO () -foreign import ccall unsafe "g_value_get_uint64" _get_uint64 :: - Ptr GValue -> IO Word64 - -set_uint64 :: GValue -> Word64 -> IO () -set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n - -get_uint64 :: GValue -> IO Word64 -get_uint64 gv = withManagedPtr gv _get_uint64 - -foreign import ccall unsafe "g_value_set_float" _set_float :: - Ptr GValue -> CFloat -> IO () -foreign import ccall unsafe "g_value_get_float" _get_float :: - Ptr GValue -> IO CFloat - -set_float :: GValue -> Float -> IO () -set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f) - -get_float :: GValue -> IO Float -get_float gv = realToFrac <$> withManagedPtr gv _get_float - -foreign import ccall unsafe "g_value_set_double" _set_double :: - Ptr GValue -> CDouble -> IO () -foreign import ccall unsafe "g_value_get_double" _get_double :: - Ptr GValue -> IO CDouble - -set_double :: GValue -> Double -> IO () -set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d) - -get_double :: GValue -> IO Double -get_double gv = realToFrac <$> withManagedPtr gv _get_double - -foreign import ccall unsafe "g_value_set_boolean" _set_boolean :: - Ptr GValue -> CInt -> IO () -foreign import ccall unsafe "g_value_get_boolean" _get_boolean :: - Ptr GValue -> IO CInt - -set_boolean :: GValue -> Bool -> IO () -set_boolean gv b = withManagedPtr gv $ \ptr -> - _set_boolean ptr (fromIntegral $ fromEnum b) - -get_boolean :: GValue -> IO Bool -get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr - -foreign import ccall unsafe "g_value_set_gtype" _set_gtype :: - Ptr GValue -> CGType -> IO () -foreign import ccall unsafe "g_value_get_gtype" _get_gtype :: - Ptr GValue -> IO CGType - -set_gtype :: GValue -> GType -> IO () -set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g - -get_gtype :: GValue -> IO GType -get_gtype gv = GType <$> withManagedPtr gv _get_gtype - -foreign import ccall "g_value_set_object" _set_object :: - Ptr GValue -> Ptr a -> IO () -foreign import ccall "g_value_get_object" _get_object :: - Ptr GValue -> IO (Ptr a) - -set_object :: GObject a => GValue -> Ptr a -> IO () -set_object gv o = withManagedPtr gv $ flip _set_object o - -get_object :: GObject b => GValue -> IO (Ptr b) -get_object gv = withManagedPtr gv _get_object - -foreign import ccall "g_value_set_boxed" _set_boxed :: - Ptr GValue -> Ptr a -> IO () -foreign import ccall "g_value_get_boxed" _get_boxed :: - Ptr GValue -> IO (Ptr b) - -set_boxed :: GValue -> Ptr a -> IO () -set_boxed gv b = withManagedPtr gv $ flip _set_boxed b - -get_boxed :: GValue -> IO (Ptr b) -get_boxed gv = withManagedPtr gv _get_boxed - -foreign import ccall "g_value_set_variant" _set_variant :: - Ptr GValue -> Ptr GVariant -> IO () -foreign import ccall "g_value_get_variant" _get_variant :: - Ptr GValue -> IO (Ptr GVariant) - -set_variant :: GValue -> Ptr GVariant -> IO () -set_variant gv v = withManagedPtr gv $ flip _set_variant v - -get_variant :: GValue -> IO (Ptr GVariant) -get_variant gv = withManagedPtr gv _get_variant - -foreign import ccall unsafe "g_value_set_enum" _set_enum :: - Ptr GValue -> CUInt -> IO () -foreign import ccall unsafe "g_value_get_enum" _get_enum :: - Ptr GValue -> IO CUInt - -set_enum :: GValue -> CUInt -> IO () -set_enum gv e = withManagedPtr gv $ flip _set_enum e - -get_enum :: GValue -> IO CUInt -get_enum gv = withManagedPtr gv _get_enum - -foreign import ccall unsafe "g_value_set_flags" _set_flags :: - Ptr GValue -> CUInt -> IO () -foreign import ccall unsafe "g_value_get_flags" _get_flags :: - Ptr GValue -> IO CUInt - -set_flags :: GValue -> CUInt -> IO () -set_flags gv f = withManagedPtr gv $ flip _set_flags f - -get_flags :: GValue -> IO CUInt -get_flags gv = withManagedPtr gv _get_flags - --- | Set the value of `GValue` containing a `StablePtr` -set_stablePtr :: GValue -> StablePtr a -> IO () -set_stablePtr gv ptr = withManagedPtr gv $ flip _set_boxed (castStablePtrToPtr ptr) - -foreign import ccall g_value_take_boxed :: Ptr GValue -> StablePtr a -> IO () - --- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr` -take_stablePtr :: Ptr GValue -> StablePtr a -> IO () -take_stablePtr = g_value_take_boxed - --- | Get the value of a `GValue` containing a `StablePtr` -get_stablePtr :: GValue -> IO (StablePtr a) -get_stablePtr gv = castPtrToStablePtr <$> withManagedPtr gv _get_boxed - -foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO () -foreign import ccall "_haskell_gi_g_value_get_type" g_value_get_type :: Ptr GValue -> IO CGType - --- | Pack the given list of GValues contiguously into a C array -packGValueArray :: [GValue] -> IO (Ptr GValue) -packGValueArray gvalues = withManagedPtrList gvalues $ \ptrs -> do - let nitems = length ptrs - mem <- callocBytes $ #{size GValue} * nitems - fill mem ptrs - return mem - where fill :: Ptr GValue -> [Ptr GValue] -> IO () - fill _ [] = return () - fill ptr (x:xs) = do - gtype <- g_value_get_type x - _ <- g_value_init ptr gtype - g_value_copy x ptr - fill (ptr `plusPtr` #{size GValue}) xs - --- | Unpack an array of contiguous GValues into a list of GValues. -unpackGValueArrayWithLength :: Integral a => - a -> Ptr GValue -> IO [GValue] -unpackGValueArrayWithLength nitems gvalues = go (fromIntegral nitems) gvalues - where go :: Int -> Ptr GValue -> IO [GValue] - go 0 _ = return [] - go n ptr = do - gv <- callocBytes #{size GValue} - gtype <- g_value_get_type ptr - _ <- g_value_init gv gtype - g_value_copy ptr gv - wrapped <- wrapGValuePtr gv - (wrapped :) <$> go (n-1) (ptr `plusPtr` #{size GValue}) - --- | Map over the `GValue`s inside a C array. -mapGValueArrayWithLength :: Integral a => - a -> (Ptr GValue -> IO c) -> Ptr GValue -> IO () -mapGValueArrayWithLength nvalues f arrayPtr - | (arrayPtr == nullPtr) = return () - | (nvalues <= 0) = return () - | otherwise = go (fromIntegral nvalues) arrayPtr - where go :: Int -> Ptr GValue -> IO () - go 0 _ = return () - go n ptr = do - _ <- f ptr - go (n-1) (ptr `plusPtr` #{size GValue}) diff --git a/Data/GI/Base/Internal/CTypes.hsc b/Data/GI/Base/Internal/CTypes.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Internal/CTypes.hsc @@ -0,0 +1,40 @@ +-- | Versions of hsc2hs older than 0.68.6 cannot deal with Haskell +-- code including promoted constructors, so isolate the required types +-- in here. +-- +-- /Warning/: This module is internal, and might disappear in the future. +module Data.GI.Base.Internal.CTypes + ( GQuark + , C_gint + , cgvalueSize + , gerror_domain_offset + , gerror_code_offset + , gerror_message_offset + ) where + +#include + +import Data.Int +import Data.Word + +-- | The size in bytes of a GValue struct in C. +cgvalueSize :: Int +cgvalueSize = #size GValue + +-- | The Haskell type corresponding to a GQuark on the C side. +type GQuark = #{type GQuark} + +-- | The Haskell type corresponding to a gint on the C side. +type C_gint = #{type gint} + +-- | The offset in bytes inside a `GError` of its @domain@ field. +gerror_domain_offset :: Int +gerror_domain_offset = #{offset GError, domain} + +-- | The offset in bytes inside a `GError` of its @code@ field. +gerror_code_offset :: Int +gerror_code_offset = #{offset GError, code} + +-- | The offset in bytes inside a `GError` of its @emssage@ field. +gerror_message_offset :: Int +gerror_message_offset = #{offset GError, message} diff --git a/haskell-gi-base.cabal b/haskell-gi-base.cabal --- a/haskell-gi-base.cabal +++ b/haskell-gi-base.cabal @@ -1,5 +1,5 @@ name: haskell-gi-base -version: 0.24.3 +version: 0.24.4 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi @@ -43,7 +43,8 @@ Data.GI.Base.Properties, Data.GI.Base.ShortPrelude, Data.GI.Base.Signals, - Data.GI.Base.Utils + Data.GI.Base.Utils, + Data.GI.Base.Internal.CTypes pkgconfig-depends: gobject-2.0 >= 2.42, glib-2.0 build-depends: base >= 4.9 && < 5, @@ -53,7 +54,7 @@ ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns - build-tool-depends: hsc2hs:hsc2hs >= 0.68.6 + build-tool-depends: hsc2hs:hsc2hs cc-options: -fPIC default-language: Haskell2010 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds