diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +### 0.22.0 + ++ Require base >= 0.4.9 (GHC version >= 8.0), so that we can use TypeApplications. + ### 0.21.5 + Add [releaseObject](https://hackage.haskell.org/package/haskell-gi-base-0.21.5/docs/Data-GI-Base-ManagedPtr.html#v:releaseObject), a function useful for manually releasing memory associated to GObjects. diff --git a/Data/GI/Base.hs b/Data/GI/Base.hs --- a/Data/GI/Base.hs +++ b/Data/GI/Base.hs @@ -8,11 +8,10 @@ ( module Data.GI.Base.Attributes , module Data.GI.Base.BasicConversions , module Data.GI.Base.BasicTypes - , module Data.GI.Base.Closure + , module Data.GI.Base.GClosure , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable - , module Data.GI.Base.GObject , module Data.GI.Base.GValue , module Data.GI.Base.GVariant , module Data.GI.Base.ManagedPtr @@ -22,11 +21,10 @@ 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.GClosure (GClosure) import Data.GI.Base.Constructible (new) import Data.GI.Base.GError import Data.GI.Base.GHashTable -import Data.GI.Base.GObject (new') import Data.GI.Base.GValue (GValue(..), IsGValue(..)) import Data.GI.Base.GVariant import Data.GI.Base.ManagedPtr diff --git a/Data/GI/Base/Attributes.hs b/Data/GI/Base/Attributes.hs --- a/Data/GI/Base/Attributes.hs +++ b/Data/GI/Base/Attributes.hs @@ -95,7 +95,7 @@ -- 'IO' monad rather than being pure. -- -- Attributes can also be set during construction of a --- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.new` +-- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Constructible.new` -- -- > button <- new Button [_label := "Can't touch this!", _sensitive := False] -- @@ -150,29 +150,22 @@ import Data.Proxy (Proxy(..)) import Data.GI.Base.GValue (GValueConstruct) -import Data.GI.Base.Overloading (HasAttributeList, - ResolveAttribute, IsLabelProxy(..)) +import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute) import GHC.TypeLits import GHC.Exts (Constraint) -#if MIN_VERSION_base(4,9,0) import GHC.OverloadedLabels (IsLabel(..)) -#endif infixr 0 :=,:~,:=>,:~> -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy --- | Support for overloaded labels. -instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where - fromLabelProxy _ = AttrLabelProxy - #if MIN_VERSION_base(4,10,0) instance a ~ x => IsLabel x (AttrLabelProxy a) where fromLabel = AttrLabelProxy -#elif MIN_VERSION_base(4,9,0) +#else instance a ~ x => IsLabel x (AttrLabelProxy a) where fromLabel _ = AttrLabelProxy #endif @@ -204,7 +197,7 @@ -- attributes). attrClear :: AttrBaseTypeConstraint info o => Proxy info -> o -> IO () - -- | Build a `GValue` representing the attribute. + -- | Build a `Data.GI.Base.GValue.GValue` representing the attribute. attrConstruct :: (AttrBaseTypeConstraint info o, AttrSetTypeConstraint info b) => Proxy info -> b -> IO (GValueConstruct o) @@ -271,8 +264,8 @@ AttrOpAllowed 'AttrSet info obj, (AttrSetTypeConstraint info) value) --- | Constraint on a @obj@\/@value@ pair so that `new` works on values --- of type @@value@. +-- | Constraint on a @obj@\/@value@ pair so that +-- `Data.GI.Base.Constructible.new` works on values of type @value@. type AttrConstructC info obj attr value = (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, diff --git a/Data/GI/Base/BasicConversions.hsc b/Data/GI/Base/BasicConversions.hsc --- a/Data/GI/Base/BasicConversions.hsc +++ b/Data/GI/Base/BasicConversions.hsc @@ -115,11 +115,11 @@ foreign import ccall "g_list_prepend" g_list_prepend :: Ptr (GList (Ptr a)) -> Ptr a -> IO (Ptr (GList (Ptr a))) --- Given a Haskell list of items, construct a GList with those values. +-- | Given a Haskell list of items, construct a GList with those values. packGList :: [Ptr a] -> IO (Ptr (GList (Ptr a))) packGList l = foldM g_list_prepend nullPtr $ reverse l --- Given a GSList construct the corresponding Haskell list. +-- | Given a GSList construct the corresponding Haskell list. unpackGList :: Ptr (GList (Ptr a)) -> IO [Ptr a] unpackGList gsl | gsl == nullPtr = return [] @@ -134,11 +134,11 @@ foreign import ccall "g_slist_prepend" g_slist_prepend :: Ptr (GSList (Ptr a)) -> Ptr a -> IO (Ptr (GSList (Ptr a))) --- Given a Haskell list of items, construct a GSList with those values. +-- | Given a Haskell list of items, construct a GSList with those values. packGSList :: [Ptr a] -> IO (Ptr (GSList (Ptr a))) packGSList l = foldM g_slist_prepend nullPtr $ reverse l --- Given a GSList construct the corresponding Haskell list. +-- | Given a GSList construct the corresponding Haskell list. unpackGSList :: Ptr (GSList (Ptr a)) -> IO [Ptr a] unpackGSList gsl = unpackGList (castPtr gsl) diff --git a/Data/GI/Base/BasicTypes.hs b/Data/GI/Base/BasicTypes.hs deleted file mode 100644 --- a/Data/GI/Base/BasicTypes.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, - DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif -#if MIN_VERSION_base(4,9,0) -{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-} -#endif --- | Basic types used in the bindings. -module Data.GI.Base.BasicTypes - ( - -- * GType related - module Data.GI.Base.GType -- reexported for convenience - - -- * Memory management - , ManagedPtr(..) - , ManagedPtrNewtype - , BoxedObject(..) - , BoxedEnum(..) - , BoxedFlags(..) - , GObject(..) - , WrappedPtr(..) - , UnexpectedNullPointerReturn(..) - , NullToNothing(..) - - -- * Basic GLib \/ GObject types - , GVariant(..) - , GParamSpec(..) - - , GArray(..) - , GPtrArray(..) - , GByteArray(..) - , GHashTable(..) - , GList(..) - , g_list_free - , GSList(..) - , g_slist_free - - , IsGFlag - - , PtrWrapped(..) - , GDestroyNotify - ) where - -#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.IORef (IORef) -import Data.Proxy (Proxy) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Foreign.Ptr (Ptr, FunPtr) -import Foreign.ForeignPtr (ForeignPtr) - -import Data.GI.Base.CallStack (CallStack) -import Data.GI.Base.GType - --- | Thin wrapper over `ForeignPtr`, supporting the extra notion of --- `disowning`, that is, not running the finalizers associated with --- the foreign ptr. -data ManagedPtr a = ManagedPtr { - managedForeignPtr :: ForeignPtr a - , managedPtrAllocCallStack :: Maybe CallStack - -- ^ `CallStack` for the call that created the pointer. - , managedPtrIsDisowned :: IORef (Maybe CallStack) - -- ^ When disowned, the `CallStack` for the disowning call. - } - --- | A constraint ensuring that the given type is coercible to a --- ManagedPtr. It will hold for newtypes of the form --- --- > newtype Foo = Foo (ManagedPtr Foo) --- --- which is the typical shape of wrapped 'GObject's. -type ManagedPtrNewtype a = Coercible a (ManagedPtr ()) --- Notice that the Coercible here is to ManagedPtr (), instead of --- "ManagedPtr a", which would be the most natural thing. Both are --- representationally equivalent, so this is not a big deal. This is --- to work around a problem in ghc 7.10: --- https://ghc.haskell.org/trac/ghc/ticket/10715 - --- | Wrapped boxed structures, identified by their `GType`. -class ManagedPtrNewtype a => BoxedObject a where - boxedType :: a -> IO GType -- This should not use the value of its - -- argument. - --- | Enums with an associated `GType`. -class BoxedEnum a where - boxedEnumType :: a -> IO GType - --- | Flags with an associated `GType`. -class BoxedFlags a where - boxedFlagsType :: Proxy a -> IO GType - --- | Pointers to structs/unions without an associated `GType`. -class ManagedPtrNewtype a => WrappedPtr a where - -- | Allocate a zero-initialized block of memory for the given type. - wrappedPtrCalloc :: IO (Ptr a) - -- | Make a copy of the given `WrappedPtr`. - wrappedPtrCopy :: a -> IO a - -- | A pointer to a function for freeing the given pointer, or - -- `Nothing` is the memory associated to the pointer does not need - -- to be freed. - wrappedPtrFree :: Maybe (FunPtr (Ptr a -> IO ())) - --- | A wrapped `GObject`. -class ManagedPtrNewtype a => GObject a where - -- | The `GType` for this object. - gobjectType :: a -> IO GType - --- | A common omission in the introspection data is missing (nullable) --- annotations for return types, when they clearly are nullable. (A --- common idiom is "Returns: valid value, or %NULL if something went --- wrong.") --- --- Haskell wrappers will raise this exception if the return value is --- an unexpected `Foreign.Ptr.nullPtr`. -data UnexpectedNullPointerReturn = - UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text } - deriving (Typeable) - -instance Show UnexpectedNullPointerReturn where - show r = T.unpack (nullPtrErrorMsg r) - -instance Exception UnexpectedNullPointerReturn - -type family UnMaybe a :: * where - UnMaybe (Maybe a) = a - UnMaybe a = a - -{-# DEPRECATED nullToNothing ["This will be removed in future versions of haskell-gi.", "If you know of wrong introspection data in a binding please report it as an issue at", "http://github.com/haskell-gi/haskell-gi", "so that it can be fixed."] #-} -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 (ManagedPtr GVariant) - --- | A . See "Data.GI.Base.GParamSpec" for further methods. -newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec) - --- | An enum usable as a flag for a function. -class Enum a => IsGFlag a - --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. -data GArray a = GArray (Ptr (GArray a)) - --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. -data GPtrArray a = GPtrArray (Ptr (GPtrArray a)) - --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. -data GByteArray = GByteArray (Ptr GByteArray) - --- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. -data GHashTable a b = GHashTable (Ptr (GHashTable a b)) - --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". -data GList a = GList (Ptr (GList a)) - --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". -data GSList a = GSList (Ptr (GSList a)) - --- | Some APIs, such as `GHashTable`, pass around scalar types --- wrapped into a pointer. We encode such a type as follows. -newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} - --- | Destroy the memory associated with a given pointer. -type GDestroyNotify a = FunPtr (Ptr a -> IO ()) - --- | Free the given 'GList'. -foreign import ccall "g_list_free" g_list_free :: - Ptr (GList a) -> IO () - --- | Free the given 'GSList'. -foreign import ccall "g_slist_free" g_slist_free :: - Ptr (GSList a) -> IO () diff --git a/Data/GI/Base/BasicTypes.hsc b/Data/GI/Base/BasicTypes.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/BasicTypes.hsc @@ -0,0 +1,187 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, + DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Basic types used in the bindings. +module Data.GI.Base.BasicTypes + ( + -- * Memory management + ManagedPtr(..) + , ManagedPtrNewtype + , BoxedObject(..) + , BoxedEnum(..) + , BoxedFlags(..) + , WrappedPtr(..) + , UnexpectedNullPointerReturn(..) + + -- * Basic GLib \/ GObject types + , GObject(..) + , GType(..) + , CGType + , gtypeName + , GVariant(..) + , GParamSpec(..) + , noGParamSpec + + , GArray(..) + , GPtrArray(..) + , GByteArray(..) + , GHashTable(..) + , GList(..) + , g_list_free + , GSList(..) + , g_slist_free + + , IsGFlag + + , PtrWrapped(..) + , GDestroyNotify + ) where + +import Control.Exception (Exception) + +import Data.Coerce (Coercible) +import Data.IORef (IORef) +import Data.Proxy (Proxy) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Data.Word + +import Foreign.C (CString, peekCString) +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.ForeignPtr (ForeignPtr) + +import Data.GI.Base.CallStack (CallStack) +import Data.GI.Base.Overloading (HasParentTypes) + +#include + +-- | Thin wrapper over `ForeignPtr`, supporting the extra notion of +-- `disowning`, that is, not running the finalizers associated with +-- the foreign ptr. +data ManagedPtr a = ManagedPtr { + managedForeignPtr :: ForeignPtr a + , managedPtrAllocCallStack :: Maybe CallStack + -- ^ `CallStack` for the call that created the pointer. + , managedPtrIsDisowned :: IORef (Maybe CallStack) + -- ^ When disowned, the `CallStack` for the disowning call. + } + +-- | A constraint ensuring that the given type is coercible to a +-- ManagedPtr. It will hold for newtypes of the form +-- +-- > newtype Foo = Foo (ManagedPtr Foo) +-- +-- which is the typical shape of wrapped 'GObject's. +type ManagedPtrNewtype a = Coercible a (ManagedPtr ()) +-- Notice that the Coercible here is to ManagedPtr (), instead of +-- "ManagedPtr a", which would be the most natural thing. Both are +-- representationally equivalent, so this is not a big deal. This is +-- to work around a problem in ghc 7.10: +-- https://ghc.haskell.org/trac/ghc/ticket/10715 + +-- | Wrapped boxed structures, identified by their `GType`. +class ManagedPtrNewtype a => BoxedObject a where + boxedType :: a -> IO GType -- This should not use the value of its + -- argument. + +-- | Enums with an associated `GType`. +class BoxedEnum a where + boxedEnumType :: a -> IO GType + +-- | Flags with an associated `GType`. +class BoxedFlags a where + boxedFlagsType :: Proxy a -> IO GType + +-- | Pointers to structs/unions without an associated `GType`. +class ManagedPtrNewtype a => WrappedPtr a where + -- | Allocate a zero-initialized block of memory for the given type. + wrappedPtrCalloc :: IO (Ptr a) + -- | Make a copy of the given `WrappedPtr`. + wrappedPtrCopy :: a -> IO a + -- | A pointer to a function for freeing the given pointer, or + -- `Nothing` is the memory associated to the pointer does not need + -- to be freed. + wrappedPtrFree :: Maybe (GDestroyNotify a) + +-- | A wrapped `GObject`. +class (ManagedPtrNewtype a, HasParentTypes a) => GObject a where + -- | The `GType` for this object. + gobjectType :: IO GType + +-- | A type identifier in the GLib type system. This is the low-level +-- type associated with the representation in memory, when using this +-- on the Haskell side use `GType` below. +type CGType = #type GType + +-- | A newtype for use on the haskell side. +newtype GType = GType {gtypeToCGType :: CGType} + +foreign import ccall "g_type_name" g_type_name :: GType -> IO CString + +-- | Get the name assigned to the given `GType`. +gtypeName :: GType -> IO String +gtypeName gtype = g_type_name gtype >>= peekCString + +-- | A common omission in the introspection data is missing (nullable) +-- annotations for return types, when they clearly are nullable. (A +-- common idiom is "Returns: valid value, or %NULL if something went +-- wrong.") +-- +-- Haskell wrappers will raise this exception if the return value is +-- an unexpected `Foreign.Ptr.nullPtr`. +data UnexpectedNullPointerReturn = + UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text } + deriving (Typeable) + +instance Show UnexpectedNullPointerReturn where + show r = T.unpack (nullPtrErrorMsg r) + +instance Exception UnexpectedNullPointerReturn + +-- | A . See "Data.GI.Base.GVariant" for further methods. +newtype GVariant = GVariant (ManagedPtr GVariant) + +-- | A . See "Data.GI.Base.GParamSpec" for further methods. +newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec) + +-- | A convenient synonym for @Nothing :: Maybe GParamSpec@. +noGParamSpec :: Maybe GParamSpec +noGParamSpec = Nothing + +-- | An enum usable as a flag for a function. +class Enum a => IsGFlag a + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GArray a = GArray (Ptr (GArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GPtrArray a = GPtrArray (Ptr (GPtrArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. +data GByteArray = GByteArray (Ptr GByteArray) + +-- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. +data GHashTable a b = GHashTable (Ptr (GHashTable a b)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GList a = GList (Ptr (GList a)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GSList a = GSList (Ptr (GSList a)) + +-- | Some APIs, such as `GHashTable`, pass around scalar types +-- wrapped into a pointer. We encode such a type as follows. +newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} + +-- | Destroy the memory associated with a given pointer. +type GDestroyNotify a = FunPtr (Ptr a -> IO ()) + +-- | Free the given 'GList'. +foreign import ccall "g_list_free" g_list_free :: + Ptr (GList a) -> IO () + +-- | Free the given 'GSList'. +foreign import ccall "g_slist_free" g_slist_free :: + Ptr (GSList a) -> IO () diff --git a/Data/GI/Base/Closure.hs b/Data/GI/Base/Closure.hs deleted file mode 100644 --- a/Data/GI/Base/Closure.hs +++ /dev/null @@ -1,41 +0,0 @@ --- Some helper functions to create closures. -module Data.GI.Base.Closure - ( Closure(..) - , newCClosure - , noClosure - ) where - -import Foreign - -import Data.GI.Base.BasicTypes -import Data.GI.Base.ManagedPtr (wrapBoxed) -import Data.GI.Base.Utils (safeFreeFunPtrPtr) - -newtype Closure = Closure (ManagedPtr Closure) - -noClosure :: Maybe Closure -noClosure = Nothing - -foreign import ccall "g_closure_get_type" c_g_closure_get_type :: - IO GType - -instance BoxedObject Closure where - boxedType _ = c_g_closure_get_type - - -foreign import ccall "g_cclosure_new" g_cclosure_new - :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure) - -foreign import ccall "g_closure_ref" g_closure_ref - :: Ptr Closure -> IO (Ptr Closure) - -foreign import ccall "g_closure_sink" g_closure_sink - :: Ptr Closure -> IO () - -newCClosure :: FunPtr a -> IO Closure -newCClosure ptr = do - closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr - -- The Haskell runtime will manage the memory associated to the - -- closure, so ref and sink to let GLib know this. - g_closure_ref closure >>= g_closure_sink - wrapBoxed Closure closure diff --git a/Data/GI/Base/Constructible.hs b/Data/GI/Base/Constructible.hs --- a/Data/GI/Base/Constructible.hs +++ b/Data/GI/Base/Constructible.hs @@ -20,7 +20,8 @@ -- | Constructible types, i.e. those which can be allocated by `new`. class Constructible a (tag :: AttrOpTag) where - new :: MonadIO m => (ManagedPtr a -> a) -> [AttrOp a tag] -> m a + -- | Allocate a new instance of the given type, with the given attributes. + new :: MonadIO m => (ManagedPtr a -> a) -> [AttrOp a tag] -> m a -- | Default instance, assuming we have a `GObject`. instance diff --git a/Data/GI/Base/GClosure.hs b/Data/GI/Base/GClosure.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GClosure.hs @@ -0,0 +1,68 @@ +-- | Some helper functions for dealing with @GClosure@s. +module Data.GI.Base.GClosure + ( GClosure(..) + , newGClosure + , wrapGClosurePtr + , newGClosureFromPtr + , noGClosure + , unrefGClosure + , disownGClosure + ) where + +import Foreign + +import Control.Monad.IO.Class (MonadIO, liftIO) + +import Data.GI.Base.BasicTypes +import Data.GI.Base.CallStack (HasCallStack) +import Data.GI.Base.ManagedPtr (newBoxed, wrapBoxed, freeBoxed, + disownManagedPtr) + +-- | The basic type. This corresponds to a wrapped @GClosure@ on the C +-- side, which is a boxed object. +newtype GClosure a = GClosure (ManagedPtr (GClosure a)) + +-- | A convenience alias for @Nothing :: Maybe (GClosure a)@. +noGClosure :: Maybe (GClosure a) +noGClosure = Nothing + +foreign import ccall "g_closure_get_type" c_g_closure_get_type :: + IO GType + +instance BoxedObject (GClosure a) where + boxedType _ = c_g_closure_get_type + +foreign import ccall "g_cclosure_new" g_cclosure_new + :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr (GClosure a)) + +-- Releasing the `FunPtr` for the signal handler. +foreign import ccall "& haskell_gi_release_signal_closure" + ptr_to_release_closure :: FunPtr (Ptr () -> Ptr () -> IO ()) + +-- | Create a new `GClosure` holding the given `FunPtr`. Note that +-- after calling this the `FunPtr` will be freed whenever the +-- `GClosure` is garbage collected, so it is generally not safe to +-- refer to the generated `FunPtr` after this function returns. +newGClosure :: MonadIO m => FunPtr a -> m (GClosure a) +newGClosure ptr = liftIO $ do + closure <- g_cclosure_new ptr nullPtr ptr_to_release_closure + wrapGClosurePtr closure + +-- | Take ownership of a passed in 'Ptr' to a 'GClosure'. +wrapGClosurePtr :: Ptr (GClosure a) -> IO (GClosure a) +wrapGClosurePtr = wrapBoxed GClosure + +-- | Construct a Haskell wrapper for the 'GClosure', without assuming +-- ownership. +newGClosureFromPtr :: Ptr (GClosure a) -> IO (GClosure a) +newGClosureFromPtr = newBoxed GClosure + +-- | Decrease the reference count of the given 'GClosure'. If the +-- reference count reaches 0 the memory will be released. +unrefGClosure :: (HasCallStack, MonadIO m) => GClosure a -> m () +unrefGClosure closure = liftIO $ freeBoxed closure + +-- | Disown (that is, remove from te purview of the Haskell Garbage +-- Collector) the given 'GClosure'. +disownGClosure :: GClosure a -> IO (Ptr (GClosure a)) +disownGClosure = disownManagedPtr diff --git a/Data/GI/Base/GObject.hsc b/Data/GI/Base/GObject.hsc --- a/Data/GI/Base/GObject.hsc +++ b/Data/GI/Base/GObject.hsc @@ -1,22 +1,72 @@ -{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module constains helpers for dealing with `GObject`-derived +-- types. + module Data.GI.Base.GObject - ( constructGObject - , new' + ( -- * Constructing new `GObject`s + constructGObject + + -- * User data + , gobjectGetUserData + , gobjectSetUserData + + -- * Deriving new object types + , DerivedGObject(..) + , registerGType + , gobjectGetPrivateData + , gobjectSetPrivateData + + , GObjectClass + , gtypeFromClass + , gtypeFromInstance + + -- * Installing properties for derived objects + , gobjectInstallProperty + , gobjectInstallCIntProperty + , gobjectInstallCStringProperty ) where import Control.Monad.IO.Class (MonadIO, liftIO) + import Data.Proxy (Proxy(..)) +import Data.Coerce (coerce) import Foreign.C (CUInt(..), CString, newCString) +import Foreign.Ptr (FunPtr) +import Foreign.StablePtr (newStablePtr, deRefStablePtr, + castStablePtrToPtr, castPtrToStablePtr) import Foreign +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T + import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy, attrConstruct) -import Data.GI.Base.BasicTypes (GType(..), GObject(..), ManagedPtr) +import Data.GI.Base.BasicTypes (CGType, GType(..), GObject(..), + GDestroyNotify, ManagedPtr(..), GParamSpec(..), + gtypeName) +import Data.GI.Base.BasicConversions (withTextCString, cstringToText) +import Data.GI.Base.CallStack (HasCallStack, prettyCallStack) +import Data.GI.Base.GParamSpec (PropertyInfo(..), + gParamSpecValue, + CIntPropertyInfo(..), CStringPropertyInfo(..), + gParamSpecCInt, gParamSpecCString, + getGParamSpecGetterSetter, + PropGetSetter(..)) +import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString) import Data.GI.Base.GValue (GValue(..), GValueConstruct(..)) import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject) import Data.GI.Base.Overloading (ResolveAttribute) +import Data.GI.Base.Utils (dbgLog) #include @@ -24,7 +74,8 @@ GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b) -- | Construct a GObject given the constructor and a list of settable --- attributes. +-- attributes. See `Data.GI.Base.Constructible.new` for a more general +-- version. constructGObject :: forall o m. (GObject o, MonadIO m) => (ManagedPtr o -> o) -> [AttrOp o 'AttrConstruct] @@ -49,7 +100,7 @@ names <- mallocBytes (nprops * sizeOf nullPtr) values <- mallocBytes (nprops * gvalueSize) fill names values props - gtype <- gobjectType (undefined :: o) + gtype <- gobjectType @o result <- g_object_new gtype (fromIntegral nprops) names values freeStrings nprops names free values @@ -89,10 +140,221 @@ do peek namePtr >>= free freeStrings (n-1) (namePtr `plusPtr` sizeOf nullPtr) --- | Construct the given `GObject`, given a set of actions --- constructing desired `GValue`s to set at construction time. -new' :: (MonadIO m, GObject o) => - (ManagedPtr o -> o) -> [IO (GValueConstruct o)] -> m o -new' constructor actions = do - props <- liftIO $ sequence (actions) - doConstructGObject constructor props +-- | Opaque wrapper around @GObjectClass@ on the C-side. +newtype GObjectClass = GObjectClass (Ptr GObjectClass) + +-- | This typeclass contains the data necessary for defining a new +-- `GObject` type from Haskell. +class GObject a => DerivedGObject a where + -- | The parent type + type GObjectParentType a + -- | Type of the private data for each instance. + type GObjectPrivateData a + + -- | Name of the type, it should be unique. + objectTypeName :: Text + -- | Code to run when the class is inited. This is a good place to + -- register signals and properties for the type. + objectClassInit :: GObjectClass -> IO () + -- | Code to run when each instance of the type is + -- constructed. Returns the private data to be associated with the + -- new instance (use `gobjectGetPrivateData` and + -- `gobjectSetPrivateData` to manipulate this further). + objectInstanceInit :: GObjectClass -> IO (GObjectPrivateData a) + +type CGTypeClassInit = GObjectClass -> IO () +foreign import ccall "wrapper" + mkClassInit :: CGTypeClassInit -> IO (FunPtr CGTypeClassInit) + +type CGTypeInstanceInit o = Ptr o -> GObjectClass -> IO () +foreign import ccall "wrapper" + mkInstanceInit :: CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o)) + +foreign import ccall g_type_from_name :: CString -> IO CGType + +foreign import ccall "haskell_gi_register_gtype" register_gtype :: + CGType -> CString -> FunPtr CGTypeClassInit -> + FunPtr (CGTypeInstanceInit o) -> IO CGType + +foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class :: + GObjectClass -> IO CGType + +-- | Find the `GType` associated to a given `GObjectClass`. +gtypeFromClass :: GObjectClass -> IO GType +gtypeFromClass klass = GType <$> gtype_from_class klass + +foreign import ccall "haskell_gi_gtype_from_instance" gtype_from_instance :: + Ptr o -> IO CGType + +-- | Find the `GType` for a given `GObject`. +gtypeFromInstance :: GObject o => o -> IO GType +gtypeFromInstance obj = withManagedPtr obj $ \objPtr -> + (GType <$> gtype_from_instance objPtr) + +foreign import ccall g_param_spec_get_name :: + Ptr GParamSpec -> IO CString + +type CPropertyGetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO () + +foreign import ccall "wrapper" + mkPropertyGetter :: CPropertyGetter o -> IO (FunPtr (CPropertyGetter o)) + +type CPropertySetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO () + +foreign import ccall "wrapper" + mkPropertySetter :: CPropertySetter o -> IO (FunPtr (CPropertySetter o)) + +-- | Register the given type into the @GObject@ type system and return +-- the resulting `GType`, if it has not been registered already. If +-- the type has been registered already the existing `GType` will be +-- returned instead. +-- +-- Note that for this function to work the type must be an instance of +-- `DerivedGObject`. +registerGType :: forall o. (HasCallStack, DerivedGObject o, + GObject (GObjectParentType o)) => + (ManagedPtr o -> o) -> IO GType +registerGType _ = withTextCString (objectTypeName @o) $ \cTypeName -> do + cgtype <- g_type_from_name cTypeName + if cgtype /= 0 + then return (GType cgtype) -- Already registered + else do + classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o) + instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o) + (GType parentCGType) <- gobjectType @(GObjectParentType o) + GType <$> register_gtype parentCGType cTypeName classInit instanceInit + + where + unwrapInstanceInit :: (GObjectClass -> IO (GObjectPrivateData o)) -> + CGTypeInstanceInit o + unwrapInstanceInit instanceInit objPtr klass = do + privateData <- instanceInit klass + instanceSetPrivateData objPtr privateData + + unwrapClassInit :: (GObjectClass -> IO ()) -> CGTypeClassInit + unwrapClassInit classInit klass@(GObjectClass klassPtr) = do + getFunPtr <- mkPropertyGetter marshallGetter + (#poke GObjectClass, get_property) klassPtr getFunPtr + setFunPtr <- mkPropertySetter marshallSetter + (#poke GObjectClass, set_property) klassPtr setFunPtr + classInit klass + + marshallSetter :: CPropertySetter o + marshallSetter objPtr _ gvPtr pspecPtr = do + maybeGetSet <- getGParamSpecGetterSetter pspecPtr + case maybeGetSet of + Nothing -> do + pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText + typeName <- gobjectType @o >>= gtypeName + dbgLog $ "WARNING: Attempting to set unknown property \"" + <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"." + Just pgs -> (propSetter pgs) objPtr gvPtr + + marshallGetter :: CPropertyGetter o + marshallGetter objPtr _ destGValuePtr pspecPtr = do + maybeGetSet <- getGParamSpecGetterSetter pspecPtr + case maybeGetSet of + Nothing -> do + pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText + typeName <- gobjectType @o >>= gtypeName + dbgLog $ "WARNING: Attempting to get unknown property \"" + <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"." + Just pgs -> (propGetter pgs) objPtr destGValuePtr + +-- | Quark with the key to the private data for this object type. +privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o)) +privateKey = gQuarkFromString $ objectTypeName @o <> "::haskell-gi-private-data" + +-- | Get the private data associated with the given object. +gobjectGetPrivateData :: forall o. (HasCallStack, DerivedGObject o) => + o -> IO (GObjectPrivateData o) +gobjectGetPrivateData obj = do + key <- privateKey @o + maybePriv <- gobjectGetUserData obj key + case maybePriv of + Just priv -> return priv + Nothing -> do + case managedPtrAllocCallStack (coerce obj) of + Nothing -> error ("Failed to get private data pointer!\n" + <> "Set the env var HASKELL_GI_DEBUG_MEM=1 to get more info.") + Just cs -> withManagedPtr obj $ \objPtr -> do + let errMsg = "Failed to get private data pointer for" <> show objPtr <> "!\n" + <> "Callstack for allocation was:\n" + <> prettyCallStack cs <> "\n\n" + error errMsg + +foreign import ccall g_object_get_qdata :: + Ptr a -> GQuark b -> IO (Ptr c) + +-- | Get the value of a given key for the object. +gobjectGetUserData :: (HasCallStack, GObject o) => o -> GQuark a -> IO (Maybe a) +gobjectGetUserData obj key = do + dataPtr <- withManagedPtr obj $ \objPtr -> + g_object_get_qdata objPtr key + if dataPtr /= nullPtr + then Just <$> deRefStablePtr (castPtrToStablePtr dataPtr) + else return Nothing + +foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr :: + FunPtr (GDestroyNotify a) + +foreign import ccall g_object_set_qdata_full :: + Ptr a -> GQuark b -> Ptr () -> FunPtr (GDestroyNotify ()) -> IO () + +-- | Set the value of the user data for the given `GObject` to a +-- `StablePtr` to the given Haskell object. The `StablePtr` will be +-- freed when the object is destroyed, or the value is replaced. +gobjectSetUserData :: (HasCallStack, GObject o) => + o -> GQuark a -> a -> IO () +gobjectSetUserData obj key value = withManagedPtr obj $ \objPtr -> + instanceSetUserData objPtr key value + +-- | Like `gobjectSetUserData`, but it works on the raw object pointer +-- (so this is unsafe, unless used in a context where we are sure that +-- the GC will not release the object while we run). +instanceSetUserData :: (HasCallStack, GObject o) => + Ptr o -> GQuark a -> a -> IO () +instanceSetUserData objPtr key value = do + stablePtr <- newStablePtr value + g_object_set_qdata_full objPtr key (castStablePtrToPtr stablePtr) + ptr_to_hs_free_stable_ptr + +-- | Set the private data associated with the given object. +gobjectSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) => + o -> GObjectPrivateData o -> IO () +gobjectSetPrivateData obj value = withManagedPtr obj $ \objPtr -> + instanceSetPrivateData objPtr value + +-- | Set the private data for a given instance. +instanceSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) => + Ptr o -> GObjectPrivateData o -> IO () +instanceSetPrivateData objPtr priv = do + key <- privateKey @o + instanceSetUserData objPtr key priv + +foreign import ccall g_object_class_install_property :: + GObjectClass -> CUInt -> Ptr GParamSpec -> IO () + +-- | Add a Haskell object-valued property to the given object class. +gobjectInstallProperty :: DerivedGObject o => + GObjectClass -> PropertyInfo o a -> IO () +gobjectInstallProperty klass propInfo = do + pspec <- gParamSpecValue propInfo + withManagedPtr pspec $ \pspecPtr -> + g_object_class_install_property klass 1 pspecPtr + +-- | Add a `Foreign.C.CInt`-valued property to the given object class. +gobjectInstallCIntProperty :: DerivedGObject o => + GObjectClass -> CIntPropertyInfo o -> IO () +gobjectInstallCIntProperty klass propInfo = do + pspec <- gParamSpecCInt propInfo + withManagedPtr pspec $ \pspecPtr -> + g_object_class_install_property klass 1 pspecPtr + +-- | Add a `CString`-valued property to the given object class. +gobjectInstallCStringProperty :: DerivedGObject o => + GObjectClass -> CStringPropertyInfo o -> IO () +gobjectInstallCStringProperty klass propInfo = do + pspec <- gParamSpecCString propInfo + withManagedPtr pspec $ \pspecPtr -> + g_object_class_install_property klass 1 pspecPtr diff --git a/Data/GI/Base/GParamSpec.hsc b/Data/GI/Base/GParamSpec.hsc --- a/Data/GI/Base/GParamSpec.hsc +++ b/Data/GI/Base/GParamSpec.hsc @@ -1,23 +1,53 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Management of `GParamSpec`s. module Data.GI.Base.GParamSpec - ( noGParamSpec + ( -- * Memory management + wrapGParamSpecPtr + , newGParamSpecFromPtr + , unrefGParamSpec + , disownGParamSpec - , wrapGParamSpecPtr - , newGParamSpecFromPtr - , unrefGParamSpec - , disownGParamSpec - ) where + -- * GParamSpec building + , PropertyInfo(..) + , gParamSpecValue + , CStringPropertyInfo(..) + , gParamSpecCString + , CIntPropertyInfo(..) + , gParamSpecCInt -import Foreign.Ptr + -- * Get\/Set + , PropGetSetter(..) + , getGParamSpecGetterSetter + ) where + +import Foreign.C (CInt(..), CString) +import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr) +import Foreign.StablePtr (newStablePtr, deRefStablePtr, + castStablePtrToPtr, castPtrToStablePtr) import Control.Monad (void) +import Data.Coerce (coerce) +import Data.Maybe (fromMaybe) +import Data.Text (Text) -import Data.GI.Base.ManagedPtr (newManagedPtr', withManagedPtr, disownManagedPtr) -import Data.GI.Base.BasicTypes (GParamSpec(..)) +import Data.GI.Base.ManagedPtr (newManagedPtr', withManagedPtr, + disownManagedPtr, + newObject, withTransient) +import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString) +import Data.GI.Base.BasicTypes (GObject(..), GParamSpec(..), + GType(..), IsGFlag, ManagedPtr) +import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString) +import Data.GI.Base.GType (gtypeStablePtr) +import qualified Data.GI.Base.GValue as GV +import Data.GI.Base.GValue (GValue(..), IsGValue(..), take_stablePtr) #include -noGParamSpec :: Maybe GParamSpec -noGParamSpec = Nothing - foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink :: Ptr GParamSpec -> IO (Ptr GParamSpec) foreign import ccall "g_param_spec_ref" g_param_spec_ref :: @@ -50,3 +80,277 @@ -- collected. disownGParamSpec :: GParamSpec -> IO (Ptr GParamSpec) disownGParamSpec = disownManagedPtr + +{- | Flags controlling the behaviour of the the parameters. -} +data GParamFlag = GParamReadable + {- ^ the parameter is readable -} + | GParamWritable + {- ^ the parameter is writable -} + | GParamConstruct + {- ^ the parameter will be set upon object construction -} + | GParamConstructOnly + {- ^ the parameter can only be set upon object construction -} + | GParamExplicitNotify + {- ^ calls to 'GI.GObject.Objects.Object.objectSetProperty' for this +property will not automatically result in a \"notify\" signal being +emitted: the implementation must call +'GI.GObject.Objects.Object.objectNotify' themselves in case the +property actually changes. -} + | AnotherGParamFlag Int + -- ^ Catch-all for unknown values + deriving (Show, Eq) + +instance Enum GParamFlag where + fromEnum GParamReadable = #const G_PARAM_READABLE + fromEnum GParamWritable = #const G_PARAM_WRITABLE + fromEnum GParamConstruct = #const G_PARAM_CONSTRUCT + fromEnum GParamConstructOnly = #const G_PARAM_CONSTRUCT_ONLY + fromEnum GParamExplicitNotify = #const G_PARAM_EXPLICIT_NOTIFY + fromEnum (AnotherGParamFlag k) = k + + toEnum (#const G_PARAM_READABLE) = GParamReadable + toEnum (#const G_PARAM_WRITABLE) = GParamWritable + toEnum (#const G_PARAM_CONSTRUCT) = GParamConstruct + toEnum (#const G_PARAM_CONSTRUCT_ONLY) = GParamConstructOnly + toEnum (#const G_PARAM_EXPLICIT_NOTIFY) = GParamExplicitNotify + toEnum k = AnotherGParamFlag k + +instance Ord GParamFlag where + compare a b = compare (fromEnum a) (fromEnum b) + +instance IsGFlag GParamFlag + +-- | Default set of flags when constructing properties. +defaultFlags :: Num a => a +defaultFlags = gflagsToWord [GParamReadable, GParamWritable, + GParamExplicitNotify] + +-- | Low-level getter and setter for the property. +data PropGetSetter o = PropGetSetter + { propGetter :: Ptr o -> Ptr GValue -> IO () + , propSetter :: Ptr o -> Ptr GValue -> IO () + } + +-- | The `GQuark` pointing to the setter and getter of the property. +pspecQuark :: IO (GQuark (PropGetSetter o)) +pspecQuark = gQuarkFromString "haskell-gi-get-set" + +-- | The basic constructor for a GObject. They are all isomorphic. +newtype GObjectConstructor = GObjectConstructor (ManagedPtr GObjectConstructor) + +-- | Construct a copy of the object from the given pointer. +objectFromPtr :: forall a o. GObject o => Ptr a -> IO o +objectFromPtr objPtr = newObject @o @o (coerce @_ @(ManagedPtr o -> o) GObjectConstructor) (castPtr objPtr) + +-- | Wrap a Haskell getter/setter into a lower level one. +wrapGetSet :: forall o a. (GObject o, IsGValue a) => + (o -> IO a) -- ^ Haskell side getter + -> (o -> a -> IO ()) -- ^ Haskell side setter + -> (GValue -> a -> IO ()) -- ^ Setter for the `GValue` + -> PropGetSetter o +wrapGetSet getter setter gvalueSetter = PropGetSetter { + propGetter = \objPtr destPtr -> do + value <- objectFromPtr objPtr >>= getter + withTransient GValue destPtr $ \dest -> gvalueSetter dest value + , propSetter = \objPtr newGValuePtr -> + withTransient GValue newGValuePtr $ \newGValue -> do + obj <- objectFromPtr objPtr + value <- fromGValue newGValue + setter obj value + } + +-- | Information on a property encoding a Haskell value. Note that +-- from the C side this property will appear as an opaque pointer. Use +-- the specialized constructors below for creating properties +-- meaningful from the C side. +-- +-- A property name consists of segments consisting of ASCII letters +-- and digits, separated by either the \'-\' or \'_\' character. The +-- first character of a property name must be a letter. Names which +-- violate these rules lead to undefined behaviour. +-- +-- When creating and looking up a property, either separator can be +-- used, but they cannot be mixed. Using \'-\' is considerably more +-- efficient and in fact required when using property names as detail +-- strings for signals. +-- +-- Beyond the name, properties have two more descriptive strings +-- associated with them, the @nick@, which should be suitable for use +-- as a label for the property in a property editor, and the @blurb@, +-- which should be a somewhat longer description, suitable for e.g. a +-- tooltip. The @nick@ and @blurb@ should ideally be localized. +data PropertyInfo o a = PropertyInfo + { name :: Text -- ^ Identifier for the property. + , nick :: Text -- ^ Identifier for display to the user. + , blurb :: Text -- ^ Description of the property. + , setter :: o -> a -> IO () -- ^ Handler invoked when the + -- property is being set. + , getter :: o -> IO a -- ^ Handler that returns the current + -- value of the property. + , flags :: Maybe [GParamFlag] -- ^ Set of flags, or `Nothing` for + -- the default set of flags. + } + +foreign import ccall g_param_spec_boxed :: + CString -> CString -> CString -> GType -> CInt -> IO (Ptr GParamSpec) + +-- | Create a `GParamSpec` for a Haskell value. +gParamSpecValue :: forall o a. GObject o => PropertyInfo o a -> IO GParamSpec +gParamSpecValue (PropertyInfo {..}) = + withTextCString name $ \cname -> + withTextCString nick $ \cnick -> + withTextCString blurb $ \cblurb -> do + ctype <- gtypeStablePtr + pspecPtr <- g_param_spec_boxed cname cnick cblurb + ctype + (maybe defaultFlags gflagsToWord flags) + quark <- pspecQuark @o + gParamSpecSetQData pspecPtr quark + (PropGetSetter { propGetter = getter', propSetter = setter'}) + wrapGParamSpecPtr pspecPtr + where + getter' :: Ptr o -> Ptr GValue -> IO () + getter' objPtr destPtr = do + stablePtr <- objectFromPtr objPtr >>= getter >>= newStablePtr + take_stablePtr destPtr stablePtr + + setter' :: Ptr o -> (Ptr GValue) -> IO () + setter' objPtr gvPtr = withTransient GValue gvPtr $ \gv -> do + obj <- objectFromPtr objPtr + val <- fromGValue gv >>= deRefStablePtr + setter obj val + +-- | Information on a property of type `CInt` to be registered. A +-- property name consists of segments consisting of ASCII letters and +-- digits, separated by either the \'-\' or \'_\' character. The first +-- character of a property name must be a letter. Names which violate +-- these rules lead to undefined behaviour. +-- +-- When creating and looking up a property, either separator can be +-- used, but they cannot be mixed. Using \'-\' is considerably more +-- efficient and in fact required when using property names as detail +-- strings for signals. +-- +-- Beyond the name, properties have two more descriptive strings +-- associated with them, the @nick@, which should be suitable for use +-- as a label for the property in a property editor, and the @blurb@, +-- which should be a somewhat longer description, suitable for e.g. a +-- tooltip. The @nick@ and @blurb@ should ideally be localized. +data CIntPropertyInfo o = CIntPropertyInfo + { name :: Text -- ^ Identifier for the property. + , nick :: Text -- ^ Identifier for display to the user. + , blurb :: Text -- ^ Description of the property. + , defaultValue :: CInt -- ^ Default value. + , setter :: o -> CInt -> IO () -- ^ Handler invoked when the + -- property is being set. + , getter :: o -> IO CInt -- ^ Handler that returns the current + -- value of the property. + , flags :: Maybe [GParamFlag] -- ^ Set of flags, or `Nothing` for + -- the default set of flags. + , minValue :: Maybe CInt -- ^ Minimum value, or `Nothing`, + -- which would be replaced by + -- @MININT@. + , maxValue :: Maybe CInt -- ^ Maximum value, or `Nothing`, + -- which would be replaced by + -- @MAXINT@. + } + +foreign import ccall g_param_spec_int :: + CString -> CString -> CString -> CInt -> CInt -> CInt -> CInt + -> IO (Ptr GParamSpec) + +-- | Create a `GParamSpec` for an integer param. +gParamSpecCInt :: GObject o => CIntPropertyInfo o -> IO GParamSpec +gParamSpecCInt (CIntPropertyInfo {..}) = + withTextCString name $ \cname -> + withTextCString nick $ \cnick -> + withTextCString blurb $ \cblurb -> do + pspecPtr <- g_param_spec_int cname cnick cblurb + (fromMaybe minBound minValue) + (fromMaybe maxBound maxValue) + defaultValue + (maybe defaultFlags gflagsToWord flags) + quark <- pspecQuark + gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter GV.set_int) + wrapGParamSpecPtr pspecPtr + +-- | Information on a property of type `Text` to be registered. A +-- property name consists of segments consisting of ASCII letters and +-- digits, separated by either the \'-\' or \'_\' character. The first +-- character of a property name must be a letter. Names which violate +-- these rules lead to undefined behaviour. +-- +-- When creating and looking up a property, either separator can be +-- used, but they cannot be mixed. Using \'-\' is considerably more +-- efficient and in fact required when using property names as detail +-- strings for signals. +-- +-- Beyond the name, properties have two more descriptive strings +-- associated with them, the @nick@, which should be suitable for use +-- as a label for the property in a property editor, and the @blurb@, +-- which should be a somewhat longer description, suitable for e.g. a +-- tooltip. The @nick@ and @blurb@ should ideally be localized. +data CStringPropertyInfo o = CStringPropertyInfo + { name :: Text + , nick :: Text + , blurb :: Text + , defaultValue :: Maybe Text + , flags :: Maybe [GParamFlag] + , setter :: o -> Maybe Text -> IO () + , getter :: o -> IO (Maybe Text) + } + +foreign import ccall g_param_spec_string :: + CString -> CString -> CString -> CString -> CInt -> IO (Ptr GParamSpec) + +-- | Create a `GParamSpec` for a string param. +gParamSpecCString :: GObject o => CStringPropertyInfo o -> IO GParamSpec +gParamSpecCString (CStringPropertyInfo {..}) = + withTextCString name $ \cname -> + withTextCString nick $ \cnick -> + withTextCString blurb $ \cblurb -> do + pspecPtr <- case defaultValue of + Nothing -> g_param_spec_string cname cnick cblurb nullPtr + (maybe defaultFlags gflagsToWord flags) + Just value -> + withTextCString value $ \cdefault -> + g_param_spec_string cname cnick cblurb cdefault + (maybe defaultFlags gflagsToWord flags) + quark <- pspecQuark + gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter GV.set_string) + wrapGParamSpecPtr pspecPtr + +foreign import ccall g_param_spec_set_qdata_full :: + Ptr GParamSpec -> GQuark a -> Ptr b -> FunPtr (Ptr c -> IO ()) -> IO () + +foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr :: + FunPtr (Ptr a -> IO ()) + +-- | Set the given user data on the `GParamSpec`. +gParamSpecSetQData :: Ptr GParamSpec -> GQuark a -> a -> IO () +gParamSpecSetQData pspecPtr quark d = do + ptr <- newStablePtr d + g_param_spec_set_qdata_full pspecPtr quark + (castStablePtrToPtr ptr) + ptr_to_hs_free_stable_ptr + +foreign import ccall g_param_spec_get_qdata :: + Ptr GParamSpec -> GQuark a -> IO (Ptr b) + +-- | Get the user data for the given `GQuark` on the `GParamSpec`. +gParamSpecGetQData :: Ptr GParamSpec -> GQuark a -> IO (Maybe a) +gParamSpecGetQData pspecPtr quark = do + ptr <- g_param_spec_get_qdata pspecPtr quark + if ptr /= nullPtr + then Just <$> deRefStablePtr (castPtrToStablePtr ptr) + else return Nothing + +-- | Attempt to get the Haskell setter and getter for the given +-- `GParamSpec`. This will only be possible if the `GParamSpec` was +-- created with one of the functions above, if this is not the case +-- the function will return `Nothing`. +getGParamSpecGetterSetter :: forall o. Ptr GParamSpec -> + IO (Maybe (PropGetSetter o)) +getGParamSpecGetterSetter pspecPtr = do + quark <- pspecQuark @o + gParamSpecGetQData pspecPtr quark diff --git a/Data/GI/Base/GQuark.hsc b/Data/GI/Base/GQuark.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GQuark.hsc @@ -0,0 +1,22 @@ +-- | Basic support for `GQuark`s. +module Data.GI.Base.GQuark + ( GQuark(..) + , gQuarkFromString + ) where + +import Data.Text (Text) +import Data.Word +import Foreign.C (CString) + +import Data.GI.Base.BasicConversions (withTextCString) + +#include + +-- | A `GQuark`, which is simply an integer. +newtype GQuark a = GQuark (#type GQuark) + +foreign import ccall g_quark_from_string :: CString -> IO (GQuark a) + +-- | Construct a GQuark from the given string. +gQuarkFromString :: Text -> IO (GQuark a) +gQuarkFromString text = withTextCString text g_quark_from_string diff --git a/Data/GI/Base/GType.hsc b/Data/GI/Base/GType.hsc --- a/Data/GI/Base/GType.hsc +++ b/Data/GI/Base/GType.hsc @@ -1,11 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Basic `GType`s. module Data.GI.Base.GType - ( GType(..) - , CGType - - , gtypeName - - , gtypeString + ( gtypeString , gtypePointer , gtypeInt , gtypeUInt @@ -23,26 +20,20 @@ , gtypeVariant , gtypeByteArray , gtypeInvalid - ) where -import Data.Word -import Foreign.C.String (CString, peekCString) - -#include + , gtypeStablePtr + ) where --- | A type identifier in the GLib type system. This is the low-level --- type associated with the representation in memory, when using this --- on the Haskell side use `GType` below. -type CGType = #type GType +import Control.Monad ((>=>)) --- | A newtype for use on the haskell side. -newtype GType = GType {gtypeToCGType :: CGType} +import Foreign.C.String (CString) +import Foreign.Ptr (FunPtr) +import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr) -foreign import ccall "g_type_name" g_type_name :: GType -> IO CString +import Data.GI.Base.BasicConversions (withTextCString) +import Data.GI.Base.BasicTypes (GType(..), CGType) --- | Get the name assigned to the given `GType`. -gtypeName :: GType -> IO String -gtypeName gtype = g_type_name gtype >>= peekCString +#include {-| [Note: compile-time vs run-time GTypes] @@ -68,19 +59,19 @@ gtypePointer :: GType gtypePointer = GType #const G_TYPE_POINTER --- | `GType` for signed integers (`gint` or `gint32`). +-- | `GType` for signed integers (@gint@ or @gint32@). gtypeInt :: GType gtypeInt = GType #const G_TYPE_INT --- | `GType` for unsigned integers (`guint` or `guint32`). +-- | `GType` for unsigned integers (@guint@ or @guint32@). gtypeUInt :: GType gtypeUInt = GType #const G_TYPE_UINT --- | `GType` for `glong`. +-- | `GType` for @glong@. gtypeLong :: GType gtypeLong = GType #const G_TYPE_LONG --- | `GType` for `gulong`. +-- | `GType` for @gulong@. gtypeULong :: GType gtypeULong = GType #const G_TYPE_ULONG @@ -104,11 +95,11 @@ gtypeBoolean :: GType gtypeBoolean = GType #const G_TYPE_BOOLEAN --- | `GType` corresponding to a `BoxedObject`. +-- | `GType` corresponding to a boxed object. gtypeBoxed :: GType gtypeBoxed = GType #const G_TYPE_BOXED --- | `GType` corresponding to a `GObject`. +-- | `GType` corresponding to a @GObject@. gtypeObject :: GType gtypeObject = GType #const G_TYPE_OBJECT @@ -117,7 +108,7 @@ gtypeInvalid :: GType gtypeInvalid = GType #const G_TYPE_INVALID --- | The `GType` corresponding to a `GVariant`. +-- | The `GType` corresponding to a @GVariant@. gtypeVariant :: GType gtypeVariant = GType #const G_TYPE_VARIANT @@ -137,6 +128,30 @@ foreign import ccall "g_byte_array_get_type" g_byte_array_get_type :: CGType --- | `GType` for a boxed type holding a `GByteArray`. +-- | `GType` for a boxed type holding a @GByteArray@. gtypeByteArray :: GType gtypeByteArray = GType g_byte_array_get_type + +-- | Given a `StablePtr`, make a new `StablePtr` to the same +-- underlying Haskell value. +duplicateStablePtr :: StablePtr a -> IO (StablePtr a) +duplicateStablePtr = deRefStablePtr >=> newStablePtr + +foreign import ccall "wrapper" + mkStablePtrDuplicator :: (StablePtr a -> IO (StablePtr a)) -> + IO (FunPtr (StablePtr a -> IO (StablePtr a))) + +foreign import ccall haskell_gi_register_Boxed_HsStablePtr :: + CString -> FunPtr (StablePtr a -> IO (StablePtr a)) -> IO GType + +foreign import ccall haskell_gi_Boxed_StablePtr_GType :: IO CGType + +-- | The `GType` for boxed `StablePtr`s. +gtypeStablePtr :: IO GType +gtypeStablePtr = withTextCString "Boxed-HsStablePtr" $ \cTypeName -> do + cgtype <- haskell_gi_Boxed_StablePtr_GType + if cgtype /= 0 + then return (GType cgtype) -- Already registered + else do + duplicator <- mkStablePtrDuplicator duplicateStablePtr + haskell_gi_register_Boxed_HsStablePtr cTypeName duplicator diff --git a/Data/GI/Base/GValue.hsc b/Data/GI/Base/GValue.hsc --- a/Data/GI/Base/GValue.hsc +++ b/Data/GI/Base/GValue.hsc @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Data.GI.Base.GValue ( -- * Constructing GValues @@ -49,14 +50,13 @@ , get_enum , set_flags , get_flags + , set_stablePtr + , get_stablePtr + , take_stablePtr ) where #include -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - import Data.Coerce (coerce) import Data.Word import Data.Int @@ -66,13 +66,15 @@ CLong(..), CULong(..)) import Foreign.C.String (CString) import Foreign.Ptr (Ptr, nullPtr) +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.Utils (callocBytes, freeMem) +-- | Haskell-side representation of a @GValue@. newtype GValue = GValue (ManagedPtr GValue) -- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@. @@ -175,6 +177,12 @@ toGValue = buildGValue gtypeGType set_gtype fromGValue = get_gtype +instance IsGValue (StablePtr a) where + toGValue val = do + gtype <- gtypeStablePtr + buildGValue gtype set_stablePtr val + 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 :: @@ -384,3 +392,17 @@ 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 diff --git a/Data/GI/Base/ManagedPtr.hs b/Data/GI/Base/ManagedPtr.hs --- a/Data/GI/Base/ManagedPtr.hs +++ b/Data/GI/Base/ManagedPtr.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -- For HasCallStack compatibility {-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} -- | We wrap most objects in a "managed pointer", which is basically a -- 'ForeignPtr' of the appropriate type together with a notion of @@ -27,6 +28,7 @@ -- * Safe casting , castTo , unsafeCastTo + , checkInstanceType -- * Wrappers , newObject @@ -207,20 +209,26 @@ -- Safe casting machinery foreign import ccall unsafe "check_object_type" - c_check_object_type :: Ptr o -> CGType -> CInt + c_check_object_type :: Ptr o -> CGType -> IO CInt +-- | Check whether the given object is an instance of the given type. +checkInstanceType :: GObject o => o -> GType -> IO Bool +checkInstanceType obj (GType cgtype) = withManagedPtr obj $ \objPtr -> do + check <- c_check_object_type objPtr cgtype + return $ check /= 0 + -- | Cast to the given type, checking that the cast is valid. If it is -- not, we return `Nothing`. Usage: -- -- > maybeWidget <- castTo Widget label castTo :: forall o o'. (GObject o, GObject o') => (ManagedPtr o' -> o') -> o -> IO (Maybe o') -castTo constructor obj = - withManagedPtr obj $ \objPtr -> do - GType t <- gobjectType (undefined :: o') - if c_check_object_type objPtr t /= 1 - then return Nothing - else Just <$> newObject constructor objPtr +castTo constructor obj = withManagedPtr obj $ \objPtr -> do + gtype <- gobjectType @o' + isInstance <- checkInstanceType obj gtype + if isInstance + then Just <$> newObject constructor objPtr + else return Nothing -- | Cast to the given type, assuming that the cast will succeed. This -- function will call `error` if the cast is illegal. @@ -228,11 +236,12 @@ (ManagedPtr o' -> o') -> o -> IO o' unsafeCastTo constructor obj = withManagedPtr obj $ \objPtr -> do - GType t <- gobjectType (undefined :: o') - if c_check_object_type objPtr t /= 1 + gtype <- gobjectType @o' + isInstance <- checkInstanceType obj gtype + if not isInstance then do - srcType <- gobjectType obj >>= gtypeName - destType <- gobjectType (undefined :: o') >>= gtypeName + srcType <- gobjectType @o >>= gtypeName + destType <- gobjectType @o' >>= gtypeName error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to " ++ destType ++ " requested." else newObject constructor objPtr diff --git a/Data/GI/Base/Overloading.hs b/Data/GI/Base/Overloading.hs --- a/Data/GI/Base/Overloading.hs +++ b/Data/GI/Base/Overloading.hs @@ -2,15 +2,14 @@ TypeFamilies, UndecidableInstances, EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} --- | Helpers for dealing with `GObject`s. +-- | Helpers for dealing with overladed properties, signals and +-- methods. module Data.GI.Base.Overloading ( -- * Type level inheritance ParentTypes + , HasParentTypes , IsDescendantOf -#if MIN_VERSION_base(4,9,0) - , UnknownAncestorError -#endif -- * Looking up attributes in parent types , AttributeList @@ -28,99 +27,58 @@ , MethodInfo(..) , MethodProxy(..) , MethodResolutionFailed - - -- * Overloaded labels - , IsLabelProxy(..) - -#if MIN_VERSION_base(4,9,0) - , module GHC.OverloadedLabels -- Reexported for convenience -#endif ) where import GHC.Exts (Constraint) import GHC.TypeLits -import Data.Proxy (Proxy) -#if MIN_VERSION_base(4,9,0) -import GHC.OverloadedLabels (IsLabel(..)) -#endif - --- | Support for overloaded labels in ghc < 8.0. This is like the --- `IsLabel` class introduced in ghc 8.0 (for use with the --- OverloadedLabels extension) with the difference that the `Proxy` --- argument is lifted. (Using the unlifted Proxy# type in user code is --- a bit of a pain, hence the choice.) -class IsLabelProxy (x :: Symbol) a where - fromLabelProxy :: Proxy x -> a - --- | Join two lists. -type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where - JoinLists '[] bs = bs - JoinLists (a ': as) bs = a ': JoinLists as bs - -- | Look in the given list of (symbol, tag) tuples for the tag -- corresponding to the given symbol. If not found raise the given -- type error. type family FindElement (m :: Symbol) (ms :: [(Symbol, *)]) -#if !MIN_VERSION_base(4,9,0) - (typeError :: *) -#else - (typeError :: ErrorMessage) -#endif - :: * where - FindElement m '[] typeError = -#if !MIN_VERSION_base(4,9,0) - typeError -#else - TypeError typeError -#endif + (typeError :: ErrorMessage) :: * where + FindElement m '[] typeError = TypeError typeError FindElement m ('(m, o) ': ms) typeError = o FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError --- | Result of a ancestor check. Basically a Bool type with a bit of --- extra info in order to improve typechecker error messages. -data AncestorCheck t a = HasAncestor a t -#if !MIN_VERSION_base(4,9,0) - | DoesNotHaveRequiredAncestor Symbol t Symbol a -#endif - -#if MIN_VERSION_base(4,9,0) --- | Type error to be generated when an ancestor check fails. -type family UnknownAncestorError (a :: *) (t :: *) where - UnknownAncestorError a t = - TypeError ('Text "Required ancestor ‘" ':<>: 'ShowType a - ':<>: 'Text "’ not found for type ‘" - ':<>: 'ShowType t ':<>: 'Text "’.") -#endif - -- | Check whether a type appears in a list. We specialize the -- names/types a bit so the error messages are more informative. -type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where - CheckForAncestorType t a '[] = -#if !MIN_VERSION_base(4,9,0) - 'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t -#else - UnknownAncestorError a t -#endif - CheckForAncestorType t a (a ': as) = 'HasAncestor a t - CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as +type family CheckForAncestorType t (a :: *) (as :: [*]) :: Constraint where + CheckForAncestorType t a '[] = TypeError ('Text "Required ancestor ‘" + ':<>: 'ShowType a + ':<>: 'Text "’ not found for type ‘" + ':<>: 'ShowType t ':<>: 'Text "’.") + CheckForAncestorType t a (a ': as) = () + CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as --- | Check that a type is in the list of `GObjectParents` of another --- `GObject`-derived type. +-- | Check that a type is in the list of `ParentTypes` of another +-- type. type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where -- Every object is defined to be a descendant of itself. - IsDescendantOf d d = () ~ () - IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) ~ 'HasAncestor p d + IsDescendantOf d d = () + IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) --- | The direct parents of this object: its direct parent type, if any, --- and the interfaces it implements. The interfaces inherited from --- parent types can be omitted. +-- | All the types that are ascendants of this type, including +-- interfaces that the type implements. type family ParentTypes a :: [*] +-- | A constraint on a type, to be fulfilled whenever it has a type +-- instance for `ParentTypes`. This leads to nicer errors, thanks to +-- the overlappable instance below. +class HasParentTypes o + +-- | Default instance, which will give rise to an error for types +-- without an associated `ParentTypes` instance. +instance {-# OVERLAPPABLE #-} + TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: + 'Text "’ does not have any known parent types.") + => HasParentTypes a + -- | The list of attributes defined for a given type. Each element of -- the list is a tuple, with the first element of the tuple the name -- of the attribute, and the second the type encoding the information --- of the attribute. This type will be an instance of `AttrInfo`. +-- of the attribute. This type will be an instance of +-- `Data.GI.Base.Attributes.AttrInfo`. type family AttributeList a :: [(Symbol, *)] -- | A constraint on a type, to be fulfilled whenever it has a type @@ -128,117 +86,64 @@ -- reporting. class HasAttributeList a -#if MIN_VERSION_base(4,9,0) --- Default instance, which will give rise to an error for types +-- | Default instance, which will give rise to an error for types -- without an associated `AttributeList`. instance {-# OVERLAPPABLE #-} TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: 'Text "’ does not have any known attributes.") => HasAttributeList a -#endif -#if !MIN_VERSION_base(4,9,0) --- | Datatype returned when the attribute is not found, hopefully making --- the resulting error messages somewhat clearer. -data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) -#endif - -- | Return the type encoding the attribute information for a given -- type and attribute. type family ResolveAttribute (s :: Symbol) (o :: *) :: * where ResolveAttribute s o = FindElement s (AttributeList o) -#if !MIN_VERSION_base(4,9,0) - (UnknownAttribute "Error: could not find attribute" s "for object" o) -#else ('Text "Unknown attribute ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -#endif -- | Whether a given type is in the given list. If found, return -- @success@, otherwise return @failure@. type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k) -#if !MIN_VERSION_base(4,9,0) - (failure :: k) -#else - (failure :: ErrorMessage) -#endif - :: k where - IsElem e '[] success failure = -#if !MIN_VERSION_base(4,9,0) - failure -#else - TypeError failure -#endif + (failure :: ErrorMessage) :: k where + IsElem e '[] success failure = TypeError failure IsElem e ( '(e, t) ': es) success failure = success IsElem e ( '(other, t) ': es) s f = IsElem e es s f --- | Isomorphic to Bool, but having some extra debug information. -data AttributeCheck a t = HasAttribute -#if !MIN_VERSION_base(4,9,0) - | DoesNotHaveAttribute Symbol a Symbol t -#endif - -- | A constraint imposing that the given object has the given attribute. -type family HasAttribute (attr :: Symbol) (o :: *) where +type family HasAttribute (attr :: Symbol) (o :: *) :: Constraint where HasAttribute attr o = IsElem attr (AttributeList o) - 'HasAttribute -#if !MIN_VERSION_base(4,9,0) - ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o) -#else + (() :: Constraint) -- success ('Text "Attribute ‘" ':<>: 'Text attr ':<>: 'Text "’ not found for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -#endif - ~ 'HasAttribute -- | A constraint that enforces that the given type has a given attribute. class HasAttr (attr :: Symbol) (o :: *) instance HasAttribute attr o => HasAttr attr o --- | The list of signals defined for a given type. Each element of --- the list is a tuple, with the first element of the tuple the name --- of the signal, and the second the type encoding the information of --- the signal. This type will be an instance of `SignalInfo`. +-- | The list of signals defined for a given type. Each element of the +-- list is a tuple, with the first element of the tuple the name of +-- the signal, and the second the type encoding the information of the +-- signal. This type will be an instance of +-- `Data.GI.Base.Signals.SignalInfo`. type family SignalList a :: [(Symbol, *)] -#if !MIN_VERSION_base(4,9,0) --- | Datatype returned when the signal is not found, hopefully making --- the resulting error messages somewhat clearer. -data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *) -#endif - -- | Return the type encoding the signal information for a given -- type and signal. type family ResolveSignal (s :: Symbol) (o :: *) :: * where ResolveSignal s o = FindElement s (SignalList o) -#if !MIN_VERSION_base(4,9,0) - (UnknownSignal "Error: could not find signal" s "for object" o) -#else ('Text "Unknown signal ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -#endif --- | Isomorphic to Bool, but having some extra debug information. -data SignalCheck s t = HasSignal -#if !MIN_VERSION_base(4,9,0) - | DoesNotHaveSignal Symbol s Symbol t -#endif - -- | A constraint enforcing that the signal exists for the given -- object, or one of its ancestors. -type family HasSignal (s :: Symbol) (o :: *) where +type family HasSignal (s :: Symbol) (o :: *) :: Constraint where HasSignal s o = IsElem s (SignalList o) - 'HasSignal -#if !MIN_VERSION_base(4,9,0) - ('DoesNotHaveSignal "Error: signal" s "not found for type" o) -#else + (() :: Constraint) -- success ('Text "Signal ‘" ':<>: 'Text s ':<>: 'Text "’ not found for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -#endif - ~ 'HasSignal -- | Class for types containing the information about an overloaded -- method of type `o -> s`. @@ -250,14 +155,10 @@ -- the autogenerated bindings. data MethodProxy a = MethodProxy -#if !MIN_VERSION_base(4,9,0) --- | Datatype returned when the method is not found, hopefully making +-- | Returned when the method is not found, hopefully making -- the resulting error messages somewhat clearer. -data MethodResolutionFailed (label :: Symbol) (o :: *) -#else type family MethodResolutionFailed (method :: Symbol) (o :: *) where MethodResolutionFailed m o = TypeError ('Text "Unknown method ‘" ':<>: 'Text m ':<>: 'Text "’ for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -#endif diff --git a/Data/GI/Base/Properties.hsc b/Data/GI/Base/Properties.hsc --- a/Data/GI/Base/Properties.hsc +++ b/Data/GI/Base/Properties.hsc @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} module Data.GI.Base.Properties ( setObjectPropertyString @@ -20,6 +20,7 @@ , setObjectPropertyBoxed , setObjectPropertyEnum , setObjectPropertyFlags + , setObjectPropertyClosure , setObjectPropertyVariant , setObjectPropertyByteArray , setObjectPropertyPtrGList @@ -45,6 +46,7 @@ , getObjectPropertyBoxed , getObjectPropertyEnum , getObjectPropertyFlags + , getObjectPropertyClosure , getObjectPropertyVariant , getObjectPropertyByteArray , getObjectPropertyPtrGList @@ -70,6 +72,7 @@ , constructObjectPropertyBoxed , constructObjectPropertyEnum , constructObjectPropertyFlags + , constructObjectPropertyClosure , constructObjectPropertyVariant , constructObjectPropertyByteArray , constructObjectPropertyPtrGList @@ -90,6 +93,8 @@ import Data.GI.Base.BasicConversions import Data.GI.Base.ManagedPtr import Data.GI.Base.GValue +import Data.GI.Base.GType +import Data.GI.Base.GClosure (GClosure(..)) import Data.GI.Base.GVariant (newGVariantFromPtr) import Data.GI.Base.Utils (freeMem, convertIfNonNull) @@ -332,21 +337,21 @@ setObjectPropertyObject :: forall a b. (GObject a, GObject b) => a -> String -> Maybe b -> IO () setObjectPropertyObject obj propName maybeObject = do - gtype <- gobjectType (undefined :: b) + gtype <- gobjectType @b maybeWithManagedPtr maybeObject $ \objectPtr -> setObjectProperty obj propName objectPtr set_object gtype constructObjectPropertyObject :: forall a o. GObject a => String -> Maybe a -> IO (GValueConstruct o) constructObjectPropertyObject propName maybeObject = do - gtype <- gobjectType (undefined :: a) + gtype <- gobjectType @a maybeWithManagedPtr maybeObject $ \objectPtr -> constructObjectProperty propName objectPtr set_object gtype getObjectPropertyObject :: forall a b. (GObject a, GObject b) => a -> String -> (ManagedPtr b -> b) -> IO (Maybe b) getObjectPropertyObject obj propName constructor = do - gtype <- gobjectType (undefined :: b) + gtype <- gobjectType @b getObjectProperty obj propName (\val -> (get_object val :: IO (Ptr b)) >>= flip convertIfNonNull (newObject constructor)) @@ -446,6 +451,18 @@ getObjectProperty obj propName (\val -> wordToGFlags <$> get_flags val) gtype + +setObjectPropertyClosure :: forall a b. GObject a => + a -> String -> Maybe (GClosure b) -> IO () +setObjectPropertyClosure = setObjectPropertyBoxed + +constructObjectPropertyClosure :: String -> Maybe (GClosure a) -> IO (GValueConstruct o) +constructObjectPropertyClosure = constructObjectPropertyBoxed + +getObjectPropertyClosure :: forall a b. GObject a => + a -> String -> IO (Maybe (GClosure b)) +getObjectPropertyClosure obj propName = + getObjectPropertyBoxed obj propName GClosure setObjectPropertyVariant :: GObject a => a -> String -> Maybe GVariant -> IO () diff --git a/Data/GI/Base/ShortPrelude.hs b/Data/GI/Base/ShortPrelude.hs --- a/Data/GI/Base/ShortPrelude.hs +++ b/Data/GI/Base/ShortPrelude.hs @@ -20,7 +20,7 @@ , module Data.GI.Base.Attributes , module Data.GI.Base.BasicTypes , module Data.GI.Base.BasicConversions - , module Data.GI.Base.Closure + , module Data.GI.Base.GClosure , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable @@ -29,7 +29,6 @@ , module Data.GI.Base.GVariant , module Data.GI.Base.GValue , module Data.GI.Base.ManagedPtr - , module Data.GI.Base.Properties , module Data.GI.Base.Signals , module Data.GI.Base.Utils @@ -78,8 +77,8 @@ import Data.GI.Base.Attributes hiding (get, set) import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions -import Data.GI.Base.Closure import Data.GI.Base.Constructible +import Data.GI.Base.GClosure (GClosure) import Data.GI.Base.GError import Data.GI.Base.GHashTable import Data.GI.Base.GObject @@ -87,7 +86,6 @@ import Data.GI.Base.GVariant import Data.GI.Base.GValue import Data.GI.Base.ManagedPtr -import Data.GI.Base.Properties import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo) import Data.GI.Base.Utils diff --git a/Data/GI/Base/Signals.hsc b/Data/GI/Base/Signals.hsc --- a/Data/GI/Base/Signals.hsc +++ b/Data/GI/Base/Signals.hsc @@ -17,6 +17,7 @@ , SignalProxy(..) , SignalConnectMode(..) , connectSignalFunPtr + , disconnectSignalHandler , SignalHandlerId , SignalInfo(..) , GObjectNotifySignalInfo @@ -27,6 +28,7 @@ import Foreign import Foreign.C +import Foreign.Ptr (nullPtr) import GHC.TypeLits @@ -34,9 +36,7 @@ import Data.GI.Base.BasicTypes import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) import Data.GI.Base.ManagedPtr (withManagedPtr) -import Data.GI.Base.Overloading (ResolveSignal, - IsLabelProxy(..), ResolveAttribute) -import Data.GI.Base.Utils (safeFreeFunPtrPtr) +import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute) #if MIN_VERSION_base(4,9,0) import GHC.OverloadedLabels (IsLabel(..)) @@ -47,10 +47,6 @@ -- | Type of a `GObject` signal handler id. type SignalHandlerId = CULong --- | A class that provides a constraint satisfied by every type. -class NoConstraint a -instance NoConstraint a - -- | Support for overloaded signal connectors. data SignalProxy (object :: *) (info :: *) where SignalProxy :: SignalProxy o info @@ -61,21 +57,11 @@ SignalProxy o (GObjectNotifySignalInfo pl) -- | Support for overloaded labels. -instance -#if !MIN_VERSION_base(4,9,0) - -- This gives better error reporting in ghc < 8.0. - (HasSignal slot object, info ~ ResolveSignal slot object) -#else - info ~ ResolveSignal slot object -#endif - => IsLabelProxy slot (SignalProxy object info) where - fromLabelProxy _ = SignalProxy - #if MIN_VERSION_base(4,10,0) instance info ~ ResolveSignal slot object => IsLabel slot (SignalProxy object info) where fromLabel = SignalProxy -#elif MIN_VERSION_base(4,9,0) +#else instance info ~ ResolveSignal slot object => IsLabel slot (SignalProxy object info) where fromLabel _ = SignalProxy @@ -119,7 +105,7 @@ after o p c = liftIO $ connectSignal p o c SignalConnectAfter -- Connecting GObjects to signals -foreign import ccall "g_signal_connect_data" g_signal_connect_data :: +foreign import ccall g_signal_connect_data :: Ptr a -> -- instance CString -> -- detailed_signal FunPtr b -> -- c_handler @@ -128,6 +114,10 @@ CUInt -> -- connect_flags IO SignalHandlerId +-- Releasing the `FunPtr` for the signal handler. +foreign import ccall "& haskell_gi_release_signal_closure" + ptr_to_release_closure :: FunPtr (Ptr () -> Ptr () -> IO ()) + -- | Connect a signal to a handler, given as a `FunPtr`. connectSignalFunPtr :: GObject o => o -> String -> FunPtr a -> SignalConnectMode -> IO SignalHandlerId @@ -137,8 +127,16 @@ SignalConnectBefore -> 0 withCString signal $ \csignal -> withManagedPtr object $ \objPtr -> - g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags + g_signal_connect_data objPtr csignal fn nullPtr ptr_to_release_closure flags +foreign import ccall g_signal_handler_disconnect :: Ptr o -> SignalHandlerId -> IO () + +-- | Disconnect a previously connected signal. +disconnectSignalHandler :: GObject o => o -> SignalHandlerId -> IO () +disconnectSignalHandler obj handlerId = + withManagedPtr obj $ \objPtr -> + g_signal_handler_disconnect objPtr handlerId + -- | Connection information for a "notify" signal indicating that a -- specific property changed (see `PropertyNotify` for the relevant -- constructor). @@ -148,7 +146,7 @@ type HaskellCallbackType (GObjectNotifySignalInfo propName) = GObjectNotifyCallback connectSignal = connectGObjectNotify (symbolVal (Proxy :: Proxy propName)) --- | Type for a `GObject` `notify` callback. +-- | Type for a `GObject` "notify" callback. type GObjectNotifyCallback = GParamSpec -> IO () gobjectNotifyCallbackWrapper :: diff --git a/c/hsgclosure.c b/c/hsgclosure.c --- a/c/hsgclosure.c +++ b/c/hsgclosure.c @@ -271,3 +271,97 @@ if (ptr != NULL) freeHaskellFunctionPtr(ptr); } + +/* Returns the GType associated to a class instance */ +GType haskell_gi_gtype_from_class (gpointer klass) +{ + return G_TYPE_FROM_CLASS (klass); +} + +/* Returns the GType associated to a given instance */ +GType haskell_gi_gtype_from_instance (gpointer instance) +{ + return G_TYPE_FROM_INSTANCE (instance); +} + +static pthread_mutex_t gtypes_mutex = PTHREAD_MUTEX_INITIALIZER; + +/* Register a new type into the GObject class hierarchy, if it has not + been registered already */ +GType haskell_gi_register_gtype (GType parent, const char *name, + GClassInitFunc class_init, + GInstanceInitFunc instance_init) +{ + GType result; + + /* We lock here in order to make sure that we don't try to register + the same type twice. */ + pthread_mutex_lock(>ypes_mutex); + result = g_type_from_name (name); + + if (result == 0) { + /* Note that class_init and instance_init are HsFunPtrs, which we + keep alive for the duration of the program. */ + GTypeQuery query; + g_type_query (parent, &query); + result = g_type_register_static_simple (parent, name, + query.class_size, class_init, + query.instance_size, instance_init, + 0); + } else { + /* Free the memory associated with the HsFunPtrs that we are + given, to avoid a (small) memory leak. */ + hs_free_fun_ptr ((HsFunPtr)class_init); + hs_free_fun_ptr ((HsFunPtr)instance_init); + } + pthread_mutex_unlock(>ypes_mutex); + + return result; +} + +static pthread_mutex_t stablePtr_mutex = PTHREAD_MUTEX_INITIALIZER; + +static GType stablePtr_gtype = 0; + +GType haskell_gi_Boxed_StablePtr_GType (void) +{ + return stablePtr_gtype; +} + +/* Register the Haskell StablePtr type as a boxed type. */ +GType haskell_gi_register_Boxed_HsStablePtr + (const char *typeName, HsStablePtr (*duplicator)(HsStablePtr)) +{ + GType result; + + /* Lock so that we avoid trying to register twice, which would give + rise to a small memory leak for the duplicator FunPtr */ + pthread_mutex_lock(&stablePtr_mutex); + + if (stablePtr_gtype != 0) { + hs_free_fun_ptr ((HsFunPtr)duplicator); + result = stablePtr_gtype; + } else { + result = g_boxed_type_register_static (typeName, duplicator, + hs_free_stable_ptr); + stablePtr_gtype = result; + } + + pthread_mutex_unlock(&stablePtr_mutex); + + return result; +} + +/* Release the FunPtr allocated for a Haskell signal handler */ +void +haskell_gi_release_signal_closure (gpointer unused, + GCClosure *closure) +{ + lock_log(); + dbg_log("Releasing a signal closure %p\n", closure->callback); + + hs_free_fun_ptr (closure->callback); + + dbg_log("\tDone.\n"); + unlock_log(); +} 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.21.5 +version: 0.22.0 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 @@ -27,11 +27,12 @@ Data.GI.Base.BasicConversions, Data.GI.Base.BasicTypes, Data.GI.Base.CallStack, - Data.GI.Base.Closure, Data.GI.Base.Constructible, Data.GI.Base.GError, + Data.GI.Base.GClosure, Data.GI.Base.GHashTable, Data.GI.Base.GObject, + Data.GI.Base.GQuark, Data.GI.Base.GType, Data.GI.Base.GValue, Data.GI.Base.GVariant, @@ -44,20 +45,15 @@ Data.GI.Base.Utils pkgconfig-depends: gobject-2.0 >= 2.32, glib-2.0 - build-depends: base >= 4.7 && < 5, + build-depends: base >= 4.9 && < 5, bytestring, containers, text >= 1.0 - if !impl(ghc >= 8.0) - build-depends: transformers - - if impl(ghc >= 8.0) - ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns - else - ghc-options: -Wall -fwarn-incomplete-patterns + ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns build-tools: hsc2hs cc-options: -fPIC extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds + other-extensions: TypeApplications, ScopedTypeVariables c-sources: c/hsgclosure.c