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.13 +version: 0.14 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi-base @@ -26,8 +26,10 @@ Data.GI.Base.BasicConversions, Data.GI.Base.BasicTypes, Data.GI.Base.Closure, + Data.GI.Base.Constructible, Data.GI.Base.GError, Data.GI.Base.GHashTable, + Data.GI.Base.GObject, Data.GI.Base.GValue, Data.GI.Base.GVariant, Data.GI.Base.ManagedPtr, @@ -38,7 +40,7 @@ Data.GI.Base.Signals, Data.GI.Base.Utils - pkgconfig-depends: gobject-2.0 >= 2.36 + pkgconfig-depends: gobject-2.0 >= 2.32 build-depends: base >= 4.7 && < 5, bytestring, containers, @@ -49,5 +51,5 @@ build-tools: hsc2hs extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse - ghc-options: -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing + ghc-options: -Wall -fwarn-incomplete-patterns c-sources: src/c/hsgclosure.c diff --git a/src/Data/GI/Base.hs b/src/Data/GI/Base.hs --- a/src/Data/GI/Base.hs +++ b/src/Data/GI/Base.hs @@ -9,27 +9,23 @@ , module Data.GI.Base.BasicConversions , module Data.GI.Base.BasicTypes , module Data.GI.Base.Closure + , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable , module Data.GI.Base.GValue , module Data.GI.Base.GVariant - , module Data.GI.Base.GParamSpec , module Data.GI.Base.ManagedPtr - , module Data.GI.Base.Properties , module Data.GI.Base.Signals - , module Data.GI.Base.Utils ) where -import Data.GI.Base.Attributes +import Data.GI.Base.Attributes (get, set, AttrOp(..)) import Data.GI.Base.BasicConversions import Data.GI.Base.BasicTypes import Data.GI.Base.Closure +import Data.GI.Base.Constructible (new) import Data.GI.Base.GError import Data.GI.Base.GHashTable -import Data.GI.Base.GValue +import Data.GI.Base.GValue (GValue(..), IsGValue(..)) import Data.GI.Base.GVariant -import Data.GI.Base.GParamSpec import Data.GI.Base.ManagedPtr -import Data.GI.Base.Properties -import Data.GI.Base.Signals -import Data.GI.Base.Utils +import Data.GI.Base.Signals (on, after, SignalProxy(PropertyNotify)) diff --git a/src/Data/GI/Base/Attributes.hs b/src/Data/GI/Base/Attributes.hs --- a/src/Data/GI/Base/Attributes.hs +++ b/src/Data/GI/Base/Attributes.hs @@ -51,7 +51,7 @@ -- > _label = fromLabelProxy (Proxy :: Proxy "label") -- -- These proxies can be automatically generated by invoking the code --- generator with the @-a@ option. The leading underscore is simply so +-- generator with the @-l@ option. The leading underscore is simply so -- the autogenerated identifiers do not pollute the namespace, but if -- this is not a concern the autogenerated names (in the autogenerated -- @GI/Properties.hs@) can be edited as one wishes. @@ -82,10 +82,10 @@ -- -- > set spinButton [ _value :~ (+1) ] -- --- There are other variants of these operators, (see 'AttrOp'). ':=>' and --- ':~>' and like ':=' and ':~' but operate in the 'IO' monad rather --- than being pure. There is also '::=' and '::~' which take the object --- as an extra parameter. +-- There are other variants of these operators, see 'AttrOp' +-- below. ':=>' and ':~>' are like ':=' and ':~' but operate in the +-- 'IO' monad rather than being pure. There is also '::=' and '::~' +-- which take the object as an extra parameter. -- -- Attributes can also be set during construction of a -- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.new` @@ -98,6 +98,26 @@ -- `set` afterwards. That these invariants hold is also checked during -- compile time. -- +-- == Nullable atributes +-- +-- Whenever the attribute is represented as a pointer in the C side, +-- it is often the case that the underlying C representation admits or +-- returns @NULL@ as a valid value for the property. In these cases +-- the `get` operation may return a `Maybe` value, with `Nothing` +-- representing the @NULL@ pointer value (notable exceptions are +-- `Data.GI.Base.BasicTypes.GList` and +-- `Data.GI.Base.BasicTypes.GSList`, for which @NULL@ is represented +-- simply as he empty list). This can be overriden in the +-- introspection data, since sometimes attributes are non-nullable, +-- even if the type would allow for @NULL@. +-- +-- For convenience, in nullable cases the `set` operation will by +-- default /not/ take a `Maybe` value, but rather assume that the +-- caller wants to set a non-@NULL@ value. If setting a @NULL@ value +-- is desired, use `clear` as follows +-- +-- > clear object _propName +-- module Data.GI.Base.Attributes ( AttrInfo(..), @@ -107,6 +127,7 @@ get, set, + clear, AttrLabelProxy(..) ) where @@ -160,6 +181,10 @@ attrSet :: (AttrBaseTypeConstraint info o, AttrSetTypeConstraint info b) => Proxy info -> o -> b -> IO () + -- | Set the value of the given attribute to @NULL@ (for nullable + -- attributes). + attrClear :: AttrBaseTypeConstraint info o => + Proxy info -> o -> IO () -- | Build a `GValue` representing the attribute. attrConstruct :: AttrSetTypeConstraint info b => Proxy info -> b -> IO (String, GValue) @@ -192,7 +217,7 @@ AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) ~ 'OpIsAllowed -- | Possible operations on an attribute. -data AttrOpTag = AttrGet | AttrSet | AttrConstruct +data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear #if MIN_VERSION_base(4,9,0) -- | A user friendly description of the `AttrOpTag`, useful when @@ -201,6 +226,7 @@ AttrOpText 'AttrGet = "gettable" AttrOpText 'AttrSet = "settable" AttrOpText 'AttrConstruct = "constructible" + AttrOpText 'AttrClear = "nullable" #endif -- | Constructors for the different operations allowed on an attribute. @@ -284,3 +310,11 @@ AttrOpAllowed 'AttrGet info, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m (AttrGetType info) get o _ = liftIO $ attrGet (Proxy :: Proxy info) o + +-- | Set a nullable attribute to @NULL@. +clear :: forall info attr obj m. + (info ~ ResolveAttribute attr obj, AttrInfo info, + (AttrBaseTypeConstraint info) obj, + AttrOpAllowed 'AttrClear info, MonadIO m) => + obj -> AttrLabelProxy (attr :: Symbol) -> m () +clear o _ = liftIO $ attrClear (Proxy :: Proxy info) o diff --git a/src/Data/GI/Base/BasicConversions.hsc b/src/Data/GI/Base/BasicConversions.hsc --- a/src/Data/GI/Base/BasicConversions.hsc +++ b/src/Data/GI/Base/BasicConversions.hsc @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.GI.Base.BasicConversions ( gflagsToWord , wordToGFlags diff --git a/src/Data/GI/Base/BasicTypes.hsc b/src/Data/GI/Base/BasicTypes.hsc --- a/src/Data/GI/Base/BasicTypes.hsc +++ b/src/Data/GI/Base/BasicTypes.hsc @@ -1,5 +1,8 @@ {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, - DeriveDataTypeable #-} + DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif -- | Basic types used in the bindings. module Data.GI.Base.BasicTypes ( @@ -11,8 +14,10 @@ , gtypeString , gtypePointer - , gtypeInt32 - , gtypeUInt32 + , gtypeInt + , gtypeUInt + , gtypeLong + , gtypeULong , gtypeInt64 , gtypeUInt64 , gtypeFloat @@ -22,14 +27,19 @@ , gtypeStrv , gtypeBoxed , gtypeObject + , gtypeVariant + , gtypeByteArray + , gtypeInvalid -- * Memory management , ForeignPtrNewtype , BoxedObject(..) , BoxedEnum(..) + , BoxedFlags(..) , GObject(..) , UnexpectedNullPointerReturn(..) + , NullToNothing(..) -- * Basic GLib \/ GObject types , GVariant(..) @@ -50,8 +60,13 @@ , GDestroyNotify ) where -import Control.Exception (Exception) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Exception (Exception, catch) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Coerce (Coercible) +import Data.Proxy (Proxy) import qualified Data.Text as T import Data.Typeable (Typeable) import Data.Word @@ -75,6 +90,22 @@ gtypeName :: GType -> IO String gtypeName gtype = g_type_name gtype >>= peekCString +{-| [Note: compile-time vs run-time GTypes] + +Notice that there are two types of GType's: the fundamental ones, +which are created with G_TYPE_MAKE_FUNDAMENTAL(n) and always have the +same runtime representation, and the ones that are registered in the +GObject type system at runtime, and whose `CGType` may change for each +program run (and generally does). + +For the first type it is safe to use hsc to read the numerical values +of the CGType at compile type, but for the second type it is essential +to call the corresponding _get_type() function at runtime, and not use +the value of the corresponding "constant" at compile time via hsc. +-} + +{- Fundamental types -} + -- | `GType` of strings. gtypeString :: GType gtypeString = GType #const G_TYPE_STRING @@ -83,14 +114,22 @@ gtypePointer :: GType gtypePointer = GType #const G_TYPE_POINTER --- | `GType` for signed integers. -gtypeInt32 :: GType -gtypeInt32 = GType #const G_TYPE_INT +-- | `GType` for signed integers (`gint` or `gint32`). +gtypeInt :: GType +gtypeInt = GType #const G_TYPE_INT --- | `GType` for unsigned integers. -gtypeUInt32 :: GType -gtypeUInt32 = GType #const G_TYPE_UINT +-- | `GType` for unsigned integers (`guint` or `guint32`). +gtypeUInt :: GType +gtypeUInt = GType #const G_TYPE_UINT +-- | `GType` for `glong`. +gtypeLong :: GType +gtypeLong = GType #const G_TYPE_LONG + +-- | `GType` for `gulong`. +gtypeULong :: GType +gtypeULong = GType #const G_TYPE_ULONG + -- | `GType` for signed 64 bit integers. gtypeInt64 :: GType gtypeInt64 = GType #const G_TYPE_INT64 @@ -111,14 +150,6 @@ gtypeBoolean :: GType gtypeBoolean = GType #const G_TYPE_BOOLEAN --- | `GType` corresponding to a `GType` itself. -gtypeGType :: GType -gtypeGType = GType #const G_TYPE_GTYPE - --- | `GType` for a NULL terminated array of strings. -gtypeStrv :: GType -gtypeStrv = GType #const G_TYPE_STRV - -- | `GType` corresponding to a `BoxedObject`. gtypeBoxed :: GType gtypeBoxed = GType #const G_TYPE_BOXED @@ -127,6 +158,35 @@ gtypeObject :: GType gtypeObject = GType #const G_TYPE_OBJECT +-- | An invalid `GType` used as error return value in some functions +-- which return a `GType`. +gtypeInvalid :: GType +gtypeInvalid = GType #const G_TYPE_INVALID + +-- | The `GType` corresponding to a `GVariant`. +gtypeVariant :: GType +gtypeVariant = GType #const G_TYPE_VARIANT + +{- Run-time types -} + +foreign import ccall "g_gtype_get_type" g_gtype_get_type :: CGType + +-- | `GType` corresponding to a `GType` itself. +gtypeGType :: GType +gtypeGType = GType g_gtype_get_type + +foreign import ccall "g_strv_get_type" g_strv_get_type :: CGType + +-- | `GType` for a NULL terminated array of strings. +gtypeStrv :: GType +gtypeStrv = GType g_strv_get_type + +foreign import ccall "g_byte_array_get_type" g_byte_array_get_type :: CGType + +-- | `GType` for a boxed type holding a `GByteArray`. +gtypeByteArray :: GType +gtypeByteArray = GType g_byte_array_get_type + -- | A constraint ensuring that the given type is coercible to a -- ForeignPtr. It will hold for newtypes of the form -- @@ -149,6 +209,10 @@ class BoxedEnum a where boxedEnumType :: a -> IO GType +-- | Flags with an associated `GType`. +class BoxedFlags a where + boxedFlagsType :: Proxy a -> IO GType + -- | A wrapped `GObject`. class ForeignPtrNewtype a => GObject a where -- | Whether the `GObject` is a descendent of . @@ -168,6 +232,36 @@ deriving (Show, Typeable) instance Exception UnexpectedNullPointerReturn + +type family UnMaybe a :: * where + UnMaybe (Maybe a) = a + UnMaybe a = a + +class NullToNothing a where + -- | Some functions are not marked as having a nullable return type + -- in the introspection data. The result is that they currently do + -- not return a Maybe type. This functions lets you work around this + -- in a way that will not break when the introspection data is fixed. + -- + -- When you want to call a `someHaskellGIFunction` that may return null + -- wrap the call like this. + -- + -- > nullToNothing (someHaskellGIFunction x y) + -- + -- The result will be a Maybe type even if the introspection data has + -- not been fixed for `someHaskellGIFunction` yet. + nullToNothing :: MonadIO m => IO a -> m (Maybe (UnMaybe a)) + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + a ~ UnMaybe a => NullToNothing a where + nullToNothing f = liftIO $ + (Just <$> f) `catch` (\(_::UnexpectedNullPointerReturn) -> return Nothing) + +instance NullToNothing (Maybe a) where + nullToNothing = liftIO -- | A . See "Data.GI.Base.GVariant" for further methods. newtype GVariant = GVariant (ForeignPtr GVariant) diff --git a/src/Data/GI/Base/Constructible.hs b/src/Data/GI/Base/Constructible.hs new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/Constructible.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, + UndecidableInstances, KindSignatures, TypeFamilies #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | `Constructible` types are those for which `new` is +-- defined. Often these are `GObject`s, but it is possible to +-- construct new (zero-initialized) structures and unions too. + +module Data.GI.Base.Constructible + ( Constructible(..) + ) where + +import Foreign (ForeignPtr) +import Control.Monad.IO.Class (MonadIO) + +import Data.GI.Base.Attributes (AttrOp, AttrOpTag(..)) +import Data.GI.Base.BasicTypes (GObject) +import Data.GI.Base.GObject (constructGObject) + +-- | Constructible types, i.e. those which can be allocated by `new`. +class Constructible a (tag :: AttrOpTag) where + new :: MonadIO m => (ForeignPtr a -> a) -> [AttrOp a tag] -> m a + +-- | Default instance, assuming we have a `GObject`. +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (GObject a, tag ~ 'AttrConstruct) => Constructible a tag where + new = constructGObject diff --git a/src/Data/GI/Base/GObject.hsc b/src/Data/GI/Base/GObject.hsc new file mode 100644 --- /dev/null +++ b/src/Data/GI/Base/GObject.hsc @@ -0,0 +1,78 @@ +{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-} + +module Data.GI.Base.GObject + ( constructGObject + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Proxy (Proxy(..)) +import Foreign.C (CUInt(..), CString, newCString) +import Foreign + +import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy, + attrConstruct) +import Data.GI.Base.BasicTypes (GType(..), GObject(..)) +import Data.GI.Base.GValue (GValue(..)) +import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject) +import Data.GI.Base.Overloading (ResolveAttribute) + +#include + +foreign import ccall "dbg_g_object_newv" g_object_newv :: + GType -> CUInt -> Ptr a -> IO (Ptr b) + +-- | Construct a GObject given the constructor and a list of settable +-- attributes. +constructGObject :: forall o m. (GObject o, MonadIO m) + => (ForeignPtr o -> o) + -> [AttrOp o 'AttrConstruct] + -> m o +constructGObject constructor attrs = liftIO $ do + props <- mapM construct attrs + let nprops = length props + params <- mallocBytes (nprops*gparameterSize) + fill params props + gtype <- gobjectType (undefined :: o) + result <- g_object_newv gtype (fromIntegral nprops) params + freeStrings nprops params + free params + -- Make sure that the GValues defining the GProperties are still + -- alive at this point (so, in particular, they are still alive when + -- g_object_newv is called). Without this the GHC garbage collector + -- may free the GValues before g_object_newv us called, which will + -- unref the referred to objects, which may drop the last reference + -- to the contained objects. g_object_newv then tries to access the + -- (now invalid) contents of the GValue, and mayhem ensues. + mapM_ (touchManagedPtr . snd) props + wrapObject constructor (result :: Ptr o) + where + resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o) + resolve _ = Proxy + + construct :: AttrOp o 'AttrConstruct -> + IO (String, GValue) + construct (attr := x) = attrConstruct (resolve attr) x + construct (attr :=> x) = x >>= attrConstruct (resolve attr) + + gvalueSize = #size GValue + gparameterSize = #size GParameter + + -- Fill the given memory address with the contents of the array of + -- GParameters. + fill :: Ptr () -> [(String, GValue)] -> IO () + fill _ [] = return () + fill dataPtr ((str, gvalue):xs) = + do cstr <- newCString str + poke (castPtr dataPtr) cstr + withManagedPtr gvalue $ \gvalueptr -> + copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize + fill (dataPtr `plusPtr` gparameterSize) xs + + -- Free the strings in the GParameter array (the GValues will be + -- freed separately). + freeStrings :: Int -> Ptr () -> IO () + freeStrings 0 _ = return () + freeStrings n dataPtr = + do cstr <- peek (castPtr dataPtr) :: IO CString + free cstr + freeStrings (n-1) (dataPtr `plusPtr` gparameterSize) diff --git a/src/Data/GI/Base/GValue.hsc b/src/Data/GI/Base/GValue.hsc --- a/src/Data/GI/Base/GValue.hsc +++ b/src/Data/GI/Base/GValue.hsc @@ -12,6 +12,14 @@ , 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 @@ -45,15 +53,16 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad ((>=>)) +import Data.Coerce (coerce) import Data.Word import Data.Int import Data.Text (Text, pack, unpack) -import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..)) +import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..), + CLong(..), CULong(..)) import Foreign.C.String (CString) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, nullPtr) import Foreign.ForeignPtr (ForeignPtr) import Data.GI.Base.BasicTypes @@ -93,11 +102,11 @@ toGValue :: a -> IO GValue fromGValue :: GValue -> IO a -instance IsGValue String where - toGValue = buildGValue gtypeString set_string . pack - fromGValue v = unpack <$> get_string v +instance IsGValue (Maybe String) where + toGValue = buildGValue gtypeString set_string . fmap pack + fromGValue v = (fmap unpack) <$> get_string v -instance IsGValue Text where +instance IsGValue (Maybe Text) where toGValue = buildGValue gtypeString set_string fromGValue = get_string @@ -106,13 +115,29 @@ fromGValue = get_pointer instance IsGValue Int32 where - toGValue = buildGValue gtypeInt32 set_int32 + toGValue = buildGValue gtypeInt set_int32 fromGValue = get_int32 instance IsGValue Word32 where - toGValue = buildGValue gtypeUInt32 set_uint32 + 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 @@ -142,14 +167,21 @@ foreign import ccall "g_value_get_string" _get_string :: Ptr GValue -> IO CString -set_string :: GValue -> Text -> IO () -set_string gv str = withManagedPtr gv $ \ptr -> do - cstr <- textToCString str - _set_string ptr cstr - freeMem cstr +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 Text -get_string gv = withManagedPtr gv $ _get_string >=> cstringToText +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 () @@ -162,27 +194,61 @@ get_pointer :: GValue -> IO (Ptr b) get_pointer gv = withManagedPtr gv _get_pointer -foreign import ccall unsafe "g_value_set_int" _set_int32 :: - Ptr GValue -> Int32 -> IO () -foreign import ccall unsafe "g_value_get_int" _get_int32 :: - Ptr GValue -> IO Int32 +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_int32 n +set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n) get_int32 :: GValue -> IO Int32 -get_int32 gv = withManagedPtr gv _get_int32 +get_int32 gv = coerce <$> withManagedPtr gv _get_int -foreign import ccall unsafe "g_value_set_uint" _set_uint32 :: - Ptr GValue -> Word32 -> IO () -foreign import ccall unsafe "g_value_get_uint" _get_uint32 :: - Ptr GValue -> IO Word32 +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_uint32 n +set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n) get_uint32 :: GValue -> IO Word32 -get_uint32 gv = withManagedPtr gv _get_uint32 +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 () diff --git a/src/Data/GI/Base/ManagedPtr.hs b/src/Data/GI/Base/ManagedPtr.hs --- a/src/Data/GI/Base/ManagedPtr.hs +++ b/src/Data/GI/Base/ManagedPtr.hs @@ -10,8 +10,10 @@ -- module deal with the memory management of such managed pointers. module Data.GI.Base.ManagedPtr - ( -- * Managed pointers + ( + -- * Managed pointers withManagedPtr + , maybeWithManagedPtr , withManagedPtrList , unsafeManagedPtrGetPtr , unsafeManagedPtrCastPtr @@ -44,7 +46,7 @@ import Foreign (poke) import Foreign.C (CInt(..)) -import Foreign.Ptr (Ptr, FunPtr, castPtr) +import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtrEnv, touchForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) @@ -54,6 +56,17 @@ -- | Perform an IO action on the 'Ptr' inside a managed pointer. withManagedPtr :: ForeignPtrNewtype a => a -> (Ptr a -> IO c) -> IO c withManagedPtr managed action = do + let ptr = unsafeManagedPtrGetPtr managed + result <- action ptr + touchManagedPtr managed + return result + +-- | Like `withManagedPtr`, but accepts a `Maybe` type. If the passed +-- value is `Nothing` the inner action will be executed with a +-- `nullPtr` argument. +maybeWithManagedPtr :: ForeignPtrNewtype a => Maybe a -> (Ptr a -> IO c) -> IO c +maybeWithManagedPtr Nothing action = action nullPtr +maybeWithManagedPtr (Just managed) action = do let ptr = unsafeManagedPtrGetPtr managed result <- action ptr touchManagedPtr managed diff --git a/src/Data/GI/Base/Properties.hsc b/src/Data/GI/Base/Properties.hsc --- a/src/Data/GI/Base/Properties.hsc +++ b/src/Data/GI/Base/Properties.hsc @@ -1,16 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, DataKinds, KindSignatures, -FlexibleInstances, MultiParamTypeClasses, TypeFamilies, PolyKinds, -EmptyDataDecls, ConstraintKinds #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.GI.Base.Properties - ( new - - , setObjectPropertyString + ( setObjectPropertyString , setObjectPropertyStringArray , setObjectPropertyPtr - , setObjectPropertyCInt - , setObjectPropertyCUInt + , setObjectPropertyInt + , setObjectPropertyUInt + , setObjectPropertyLong + , setObjectPropertyULong + , setObjectPropertyInt32 + , setObjectPropertyUInt32 , setObjectPropertyInt64 , setObjectPropertyUInt64 , setObjectPropertyFloat @@ -29,8 +28,12 @@ , getObjectPropertyString , getObjectPropertyStringArray , getObjectPropertyPtr - , getObjectPropertyCInt - , getObjectPropertyCUInt + , getObjectPropertyInt + , getObjectPropertyUInt + , getObjectPropertyLong + , getObjectPropertyULong + , getObjectPropertyInt32 + , getObjectPropertyUInt32 , getObjectPropertyInt64 , getObjectPropertyUInt64 , getObjectPropertyFloat @@ -49,8 +52,12 @@ , constructObjectPropertyString , constructObjectPropertyStringArray , constructObjectPropertyPtr - , constructObjectPropertyCInt - , constructObjectPropertyCUInt + , constructObjectPropertyInt + , constructObjectPropertyUInt + , constructObjectPropertyLong + , constructObjectPropertyULong + , constructObjectPropertyInt32 + , constructObjectPropertyUInt32 , constructObjectPropertyInt64 , constructObjectPropertyUInt64 , constructObjectPropertyFloat @@ -71,7 +78,6 @@ import Control.Applicative ((<$>)) #endif import Control.Monad ((>=>)) -import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString.Char8 as B import Data.Text (Text) @@ -80,76 +86,16 @@ import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions import Data.GI.Base.ManagedPtr -import Data.GI.Base.Attributes import Data.GI.Base.GValue import Data.GI.Base.GVariant (newGVariantFromPtr) -import Data.GI.Base.Overloading (ResolveAttribute) +import Data.GI.Base.Utils (freeMem, convertIfNonNull) -import Foreign hiding (new) -import Foreign.C +import Foreign (Ptr, ForeignPtr, Int32, Word32, Int64, Word64, nullPtr) +import Foreign.C (CString, withCString) +import Foreign.C.Types (CInt, CUInt, CLong, CULong) #include -foreign import ccall "dbg_g_object_newv" g_object_newv :: - GType -> CUInt -> Ptr a -> IO (Ptr b) - --- | Construct a GObject given the constructor and a list of settable --- attributes. AttrOps are always constructible, so we don't need to --- enforce constraints here. -new :: forall o m. (GObject o, MonadIO m) - => (ForeignPtr o -> o) - -> [AttrOp o 'AttrConstruct] - -> m o -new constructor attrs = liftIO $ do - props <- mapM construct attrs - let nprops = length props - params <- mallocBytes (nprops*gparameterSize) - fill params props - gtype <- gobjectType (undefined :: o) - result <- g_object_newv gtype (fromIntegral nprops) params - freeStrings nprops params - free params - -- Make sure that the GValues defining the GProperties are still - -- alive at this point (so, in particular, they are still alive when - -- g_object_newv is called). Without this the GHC garbage collector - -- may free the GValues before g_object_newv us called, which will - -- unref the referred to objects, which may drop the last reference - -- to the contained objects. g_object_newv then tries to access the - -- (now invalid) contents of the GValue, and mayhem ensues. - mapM_ (touchManagedPtr . snd) props - wrapObject constructor (result :: Ptr o) - where - resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o) - resolve _ = Proxy - - construct :: AttrOp o 'AttrConstruct -> - IO (String, GValue) - construct (attr := x) = attrConstruct (resolve attr) x - construct (attr :=> x) = x >>= attrConstruct (resolve attr) - - gvalueSize = #size GValue - gparameterSize = #size GParameter - - -- Fill the given memory address with the contents of the array of - -- GParameters. - fill :: Ptr () -> [(String, GValue)] -> IO () - fill _ [] = return () - fill dataPtr ((str, gvalue):xs) = - do cstr <- newCString str - poke (castPtr dataPtr) cstr - withManagedPtr gvalue $ \gvalueptr -> - copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize - fill (dataPtr `plusPtr` gparameterSize) xs - - -- Free the strings in the GParameter array (the GValues will be - -- freed separately). - freeStrings :: Int -> Ptr () -> IO () - freeStrings 0 _ = return () - freeStrings n dataPtr = - do cstr <- peek (castPtr dataPtr) :: IO CString - free cstr - freeStrings (n-1) (dataPtr `plusPtr` gparameterSize) - foreign import ccall "g_object_set_property" g_object_set_property :: Ptr a -> CString -> Ptr GValue -> IO () @@ -182,213 +128,275 @@ return (propName, gvalue) setObjectPropertyString :: GObject a => - a -> String -> Text -> IO () + a -> String -> Maybe Text -> IO () setObjectPropertyString obj propName str = - setObjectProperty obj propName str set_string (GType #const G_TYPE_STRING) + setObjectProperty obj propName str set_string gtypeString -constructObjectPropertyString :: String -> Text -> +constructObjectPropertyString :: String -> Maybe Text -> IO (String, GValue) constructObjectPropertyString propName str = - constructObjectProperty propName str set_string (GType #const G_TYPE_STRING) + constructObjectProperty propName str set_string gtypeString getObjectPropertyString :: GObject a => - a -> String -> IO Text + a -> String -> IO (Maybe Text) getObjectPropertyString obj propName = - getObjectProperty obj propName get_string (GType #const G_TYPE_STRING) + getObjectProperty obj propName get_string gtypeString setObjectPropertyPtr :: GObject a => a -> String -> Ptr b -> IO () setObjectPropertyPtr obj propName ptr = - setObjectProperty obj propName ptr set_pointer (GType #const G_TYPE_POINTER) + setObjectProperty obj propName ptr set_pointer gtypePointer constructObjectPropertyPtr :: String -> Ptr b -> IO (String, GValue) constructObjectPropertyPtr propName ptr = - constructObjectProperty propName ptr set_pointer (GType #const G_TYPE_POINTER) + constructObjectProperty propName ptr set_pointer gtypePointer getObjectPropertyPtr :: GObject a => a -> String -> IO (Ptr b) getObjectPropertyPtr obj propName = - getObjectProperty obj propName get_pointer (GType #const G_TYPE_POINTER) + getObjectProperty obj propName get_pointer gtypePointer -setObjectPropertyCInt :: GObject a => - a -> String -> Int32 -> IO () -setObjectPropertyCInt obj propName int = - setObjectProperty obj propName int set_int32 (GType #const G_TYPE_INT) +setObjectPropertyInt :: GObject a => + a -> String -> CInt -> IO () +setObjectPropertyInt obj propName int = + setObjectProperty obj propName int set_int gtypeInt -constructObjectPropertyCInt :: String -> Int32 -> +constructObjectPropertyInt :: String -> CInt -> + IO (String, GValue) +constructObjectPropertyInt propName int = + constructObjectProperty propName int set_int gtypeInt + +getObjectPropertyInt :: GObject a => a -> String -> IO CInt +getObjectPropertyInt obj propName = + getObjectProperty obj propName get_int gtypeInt + +setObjectPropertyUInt :: GObject a => + a -> String -> CUInt -> IO () +setObjectPropertyUInt obj propName uint = + setObjectProperty obj propName uint set_uint gtypeUInt + +constructObjectPropertyUInt :: String -> CUInt -> IO (String, GValue) -constructObjectPropertyCInt propName int = - constructObjectProperty propName int set_int32 (GType #const G_TYPE_INT) +constructObjectPropertyUInt propName uint = + constructObjectProperty propName uint set_uint gtypeUInt -getObjectPropertyCInt :: GObject a => a -> String -> IO Int32 -getObjectPropertyCInt obj propName = - getObjectProperty obj propName get_int32 (GType #const G_TYPE_INT) +getObjectPropertyUInt :: GObject a => a -> String -> IO CUInt +getObjectPropertyUInt obj propName = + getObjectProperty obj propName get_uint gtypeUInt -setObjectPropertyCUInt :: GObject a => - a -> String -> Word32 -> IO () -setObjectPropertyCUInt obj propName uint = - setObjectProperty obj propName uint set_uint32 (GType #const G_TYPE_UINT) +setObjectPropertyLong :: GObject a => + a -> String -> CLong -> IO () +setObjectPropertyLong obj propName int = + setObjectProperty obj propName int set_long gtypeLong -constructObjectPropertyCUInt :: String -> Word32 -> +constructObjectPropertyLong :: String -> CLong -> + IO (String, GValue) +constructObjectPropertyLong propName int = + constructObjectProperty propName int set_long gtypeLong + +getObjectPropertyLong :: GObject a => a -> String -> IO CLong +getObjectPropertyLong obj propName = + getObjectProperty obj propName get_long gtypeLong + +setObjectPropertyULong :: GObject a => + a -> String -> CULong -> IO () +setObjectPropertyULong obj propName uint = + setObjectProperty obj propName uint set_ulong gtypeULong + +constructObjectPropertyULong :: String -> CULong -> IO (String, GValue) -constructObjectPropertyCUInt propName uint = - constructObjectProperty propName uint set_uint32 (GType #const G_TYPE_UINT) +constructObjectPropertyULong propName uint = + constructObjectProperty propName uint set_ulong gtypeULong -getObjectPropertyCUInt :: GObject a => a -> String -> IO Word32 -getObjectPropertyCUInt obj propName = - getObjectProperty obj propName get_uint32 (GType #const G_TYPE_UINT) +getObjectPropertyULong :: GObject a => a -> String -> IO CULong +getObjectPropertyULong obj propName = + getObjectProperty obj propName get_ulong gtypeULong +setObjectPropertyInt32 :: GObject a => + a -> String -> Int32 -> IO () +setObjectPropertyInt32 obj propName int32 = + setObjectProperty obj propName int32 set_int32 gtypeInt + +constructObjectPropertyInt32 :: String -> Int32 -> + IO (String, GValue) +constructObjectPropertyInt32 propName int32 = + constructObjectProperty propName int32 set_int32 gtypeInt + +getObjectPropertyInt32 :: GObject a => a -> String -> IO Int32 +getObjectPropertyInt32 obj propName = + getObjectProperty obj propName get_int32 gtypeInt + +setObjectPropertyUInt32 :: GObject a => + a -> String -> Word32 -> IO () +setObjectPropertyUInt32 obj propName uint32 = + setObjectProperty obj propName uint32 set_uint32 gtypeUInt + +constructObjectPropertyUInt32 :: String -> Word32 -> + IO (String, GValue) +constructObjectPropertyUInt32 propName uint32 = + constructObjectProperty propName uint32 set_uint32 gtypeUInt + +getObjectPropertyUInt32 :: GObject a => a -> String -> IO Word32 +getObjectPropertyUInt32 obj propName = + getObjectProperty obj propName get_uint32 gtypeUInt + setObjectPropertyInt64 :: GObject a => a -> String -> Int64 -> IO () setObjectPropertyInt64 obj propName int64 = - setObjectProperty obj propName int64 set_int64 (GType #const G_TYPE_INT64) + setObjectProperty obj propName int64 set_int64 gtypeInt64 constructObjectPropertyInt64 :: String -> Int64 -> IO (String, GValue) constructObjectPropertyInt64 propName int64 = - constructObjectProperty propName int64 set_int64 (GType #const G_TYPE_INT64) + constructObjectProperty propName int64 set_int64 gtypeInt64 getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64 getObjectPropertyInt64 obj propName = - getObjectProperty obj propName get_int64 (GType #const G_TYPE_INT64) + getObjectProperty obj propName get_int64 gtypeInt64 setObjectPropertyUInt64 :: GObject a => a -> String -> Word64 -> IO () setObjectPropertyUInt64 obj propName uint64 = - setObjectProperty obj propName uint64 set_uint64 (GType #const G_TYPE_UINT64) + setObjectProperty obj propName uint64 set_uint64 gtypeUInt64 constructObjectPropertyUInt64 :: String -> Word64 -> IO (String, GValue) constructObjectPropertyUInt64 propName uint64 = - constructObjectProperty propName uint64 set_uint64 (GType #const G_TYPE_UINT64) + constructObjectProperty propName uint64 set_uint64 gtypeUInt64 getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64 getObjectPropertyUInt64 obj propName = - getObjectProperty obj propName get_uint64 (GType #const G_TYPE_UINT64) + getObjectProperty obj propName get_uint64 gtypeUInt64 setObjectPropertyFloat :: GObject a => a -> String -> Float -> IO () setObjectPropertyFloat obj propName float = - setObjectProperty obj propName float set_float (GType #const G_TYPE_FLOAT) + setObjectProperty obj propName float set_float gtypeFloat constructObjectPropertyFloat :: String -> Float -> IO (String, GValue) constructObjectPropertyFloat propName float = - constructObjectProperty propName float set_float (GType #const G_TYPE_FLOAT) + constructObjectProperty propName float set_float gtypeFloat getObjectPropertyFloat :: GObject a => a -> String -> IO Float getObjectPropertyFloat obj propName = - getObjectProperty obj propName get_float (GType #const G_TYPE_FLOAT) + getObjectProperty obj propName get_float gtypeFloat setObjectPropertyDouble :: GObject a => a -> String -> Double -> IO () setObjectPropertyDouble obj propName double = - setObjectProperty obj propName double set_double (GType #const G_TYPE_DOUBLE) + setObjectProperty obj propName double set_double gtypeDouble constructObjectPropertyDouble :: String -> Double -> IO (String, GValue) constructObjectPropertyDouble propName double = - constructObjectProperty propName double set_double (GType #const G_TYPE_DOUBLE) + constructObjectProperty propName double set_double gtypeDouble getObjectPropertyDouble :: GObject a => a -> String -> IO Double getObjectPropertyDouble obj propName = - getObjectProperty obj propName get_double (GType #const G_TYPE_DOUBLE) + getObjectProperty obj propName get_double gtypeDouble setObjectPropertyBool :: GObject a => a -> String -> Bool -> IO () setObjectPropertyBool obj propName bool = - setObjectProperty obj propName bool set_boolean (GType #const G_TYPE_BOOLEAN) + setObjectProperty obj propName bool set_boolean gtypeBoolean constructObjectPropertyBool :: String -> Bool -> IO (String, GValue) constructObjectPropertyBool propName bool = - constructObjectProperty propName bool set_boolean (GType #const G_TYPE_BOOLEAN) + constructObjectProperty propName bool set_boolean gtypeBoolean getObjectPropertyBool :: GObject a => a -> String -> IO Bool getObjectPropertyBool obj propName = - getObjectProperty obj propName get_boolean (GType #const G_TYPE_BOOLEAN) + getObjectProperty obj propName get_boolean gtypeBoolean setObjectPropertyGType :: GObject a => a -> String -> GType -> IO () setObjectPropertyGType obj propName gtype = - setObjectProperty obj propName gtype set_gtype (GType #const G_TYPE_GTYPE) + setObjectProperty obj propName gtype set_gtype gtypeGType constructObjectPropertyGType :: String -> GType -> IO (String, GValue) constructObjectPropertyGType propName bool = - constructObjectProperty propName bool set_gtype (GType #const G_TYPE_GTYPE) + constructObjectProperty propName bool set_gtype gtypeGType getObjectPropertyGType :: GObject a => a -> String -> IO GType getObjectPropertyGType obj propName = - getObjectProperty obj propName get_gtype (GType #const G_TYPE_GTYPE) + getObjectProperty obj propName get_gtype gtypeGType -setObjectPropertyObject :: (GObject a, GObject b) => - a -> String -> b -> IO () -setObjectPropertyObject obj propName object = do - gtype <- gobjectType object - withManagedPtr object $ \objectPtr -> +setObjectPropertyObject :: forall a b. (GObject a, GObject b) => + a -> String -> Maybe b -> IO () +setObjectPropertyObject obj propName maybeObject = do + gtype <- gobjectType (undefined :: b) + maybeWithManagedPtr maybeObject $ \objectPtr -> setObjectProperty obj propName objectPtr set_object gtype -constructObjectPropertyObject :: GObject a => - String -> a -> IO (String, GValue) -constructObjectPropertyObject propName object = do - gtype <- gobjectType object - withManagedPtr object $ \objectPtr -> +constructObjectPropertyObject :: forall a. GObject a => + String -> Maybe a -> IO (String, GValue) +constructObjectPropertyObject propName maybeObject = do + gtype <- gobjectType (undefined :: a) + maybeWithManagedPtr maybeObject $ \objectPtr -> constructObjectProperty propName objectPtr set_object gtype getObjectPropertyObject :: forall a b. (GObject a, GObject b) => - a -> String -> (ForeignPtr b -> b) -> IO b + a -> String -> (ForeignPtr b -> b) -> IO (Maybe b) getObjectPropertyObject obj propName constructor = do gtype <- gobjectType (undefined :: b) getObjectProperty obj propName (\val -> (get_object val :: IO (Ptr b)) - >>= newObject constructor) + >>= flip convertIfNonNull (newObject constructor)) gtype -setObjectPropertyBoxed :: (GObject a, BoxedObject b) => - a -> String -> b -> IO () -setObjectPropertyBoxed obj propName boxed = do - gtype <- boxedType boxed - withManagedPtr boxed $ \boxedPtr -> +setObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) => + a -> String -> Maybe b -> IO () +setObjectPropertyBoxed obj propName maybeBoxed = do + gtype <- boxedType (undefined :: b) + maybeWithManagedPtr maybeBoxed $ \boxedPtr -> setObjectProperty obj propName boxedPtr set_boxed gtype -constructObjectPropertyBoxed :: (BoxedObject a) => String -> a -> - IO (String, GValue) -constructObjectPropertyBoxed propName boxed = do - gtype <- boxedType boxed - withManagedPtr boxed $ \boxedPtr -> +constructObjectPropertyBoxed :: forall a. (BoxedObject a) => + String -> Maybe a -> IO (String, GValue) +constructObjectPropertyBoxed propName maybeBoxed = do + gtype <- boxedType (undefined :: a) + maybeWithManagedPtr maybeBoxed $ \boxedPtr -> constructObjectProperty propName boxedPtr set_boxed gtype getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) => - a -> String -> (ForeignPtr b -> b) -> IO b + a -> String -> (ForeignPtr b -> b) -> IO (Maybe b) getObjectPropertyBoxed obj propName constructor = do gtype <- boxedType (undefined :: b) - getObjectProperty obj propName (get_boxed >=> newBoxed constructor) gtype + getObjectProperty obj propName (get_boxed >=> + flip convertIfNonNull (newBoxed constructor)) + gtype setObjectPropertyStringArray :: GObject a => - a -> String -> [Text] -> IO () -setObjectPropertyStringArray obj propName strv = do + a -> String -> Maybe [Text] -> IO () +setObjectPropertyStringArray obj propName Nothing = + setObjectProperty obj propName nullPtr set_boxed gtypeStrv +setObjectPropertyStringArray obj propName (Just strv) = do cStrv <- packZeroTerminatedUTF8CArray strv - setObjectProperty obj propName cStrv set_boxed (GType #const G_TYPE_STRV) - mapZeroTerminatedCArray free cStrv - free cStrv + setObjectProperty obj propName cStrv set_boxed gtypeStrv + mapZeroTerminatedCArray freeMem cStrv + freeMem cStrv -constructObjectPropertyStringArray :: String -> [Text] -> +constructObjectPropertyStringArray :: String -> Maybe [Text] -> IO (String, GValue) -constructObjectPropertyStringArray propName strv = do +constructObjectPropertyStringArray propName Nothing = + constructObjectProperty propName nullPtr set_boxed gtypeStrv +constructObjectPropertyStringArray propName (Just strv) = do cStrv <- packZeroTerminatedUTF8CArray strv - result <- constructObjectProperty propName cStrv set_boxed (GType #const G_TYPE_STRV) - mapZeroTerminatedCArray free cStrv - free cStrv + result <- constructObjectProperty propName cStrv set_boxed gtypeStrv + mapZeroTerminatedCArray freeMem cStrv + freeMem cStrv return result -getObjectPropertyStringArray :: GObject a => - a -> String -> IO [Text] +getObjectPropertyStringArray :: GObject a => a -> String -> IO (Maybe [Text]) getObjectPropertyStringArray obj propName = getObjectProperty obj propName - (get_boxed >=> unpackZeroTerminatedUTF8CArray . castPtr) - (GType #const G_TYPE_STRV) + (get_boxed >=> + flip convertIfNonNull unpackZeroTerminatedUTF8CArray) + gtypeStrv setObjectPropertyEnum :: (GObject a, Enum b, BoxedEnum b) => a -> String -> b -> IO () @@ -413,87 +421,92 @@ (\val -> toEnum . fromIntegral <$> get_enum val) gtype -setObjectPropertyFlags :: (IsGFlag b, GObject a) => +setObjectPropertyFlags :: forall a b. (IsGFlag b, BoxedFlags b, GObject a) => a -> String -> [b] -> IO () -setObjectPropertyFlags obj propName flags = - let cFlags = gflagsToWord flags - in setObjectProperty obj propName cFlags set_flags (GType #const G_TYPE_FLAGS) +setObjectPropertyFlags obj propName flags = do + let cFlags = gflagsToWord flags + gtype <- boxedFlagsType (Proxy :: Proxy b) + setObjectProperty obj propName cFlags set_flags gtype -constructObjectPropertyFlags :: IsGFlag a => String -> [a] -> - IO (String, GValue) -constructObjectPropertyFlags propName flags = - let cFlags = gflagsToWord flags - in constructObjectProperty propName cFlags set_flags (GType #const G_TYPE_FLAGS) +constructObjectPropertyFlags :: forall a. (IsGFlag a, BoxedFlags a) + => String -> [a] -> IO (String, GValue) +constructObjectPropertyFlags propName flags = do + let cFlags = gflagsToWord flags + gtype <- boxedFlagsType (Proxy :: Proxy a) + constructObjectProperty propName cFlags set_flags gtype -getObjectPropertyFlags :: (GObject a, IsGFlag b) => +getObjectPropertyFlags :: forall a b. (GObject a, IsGFlag b, BoxedFlags b) => a -> String -> IO [b] -getObjectPropertyFlags obj propName = - getObjectProperty obj propName - (\val -> wordToGFlags <$> get_flags val) - (GType #const G_TYPE_FLAGS) +getObjectPropertyFlags obj propName = do + gtype <- boxedFlagsType (Proxy :: Proxy b) + getObjectProperty obj propName + (\val -> wordToGFlags <$> get_flags val) + gtype setObjectPropertyVariant :: GObject a => - a -> String -> GVariant -> IO () -setObjectPropertyVariant obj propName variant = - withManagedPtr variant $ \variantPtr -> - setObjectProperty obj propName variantPtr set_variant - (GType #const G_TYPE_VARIANT) + a -> String -> Maybe GVariant -> IO () +setObjectPropertyVariant obj propName maybeVariant = + maybeWithManagedPtr maybeVariant $ \variantPtr -> + setObjectProperty obj propName variantPtr set_variant gtypeVariant -constructObjectPropertyVariant :: String -> GVariant -> IO (String, GValue) -constructObjectPropertyVariant propName obj = - withManagedPtr obj $ \objPtr -> - constructObjectProperty propName objPtr set_variant - (GType #const G_TYPE_VARIANT) +constructObjectPropertyVariant :: String -> Maybe GVariant + -> IO (String, GValue) +constructObjectPropertyVariant propName maybeVariant = + maybeWithManagedPtr maybeVariant $ \objPtr -> + constructObjectProperty propName objPtr set_variant gtypeVariant getObjectPropertyVariant :: GObject a => a -> String -> - IO GVariant + IO (Maybe GVariant) getObjectPropertyVariant obj propName = - getObjectProperty obj propName (get_variant >=> newGVariantFromPtr) - (GType #const G_TYPE_VARIANT) + getObjectProperty obj propName (get_variant >=> + flip convertIfNonNull newGVariantFromPtr) + gtypeVariant setObjectPropertyByteArray :: GObject a => - a -> String -> B.ByteString -> IO () -setObjectPropertyByteArray obj propName bytes = do + a -> String -> Maybe B.ByteString -> IO () +setObjectPropertyByteArray obj propName Nothing = + setObjectProperty obj propName nullPtr set_boxed gtypeByteArray +setObjectPropertyByteArray obj propName (Just bytes) = do packed <- packGByteArray bytes - setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_BYTE_ARRAY) + setObjectProperty obj propName packed set_boxed gtypeByteArray unrefGByteArray packed -constructObjectPropertyByteArray :: String -> B.ByteString -> +constructObjectPropertyByteArray :: String -> Maybe B.ByteString -> IO (String, GValue) -constructObjectPropertyByteArray propName bytes = do +constructObjectPropertyByteArray propName Nothing = + constructObjectProperty propName nullPtr set_boxed gtypeByteArray +constructObjectPropertyByteArray propName (Just bytes) = do packed <- packGByteArray bytes - result <- constructObjectProperty propName packed - set_boxed (GType #const G_TYPE_BYTE_ARRAY) + result <- constructObjectProperty propName packed set_boxed gtypeByteArray unrefGByteArray packed return result getObjectPropertyByteArray :: GObject a => - a -> String -> IO B.ByteString + a -> String -> IO (Maybe B.ByteString) getObjectPropertyByteArray obj propName = - getObjectProperty obj propName (get_boxed >=> unpackGByteArray) - (GType #const G_TYPE_BYTE_ARRAY) + getObjectProperty obj propName (get_boxed >=> + flip convertIfNonNull unpackGByteArray) + gtypeByteArray setObjectPropertyPtrGList :: GObject a => a -> String -> [Ptr b] -> IO () setObjectPropertyPtrGList obj propName ptrs = do packed <- packGList ptrs - setObjectProperty obj propName packed set_boxed (GType #const G_TYPE_POINTER) + setObjectProperty obj propName packed set_boxed gtypePointer g_list_free packed constructObjectPropertyPtrGList :: String -> [Ptr a] -> IO (String, GValue) constructObjectPropertyPtrGList propName ptrs = do packed <- packGList ptrs - result <- constructObjectProperty propName packed - set_boxed (GType #const G_TYPE_POINTER) + result <- constructObjectProperty propName packed set_boxed gtypePointer g_list_free packed return result getObjectPropertyPtrGList :: GObject a => a -> String -> IO [Ptr b] getObjectPropertyPtrGList obj propName = - getObjectProperty obj propName (get_pointer >=> unpackGList) - (GType #const G_TYPE_POINTER) + getObjectProperty obj propName (get_pointer >=> unpackGList) gtypePointer setObjectPropertyHash :: GObject a => a -> String -> b -> IO () setObjectPropertyHash = diff --git a/src/Data/GI/Base/ShortPrelude.hs b/src/Data/GI/Base/ShortPrelude.hs --- a/src/Data/GI/Base/ShortPrelude.hs +++ b/src/Data/GI/Base/ShortPrelude.hs @@ -1,7 +1,8 @@ -- | The Haskell Prelude exports a number of symbols that can easily -- collide with functions appearing in bindings. The generated code --- requires just a small subset of the functions in the Prelude, which --- we reexport explicitly here. +-- requires just a small subset of the functions in the Prelude, +-- together with some of the functionality in Data.GI.Base, we +-- reexport this explicitly here. module Data.GI.Base.ShortPrelude ( module Data.Char , module Data.Int @@ -20,9 +21,11 @@ , module Data.GI.Base.BasicTypes , module Data.GI.Base.BasicConversions , module Data.GI.Base.Closure + , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable , module Data.GI.Base.GParamSpec + , module Data.GI.Base.GObject , module Data.GI.Base.GVariant , module Data.GI.Base.GValue , module Data.GI.Base.ManagedPtr @@ -66,7 +69,7 @@ import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Data.ByteString.Char8 (ByteString) -import Foreign.C (CInt(..), CUInt(..), CFloat(..), CDouble(..), CString, CIntPtr(..), CUIntPtr(..)) +import Foreign.C (CInt(..), CUInt(..), CFloat(..), CDouble(..), CString, CIntPtr(..), CUIntPtr(..), CLong(..), CULong(..)) import Foreign.Ptr (Ptr, plusPtr, FunPtr, nullPtr, castFunPtrToPtr, castPtrToFunPtr) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_) @@ -80,14 +83,16 @@ import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions import Data.GI.Base.Closure +import Data.GI.Base.Constructible import Data.GI.Base.GError import Data.GI.Base.GHashTable +import Data.GI.Base.GObject import Data.GI.Base.GParamSpec import Data.GI.Base.GVariant import Data.GI.Base.GValue import Data.GI.Base.ManagedPtr import Data.GI.Base.Overloading -import Data.GI.Base.Properties hiding (new) +import Data.GI.Base.Properties import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo) import Data.GI.Base.Utils diff --git a/src/Data/GI/Base/Signals.hsc b/src/Data/GI/Base/Signals.hsc --- a/src/Data/GI/Base/Signals.hsc +++ b/src/Data/GI/Base/Signals.hsc @@ -44,10 +44,8 @@ import Data.GI.Base.Overloading (HasSignal) #endif -#include - -- | Type of a `GObject` signal handler id. -type SignalHandlerId = #type gulong +type SignalHandlerId = CULong -- | A class that provides a constraint satisfied by every type. class NoConstraint a @@ -166,7 +164,7 @@ SignalProxy o (i :: *) -> o -> GObjectNotifyCallback -> SignalConnectMode -> IO SignalHandlerId -connectGObjectNotify propName _ obj cb after = do +connectGObjectNotify propName _ obj cb mode = do cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb) let signalName = "notify::" ++ propName - connectSignalFunPtr obj signalName cb' after + connectSignalFunPtr obj signalName cb' mode diff --git a/src/Data/GI/Base/Utils.hsc b/src/Data/GI/Base/Utils.hsc --- a/src/Data/GI/Base/Utils.hsc +++ b/src/Data/GI/Base/Utils.hsc @@ -21,6 +21,7 @@ , safeFreeFunPtrPtr , maybeReleaseFunPtr , checkUnexpectedReturnNULL + , checkUnexpectedNothing ) where #include @@ -134,7 +135,7 @@ allocMem :: forall a. Storable a => IO (Ptr a) allocMem = g_malloc $ (fromIntegral . sizeOf) (undefined :: a) --- | A wrapped for `g_free`. +-- | A wrapper for `g_free`. foreign import ccall "g_free" freeMem :: Ptr a -> IO () -- | Pointer to `g_free`. @@ -177,3 +178,15 @@ <> fnName <> "\"." }) | otherwise = return () + +-- | An annotated version of `fromJust`, which raises a +-- `UnexpectedNullPointerReturn` in case it encounters a `Nothing`. +checkUnexpectedNothing :: T.Text -> IO (Maybe a) -> IO a +checkUnexpectedNothing fnName action = do + result <- action + case result of + Just r -> return r + Nothing -> throwIO (UnexpectedNullPointerReturn { + nullPtrErrorMsg = "Received unexpected nullPtr in \"" + <> fnName <> "\"." + }) diff --git a/src/c/hsgclosure.c b/src/c/hsgclosure.c --- a/src/c/hsgclosure.c +++ b/src/c/hsgclosure.c @@ -26,7 +26,7 @@ static int __print_debug_info = -1; if (__print_debug_info == -1) { - __print_debug_info = secure_getenv ("HASKELL_GI_DEBUG_MEM") != NULL; + __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL; } return __print_debug_info;