haskell-gi-base 0.23.0 → 0.26.9
raw patch · 32 files changed
Files
- ChangeLog.md +28/−0
- Data/GI/Base.hs +3/−2
- Data/GI/Base/Attributes.hs +241/−17
- Data/GI/Base/BasicConversions.hsc +3/−4
- Data/GI/Base/BasicTypes.hsc +86/−57
- Data/GI/Base/Constructible.hs +1/−1
- Data/GI/Base/DynVal.hs +144/−0
- Data/GI/Base/GArray.hs +16/−0
- Data/GI/Base/GClosure.hs +13/−2
- Data/GI/Base/GError.hs +259/−0
- Data/GI/Base/GError.hsc +0/−254
- Data/GI/Base/GHashTable.hsc +14/−11
- Data/GI/Base/GObject.hsc +160/−35
- Data/GI/Base/GParamSpec.hsc +55/−9
- Data/GI/Base/GType.hsc +17/−3
- Data/GI/Base/GValue.hs +541/−0
- Data/GI/Base/GValue.hsc +0/−406
- Data/GI/Base/GVariant.hsc +51/−47
- Data/GI/Base/Internal/CTypes.hsc +40/−0
- Data/GI/Base/Internal/PathFieldAccess.hs +76/−0
- Data/GI/Base/ManagedPtr.hs +71/−52
- Data/GI/Base/Overloading.hs +74/−34
- Data/GI/Base/Overloading.hs-boot +1/−1
- Data/GI/Base/Properties.hsc +147/−116
- Data/GI/Base/ShortPrelude.hs +6/−0
- Data/GI/Base/Signals.hs +292/−0
- Data/GI/Base/Signals.hs-boot +53/−0
- Data/GI/Base/Signals.hsc +0/−226
- Data/GI/Base/Utils.hsc +12/−4
- c/hsgclosure.c +0/−363
- csrc/hsgclosure.c +477/−0
- haskell-gi-base.cabal +14/−9
ChangeLog.md view
@@ -1,3 +1,31 @@+### 0.24.8+++ Make the StablePtr IsGValue instance make a copy in fromGValue.++### 0.24.7+++ Add a mechanism for marshalling generic Haskell values into `GValue`s.++### 0.24.4+++ Add a workaround for old hsc2hs versions, so drop the constraint on hsc2hs.++### 0.24.3+++ Require hsc2hs version 0.68.6 or higher++### 0.24.2+++ Provide type init functions for GParamSpec types.++### 0.24.1+++ Support for allocating `GArray`s.++### 0.24.0+++ Support for non-GObject objects. As part of this work the GObject hierarchy has been slightly reworked. The main change is that 'gobjectType' has now become [glibType](https://hackage.haskell.org/package/haskell-gi-base-0.24.0/docs/Data-GI-Base-BasicTypes.html#v:glibType) (part of the [TypedObject](https://hackage.haskell.org/package/haskell-gi-base-0.24.0/docs/Data-GI-Base-BasicTypes.html#t:TypedObject) typeclass).+ ### 0.22.2 + Reinstate the new' method.
Data/GI/Base.hs view
@@ -26,8 +26,9 @@ import Data.GI.Base.Constructible (new) import Data.GI.Base.GError import Data.GI.Base.GHashTable-import Data.GI.Base.GValue (GValue(..), IsGValue(..))+import Data.GI.Base.GValue (GValue(..), fromGValue, toGValue, IsGValue(..)) import Data.GI.Base.GVariant import Data.GI.Base.ManagedPtr-import Data.GI.Base.Signals (on, after, SignalProxy(PropertyNotify, (:::)))+import Data.GI.Base.Signals (on, after,+ SignalProxy(PropertyNotify, PropertySet, (:::))) import Data.GI.Base.Overloading (asA)
Data/GI/Base/Attributes.hs view
@@ -1,7 +1,19 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,- TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,- UndecidableInstances, FlexibleInstances, TypeApplications,- DefaultSignatures, PolyKinds, AllowAmbiguousTypes #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -- | --@@ -106,7 +118,7 @@ -- `set` afterwards. That these invariants hold is also checked during -- compile time. ----- == Nullable atributes+-- == Nullable attributes -- -- Whenever the attribute is represented as a pointer in the C side, -- it is often the case that the underlying C representation admits or@@ -115,7 +127,7 @@ -- 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+-- simply as the empty list). This can be overridden in the -- introspection data, since sometimes attributes are non-nullable, -- even if the type would allow for @NULL@. --@@ -143,22 +155,43 @@ set, clear, - AttrLabelProxy(..)+ AttrLabelProxy(..),++ resolveAttr,+ bindPropToField,++ EqMaybe(..) ) where +import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.GI.Base.BasicTypes (GObject)+import Data.GI.Base.DynVal (DynVal(..), ModelProxy, DVKey(..),+ modelProxyCurrentValue, modelProxyRegisterHandler,+ modelProxyUpdate, dvKeys, dvRead) import Data.GI.Base.GValue (GValueConstruct)-import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute)+import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute,+ ResolvedSymbolInfo)+import Data.GI.Base.Internal.PathFieldAccess (PathFieldAccess(..), Components) +import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..),+ SignalProxy,+ on, after, connectGObjectNotify,+ SignalConnectMode(..))++import Data.Kind (Type) import Data.Proxy (Proxy(..))+import qualified Data.Text as T -import GHC.TypeLits+import GHC.TypeLits (Symbol, KnownSymbol, ErrorMessage(..), TypeError,+ symbolVal) import GHC.Exts (Constraint) import GHC.OverloadedLabels (IsLabel(..))+import qualified Optics.Core as O -infixr 0 :=,:~,:=>,:~>+infixr 0 :=,:~,:=>,:~>,:<~,:!<~ -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy@@ -172,28 +205,28 @@ #endif -- | Info describing an attribute.-class AttrInfo (info :: *) where+class AttrInfo (info :: Type) where -- | The operations that are allowed on the attribute. type AttrAllowedOps info :: [AttrOpTag] -- | Constraint on the type for which we are allowed to -- create\/set\/get the attribute.- type AttrBaseTypeConstraint info :: * -> Constraint+ type AttrBaseTypeConstraint info :: Type -> Constraint -- | Type returned by `attrGet`. type AttrGetType info -- | Constraint on the value being set.- type AttrSetTypeConstraint info :: * -> Constraint+ type AttrSetTypeConstraint info :: Type -> Constraint type AttrSetTypeConstraint info = (~) (AttrGetType info) -- | Constraint on the value being set, with allocation allowed -- (see ':&=' below).- type AttrTransferTypeConstraint info :: * -> Constraint+ type AttrTransferTypeConstraint info :: Type -> Constraint type AttrTransferTypeConstraint info = (~) (AttrTransferType info) -- | Type resulting from the allocation.- type AttrTransferType info :: *+ type AttrTransferType info :: Type type AttrTransferType info = AttrGetType info -- | Name of the attribute.@@ -264,6 +297,26 @@ Proxy o -> b -> IO (AttrTransferType info) attrTransfer _ = return + -- | Like `attrSet`, but it uses the same type as the getter. This+ -- is useful for some nullable types, for which the getter returns+ -- @Maybe a@, while the setter takes an @a@. `attrPut` will+ -- instead accept an @Maybe a@.+ attrPut :: AttrBaseTypeConstraint info o =>+ o -> AttrGetType info -> IO ()+ default attrPut :: -- Make sure that a non-default method+ -- implementation is provided if AttrSet+ -- is set.+ CheckNotElem 'AttrPut (AttrAllowedOps info)+ (PutNotProvidedError info) =>+ o -> AttrGetType info -> IO ()+ attrPut = undefined++ -- | Return some information about the overloaded attribute,+ -- useful for debugging. See `resolveAttr` for how to access this+ -- conveniently.+ dbgAttrInfo :: Maybe ResolvedSymbolInfo+ dbgAttrInfo = Nothing+ -- | Pretty print a type, indicating the parent type that introduced -- the attribute, if different. type family TypeOriginInfo definingType useType :: ErrorMessage where@@ -276,7 +329,7 @@ -- | Look in the given list to see if the given `AttrOp` is a member, -- if not return an error type.-type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: *) (useType :: *) :: Constraint where+type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: Type) (useType :: Type) :: Constraint where AttrOpIsAllowed tag '[] label definingType useType = TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>: 'Text "’ for type " ':<>:@@ -288,7 +341,7 @@ -- | Whether a given `AttrOpTag` is allowed on an attribute, given the -- info type.-type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) (useType :: *) :: Constraint where+type family AttrOpAllowed (tag :: AttrOpTag) (info :: Type) (useType :: Type) :: Constraint where AttrOpAllowed tag info useType = AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) (AttrOrigin info) useType @@ -325,6 +378,11 @@ type family SetNotProvidedError (info :: o) :: ErrorMessage where SetNotProvidedError info = OpNotProvidedError info 'AttrSet "attrSet" +-- | Error to be raised when AttrSet is allowed, but an `attrPut`+-- implementation has not been provided.+type family PutNotProvidedError (info :: o) :: ErrorMessage where+ PutNotProvidedError info = OpNotProvidedError info 'AttrSet "attrPut"+ -- | Error to be raised when AttrConstruct is allowed, but an -- implementation has not been provided. type family ConstructNotProvidedError (info :: o) :: ErrorMessage where@@ -350,6 +408,9 @@ | AttrClear -- ^ It is possible to clear the value of the -- (nullable) attribute with `clear`.+ | AttrPut+ -- ^ It is possible to set a value of the same type as+ -- the one returned by `get`. deriving (Eq, Ord, Enum, Bounded, Show) -- | A user friendly description of the `AttrOpTag`, useful when@@ -359,6 +420,7 @@ AttrOpText 'AttrSet = "settable" AttrOpText 'AttrConstruct = "constructible" AttrOpText 'AttrClear = "nullable"+ AttrOpText 'AttrPut = "puttable" -- | Constraint on a @obj@\/@attr@ pair so that `set` works on values -- of type @value@.@@ -434,7 +496,82 @@ (AttrTransferTypeConstraint info) b, AttrSetTypeConstraint info (AttrTransferType info)) => AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag+ -- | Bind a property to the given `DynVal`, so that the property+ -- is changed whenever the `DynVal` is. This requires the implicit+ -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@ to be set.+ (:!<~) :: (HasAttributeList obj,+ info ~ ResolveAttribute attr obj,+ AttrInfo info,+ AttrBaseTypeConstraint info obj,+ AttrOpAllowed tag info obj,+ (AttrSetTypeConstraint info) b,+ ?_haskell_gi_modelProxy :: ModelProxy model+ ) =>+ AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj ta+ -- | Bind a property to the given `DynVal`, so that the property+ -- is changed whenever the `DynVal` is. This requires the implicit+ -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@+ -- to be set. This will only actually set the property whenever+ -- the `DynVal` changes if the new value of the `DynVal` is+ -- different from the actual value of the property. If you want to+ -- set the property without checking equality you can use `:!<~`+ -- instead.+ (:<~) :: (HasAttributeList obj,+ info ~ ResolveAttribute attr obj,+ AttrInfo info,+ AttrBaseTypeConstraint info obj,+ AttrOpAllowed tag info obj,+ (AttrSetTypeConstraint info) b,+ AttrOpAllowed 'AttrGet info obj,+ EqMaybe b (AttrGetType info),+ ?_haskell_gi_modelProxy :: ModelProxy model+ ) =>+ AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj tag+ -- | Given an AttrLabelProxy, bind the given attribute to the+ -- corresponding field in the model proxy (if there's one), so+ -- that changes in the attribute are reflected back into changes+ -- of the model.+ Bind :: (HasAttributeList obj,+ GObject obj,+ info ~ ResolveAttribute propName obj,+ AttrInfo info,+ KnownSymbol (AttrLabel info),+ AttrBaseTypeConstraint info obj,+ AttrOpAllowed tag info obj,+ AttrOpAllowed 'AttrPut info obj,+ ?_haskell_gi_modelProxy :: ModelProxy model,+ outType ~ AttrGetType info,+ (AttrSetTypeConstraint info) outType,+ components ~ Components fieldName,+ PathFieldAccess components model outType,+ KnownSymbol fieldName,+ Eq outType+ ) =>+ AttrLabelProxy (propName :: Symbol) ->+ AttrLabelProxy (fieldName :: Symbol) ->+ AttrOp obj tag + -- | Connect the given signal to a signal handler.+ On :: (GObject obj, SignalInfo info) =>+ SignalProxy obj info+ -> ((?self :: obj) => HaskellCallbackType info)+ -> AttrOp obj tag+ -- | Like 'On', but connect after the default signal.+ After :: (GObject obj, SignalInfo info) =>+ SignalProxy obj info+ -> ((?self :: obj) => HaskellCallbackType info)+ -> AttrOp obj tag++class EqMaybe a b where+ eqMaybe :: a -> b -> Bool++instance Eq a => EqMaybe a a where+ eqMaybe x y = x == y++instance Eq a => EqMaybe a (Maybe a) where+ eqMaybe _ Nothing = False+ eqMaybe x (Just y) = x == y+ -- | Set a number of properties for some object. set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m () set obj = liftIO . mapM_ app@@ -458,6 +595,29 @@ attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>= attrSet @(ResolveAttribute label o) obj + app ((_attr :: AttrLabelProxy label) :!<~ dv) = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+ attrSet @(ResolveAttribute label o) obj (dvRead dv model)+ modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel ->+ attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel)++ app ((_attr :: AttrLabelProxy label) :<~ dv) = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+ currentValue <- attrGet @(ResolveAttribute label o) obj+ let newValue = dvRead dv model+ when (not $ newValue `eqMaybe` currentValue) $ do+ attrSet @(ResolveAttribute label o) obj newValue+ modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do+ current <- attrGet @(ResolveAttribute label o) obj+ let modifiedValue = dvRead dv modifiedModel+ when (not $ modifiedValue `eqMaybe` current) $+ attrSet @(ResolveAttribute label o) obj modifiedValue++ app (Bind pattr fattr) = bindPropToField (Proxy @'AttrSet) obj pattr fattr++ app (On signal callback) = void $ on obj signal callback+ app (After signal callback) = void $ after obj signal callback+ -- | Constraints on a @obj@\/@attr@ pair so `get` is possible, -- producing a value of type @result@. type AttrGetC info obj attr result = (HasAttributeList obj,@@ -485,3 +645,67 @@ (AttrClearC info obj attr, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m () clear o _ = liftIO $ attrClear @info o++-- | Return the fully qualified attribute name that a given overloaded+-- attribute resolves to (mostly useful for debugging).+--+-- > resolveAttr #sensitive button+resolveAttr :: forall info attr obj.+ (HasAttributeList obj, info ~ ResolveAttribute attr obj,+ AttrInfo info) =>+ obj -> AttrLabelProxy (attr :: Symbol) -> Maybe ResolvedSymbolInfo+resolveAttr _o _p = dbgAttrInfo @info++-- | Create a binding between the given property of an object and a+-- field in the model.+bindPropToField :: forall o info prop field model outType tag components.+ (HasAttributeList o,+ GObject o,+ info ~ ResolveAttribute prop o,+ AttrInfo info,+ KnownSymbol (AttrLabel info),+ AttrBaseTypeConstraint info o,+ AttrOpAllowed tag info o,+ AttrOpAllowed 'AttrPut info o,+ ?_haskell_gi_modelProxy :: ModelProxy model,+ outType ~ AttrGetType info,+ (AttrSetTypeConstraint info) outType,+ components ~ Components field,+ PathFieldAccess components model outType,+ KnownSymbol field,+ Eq outType+ ) =>+ Proxy tag -> o -> AttrLabelProxy (prop :: Symbol) ->+ AttrLabelProxy (field :: Symbol) -> IO ()+bindPropToField _ obj _ _ = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy++ -- Set the property to the current value in the model.+ currentPropValue <- attrGet @(ResolveAttribute prop o) obj+ let (lens, components) = pathFieldAccess (Proxy @components)+ (Proxy @model)+ key = DVKeyDirect components+ currentModelValue = O.view lens model+ when (currentModelValue /= currentPropValue) $+ attrPut @(ResolveAttribute prop o) obj currentModelValue++ -- Set the property whenever the model changes.+ modelProxyRegisterHandler ?_haskell_gi_modelProxy key $ \modifiedModel -> do+ let newVal = O.view lens modifiedModel+ oldVal <- attrGet @(ResolveAttribute prop o) obj+ when (newVal /= oldVal) $+ attrPut @(ResolveAttribute prop o) obj newVal++ -- Change the model whenever the property changes.+ let handler = \_parent _psec -> do+ newVal <- attrGet @(ResolveAttribute prop o) obj+ let doUpdate curModel =+ let oldVal = O.view lens curModel+ in if newVal == oldVal+ then Nothing+ else Just $ O.set lens newVal curModel+ modelProxyUpdate ?_haskell_gi_modelProxy components doUpdate+ propName = T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute prop o)))++ void $ connectGObjectNotify obj handler SignalConnectBefore (Just propName)+
Data/GI/Base/BasicConversions.hsc view
@@ -89,7 +89,6 @@ import Data.GI.Base.BasicTypes import Data.GI.Base.CallStack (HasCallStack)-import Data.GI.Base.GHashTable (GEqualFunc, GHashFunc) import Data.GI.Base.ManagedPtr (copyBoxedPtr) import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem, checkUnexpectedReturnNULL)@@ -169,7 +168,7 @@ dataPtr <- peek (castPtr array :: Ptr (Ptr a)) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems- where go :: Ptr a -> Int -> IO [a]+ where go :: Ptr a -> CUInt -> IO [a] go _ 0 = return [] go ptr n = do x <- peek ptr@@ -201,7 +200,7 @@ dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a))) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems- where go :: Ptr (Ptr a) -> Int -> IO [Ptr a]+ where go :: Ptr (Ptr a) -> CUInt -> IO [Ptr a] go _ 0 = return [] go ptr n = do x <- peek ptr@@ -558,7 +557,7 @@ buf <- g_memdup ptr (fromIntegral size) (buf :) <$> go size (n-1) (ptr `plusPtr` size) -unpackBoxedArrayWithLength :: forall a b. (Integral a, BoxedObject b) =>+unpackBoxedArrayWithLength :: forall a b. (Integral a, GBoxed b) => Int -> a -> Ptr b -> IO [Ptr b] unpackBoxedArrayWithLength size n ptr = go size (fromIntegral n) ptr where go :: Int -> Int -> Ptr b -> IO [Ptr b]
Data/GI/Base/BasicTypes.hsc view
@@ -1,26 +1,28 @@ {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,- DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-}-{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}+ TypeFamilies, ScopedTypeVariables,+ MultiParamTypeClasses, DataKinds, TypeOperators, UndecidableInstances,+ AllowAmbiguousTypes #-} -- | Basic types used in the bindings. module Data.GI.Base.BasicTypes ( -- * Memory management ManagedPtr(..)- , ManagedPtrNewtype- , BoxedObject(..)- , BoxedEnum(..)- , BoxedFlags(..)- , WrappedPtr(..)+ , ManagedPtrNewtype(..)+ , BoxedPtr(..)+ , CallocPtr(..) , UnexpectedNullPointerReturn(..) -- * Basic GLib \/ GObject types- , GObject(..)+ , TypedObject(..)+ , GObject , GType(..) , CGType , gtypeName , GVariant(..)+ , GBoxed+ , BoxedEnum+ , BoxedFlags , GParamSpec(..) , noGParamSpec @@ -37,23 +39,25 @@ , PtrWrapped(..) , GDestroyNotify++ , GHashFunc+ , GEqualFunc ) where import Control.Exception (Exception) -import Data.Coerce (Coercible)+import Data.Coerce (coerce, Coercible) import Data.IORef (IORef)-import Data.Proxy (Proxy) import qualified Data.Text as T-import Data.Typeable (Typeable)+import Data.Int import Data.Word import Foreign.C (CString, peekCString) import Foreign.Ptr (Ptr, FunPtr) import Foreign.ForeignPtr (ForeignPtr) -import Data.GI.Base.CallStack (CallStack) import {-# SOURCE #-} Data.GI.Base.Overloading (HasParentTypes)+import Data.GI.Base.CallStack (CallStack) #include <glib-object.h> @@ -73,55 +77,75 @@ instance Eq (ManagedPtr a) where a == b = managedForeignPtr a == managedForeignPtr b --- | 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+-- | A constraint ensuring that the given type is a newtype over a+-- `ManagedPtr`.+class Coercible a (ManagedPtr ()) => ManagedPtrNewtype a where+ toManagedPtr :: a -> ManagedPtr a++-- | A default instance for `IsManagedPtr` for newtypes over `ManagedPtr`.+instance {-# OVERLAPPABLE #-} Coercible a (ManagedPtr ()) => ManagedPtrNewtype a where+ toManagedPtr = coerce+-- Notice that the Coercible here above 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+--+-- Additionally, a simpler approach would be to simply do+--+-- > type IsManagedPtr a = Coercible a (ManagedPtr ())+--+-- but this requires the constructor of the datatype to be in scope,+-- which is cumbersome (for instance, one often wants to call `castTo`+-- on the results of `Gtk.builderGetObject`, which is a `GObject`,+-- whose constructor is not necessarily in scope when using `GI.Gtk`).+--+-- When we make the bindings we will always add explicit instances,+-- which cannot be hidden, avoiding the issue. We keep the default+-- instance for convenience when writing new object types. --- | 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.+-- | Pointers to chunks of memory which we know how to copy and+-- release.+class ManagedPtrNewtype a => BoxedPtr a where+ -- | Make a copy of the given `BoxedPtr`.+ boxedPtrCopy :: a -> IO a+ -- | A pointer to a function for freeing the given pointer.+ boxedPtrFree :: a -> IO () --- | Enums with an associated `GType`.-class BoxedEnum a where- boxedEnumType :: a -> IO GType+-- | A ptr to a memory block which we know how to allocate and fill+-- with zero.+class BoxedPtr a => CallocPtr a where+ -- | Allocate a zero-initialized block of memory for the given type.+ boxedPtrCalloc :: IO (Ptr a) --- | Flags with an associated `GType`.-class BoxedFlags a where- boxedFlagsType :: Proxy a -> IO GType+-- | A wrapped object that has an associated GLib type. This does not+-- necessarily descend from `GObject`, that constraint is implemented+-- by `GObject` below.+class HasParentTypes a => TypedObject a where+ -- | The `GType` for this object.+ glibType :: 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)+-- | Chunks of memory whose allocation/deallocation info has been+-- registered with the GLib type system.+class (ManagedPtrNewtype a, TypedObject a) => GBoxed a --- | A wrapped `GObject`.-class (ManagedPtrNewtype a, HasParentTypes a) => GObject a where- -- | The `GType` for this object.- gobjectType :: IO GType+-- | A wrapped `GObject`, or any other type that descends from it.+class (ManagedPtrNewtype a, TypedObject a) => GObject a +-- | Enums with an associated `GType`.+class TypedObject a => BoxedEnum a++-- | Flags with an associated `GType`.+class TypedObject a => BoxedFlags a+ -- | 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.+-- | A newtype for use on the Haskell side. newtype GType = GType {gtypeToCGType :: CGType}+ deriving (Eq, Show) foreign import ccall "g_type_name" g_type_name :: GType -> IO CString @@ -138,17 +162,16 @@ -- 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 <https://developer.gnome.org/glib/stable/glib-GVariant.html GVariant>. See "Data.GI.Base.GVariant" for further methods.+-- | A <https://docs.gtk.org/glib/struct.Variant.html GVariant>. See "Data.GI.Base.GVariant" for further methods. newtype GVariant = GVariant (ManagedPtr GVariant) --- | A <https://developer.gnome.org/gobject/stable/gobject-GParamSpec.html GParamSpec>. See "Data.GI.Base.GParamSpec" for further methods.+-- | A <https://docs.gtk.org/gobject/class.ParamSpec.html GParamSpec>. See "Data.GI.Base.GParamSpec" for further methods. newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec) -- | A convenient synonym for @Nothing :: Maybe GParamSpec@.@@ -158,30 +181,30 @@ -- | An enum usable as a flag for a function. class Enum a => IsGFlag a --- | A <https://developer.gnome.org/glib/stable/glib-Arrays.html GArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side.+-- | A <https://docs.gtk.org/glib/struct.Array.html GArray>. 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 <https://developer.gnome.org/glib/stable/glib-Pointer-Arrays.html GPtrArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side.+-- | A <https://docs.gtk.org/glib/struct.PtrArray.html GPtrArray>. 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 <https://developer.gnome.org/glib/stable/glib-Byte-Arrays.html GByteArray>. Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side.+-- | A <https://docs.gtk.org/glib/struct.ByteArray.html GByteArray>. 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 <https://developer.gnome.org/glib/stable/glib-Hash-Tables.html GHashTable>. It is mapped to a 'Data.Map.Map' on the Haskell side.+-- | A <https://docs.gtk.org/glib/struct.HashTable.html GHashTable>. It is mapped to a 'Data.Map.Map' on the Haskell side. data GHashTable a b = GHashTable (Ptr (GHashTable a b)) --- | A <https://developer.gnome.org/glib/stable/glib-Doubly-Linked-Lists.html GList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+-- | A <https://docs.gtk.org/glib/struct.List.html GList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". data GList a = GList (Ptr (GList a)) --- | A <https://developer.gnome.org/glib/stable/glib-Singly-Linked-Lists.html GSList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+-- | A <https://docs.gtk.org/glib/struct.SList.html GSList>, 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 ())+-- | Destroy the memory pointed to by a given pointer type.+type GDestroyNotify ptr = FunPtr (ptr -> IO ()) -- | Free the given 'GList'. foreign import ccall "g_list_free" g_list_free ::@@ -190,3 +213,9 @@ -- | Free the given 'GSList'. foreign import ccall "g_slist_free" g_slist_free :: Ptr (GSList a) -> IO ()++-- | A pointer to a hashing function on the C side.+type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})++-- | A pointer to an equality checking function on the C side.+type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})
Data/GI/Base/Constructible.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses,- UndecidableInstances, KindSignatures, TypeFamilies #-}+ UndecidableInstances, KindSignatures, TypeFamilies, TypeOperators #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif
+ Data/GI/Base/DynVal.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|++This is an __experimental__ module that introduces support for dynamic+values: these are functions from a record @model@ to some type @a@+which keep track of which selectors of @model@ does the result depend+on. For example, for a record of the form++> data Example = Example {+> first :: Int,+> second :: Bool,+> third :: Float+> }++a `DynVal Example String` could be constructed, assuming that you are+given a @record@ `DynVal` representing the full record, using:++> let format = \f s -> "First is " <> f <> " and second is " <> s+> formatted = format <$> record.first <*> record.second :: DynVal Example String++Here we are showcasing two properties of `DynVal`s: they can be+conveniently constructed using @OverloadedRecordDot@, and they provide+an `Applicative` instance. The resulting @formatted@ `DynVal` keeps+track of the fact that it depends on the @first@ and @second@ record+selectors.++-}++module Data.GI.Base.DynVal+ ( DynVal(..), DVKey(..), ModelProxy(..), dvKeys, dvRead,+ modelProxyCurrentValue, modelProxyRegisterHandler, modelProxyUpdate) where++import GHC.Records (HasField(..))+import qualified GHC.TypeLits as TL++import Data.Proxy (Proxy(..))+import qualified Data.Set as S+import Data.String (IsString(..))+import qualified Data.Text as T++data DVKey = DVKeyDirect [T.Text]+ -- ^ Direct access to subfields: for example writing+ -- @record.field.subfield@ (using the `HasField`+ -- instance) would lead to @`DVKeyDirect` ["field",+ -- "subfield"]@+ | DVKeyDerived (S.Set [T.Text])+ -- ^ Value derived from a direct key, by acting with the+ -- functor or applicative instances.+ deriving (Eq, Ord, Show)++-- | A `DynVal` is a way of extracting values of type @a@ from+-- @model@, which keeps track of which fields (parameterised by+-- `dvKeys`) in @model@ are needed for computing the `DynVal`.+data DynVal model a = DynVal DVKey (model -> a)++-- | Keys to fields in the model that this `DynVal` depends on.+dvKeys :: DynVal model a -> DVKey+dvKeys (DynVal s _) = s++-- | Compute the actual value given a model.+dvRead :: DynVal model a -> model -> a+dvRead (DynVal _ r) = r++-- | Turn a key into a derived one.+toDerived :: DVKey -> DVKey+toDerived (DVKeyDirect d) = DVKeyDerived (S.singleton d)+toDerived derived = derived++-- | Joining of keys always produces derived ones.+instance Semigroup DVKey where+ DVKeyDirect a <> DVKeyDirect b = DVKeyDerived $ S.fromList [a,b]+ (DVKeyDirect a) <> (DVKeyDerived b) =+ DVKeyDerived $ S.insert a b+ (DVKeyDerived a) <> (DVKeyDirect b) =+ DVKeyDerived $ S.insert b a+ (DVKeyDerived a) <> (DVKeyDerived b) =+ DVKeyDerived $ S.union a b++instance Functor (DynVal model) where+ fmap f dv = DynVal (toDerived $ dvKeys dv) (f . dvRead dv)++instance Applicative (DynVal model) where+ pure x = DynVal (DVKeyDerived S.empty) (const x)+ dF <*> dA = DynVal (dvKeys dF <> dvKeys dA)+ (\m -> let f = dvRead dF m+ in f (dvRead dA m))++instance IsString (DynVal model T.Text) where+ fromString s = pure (T.pack s)++{-+-- If we make dvKeys :: model -> S.Set DVKey we can also produce a+-- Monad instance, but the set of resulting keys might depend on the+-- specific model passed, which could lead to subtle bugs.++instance Monad (DynVal model) where+ dv >>= gen = let runGen = \m -> gen (dvRead dv m)+ in DynVal {dvKeys = \m -> S.union (dvKeys dv m)+ (dvKeys (runGen m) m)+ , dvRead = \m -> dvRead (runGen m) m+ }+-}++-- | A `ModelProxy` is a way of obtaining records of type `model`,+-- which allows for registering for notifications whenever certain+-- keys (typically associated to record fields) get modified, and+-- allows to modify fields of the model.+data ModelProxy model = ModelProxy (IO model) (DVKey -> (model -> IO ()) -> IO ()) ([T.Text] -> (model -> Maybe model) -> IO ())++-- The following would be most naturally field accessors, but because+-- we introduce HasField instances for proxies we need to make these+-- ordinary functions instead.++-- | Obtain the current value of the model.+modelProxyCurrentValue :: ModelProxy model -> IO model+modelProxyCurrentValue (ModelProxy m _ _) = m++-- | Register a handler that will be executed whenever any of the+-- fields in the model pointed to by the keys is modified.+modelProxyRegisterHandler :: ModelProxy model -> DVKey -> (model -> IO ()) -> IO ()+modelProxyRegisterHandler (ModelProxy _ r _) = r++-- | Modify the given keys in the proxy, using the given update+-- function, of type (model -> Maybe model). If this function returns+-- Nothing no modification will be performed, otherwise the modified+-- model will be stored in the ModelProxy, and any listeners will be+-- notified of a change.+modelProxyUpdate :: ModelProxy model -> [T.Text] -> (model -> Maybe model)+ -> IO ()+modelProxyUpdate (ModelProxy _ _ u) = u++instance (HasField fieldName field a,+ TL.KnownSymbol fieldName) =>+ HasField fieldName (DynVal model field) (DynVal model a) where+ getField dv = let fn = T.pack . TL.symbolVal $ (Proxy :: Proxy fieldName)+ key = case dvKeys dv of+ derived@(DVKeyDerived _) -> derived+ DVKeyDirect direct -> DVKeyDirect (direct <> [fn])+ in DynVal key (getField @fieldName . dvRead dv)
+ Data/GI/Base/GArray.hs view
@@ -0,0 +1,16 @@+-- | Utilities for dealing with `GArray` types.+module Data.GI.Base.GArray+ ( allocGArray+ ) where++import Foreign.C (CInt(..), CUInt(..))+import Foreign.Ptr (Ptr)++import Data.GI.Base.BasicTypes (GArray(..))++-- | Args are zero_terminated, clear_, element_size+foreign import ccall g_array_new :: CInt -> CInt -> CUInt -> IO (Ptr (GArray a))++-- | Allocate a `GArray` with elements of the given size.+allocGArray :: CUInt -> IO (Ptr (GArray a))+allocGArray size = g_array_new 0 1 size
Data/GI/Base/GClosure.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies, DataKinds #-} -- | Some helper functions for dealing with @GClosure@s. module Data.GI.Base.GClosure ( GClosure(..)@@ -19,6 +20,7 @@ import Data.GI.Base.CallStack (HasCallStack) import Data.GI.Base.ManagedPtr (newBoxed, newManagedPtr', disownManagedPtr, withManagedPtr)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes) -- | The basic type. This corresponds to a wrapped @GClosure@ on the C -- side, which is a boxed object.@@ -31,8 +33,17 @@ 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+-- | There are no types in the bindings that a closure can be safely+-- cast to.+type instance ParentTypes (GClosure a) = '[]+instance HasParentTypes (GClosure a)++-- | Find the associated `GType` for the given closure.+instance TypedObject (GClosure a) where+ glibType = c_g_closure_get_type++-- | `GClosure`s are registered as boxed in the GLib type system.+instance GBoxed (GClosure a) foreign import ccall "g_cclosure_new" g_cclosure_new :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr (GClosure a))
+ Data/GI/Base/GError.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, DataKinds #-}++-- | To catch GError exceptions use the+-- catchGError* or handleGError* functions. They work in a similar+-- way to the standard 'Control.Exception.catch' and+-- 'Control.Exception.handle' functions.+--+-- To catch just a single specific error use 'catchGErrorJust' \/+-- 'handleGErrorJust'. To catch any error in a particular error domain+-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'+--+-- For convenience, generated code also includes specialized variants+-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For+-- example, for errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> one could+-- invoke <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#v:catchPixbufError catchPixbufError> \/+-- <https://hackage.haskell.org/package/gi-gdkpixbuf-2.0.14/docs/GI-GdkPixbuf-Enums.html#v:handlePixbufError handlePixbufError>. The definition is simply+--+-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a+-- > catchPixbufError = catchGErrorJustDomain+--+-- Notice that the type is suitably specialized, so only+-- errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> will be caught.+module Data.GI.Base.GError+ (+ -- * Unpacking GError+ --+ GError(..)+ , gerrorDomain+ , gerrorCode+ , gerrorMessage++ , GErrorDomain+ , GErrorCode+ , GErrorMessage++ -- * Catching GError exceptions+ , catchGErrorJust+ , catchGErrorJustDomain++ , handleGErrorJust+ , handleGErrorJustDomain++ -- * Creating new 'GError's+ , gerrorNew++ -- * Implementation specific details+ -- | The following are used in the implementation+ -- of the bindings, and are in general not necessary for using the+ -- API.+ , GErrorClass(..)++ , propagateGError+ , checkGError+ , maybePokeGError+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Foreign (poke, peek)+import Foreign.Ptr (Ptr, plusPtr, nullPtr)+import Foreign.C+import Control.Exception+import Data.Text (Text)+import qualified Data.Text as T++import System.IO.Unsafe (unsafePerformIO)++import Data.GI.Base.BasicTypes (GType(..), ManagedPtr, TypedObject(..),+ GBoxed)+import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.ManagedPtr (withManagedPtr, wrapBoxed, copyBoxed)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)+import Data.GI.Base.Utils (allocMem, freeMem)++import Data.GI.Base.Internal.CTypes (GQuark, C_gint, gerror_domain_offset,+ gerror_code_offset, gerror_message_offset)++-- | A GError, consisting of a domain, code and a human readable+-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and+-- 'gerrorMessage' below.+newtype GError = GError (ManagedPtr GError)++instance Show GError where+ show gerror = unsafePerformIO $ do+ code <- gerrorCode gerror+ message <- gerrorMessage gerror+ return $ T.unpack message ++ " (" ++ show code ++ ")"++instance Exception GError++-- | There are no types in the bindings that a `GError` can be safely+-- cast to.+type instance ParentTypes GError = '[]+instance HasParentTypes GError++foreign import ccall "g_error_get_type" g_error_get_type :: IO GType++instance TypedObject GError where+ glibType = g_error_get_type++-- | `GError`s are registered as boxed in the GLib type system.+instance GBoxed GError++-- | A code used to identify the "namespace" of the error. Within each error+-- domain all the error codes are defined in an enumeration. Each gtk\/gnome+-- module that uses GErrors has its own error domain. The rationale behind+-- using error domains is so that each module can organise its own error codes+-- without having to coordinate on a global error code list.+type GErrorDomain = GQuark++-- | A code to identify a specific error within a given 'GErrorDomain'. Most of+-- time you will not need to deal with this raw code since there is an+-- enumeration type for each error domain. Of course which enumeration to use+-- depends on the error domain, but if you use 'catchGErrorJustDomain' or+-- 'handleGErrorJustDomain', this is worked out for you automatically.+type GErrorCode = C_gint++-- | A human readable error message.+type GErrorMessage = Text++foreign import ccall "g_error_new_literal" g_error_new_literal ::+ GQuark -> GErrorCode -> CString -> IO (Ptr GError)++-- | Create a new 'GError'.+gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError+gerrorNew domain code message =+ withTextCString message $ \cstring ->+ g_error_new_literal domain code cstring >>= wrapBoxed GError++-- | Return the domain for the given `GError`. This is a GQuark, a+-- textual representation can be obtained with+-- `GI.GLib.quarkToString`.+gerrorDomain :: GError -> IO GQuark+gerrorDomain gerror =+ withManagedPtr gerror $ \ptr ->+ peek $ ptr `plusPtr` gerror_domain_offset++-- | The numeric code for the given `GError`.+gerrorCode :: GError -> IO GErrorCode+gerrorCode gerror =+ withManagedPtr gerror $ \ptr ->+ peek $ ptr `plusPtr` gerror_code_offset++-- | A text message describing the `GError`.+gerrorMessage :: GError -> IO GErrorMessage+gerrorMessage gerror =+ withManagedPtr gerror $ \ptr ->+ (peek $ ptr `plusPtr` gerror_message_offset) >>= cstringToText++-- | Each error domain's error enumeration type should be an instance of this+-- class. This class helps to hide the raw error and domain codes from the+-- user.+--+-- Example for <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError>:+--+-- > instance GErrorClass PixbufError where+-- > gerrorClassDomain _ = "gdk-pixbuf-error-quark"+--+class Enum err => GErrorClass err where+ gerrorClassDomain :: err -> Text -- ^ This must not use the value of its+ -- parameter so that it is safe to pass+ -- 'undefined'.++foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::+ CString -> IO GQuark++-- | Given the string representation of an error domain returns the+-- corresponding error quark.+gErrorQuarkFromDomain :: Text -> IO GQuark+gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string++-- | This will catch just a specific GError exception. If you need to catch a+-- range of related errors, 'catchGErrorJustDomain' is probably more+-- appropriate. Example:+--+-- > do image <- catchGErrorJust PixbufErrorCorruptImage+-- > loadImage+-- > (\errorMessage -> do log errorMessage+-- > return mssingImagePlaceholder)+--+catchGErrorJust :: GErrorClass err => err -- ^ The error to catch+ -> IO a -- ^ The computation to run+ -> (GErrorMessage -> IO a) -- ^ Handler to invoke if+ -- an exception is raised+ -> IO a+catchGErrorJust code action handler = catch action handler'+ where handler' gerror = do+ quark <- gErrorQuarkFromDomain (gerrorClassDomain code)+ domain <- gerrorDomain gerror+ code' <- gerrorCode gerror+ if domain == quark && code' == (fromIntegral . fromEnum) code+ then gerrorMessage gerror >>= handler+ else throw gerror -- Pass it on++-- | Catch all GErrors from a particular error domain. The handler function+-- should just deal with one error enumeration type. If you need to catch+-- errors from more than one error domain, use this function twice with an+-- appropriate handler functions for each.+--+-- > catchGErrorJustDomain+-- > loadImage+-- > (\err message -> case err of+-- > PixbufErrorCorruptImage -> ...+-- > PixbufErrorInsufficientMemory -> ...+-- > PixbufErrorUnknownType -> ...+-- > _ -> ...)+--+catchGErrorJustDomain :: forall err a. GErrorClass err =>+ IO a -- ^ The computation to run+ -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised+ -> IO a+catchGErrorJustDomain action handler = catch action handler'+ where handler' gerror = do+ quark <- gErrorQuarkFromDomain (gerrorClassDomain (undefined :: err))+ domain <- gerrorDomain gerror+ if domain == quark+ then do+ code <- (toEnum . fromIntegral) <$> gerrorCode gerror+ msg <- gerrorMessage gerror+ handler code msg+ else throw gerror++-- | A verson of 'handleGErrorJust' with the arguments swapped around.+handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJust code = flip (catchGErrorJust code)++-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.+handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJustDomain = flip catchGErrorJustDomain++-- | Run the given function catching possible 'GError's in its+-- execution. If a 'GError' is emitted this throws the corresponding+-- exception.+propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a+propagateGError f = checkGError f throw++-- | Like 'propagateGError', but allows to specify a custom handler+-- instead of just throwing the exception.+checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a+checkGError f handler = do+ gerrorPtr <- allocMem+ poke gerrorPtr nullPtr+ result <- f gerrorPtr+ gerror <- peek gerrorPtr+ freeMem gerrorPtr+ if gerror /= nullPtr+ then wrapBoxed GError gerror >>= handler+ else return result++-- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a+-- copy in the passed in pointer, unless the pointer is `nullPtr`.+maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()+maybePokeGError _ Nothing = return ()+maybePokeGError ptrPtr (Just gerror)+ | ptrPtr == nullPtr = return ()+ | otherwise = copyBoxed gerror >>= poke ptrPtr
− Data/GI/Base/GError.hsc
@@ -1,254 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}---- | To catch GError exceptions use the--- catchGError* or handleGError* functions. They work in a similar--- way to the standard 'Control.Exception.catch' and--- 'Control.Exception.handle' functions.------ To catch just a single specific error use 'catchGErrorJust' \/--- 'handleGErrorJust'. To catch any error in a particular error domain--- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'------ For convenience, generated code also includes specialized variants--- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For--- example, for errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> one could--- invoke <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#v:catchPixbufError catchPixbufError> \/--- <https://hackage.haskell.org/package/gi-gdkpixbuf-2.0.14/docs/GI-GdkPixbuf-Enums.html#v:handlePixbufError handlePixbufError>. The definition is simply------ > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a--- > catchPixbufError = catchGErrorJustDomain------ Notice that the type is suitably specialized, so only--- errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> will be caught.-module Data.GI.Base.GError- (- -- * Unpacking GError- --- GError(..)- , gerrorDomain- , gerrorCode- , gerrorMessage-- , GErrorDomain- , GErrorCode- , GErrorMessage-- -- * Catching GError exceptions- , catchGErrorJust- , catchGErrorJustDomain-- , handleGErrorJust- , handleGErrorJustDomain-- -- * Creating new 'GError's- , gerrorNew-- -- * Implementation specific details- -- | The following are used in the implementation- -- of the bindings, and are in general not necessary for using the- -- API.- , GErrorClass(..)-- , propagateGError- , checkGError- , maybePokeGError- ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif--import Foreign (poke, peek)-import Foreign.Ptr (Ptr, plusPtr, nullPtr)-import Foreign.C-import Control.Exception-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Data.Int-import Data.Word--import System.IO.Unsafe (unsafePerformIO)--import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), ManagedPtr)-import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr, copyBoxed)-import Data.GI.Base.Utils (allocMem, freeMem)--#include <glib.h>---- | A GError, consisting of a domain, code and a human readable--- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and--- 'gerrorMessage' below.-newtype GError = GError (ManagedPtr GError)- deriving (Typeable)--instance Show GError where- show gerror = unsafePerformIO $ do- code <- gerrorCode gerror- message <- gerrorMessage gerror- return $ T.unpack message ++ " (" ++ show code ++ ")"--instance Exception GError--foreign import ccall "g_error_get_type" g_error_get_type :: IO GType--instance BoxedObject GError where- boxedType _ = g_error_get_type---- | A GQuark.-type GQuark = #type GQuark---- | A code used to identify the "namespace" of the error. Within each error--- domain all the error codes are defined in an enumeration. Each gtk\/gnome--- module that uses GErrors has its own error domain. The rationale behind--- using error domains is so that each module can organise its own error codes--- without having to coordinate on a global error code list.-type GErrorDomain = GQuark---- | A code to identify a specific error within a given 'GErrorDomain'. Most of--- time you will not need to deal with this raw code since there is an--- enumeration type for each error domain. Of course which enumeration to use--- depends on the error domain, but if you use 'catchGErrorJustDomain' or--- 'handleGErrorJustDomain', this is worked out for you automatically.-type GErrorCode = #type gint---- | A human readable error message.-type GErrorMessage = Text--foreign import ccall "g_error_new_literal" g_error_new_literal ::- GQuark -> GErrorCode -> CString -> IO (Ptr GError)---- | Create a new 'GError'.-gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError-gerrorNew domain code message =- withTextCString message $ \cstring ->- g_error_new_literal domain code cstring >>= wrapBoxed GError---- | Return the domain for the given `GError`. This is a GQuark, a--- textual representation can be obtained with--- `GI.GLib.quarkToString`.-gerrorDomain :: GError -> IO GQuark-gerrorDomain gerror =- withManagedPtr gerror $ \ptr ->- peek $ ptr `plusPtr` #{offset GError, domain}---- | The numeric code for the given `GError`.-gerrorCode :: GError -> IO GErrorCode-gerrorCode gerror =- withManagedPtr gerror $ \ptr ->- peek $ ptr `plusPtr` #{offset GError, code}---- | A text message describing the `GError`.-gerrorMessage :: GError -> IO GErrorMessage-gerrorMessage gerror =- withManagedPtr gerror $ \ptr ->- (peek $ ptr `plusPtr` #{offset GError, message}) >>= cstringToText---- | Each error domain's error enumeration type should be an instance of this--- class. This class helps to hide the raw error and domain codes from the--- user.------ Example for <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError>:------ > instance GErrorClass PixbufError where--- > gerrorClassDomain _ = "gdk-pixbuf-error-quark"----class Enum err => GErrorClass err where- gerrorClassDomain :: err -> Text -- ^ This must not use the value of its- -- parameter so that it is safe to pass- -- 'undefined'.--foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::- CString -> IO GQuark---- | Given the string representation of an error domain returns the--- corresponding error quark.-gErrorQuarkFromDomain :: Text -> IO GQuark-gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string---- | This will catch just a specific GError exception. If you need to catch a--- range of related errors, 'catchGErrorJustDomain' is probably more--- appropriate. Example:------ > do image <- catchGErrorJust PixbufErrorCorruptImage--- > loadImage--- > (\errorMessage -> do log errorMessage--- > return mssingImagePlaceholder)----catchGErrorJust :: GErrorClass err => err -- ^ The error to catch- -> IO a -- ^ The computation to run- -> (GErrorMessage -> IO a) -- ^ Handler to invoke if- -- an exception is raised- -> IO a-catchGErrorJust code action handler = catch action handler'- where handler' gerror = do- quark <- gErrorQuarkFromDomain (gerrorClassDomain code)- domain <- gerrorDomain gerror- code' <- gerrorCode gerror- if domain == quark && code' == (fromIntegral . fromEnum) code- then gerrorMessage gerror >>= handler- else throw gerror -- Pass it on---- | Catch all GErrors from a particular error domain. The handler function--- should just deal with one error enumeration type. If you need to catch--- errors from more than one error domain, use this function twice with an--- appropriate handler functions for each.------ > catchGErrorJustDomain--- > loadImage--- > (\err message -> case err of--- > PixbufErrorCorruptImage -> ...--- > PixbufErrorInsufficientMemory -> ...--- > PixbufErrorUnknownType -> ...--- > _ -> ...)----catchGErrorJustDomain :: forall err a. GErrorClass err =>- IO a -- ^ The computation to run- -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised- -> IO a-catchGErrorJustDomain action handler = catch action handler'- where handler' gerror = do- quark <- gErrorQuarkFromDomain (gerrorClassDomain (undefined :: err))- domain <- gerrorDomain gerror- if domain == quark- then do- code <- (toEnum . fromIntegral) <$> gerrorCode gerror- msg <- gerrorMessage gerror- handler code msg- else throw gerror---- | A verson of 'handleGErrorJust' with the arguments swapped around.-handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a-handleGErrorJust code = flip (catchGErrorJust code)---- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.-handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a-handleGErrorJustDomain = flip catchGErrorJustDomain---- | Run the given function catching possible 'GError's in its--- execution. If a 'GError' is emitted this throws the corresponding--- exception.-propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a-propagateGError f = checkGError f throw---- | Like 'propagateGError', but allows to specify a custom handler--- instead of just throwing the exception.-checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a-checkGError f handler = do- gerrorPtr <- allocMem- poke gerrorPtr nullPtr- result <- f gerrorPtr- gerror <- peek gerrorPtr- freeMem gerrorPtr- if gerror /= nullPtr- then wrapBoxed GError gerror >>= handler- else return result---- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a--- copy in the passed in pointer, unless the pointer is `nullPtr`.-maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()-maybePokeGError _ Nothing = return ()-maybePokeGError ptrPtr (Just gerror)- | ptrPtr == nullPtr = return ()- | otherwise = copyBoxed gerror >>= poke ptrPtr
Data/GI/Base/GHashTable.hsc view
@@ -21,24 +21,18 @@ , gStrEqual , cstringPackPtr , cstringUnpackPtr+ , gvaluePackPtr+ , gvalueUnpackPtr ) where -import Data.Int-import Data.Word- import Foreign.C-import Foreign.Ptr (Ptr, castPtr, FunPtr)+import Foreign.Ptr (Ptr, castPtr) -import Data.GI.Base.BasicTypes (PtrWrapped(..))+import Data.GI.Base.BasicTypes (PtrWrapped(..), GHashFunc, GEqualFunc)+import Data.GI.Base.GValue (GValue) #include <glib-object.h> --- | A pointer to a hashing function on the C side.-type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})---- | A pointer to an equality checking function on the C side.-type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})- -- | Compute the hash for a `Ptr`. foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a) @@ -66,3 +60,12 @@ -- | Extract a `CString` wrapped into a `Ptr` coming from a `GHashTable`. cstringUnpackPtr :: PtrWrapped CString -> CString cstringUnpackPtr = ptrUnpackPtr++-- | Pack a `Ptr` to `GValue` into a `Ptr` than can go into a `GHashTable`.+gvaluePackPtr :: Ptr GValue -> PtrWrapped (Ptr GValue)+gvaluePackPtr = ptrPackPtr++-- | Extract a `Ptr` to `GValue` wrapped into a `Ptr` coming from a+-- `GHashTable`.+gvalueUnpackPtr :: PtrWrapped (Ptr GValue) -> Ptr GValue+gvalueUnpackPtr = ptrUnpackPtr
Data/GI/Base/GObject.hsc view
@@ -1,11 +1,13 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | This module constains helpers for dealing with `GObject`-derived -- types.@@ -35,20 +37,22 @@ , gobjectInstallProperty , gobjectInstallCIntProperty , gobjectInstallCStringProperty+ , gobjectInstallGBooleanProperty ) where +import Data.Maybe (catMaybes)+import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Proxy (Proxy(..)) import Data.Coerce (coerce) import Foreign.C (CUInt(..), CString, newCString)-#if !MIN_VERSION_base(4,13,0)-import Foreign.Ptr (FunPtr)+import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, nullFunPtr) import Foreign.StablePtr (newStablePtr, deRefStablePtr, castStablePtrToPtr, castPtrToStablePtr)-#endif-import Foreign+import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf))+import Foreign (mallocBytes, copyBytes, free) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))@@ -56,18 +60,25 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Optics.Core as O+ import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy, attrConstruct, attrTransfer,- AttrInfo(..))-import Data.GI.Base.BasicTypes (CGType, GType(..), GObject(..),+ AttrInfo(..), EqMaybe(..), bindPropToField)+import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, GSList, GDestroyNotify, ManagedPtr(..), GParamSpec(..),- gtypeName)-import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+ TypedObject(glibType),+ gtypeName, g_slist_free)+import Data.GI.Base.BasicConversions (withTextCString, cstringToText,+ packGSList, mapGSList) import Data.GI.Base.CallStack (HasCallStack, prettyCallStack)+import Data.GI.Base.DynVal (modelProxyCurrentValue, modelProxyRegisterHandler,+ dvKeys, dvRead) import Data.GI.Base.GParamSpec (PropertyInfo(..), gParamSpecValue, CIntPropertyInfo(..), CStringPropertyInfo(..),- gParamSpecCInt, gParamSpecCString,+ GBooleanPropertyInfo(..),+ gParamSpecCInt, gParamSpecCString, gParamSpecGBoolean, getGParamSpecGetterSetter, PropGetSetter(..)) import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString)@@ -75,7 +86,9 @@ import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject, newObject) import Data.GI.Base.Overloading (ResolveAttribute)-import Data.GI.Base.Utils (dbgLog)+import Data.GI.Base.Signals (on, after)+import Data.GI.Base.Utils (dbgLog, callocBytes, freeMem)+import Data.GI.Base.Internal.PathFieldAccess (Components, PathFieldAccess(..)) #include <glib-object.h> @@ -90,38 +103,90 @@ -> [AttrOp o 'AttrConstruct] -> m o constructGObject constructor attrs = liftIO $ do- props <- mapM construct attrs- doConstructGObject constructor props+ props <- catMaybes <$> mapM construct attrs+ obj <- doConstructGObject constructor props+ mapM_ (setSignal obj) attrs+ mapM_ (registerHandlers obj) attrs+ return obj where construct :: AttrOp o 'AttrConstruct ->- IO (GValueConstruct o)+ IO (Maybe (GValueConstruct o)) construct ((_attr :: AttrLabelProxy label) := x) =- attrConstruct @(ResolveAttribute label o) x+ Just <$> attrConstruct @(ResolveAttribute label o) x construct ((_attr :: AttrLabelProxy label) :=> x) =- x >>= attrConstruct @(ResolveAttribute label o)+ Just <$> (x >>= attrConstruct @(ResolveAttribute label o)) - construct ((_attr :: AttrLabelProxy label) :&= x) =- attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>=- attrConstruct @(ResolveAttribute label o)+ construct ((_attr :: AttrLabelProxy label) :&= x) = Just <$>+ (attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>=+ attrConstruct @(ResolveAttribute label o)) + construct ((_attr :: AttrLabelProxy label) :!<~ dv) = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+ Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model)++ construct (Bind (_pattr :: AttrLabelProxy prop)+ (_fattr :: AttrLabelProxy field)) = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+ let lens = getLens (Proxy @field) model+ value = O.view lens model+ Just <$> attrConstruct @(ResolveAttribute prop o) value+ where getLens :: forall path components model value.+ (components ~ Components path,+ PathFieldAccess components model value) =>+ Proxy path -> model -> O.Lens' model value+ getLens _ _ = let+ (lens, _) = pathFieldAccess (Proxy @components) (Proxy @model)+ in lens++ -- Since we are constructing the object there's nothing to compare+ -- to, so we just set the value.+ construct ((_attr :: AttrLabelProxy label) :<~ dv) = do+ model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+ Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model)++ construct (On _ _) = return Nothing+ construct (After _ _) = return Nothing++ setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()+ setSignal obj (On signal callback) = void $ on obj signal callback+ setSignal obj (After signal callback) = void $ after obj signal callback+ setSignal _ _ = return ()++ registerHandlers :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()+ registerHandlers obj ((_attr :: AttrLabelProxy label) :!<~ dv) =+ modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel ->+ attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel)++ registerHandlers obj ((_attr :: AttrLabelProxy label) :<~ dv) =+ modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do+ current <- attrGet @(ResolveAttribute label o) obj+ let modifiedValue = dvRead dv modifiedModel+ when (not $ eqMaybe modifiedValue current) $+ attrSet @(ResolveAttribute label o) obj modifiedValue++ registerHandlers obj (Bind pattr fattr) =+ bindPropToField (Proxy @'AttrConstruct) obj pattr fattr++ registerHandlers _ _ = pure ()+ -- | 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' :: (HasCallStack, MonadIO m, GObject o) =>+ (ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o new' constructor actions = do- props <- liftIO $ sequence (actions)+ props <- sequence actions doConstructGObject constructor props -- | Construct the `GObject` given the list of `GValueConstruct`s.-doConstructGObject :: forall o m. (GObject o, MonadIO m)+doConstructGObject :: forall o m. (HasCallStack, GObject o, MonadIO m) => (ManagedPtr o -> o) -> [GValueConstruct o] -> m o doConstructGObject constructor props = liftIO $ do let nprops = length props names <- mallocBytes (nprops * sizeOf nullPtr) values <- mallocBytes (nprops * gvalueSize) fill names values props- gtype <- gobjectType @o+ gtype <- glibType @o result <- g_object_new gtype (fromIntegral nprops) names values freeStrings nprops names free values@@ -174,15 +239,26 @@ -- | 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 -> a -> IO (GObjectPrivateData a) + -- | List of interfaces implemented by the type. Each element is a+ -- triplet (@gtype@, @interfaceInit@, @interfaceFinalize@), where+ -- @gtype :: IO GType@ is a constructor for the type of the+ -- interface, @interfaceInit :: Ptr () -> IO ()@ is a function that+ -- registers the callbacks in the interface, and @interfaceFinalize+ -- :: Maybe (Ptr () -> IO ())@ is the (optional) finalizer.+ objectInterfaces :: [(IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))]+ objectInterfaces = []+ type CGTypeClassInit = GObjectClass -> IO () foreign import ccall "wrapper" mkClassInit :: CGTypeClassInit -> IO (FunPtr CGTypeClassInit)@@ -191,11 +267,19 @@ foreign import ccall "wrapper" mkInstanceInit :: CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o)) +type CGTypeInterfaceInit = Ptr () -> Ptr () -> IO ()+foreign import ccall "wrapper"+ mkInterfaceInit :: CGTypeInterfaceInit -> IO (FunPtr CGTypeInterfaceInit)++type CGTypeInterfaceFinalize = Ptr () -> Ptr () -> IO ()+foreign import ccall "wrapper"+ mkInterfaceFinalize :: CGTypeInterfaceFinalize -> IO (FunPtr CGTypeInterfaceFinalize)+ 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+ FunPtr (CGTypeInstanceInit o) -> Ptr (GSList a) -> IO CGType foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class :: GObjectClass -> IO CGType@@ -243,8 +327,12 @@ else do classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o) instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o)- (GType parentCGType) <- gobjectType @(GObjectParentType o)- GType <$> register_gtype parentCGType cTypeName classInit instanceInit+ (GType parentCGType) <- glibType @(GObjectParentType o)+ interfaces <- mapM packInterface (objectInterfaces @o) >>= packGSList+ gtype <- GType <$> register_gtype parentCGType cTypeName classInit instanceInit interfaces+ mapGSList freeInterfaceInfo interfaces+ g_slist_free interfaces+ return gtype where unwrapInstanceInit :: (GObjectClass -> o -> IO (GObjectPrivateData o)) ->@@ -269,7 +357,7 @@ case maybeGetSet of Nothing -> do pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText- typeName <- gobjectType @o >>= gtypeName+ typeName <- glibType @o >>= gtypeName dbgLog $ "WARNING: Attempting to set unknown property \"" <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"." Just pgs -> (propSetter pgs) objPtr gvPtr@@ -280,11 +368,40 @@ case maybeGetSet of Nothing -> do pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText- typeName <- gobjectType @o >>= gtypeName+ typeName <- glibType @o >>= gtypeName dbgLog $ "WARNING: Attempting to get unknown property \"" <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"." Just pgs -> (propGetter pgs) objPtr destGValuePtr + packInterface :: (IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))+ -> IO (Ptr CGType)+ packInterface (ifaceGTypeConstruct, initHs, maybeFinalize) = do+ gtype <- ifaceGTypeConstruct+ info <- callocBytes #{size GInterfaceInfo}+ initFn <- mkInterfaceInit (unwrapInit initHs)+ finalizeFn <- case maybeFinalize of+ Just finalizeHs -> mkInterfaceFinalize (unwrapFinalize finalizeHs)+ Nothing -> pure nullFunPtr+ #{poke GInterfaceInfo, interface_init} info initFn+ #{poke GInterfaceInfo, interface_finalize} info finalizeFn++ combined <- callocBytes (#{size GType} + #{size gpointer})+ poke combined (gtypeToCGType gtype)+ poke (combined `plusPtr` #{size GType}) info+ return combined++ unwrapInit :: (Ptr () -> IO ()) -> CGTypeInterfaceInit+ unwrapInit f ptr _data = f ptr++ unwrapFinalize :: (Ptr () -> IO ()) -> CGTypeInterfaceFinalize+ unwrapFinalize = unwrapInit++ freeInterfaceInfo :: Ptr CGType -> IO ()+ freeInterfaceInfo combinedPtr = do+ info <- peek (combinedPtr `plusPtr` #{size GType})+ freeMem info+ freeMem combinedPtr+ -- | 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"@@ -320,10 +437,10 @@ else return Nothing foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr ::- FunPtr (GDestroyNotify a)+ GDestroyNotify (Ptr ()) foreign import ccall g_object_set_qdata_full ::- Ptr a -> GQuark b -> Ptr () -> FunPtr (GDestroyNotify ()) -> IO ()+ Ptr a -> GQuark b -> Ptr () -> GDestroyNotify (Ptr ()) -> IO () -- | Set the value of the user data for the given `GObject` to a -- `StablePtr` to the given Haskell object. The `StablePtr` will be@@ -396,5 +513,13 @@ GObjectClass -> CStringPropertyInfo o -> IO () gobjectInstallCStringProperty klass propInfo = do pspec <- gParamSpecCString propInfo+ withManagedPtr pspec $ \pspecPtr ->+ g_object_class_install_property klass 1 pspecPtr++-- | Add a `${type gboolean}`-valued property to the given object class.+gobjectInstallGBooleanProperty :: DerivedGObject o =>+ GObjectClass -> GBooleanPropertyInfo o -> IO ()+gobjectInstallGBooleanProperty klass propInfo = do+ pspec <- gParamSpecGBoolean propInfo withManagedPtr pspec $ \pspecPtr -> g_object_class_install_property klass 1 pspecPtr
Data/GI/Base/GParamSpec.hsc view
@@ -20,6 +20,9 @@ , gParamSpecCString , CIntPropertyInfo(..) , gParamSpecCInt+ , GBooleanPropertyInfo(..)+ , gParamSpecGBoolean+ , GParamFlag(..) -- * Get\/Set , PropGetSetter(..)@@ -32,6 +35,7 @@ castStablePtrToPtr, castPtrToStablePtr) import Control.Monad (void) import Data.Coerce (coerce)+import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -39,7 +43,7 @@ disownManagedPtr, newObject, withTransient) import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString)-import Data.GI.Base.BasicTypes (GObject(..), GParamSpec(..),+import Data.GI.Base.BasicTypes (GObject, GParamSpec(..), GType(..), IsGFlag, ManagedPtr) import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString) import Data.GI.Base.GType (gtypeStablePtr)@@ -146,16 +150,16 @@ 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`+ -> (Ptr 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+ gvalueSetter destPtr value , propSetter = \objPtr newGValuePtr ->- withTransient GValue newGValuePtr $ \newGValue -> do+ withTransient newGValuePtr $ \newGValue -> do obj <- objectFromPtr objPtr- value <- fromGValue newGValue+ value <- GV.fromGValue newGValue setter obj value } @@ -214,9 +218,9 @@ take_stablePtr destPtr stablePtr setter' :: Ptr o -> (Ptr GValue) -> IO ()- setter' objPtr gvPtr = withTransient GValue gvPtr $ \gv -> do+ setter' objPtr gvPtr = withTransient gvPtr $ \gv -> do obj <- objectFromPtr objPtr- val <- fromGValue gv >>= deRefStablePtr+ val <- GV.fromGValue gv >>= deRefStablePtr setter obj val -- | Information on a property of type `CInt` to be registered. A@@ -270,7 +274,7 @@ defaultValue (maybe defaultFlags gflagsToWord flags) quark <- pspecQuark- gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter GV.set_int)+ gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_) wrapGParamSpecPtr pspecPtr -- | Information on a property of type `Text` to be registered. A@@ -316,7 +320,49 @@ g_param_spec_string cname cnick cblurb cdefault (maybe defaultFlags gflagsToWord flags) quark <- pspecQuark- gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter GV.set_string)+ gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_)+ wrapGParamSpecPtr pspecPtr++-- | Information on a property of type `type gboolean` 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 GBooleanPropertyInfo o = GBooleanPropertyInfo+ { name :: Text+ , nick :: Text+ , blurb :: Text+ , defaultValue :: Bool+ , flags :: Maybe [GParamFlag]+ , setter :: o -> Bool -> IO ()+ , getter :: o -> IO (Bool)+ }++foreign import ccall g_param_spec_boolean ::+ CString -> CString -> CString -> #{type gboolean} -> CInt -> IO (Ptr GParamSpec)++-- | Create a `GParamSpec` for a bool param.+gParamSpecGBoolean :: GObject o => GBooleanPropertyInfo o -> IO GParamSpec+gParamSpecGBoolean (GBooleanPropertyInfo {..}) =+ withTextCString name $ \cname ->+ withTextCString nick $ \cnick ->+ withTextCString blurb $ \cblurb -> do+ pspecPtr <- g_param_spec_boolean cname cnick cblurb+ ((fromIntegral . fromEnum) defaultValue)+ (maybe defaultFlags gflagsToWord flags)+ quark <- pspecQuark+ gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_) wrapGParamSpecPtr pspecPtr foreign import ccall g_param_spec_set_qdata_full ::
Data/GI/Base/GType.hsc view
@@ -21,8 +21,10 @@ , gtypeVariant , gtypeByteArray , gtypeInvalid+ , gtypeParam , gtypeStablePtr+ , gtypeHValue ) where import Data.GI.Base.BasicTypes (GType(..), CGType)@@ -106,9 +108,9 @@ gtypeVariant :: GType gtypeVariant = GType #const G_TYPE_VARIANT --- | The `GType` corresponding to 'Data.GI.Base.GError.GError'.-gtypeError :: GType-gtypeError = GType #const G_TYPE_ERROR+-- | The `GType` corresponding to 'Data.GI.Base.BasicTypes.GParamSpec'.+gtypeParam :: GType+gtypeParam = GType #const G_TYPE_PARAM {- Run-time types -} @@ -135,3 +137,15 @@ -- | The `GType` for boxed `StablePtr`s. gtypeStablePtr :: GType gtypeStablePtr = GType haskell_gi_StablePtr_get_type++foreign import ccall haskell_gi_HaskellValue_get_type :: CGType++-- | The `GType` for a generic Haskell value.+gtypeHValue :: GType+gtypeHValue = GType haskell_gi_HaskellValue_get_type++foreign import ccall "g_error_get_type" g_error_get_type :: CGType++-- | The `GType` corresponding to 'Data.GI.Base.GError.GError'.+gtypeError :: GType+gtypeError = GType g_error_get_type
+ Data/GI/Base/GValue.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.GI.Base.GValue+ (+ -- * Constructing GValues+ GValue(..)+ , IsGValue(..)+ , toGValue+ , fromGValue+ , GValueConstruct(..)+ , ptr_to_gvalue_free++ , newGValue+ , buildGValue+ , disownGValue+ , noGValue+ , newGValueFromPtr+ , wrapGValuePtr+ , unsetGValue+ , gvalueType++ -- * Packing GValues into arrays+ , packGValueArray+ , unpackGValueArrayWithLength+ , mapGValueArrayWithLength++ -- * Packing Haskell values into GValues+ , HValue(..)++ -- * Setters and getters+ , set_object+ , get_object+ , set_boxed+ , get_boxed+ , set_variant+ , get_variant+ , set_enum+ , get_enum+ , set_flags+ , get_flags+ , set_stablePtr+ , get_stablePtr+ , take_stablePtr+ , set_param+ , get_param+ , set_hvalue+ , get_hvalue+ ) where++import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.Coerce (coerce)+import Data.Word+import Data.Int+import Data.Text (Text, pack, unpack)++import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),+ CLong(..), CULong(..))+import Foreign.C.String (CString)+import Foreign.Ptr (Ptr, nullPtr, plusPtr, FunPtr)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr,+ newStablePtr, deRefStablePtr)+import Type.Reflection (typeRep, TypeRep)+import System.IO (hPutStrLn, stderr)++import Data.Dynamic (toDyn, fromDynamic, Typeable)+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)+import Data.GI.Base.Internal.CTypes (cgvalueSize)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)++-- | Haskell-side representation of a @GValue@.+newtype GValue = GValue (ManagedPtr GValue)++-- | A pointer to a function freeing GValues.+foreign import ccall "&haskell_gi_gvalue_free" ptr_to_gvalue_free ::+ FunPtr (Ptr GValue -> IO ())++-- | There are no types in the bindings that a `GValue` can be safely+-- cast to.+type instance ParentTypes GValue = '[]+instance HasParentTypes GValue++foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::+ IO GType++-- | Find the associated `GType` for `GValue`.+instance TypedObject GValue where+ glibType = c_g_value_get_type++-- | `GValue`s are registered as boxed in the GLib type system.+instance GBoxed GValue++foreign import ccall "g_value_init" g_value_init ::+ Ptr GValue -> CGType -> IO (Ptr GValue)++-- | A type holding a `GValue` with an associated label. It is+-- parameterized by a phantom type encoding the target type for the+-- `GValue` (useful when constructing properties).+data GValueConstruct o = GValueConstruct String GValue++-- | Build a new, empty, `GValue` of the given type.+newGValue :: GType -> IO GValue+newGValue (GType gtype) = do+ gvptr <- callocBytes cgvalueSize+ _ <- g_value_init gvptr gtype+ gv <- wrapBoxed GValue gvptr+ return $! gv++-- | Take ownership of a passed in 'Ptr'.+wrapGValuePtr :: Ptr GValue -> IO GValue+wrapGValuePtr ptr = wrapBoxed GValue ptr++-- | Construct a Haskell wrapper for the given 'GValue', making a+-- copy.+newGValueFromPtr :: Ptr GValue -> IO GValue+newGValueFromPtr ptr = newBoxed GValue ptr++-- | A convenience function for building a new GValue and setting the+-- initial value.+buildGValue :: GType -> (Ptr GValue -> a -> IO ()) -> a -> IO GValue+buildGValue gtype setter val = do+ gv <- newGValue gtype+ withManagedPtr gv $ \gvPtr -> setter gvPtr val+ return gv++-- | Disown a `GValue`, i.e. do not unref the underlying object when+-- the Haskell object is garbage collected.+disownGValue :: GValue -> IO (Ptr GValue)+disownGValue = disownManagedPtr++foreign import ccall "_haskell_gi_g_value_get_type" g_value_get_type :: Ptr GValue -> IO CGType++-- | Return the `GType` contained by a `GValue`.+gvalueType :: GValue -> IO GType+gvalueType gv = withManagedPtr gv $ \gvptr -> do+ cgtype <- g_value_get_type gvptr+ return (GType cgtype)++foreign import ccall "g_value_unset" g_value_unset :: Ptr GValue -> IO ()++-- | Unset the `GValue`, freeing all resources associated to it.+unsetGValue :: Ptr GValue -> IO ()+unsetGValue = g_value_unset++-- | A convenient alias for @Nothing :: Maybe GValue@.+noGValue :: Maybe GValue+noGValue = Nothing++-- | Class for types that can be marshaled back and forth between+-- Haskell values and `GValue`s. These are low-level methods, you+-- might want to use `toGValue` and `fromGValue` instead for a higher+-- level interface.+class IsGValue a where+ gvalueGType_ :: IO GType -- ^ `GType` for the `GValue`+ -- containing values of this type.+ gvalueSet_ :: Ptr GValue -> a -> IO () -- ^ Set the `GValue` to+ -- the given Haskell+ -- value.+ gvalueGet_ :: Ptr GValue -> IO a -- ^ Get the Haskel value inside+ -- the `GValue`.++-- | Create a `GValue` from the given Haskell value.+toGValue :: forall a m. (IsGValue a, MonadIO m) => a -> m GValue+toGValue val = liftIO $ do+ gvptr <- callocBytes cgvalueSize+ GType gtype <- gvalueGType_ @a+ _ <- g_value_init gvptr gtype+ gvalueSet_ gvptr val+ gv <- wrapBoxed GValue gvptr+ return $! gv++-- | Create a Haskell object out of the given `GValue`.+fromGValue :: (IsGValue a, MonadIO m) => GValue -> m a+fromGValue gv = liftIO $ withManagedPtr gv gvalueGet_++instance IsGValue (Maybe String) where+ gvalueGType_ = return gtypeString+ gvalueSet_ gvPtr mstr = set_string gvPtr (pack <$> mstr)+ gvalueGet_ v = (fmap unpack) <$> get_string v++instance IsGValue (Maybe Text) where+ gvalueGType_ = return gtypeString+ gvalueSet_ = set_string+ gvalueGet_ = get_string++instance IsGValue (Ptr a) where+ gvalueGType_ = return gtypePointer+ gvalueSet_ = set_pointer+ gvalueGet_ = get_pointer++instance IsGValue Int32 where+ gvalueGType_ = return gtypeInt+ gvalueSet_ = set_int32+ gvalueGet_ = get_int32++instance IsGValue Word32 where+ gvalueGType_ = return gtypeUInt+ gvalueSet_ = set_uint32+ gvalueGet_ = get_uint32++instance IsGValue CInt where+ gvalueGType_ = return gtypeInt+ gvalueSet_ = set_int+ gvalueGet_ = get_int++instance IsGValue CUInt where+ gvalueGType_ = return gtypeUInt+ gvalueSet_ = set_uint+ gvalueGet_ = get_uint++instance IsGValue CLong where+ gvalueGType_ = return gtypeLong+ gvalueSet_ = set_long+ gvalueGet_ = get_long++instance IsGValue CULong where+ gvalueGType_ = return gtypeULong+ gvalueSet_ = set_ulong+ gvalueGet_ = get_ulong++instance IsGValue Int64 where+ gvalueGType_ = return gtypeInt64+ gvalueSet_ = set_int64+ gvalueGet_ = get_int64++instance IsGValue Word64 where+ gvalueGType_ = return gtypeUInt64+ gvalueSet_ = set_uint64+ gvalueGet_ = get_uint64++instance IsGValue Float where+ gvalueGType_ = return gtypeFloat+ gvalueSet_ = set_float+ gvalueGet_ = get_float++instance IsGValue Double where+ gvalueGType_ = return gtypeDouble+ gvalueSet_ = set_double+ gvalueGet_ = get_double++instance IsGValue Bool where+ gvalueGType_ = return gtypeBoolean+ gvalueSet_ = set_boolean+ gvalueGet_ = get_boolean++instance IsGValue GType where+ gvalueGType_ = return gtypeGType+ gvalueSet_ = set_gtype+ gvalueGet_ = get_gtype++instance IsGValue (StablePtr a) where+ gvalueGType_ = return gtypeStablePtr+ gvalueSet_ = set_stablePtr+ gvalueGet_ = get_stablePtr++instance IsGValue (Maybe GParamSpec) where+ gvalueGType_ = return gtypeParam+ gvalueSet_ = set_param+ gvalueGet_ = get_param++instance Typeable a => IsGValue (HValue a) where+ gvalueGType_ = return gtypeHValue+ gvalueSet_ = set_hvalue+ gvalueGet_ = get_hvalue++foreign import ccall "g_value_set_string" _set_string ::+ Ptr GValue -> CString -> IO ()+foreign import ccall "g_value_get_string" _get_string ::+ Ptr GValue -> IO CString++set_string :: Ptr GValue -> Maybe Text -> IO ()+set_string ptr maybeStr = do+ cstr <- case maybeStr of+ Just str -> textToCString str+ Nothing -> return nullPtr+ _set_string ptr cstr+ freeMem cstr++get_string :: Ptr GValue -> IO (Maybe Text)+get_string gvptr = do+ cstr <- _get_string gvptr+ if cstr /= nullPtr+ then Just <$> cstringToText cstr+ else return Nothing++foreign import ccall unsafe "g_value_set_pointer" set_pointer ::+ Ptr GValue -> Ptr a -> IO ()+foreign import ccall unsafe "g_value_get_pointer" get_pointer ::+ Ptr GValue -> IO (Ptr b)++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 :: Ptr GValue -> Int32 -> IO ()+set_int32 gv n = set_int gv (coerce n)++get_int32 :: Ptr GValue -> IO Int32+get_int32 gv = coerce <$> get_int gv++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 :: Ptr GValue -> Word32 -> IO ()+set_uint32 gv n = set_uint gv (coerce n)++get_uint32 :: Ptr GValue -> IO Word32+get_uint32 gv = coerce <$> get_uint gv++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++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++foreign import ccall unsafe "g_value_set_int64" set_int64 ::+ Ptr GValue -> Int64 -> IO ()+foreign import ccall unsafe "g_value_get_int64" get_int64 ::+ Ptr GValue -> IO Int64++foreign import ccall unsafe "g_value_set_uint64" set_uint64 ::+ Ptr GValue -> Word64 -> IO ()+foreign import ccall unsafe "g_value_get_uint64" get_uint64 ::+ Ptr GValue -> IO Word64++foreign import ccall unsafe "g_value_set_float" _set_float ::+ Ptr GValue -> CFloat -> IO ()+foreign import ccall unsafe "g_value_get_float" _get_float ::+ Ptr GValue -> IO CFloat++set_float :: Ptr GValue -> Float -> IO ()+set_float gv f = _set_float gv (realToFrac f)++get_float :: Ptr GValue -> IO Float+get_float gv = realToFrac <$> _get_float gv++foreign import ccall unsafe "g_value_set_double" _set_double ::+ Ptr GValue -> CDouble -> IO ()+foreign import ccall unsafe "g_value_get_double" _get_double ::+ Ptr GValue -> IO CDouble++set_double :: Ptr GValue -> Double -> IO ()+set_double gv d = _set_double gv (realToFrac d)++get_double :: Ptr GValue -> IO Double+get_double gv = realToFrac <$> _get_double gv++foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::+ Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::+ Ptr GValue -> IO CInt++set_boolean :: Ptr GValue -> Bool -> IO ()+set_boolean gv b = _set_boolean gv (fromIntegral $ fromEnum b)++get_boolean :: Ptr GValue -> IO Bool+get_boolean gv = (/= 0) <$> _get_boolean gv++foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::+ Ptr GValue -> CGType -> IO ()+foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::+ Ptr GValue -> IO CGType++set_gtype :: Ptr GValue -> GType -> IO ()+set_gtype gv (GType g) = _set_gtype gv g++get_gtype :: Ptr GValue -> IO GType+get_gtype gv = GType <$> _get_gtype gv++foreign import ccall "g_value_set_object" _set_object ::+ Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_object" _get_object ::+ Ptr GValue -> IO (Ptr a)++set_object :: GObject a => Ptr GValue -> Ptr a -> IO ()+set_object = _set_object++get_object :: GObject a => Ptr GValue -> IO (Ptr a)+get_object = _get_object++foreign import ccall "g_value_set_boxed" set_boxed ::+ Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_boxed" get_boxed ::+ Ptr GValue -> IO (Ptr b)+foreign import ccall "g_value_dup_boxed" dup_boxed ::+ Ptr GValue -> IO (Ptr b)++foreign import ccall "g_value_set_variant" set_variant ::+ Ptr GValue -> Ptr GVariant -> IO ()+foreign import ccall "g_value_get_variant" get_variant ::+ Ptr GValue -> IO (Ptr GVariant)++foreign import ccall unsafe "g_value_set_enum" set_enum ::+ Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_enum" get_enum ::+ Ptr GValue -> IO CUInt++foreign import ccall unsafe "g_value_set_flags" set_flags ::+ Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_flags" get_flags ::+ Ptr GValue -> IO CUInt++-- | Set the value of `GValue` containing a `StablePtr`+set_stablePtr :: Ptr GValue -> StablePtr a -> IO ()+set_stablePtr gv ptr = set_boxed gv (castStablePtrToPtr ptr)++foreign import ccall g_value_take_boxed :: Ptr GValue -> Ptr a -> IO ()++-- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr`+take_stablePtr :: Ptr GValue -> StablePtr a -> IO ()+take_stablePtr gvPtr stablePtr =+ g_value_take_boxed gvPtr (castStablePtrToPtr stablePtr)++-- | Get (a freshly allocated copy of) the value of a `GValue`+-- containing a `StablePtr`+get_stablePtr :: Ptr GValue -> IO (StablePtr a)+get_stablePtr gv = castPtrToStablePtr <$> dup_boxed gv++foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO ()++-- | Pack the given list of GValues contiguously into a C array+packGValueArray :: [GValue] -> IO (Ptr GValue)+packGValueArray gvalues = withManagedPtrList gvalues $ \ptrs -> do+ let nitems = length ptrs+ mem <- callocBytes $ cgvalueSize * nitems+ fill mem ptrs+ return mem+ where fill :: Ptr GValue -> [Ptr GValue] -> IO ()+ fill _ [] = return ()+ fill ptr (x:xs) = do+ gtype <- g_value_get_type x+ _ <- g_value_init ptr gtype+ g_value_copy x ptr+ fill (ptr `plusPtr` cgvalueSize) xs++-- | Unpack an array of contiguous GValues into a list of GValues.+unpackGValueArrayWithLength :: Integral a =>+ a -> Ptr GValue -> IO [GValue]+unpackGValueArrayWithLength nitems gvalues = go (fromIntegral nitems) gvalues+ where go :: Int -> Ptr GValue -> IO [GValue]+ go 0 _ = return []+ go n ptr = do+ gv <- callocBytes cgvalueSize+ gtype <- g_value_get_type ptr+ _ <- g_value_init gv gtype+ g_value_copy ptr gv+ wrapped <- wrapGValuePtr gv+ (wrapped :) <$> go (n-1) (ptr `plusPtr` cgvalueSize)++-- | Map over the `GValue`s inside a C array.+mapGValueArrayWithLength :: Integral a =>+ a -> (Ptr GValue -> IO c) -> Ptr GValue -> IO ()+mapGValueArrayWithLength nvalues f arrayPtr+ | (arrayPtr == nullPtr) = return ()+ | (nvalues <= 0) = return ()+ | otherwise = go (fromIntegral nvalues) arrayPtr+ where go :: Int -> Ptr GValue -> IO ()+ go 0 _ = return ()+ go n ptr = do+ _ <- f ptr+ go (n-1) (ptr `plusPtr` cgvalueSize)++foreign import ccall unsafe "g_value_set_param" _set_param ::+ Ptr GValue -> Ptr GParamSpec -> IO ()+foreign import ccall unsafe "g_value_get_param" _get_param ::+ Ptr GValue -> IO (Ptr GParamSpec)++-- | Set the value of `GValue` containing a `GParamSpec`+set_param :: Ptr GValue -> Maybe GParamSpec -> IO ()+set_param gv (Just ps) = withManagedPtr ps (_set_param gv)+set_param gv Nothing = _set_param gv nullPtr++foreign import ccall "g_param_spec_ref" g_param_spec_ref ::+ Ptr GParamSpec -> IO (Ptr GParamSpec)+foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref ::+ FunPtr (Ptr GParamSpec -> IO ())++-- | Get the value of a `GValue` containing a `GParamSpec`+get_param :: Ptr GValue -> IO (Maybe GParamSpec)+get_param gv = do+ ptr <- _get_param gv+ if ptr == nullPtr+ then return Nothing+ else do+ fPtr <- g_param_spec_ref ptr >>= newManagedPtr' ptr_to_g_param_spec_unref+ return . Just $! GParamSpec fPtr++-- | A type isomorphic to `Maybe a`, used to indicate to+-- `fromGValue`/`toGValue` that we are packing a native Haskell value,+-- without attempting to marshall it to the corresponding C type.+data HValue a = HValue a -- ^ A packed value of type `a`+ | NoHValue -- ^ An empty `HValue`+ deriving (Show, Eq)++-- | Set the `GValue` to the given Haskell value.+set_hvalue :: Typeable a => Ptr GValue -> HValue a -> IO ()+set_hvalue gvPtr NoHValue = set_boxed gvPtr nullPtr+set_hvalue gvPtr (HValue v) = do+ sPtr <- newStablePtr (toDyn v)+ g_value_take_boxed gvPtr (castStablePtrToPtr sPtr)++-- | Get the value in the GValue, checking that the type is+-- `gtypeHValue`. Will return NULL and print a warning if the GValue+-- is of the wrong type.+foreign import ccall "haskell_gi_safe_get_boxed_haskell_value" safe_get_boxed_hvalue ::+ Ptr GValue -> IO (Ptr b)++-- | Read the Haskell value of the given type from the `GValue`. If+-- the `GValue` contains no value of the expected type, `NoHValue`+-- will be returned instead, and an error will be printed to stderr.+get_hvalue :: forall a. Typeable a => Ptr GValue -> IO (HValue a)+get_hvalue gvPtr = do+ hvaluePtr <- safe_get_boxed_hvalue gvPtr+ if hvaluePtr == nullPtr+ then return NoHValue+ else do+ dyn <- deRefStablePtr (castPtrToStablePtr hvaluePtr)+ case fromDynamic dyn of+ Nothing -> do+ hPutStrLn stderr ("HASKELL-GI: Unexpected type ‘" <> show dyn+ <> "’ inside the GValue at ‘" <> show gvPtr+ <> "’.\n\tExpected ‘" <> show (typeRep :: TypeRep a)+ <> "’.")+ return NoHValue+ Just val -> return (HValue val)
− Data/GI/Base/GValue.hsc
@@ -1,406 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-module Data.GI.Base.GValue- (- -- * Constructing GValues- GValue(..)- , IsGValue(..)- , GValueConstruct(..)-- , newGValue- , buildGValue- , noGValue-- -- * Setters and getters- , set_string- , get_string- , set_pointer- , get_pointer- , set_int- , get_int- , set_uint- , get_uint- , set_long- , get_long- , set_ulong- , get_ulong- , set_int32- , get_int32- , set_uint32- , get_uint32- , set_int64- , get_int64- , set_uint64- , get_uint64- , set_float- , get_float- , set_double- , get_double- , set_boolean- , get_boolean- , set_gtype- , get_gtype- , set_object- , get_object- , set_boxed- , get_boxed- , set_variant- , get_variant- , set_enum- , get_enum- , set_flags- , get_flags- , set_stablePtr- , get_stablePtr- , take_stablePtr- ) where--#include <glib-object.h>--import Data.Coerce (coerce)-import Data.Word-import Data.Int-import Data.Text (Text, pack, unpack)--import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),- CLong(..), CULong(..))-import Foreign.C.String (CString)-import Foreign.Ptr (Ptr, nullPtr)-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`@.-noGValue :: Maybe GValue-noGValue = Nothing--foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::- IO CGType--instance BoxedObject GValue where- boxedType _ = GType <$> c_g_value_get_type--foreign import ccall "g_value_init" g_value_init ::- Ptr GValue -> CGType -> IO (Ptr GValue)---- | A type holding a `GValue` with an associated label. It is--- parameterized by a phantom type encoding the target type for the--- `GValue` (useful when constructing properties).-data GValueConstruct o = GValueConstruct String GValue---- | Build a new, empty, `GValue` of the given type.-newGValue :: GType -> IO GValue-newGValue (GType gtype) = do- gvptr <- callocBytes (#size GValue)- _ <- g_value_init gvptr gtype- gv <- wrapBoxed GValue gvptr- return $! gv---- | A convenience function for building a new GValue and setting the--- initial value.-buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue-buildGValue gtype setter val = do- gv <- newGValue gtype- setter gv val- return gv---- | A convenience class for marshaling back and forth between Haskell--- values and `GValue`s.-class IsGValue a where- toGValue :: a -> IO GValue- fromGValue :: GValue -> IO a--instance IsGValue (Maybe String) where- toGValue = buildGValue gtypeString set_string . fmap pack- fromGValue v = (fmap unpack) <$> get_string v--instance IsGValue (Maybe Text) where- toGValue = buildGValue gtypeString set_string- fromGValue = get_string--instance IsGValue (Ptr a) where- toGValue = buildGValue gtypePointer set_pointer- fromGValue = get_pointer--instance IsGValue Int32 where- toGValue = buildGValue gtypeInt set_int32- fromGValue = get_int32--instance IsGValue Word32 where- toGValue = buildGValue gtypeUInt set_uint32- fromGValue = get_uint32--instance IsGValue CInt where- toGValue = buildGValue gtypeInt set_int- fromGValue = get_int--instance IsGValue CUInt where- toGValue = buildGValue gtypeUInt set_uint- fromGValue = get_uint--instance IsGValue CLong where- toGValue = buildGValue gtypeLong set_long- fromGValue = get_long--instance IsGValue CULong where- toGValue = buildGValue gtypeULong set_ulong- fromGValue = get_ulong--instance IsGValue Int64 where- toGValue = buildGValue gtypeInt64 set_int64- fromGValue = get_int64--instance IsGValue Word64 where- toGValue = buildGValue gtypeUInt64 set_uint64- fromGValue = get_uint64--instance IsGValue Float where- toGValue = buildGValue gtypeFloat set_float- fromGValue = get_float--instance IsGValue Double where- toGValue = buildGValue gtypeDouble set_double- fromGValue = get_double--instance IsGValue Bool where- toGValue = buildGValue gtypeBoolean set_boolean- fromGValue = get_boolean--instance IsGValue GType where- toGValue = buildGValue gtypeGType set_gtype- fromGValue = get_gtype--instance IsGValue (StablePtr a) where- toGValue = buildGValue gtypeStablePtr set_stablePtr- fromGValue = get_stablePtr--foreign import ccall "g_value_set_string" _set_string ::- Ptr GValue -> CString -> IO ()-foreign import ccall "g_value_get_string" _get_string ::- Ptr GValue -> IO CString--set_string :: GValue -> Maybe Text -> IO ()-set_string gv maybeStr =- withManagedPtr gv $ \ptr -> do- cstr <- case maybeStr of- Just str -> textToCString str- Nothing -> return nullPtr- _set_string ptr cstr- freeMem cstr--get_string :: GValue -> IO (Maybe Text)-get_string gv = withManagedPtr gv $ \gvptr -> do- cstr <- _get_string gvptr- if cstr /= nullPtr- then Just <$> cstringToText cstr- else return Nothing--foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::- Ptr GValue -> Ptr a -> IO ()-foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::- Ptr GValue -> IO (Ptr b)--set_pointer :: GValue -> Ptr a -> IO ()-set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr--get_pointer :: GValue -> IO (Ptr b)-get_pointer gv = withManagedPtr gv _get_pointer--foreign import ccall unsafe "g_value_set_int" _set_int ::- Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_int" _get_int ::- Ptr GValue -> IO CInt--set_int32 :: GValue -> Int32 -> IO ()-set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n)--get_int32 :: GValue -> IO Int32-get_int32 gv = coerce <$> withManagedPtr gv _get_int--set_int :: GValue -> CInt -> IO ()-set_int gv n = withManagedPtr gv $ flip _set_int n--get_int :: GValue -> IO CInt-get_int gv = withManagedPtr gv _get_int--foreign import ccall unsafe "g_value_set_uint" _set_uint ::- Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_uint" _get_uint ::- Ptr GValue -> IO CUInt--set_uint32 :: GValue -> Word32 -> IO ()-set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n)--get_uint32 :: GValue -> IO Word32-get_uint32 gv = coerce <$> withManagedPtr gv _get_uint--set_uint :: GValue -> CUInt -> IO ()-set_uint gv n = withManagedPtr gv $ flip _set_uint n--get_uint :: GValue -> IO CUInt-get_uint gv = withManagedPtr gv _get_uint--foreign import ccall unsafe "g_value_set_long" _set_long ::- Ptr GValue -> CLong -> IO ()-foreign import ccall unsafe "g_value_get_long" _get_long ::- Ptr GValue -> IO CLong--set_long :: GValue -> CLong -> IO ()-set_long gv n = withManagedPtr gv $ flip _set_long n--get_long :: GValue -> IO CLong-get_long gv = withManagedPtr gv _get_long--foreign import ccall unsafe "g_value_set_ulong" _set_ulong ::- Ptr GValue -> CULong -> IO ()-foreign import ccall unsafe "g_value_get_ulong" _get_ulong ::- Ptr GValue -> IO CULong--set_ulong :: GValue -> CULong -> IO ()-set_ulong gv n = withManagedPtr gv $ flip _set_ulong n--get_ulong :: GValue -> IO CULong-get_ulong gv = withManagedPtr gv _get_ulong--foreign import ccall unsafe "g_value_set_int64" _set_int64 ::- Ptr GValue -> Int64 -> IO ()-foreign import ccall unsafe "g_value_get_int64" _get_int64 ::- Ptr GValue -> IO Int64--set_int64 :: GValue -> Int64 -> IO ()-set_int64 gv n = withManagedPtr gv $ flip _set_int64 n--get_int64 :: GValue -> IO Int64-get_int64 gv = withManagedPtr gv _get_int64--foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::- Ptr GValue -> Word64 -> IO ()-foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::- Ptr GValue -> IO Word64--set_uint64 :: GValue -> Word64 -> IO ()-set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n--get_uint64 :: GValue -> IO Word64-get_uint64 gv = withManagedPtr gv _get_uint64--foreign import ccall unsafe "g_value_set_float" _set_float ::- Ptr GValue -> CFloat -> IO ()-foreign import ccall unsafe "g_value_get_float" _get_float ::- Ptr GValue -> IO CFloat--set_float :: GValue -> Float -> IO ()-set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)--get_float :: GValue -> IO Float-get_float gv = realToFrac <$> withManagedPtr gv _get_float--foreign import ccall unsafe "g_value_set_double" _set_double ::- Ptr GValue -> CDouble -> IO ()-foreign import ccall unsafe "g_value_get_double" _get_double ::- Ptr GValue -> IO CDouble--set_double :: GValue -> Double -> IO ()-set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)--get_double :: GValue -> IO Double-get_double gv = realToFrac <$> withManagedPtr gv _get_double--foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::- Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::- Ptr GValue -> IO CInt--set_boolean :: GValue -> Bool -> IO ()-set_boolean gv b = withManagedPtr gv $ \ptr ->- _set_boolean ptr (fromIntegral $ fromEnum b)--get_boolean :: GValue -> IO Bool-get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr--foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::- Ptr GValue -> CGType -> IO ()-foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::- Ptr GValue -> IO CGType--set_gtype :: GValue -> GType -> IO ()-set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g--get_gtype :: GValue -> IO GType-get_gtype gv = GType <$> withManagedPtr gv _get_gtype--foreign import ccall "g_value_set_object" _set_object ::- Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_object" _get_object ::- Ptr GValue -> IO (Ptr a)--set_object :: GObject a => GValue -> Ptr a -> IO ()-set_object gv o = withManagedPtr gv $ flip _set_object o--get_object :: GObject b => GValue -> IO (Ptr b)-get_object gv = withManagedPtr gv _get_object--foreign import ccall "g_value_set_boxed" _set_boxed ::- Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_boxed" _get_boxed ::- Ptr GValue -> IO (Ptr b)--set_boxed :: GValue -> Ptr a -> IO ()-set_boxed gv b = withManagedPtr gv $ flip _set_boxed b--get_boxed :: GValue -> IO (Ptr b)-get_boxed gv = withManagedPtr gv _get_boxed--foreign import ccall "g_value_set_variant" _set_variant ::- Ptr GValue -> Ptr GVariant -> IO ()-foreign import ccall "g_value_get_variant" _get_variant ::- Ptr GValue -> IO (Ptr GVariant)--set_variant :: GValue -> Ptr GVariant -> IO ()-set_variant gv v = withManagedPtr gv $ flip _set_variant v--get_variant :: GValue -> IO (Ptr GVariant)-get_variant gv = withManagedPtr gv _get_variant--foreign import ccall unsafe "g_value_set_enum" _set_enum ::- Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_enum" _get_enum ::- Ptr GValue -> IO CUInt--set_enum :: GValue -> CUInt -> IO ()-set_enum gv e = withManagedPtr gv $ flip _set_enum e--get_enum :: GValue -> IO CUInt-get_enum gv = withManagedPtr gv _get_enum--foreign import ccall unsafe "g_value_set_flags" _set_flags ::- Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_flags" _get_flags ::- Ptr GValue -> IO CUInt--set_flags :: GValue -> CUInt -> IO ()-set_flags gv f = withManagedPtr gv $ flip _set_flags f--get_flags :: GValue -> IO CUInt-get_flags gv = withManagedPtr gv _get_flags---- | Set the value of `GValue` containing a `StablePtr`-set_stablePtr :: GValue -> StablePtr a -> IO ()-set_stablePtr gv ptr = withManagedPtr gv $ flip _set_boxed (castStablePtrToPtr ptr)--foreign import ccall g_value_take_boxed :: Ptr GValue -> StablePtr a -> IO ()---- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr`-take_stablePtr :: Ptr GValue -> StablePtr a -> IO ()-take_stablePtr = g_value_take_boxed---- | Get the value of a `GValue` containing a `StablePtr`-get_stablePtr :: GValue -> IO (StablePtr a)-get_stablePtr gv = castPtrToStablePtr <$> withManagedPtr gv _get_boxed
Data/GI/Base/GVariant.hsc view
@@ -238,7 +238,7 @@ -- | Get the expected type of a 'GVariant', in 'GVariant' -- notation. See--- <https://developer.gnome.org/glib/stable/glib-GVariantType.html>+-- <https://docs.gtk.org/glib/struct.VariantType.html> -- for the meaning of the resulting format string. gvariantGetTypeString :: GVariant -> IO Text gvariantGetTypeString variant =@@ -643,6 +643,12 @@ [0..(n_children-1)] else return [] +-- No type checking is done here, it is assumed that the caller knows+-- that the passed variant is indeed of a container type with at least+-- one child.+gvariant_get_child :: (Ptr GVariant) -> IO GVariant+gvariant_get_child vptr = g_variant_get_child_value vptr 0 >>= wrapGVariantPtr+ instance IsGVariant a => IsGVariant (Maybe a) where toGVariant = gvariantFromMaybe fromGVariant = gvariantToMaybe@@ -829,9 +835,7 @@ gvariantToSinglet :: forall a. IsGVariant a => GVariant -> IO (Maybe a) gvariantToSinglet = withExplicitType fmt- (gvariant_get_children- >=> return . head- >=> unsafeFromGVariant)+ (gvariant_get_child >=> unsafeFromGVariant) where fmt = toGVariantFormatString (undefined :: GVariantSinglet a) instance (IsGVariant a, IsGVariant b) => IsGVariant (a,b) where@@ -854,14 +858,14 @@ gvariantToTwoTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant- if isJust maybeChildren- then do- let (Just [a1,a2]) = maybeChildren- (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2- return $ if isJust ma1 && isJust ma2- then Just (fromJust ma1, fromJust ma2)- else Nothing- else return Nothing+ case maybeChildren of+ Just [a1,a2] -> do+ (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2+ return $ if isJust ma1 && isJust ma2+ then Just (fromJust ma1, fromJust ma2)+ else Nothing+ Just _ -> error "gvariantToTwoTuple :: the impossible happened, this is a bug."+ Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c) => IsGVariant (a,b,c) where toGVariant = gvariantFromThreeTuple@@ -886,16 +890,16 @@ gvariantToThreeTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant- if isJust maybeChildren- then do- let (Just [a1,a2,a3]) = maybeChildren- (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1- <*> fromGVariant a2- <*> fromGVariant a3- return $ if isJust ma1 && isJust ma2 && isJust ma3- then Just (fromJust ma1, fromJust ma2, fromJust ma3)- else Nothing- else return Nothing+ case maybeChildren of+ Just [a1,a2,a3] -> do+ (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1+ <*> fromGVariant a2+ <*> fromGVariant a3+ return $ if isJust ma1 && isJust ma2 && isJust ma3+ then Just (fromJust ma1, fromJust ma2, fromJust ma3)+ else Nothing+ Just _ -> error "gvariantToThreeTuple :: the impossible happened, this is a bug."+ Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => IsGVariant (a,b,c,d) where@@ -923,17 +927,17 @@ gvariantToFourTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant- if isJust maybeChildren- then do- let (Just [a1,a2,a3,a4]) = maybeChildren- (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1- <*> fromGVariant a2- <*> fromGVariant a3- <*> fromGVariant a4- return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4- then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4)- else Nothing- else return Nothing+ case maybeChildren of+ Just [a1,a2,a3,a4] -> do+ (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1+ <*> fromGVariant a2+ <*> fromGVariant a3+ <*> fromGVariant a4+ return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4+ then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4)+ else Nothing+ Just _ -> error "gvariantToFourTuple :: the impossible happened, this is a bug."+ Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) => IsGVariant (a,b,c,d,e) where@@ -965,17 +969,17 @@ gvariantToFiveTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant- if isJust maybeChildren- then do- let (Just [a1,a2,a3,a4,a5]) = maybeChildren- (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1- <*> fromGVariant a2- <*> fromGVariant a3- <*> fromGVariant a4- <*> fromGVariant a5- return $ if isJust ma1 && isJust ma2 && isJust ma3 &&- isJust ma4 && isJust ma5- then Just (fromJust ma1, fromJust ma2, fromJust ma3,- fromJust ma4, fromJust ma5)- else Nothing- else return Nothing+ case maybeChildren of+ Just [a1,a2,a3,a4,a5] -> do+ (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1+ <*> fromGVariant a2+ <*> fromGVariant a3+ <*> fromGVariant a4+ <*> fromGVariant a5+ return $ if isJust ma1 && isJust ma2 && isJust ma3 &&+ isJust ma4 && isJust ma5+ then Just (fromJust ma1, fromJust ma2, fromJust ma3,+ fromJust ma4, fromJust ma5)+ else Nothing+ Just _ -> error "gvariantToFiveTuple :: the impossible happened, this is a bug."+ Nothing -> return Nothing
+ Data/GI/Base/Internal/CTypes.hsc view
@@ -0,0 +1,40 @@+-- | Versions of hsc2hs older than 0.68.6 cannot deal with Haskell+-- code including promoted constructors, so isolate the required types+-- in here.+--+-- /Warning/: This module is internal, and might disappear in the future.+module Data.GI.Base.Internal.CTypes+ ( GQuark+ , C_gint+ , cgvalueSize+ , gerror_domain_offset+ , gerror_code_offset+ , gerror_message_offset+ ) where++#include <glib-object.h>++import Data.Int+import Data.Word++-- | The size in bytes of a GValue struct in C.+cgvalueSize :: Int+cgvalueSize = #size GValue++-- | The Haskell type corresponding to a GQuark on the C side.+type GQuark = #{type GQuark}++-- | The Haskell type corresponding to a gint on the C side.+type C_gint = #{type gint}++-- | The offset in bytes inside a `GError` of its @domain@ field.+gerror_domain_offset :: Int+gerror_domain_offset = #{offset GError, domain}++-- | The offset in bytes inside a `GError` of its @code@ field.+gerror_code_offset :: Int+gerror_code_offset = #{offset GError, code}++-- | The offset in bytes inside a `GError` of its @emssage@ field.+gerror_message_offset :: Int+gerror_message_offset = #{offset GError, message}
+ Data/GI/Base/Internal/PathFieldAccess.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Support for creating lenses from overloaded labels of the type+-- @#fieldName@, or @#"fieldName.subfield"@.++module Data.GI.Base.Internal.PathFieldAccess+ ( Components, PathFieldAccess(..)) where++import qualified GHC.TypeLits as TL+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import qualified Optics.Core as O+import qualified Optics.Internal.Generic as OG++-- The Char class was introduced in GHC 9.2 (base 4.16), if this is+-- not available we fall back to an implementation that does not allow+-- for nested access. Note that overloaded labels of the form+-- #"record.subrecord" only became valid syntax in GHC 9.6, so this is+-- only really useful from that version.+#if MIN_VERSION_base(4,16,0)+type family AppendChar (s :: TL.Symbol) (c :: Char) where+ AppendChar s c = TL.AppendSymbol s (TL.ConsSymbol c "")++type family DoSplit (c :: Char) (acc :: TL.Symbol) (uncons :: Maybe (Char, TL.Symbol)) where+ DoSplit _ acc Nothing = '[acc]+ DoSplit c acc (Just '(c, rest)) = acc : DoSplit c "" (TL.UnconsSymbol rest)+ DoSplit c acc (Just '(k, rest)) = DoSplit c (AppendChar acc k) (TL.UnconsSymbol rest)++type family SplitByChar (c :: Char) (s :: TL.Symbol) :: [TL.Symbol] where+ SplitByChar c s = DoSplit c "" (TL.UnconsSymbol s)++type family Components (s :: TL.Symbol) :: [TL.Symbol] where+ Components s = SplitByChar '.' s+#else+type family Components (s :: TL.Symbol) :: [TL.Symbol] where+ Components s = '[s]+#endif++-- | Check that the given symbol is not the empty string. If it is,+-- raise a TypeError with the given msg.+type family NonEmpty (s :: TL.Symbol) (msg :: TL.ErrorMessage) :: Constraint where+ NonEmpty "" msg = TL.TypeError msg+ NonEmpty _ _ = ()++-- | Create a lens for the given path, and return it together with the+-- path split into components.+class PathFieldAccess (path :: [TL.Symbol]) (model :: Type) (val :: Type) | path model -> val where+ pathFieldAccess :: Proxy path -> Proxy model -> (O.Lens' model val, [T.Text])++instance {-# OVERLAPPING #-}+ (OG.GFieldImpl fieldName model model val val,+ NonEmpty fieldName (TL.Text "Field names cannot be empty"),+ TL.KnownSymbol fieldName) =>+ PathFieldAccess (fieldName : '[]) model val where+ pathFieldAccess _ _ = (OG.gfieldImpl @fieldName @model @model @val @val,+ [T.pack $ TL.symbolVal (Proxy @fieldName)])++instance (OG.GFieldImpl fieldName model model val val,+ TL.KnownSymbol fieldName,+ PathFieldAccess rest val inner) =>+ PathFieldAccess (fieldName : rest) model inner where+ pathFieldAccess _ _ =+ let (innerLens, innerPath) = pathFieldAccess (Proxy @rest) (Proxy @val)+ outerLens = OG.gfieldImpl @fieldName @model @model @val @val+ outerName = T.pack $ TL.symbolVal (Proxy @fieldName)+ in (outerLens O.% innerLens, outerName : innerPath)+
Data/GI/Base/ManagedPtr.hs view
@@ -32,6 +32,7 @@ -- * Wrappers , newObject+ , withNewObject , wrapObject , releaseObject , unrefObject@@ -51,6 +52,7 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (when, void)+import Control.Monad.Fix (mfix) import Data.Coerce (coerce) import Data.IORef (newIORef, readIORef, writeIORef, IORef)@@ -97,9 +99,12 @@ ownedFinalizer finalizer ptr allocCallStack callStackRef = do cs <- readIORef callStackRef -- cs will be @Just cs@ whenever the pointer has been disowned.- when (isNothing cs) $ do- maybe (return ()) (printAllocDebug ptr) allocCallStack- finalizer+ when (isNothing cs) $ case allocCallStack of+ Just acs -> do+ printAllocDebug ptr acs+ finalizer+ dbgLog (T.pack "Released successfully.\n")+ Nothing -> finalizer -- | Print some debug diagnostics for an allocation. printAllocDebug :: Ptr a -> CallStack -> IO ()@@ -129,12 +134,12 @@ -- | Do not run the finalizers upon garbage collection of the -- `ManagedPtr`.-disownManagedPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)+disownManagedPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b) disownManagedPtr managed = do ptr <- unsafeManagedPtrGetPtr managed writeIORef (managedPtrIsDisowned c) (Just callStack)- return ptr- where c = coerce managed :: ManagedPtr ()+ return (castPtr ptr)+ where c = toManagedPtr managed -- | Perform an IO action on the 'Ptr' inside a managed pointer. withManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c@@ -162,11 +167,11 @@ -- | Perform the IO action with a transient managed pointer. The -- managed pointer will be valid while calling the action, but will be--- disowned as soon as the action finished.+-- disowned as soon as the action finishes. withTransient :: (HasCallStack, ManagedPtrNewtype a)- => (ManagedPtr a -> a) -> Ptr a -> (a -> IO b) -> IO b-withTransient constructor ptr action = do- managed <- constructor <$> newManagedPtr_ ptr+ => Ptr a -> (a -> IO b) -> IO b+withTransient ptr action = do+ managed <- coerce <$> newManagedPtr_ ptr r <- action managed _ <- disownManagedPtr managed return r@@ -184,7 +189,7 @@ unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b) unsafeManagedPtrCastPtr m = do- let c = coerce m :: ManagedPtr ()+ let c = toManagedPtr m ptr = (castPtr . unsafeForeignPtrToPtr . managedForeignPtr) c disowned <- readIORef (managedPtrIsDisowned c) maybe (return ptr) (notOwnedWarning ptr) disowned@@ -204,7 +209,7 @@ -- (i.e. it has not been garbage collected by the runtime) at the -- point that this is called. touchManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO ()-touchManagedPtr m = let c = coerce m :: ManagedPtr ()+touchManagedPtr m = let c = toManagedPtr m in (touchForeignPtr . managedForeignPtr) c -- Safe casting machinery@@ -212,39 +217,45 @@ 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 :: (ManagedPtrNewtype o, TypedObject 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:+-- | Cast from one object type to another, 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') =>+castTo :: forall o o'. (HasCallStack,+ ManagedPtrNewtype o, TypedObject o,+ ManagedPtrNewtype o', TypedObject o',+ GObject o') => (ManagedPtr o' -> o') -> o -> IO (Maybe o')-castTo constructor obj = withManagedPtr obj $ \objPtr -> do- gtype <- gobjectType @o'+castTo constructor obj = do+ gtype <- glibType @o' isInstance <- checkInstanceType obj gtype if isInstance- then Just <$> newObject constructor objPtr+ then return . Just . constructor . coerce $ toManagedPtr obj else return Nothing --- | Cast to the given type, assuming that the cast will succeed. This--- function will call `error` if the cast is illegal.-unsafeCastTo :: forall o o'. (HasCallStack, GObject o, GObject o') =>+-- | Cast a typed object to a new type (without any assumption that+-- both types descend from `GObject`), assuming that the cast will+-- succeed. This function will call `error` if the cast is illegal.+unsafeCastTo :: forall o o'. (HasCallStack,+ ManagedPtrNewtype o, TypedObject o,+ ManagedPtrNewtype o', TypedObject o') => (ManagedPtr o' -> o') -> o -> IO o'-unsafeCastTo constructor obj =- withManagedPtr obj $ \objPtr -> do- gtype <- gobjectType @o'+unsafeCastTo constructor obj = do+ gtype <- glibType @o' isInstance <- checkInstanceType obj gtype if not isInstance then do- srcType <- gobjectType @o >>= gtypeName- destType <- gobjectType @o' >>= gtypeName+ srcType <- glibType @o >>= gtypeName+ destType <- glibType @o' >>= gtypeName error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to " ++ destType ++ " requested."- else newObject constructor objPtr+ else return (constructor $ coerce $ toManagedPtr obj) -- Reference counting for constructors foreign import ccall "&dbg_g_object_unref"@@ -277,6 +288,16 @@ fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr return $! constructor fPtr +-- | Perform the given IO action with a wrapped copy of the given ptr+-- to a GObject. Note that this increases the reference count of the+-- wrapped GObject, similarly to 'newObject'.+withNewObject :: (HasCallStack, GObject o)+ => Ptr o -> (o -> IO b) -> IO b+withNewObject ptr action = do+ void $ g_object_ref_sink ptr+ managed <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr+ action (coerce managed)+ -- | Same as 'newObject', but we steal ownership of the object. wrapObject :: forall a b. (HasCallStack, GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a@@ -335,32 +356,32 @@ -- | Construct a Haskell wrapper for the given boxed object. We make a -- copy of the object.-newBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a+newBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a newBoxed constructor ptr = do- GType gtype <- boxedType (undefined :: a)+ GType gtype <- glibType @a ptr' <- g_boxed_copy gtype ptr fPtr <- newManagedPtr ptr' (boxed_free_helper gtype ptr') return $! constructor fPtr -- | Like 'newBoxed', but we do not make a copy (we "steal" the passed -- object, so now it is managed by the Haskell runtime).-wrapBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a wrapBoxed constructor ptr = do- GType gtype <- boxedType (undefined :: a)+ GType gtype <- glibType @a fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr) return $! constructor fPtr -- | Make a copy of the given boxed object.-copyBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO (Ptr a)+copyBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a) copyBoxed b = do- GType gtype <- boxedType b+ GType gtype <- glibType @a withManagedPtr b (g_boxed_copy gtype) -- | Like 'copyBoxed', but acting directly on a pointer, instead of a -- managed pointer.-copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)+copyBoxedPtr :: forall a. GBoxed a => Ptr a -> IO (Ptr a) copyBoxedPtr ptr = do- GType gtype <- boxedType (undefined :: a)+ GType gtype <- glibType @a g_boxed_copy gtype ptr foreign import ccall "g_boxed_free" g_boxed_free ::@@ -368,53 +389,51 @@ -- | Free the memory associated with a boxed object. Note that this -- disowns the associated `ManagedPtr` via `disownManagedPtr`.-freeBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO ()+freeBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO () freeBoxed boxed = do- GType gtype <- boxedType (undefined :: a)+ GType gtype <- glibType @a ptr <- disownManagedPtr boxed dbgDealloc boxed g_boxed_free gtype ptr -- | Disown a boxed object, that is, do not free the associated -- foreign GBoxed when the Haskell object gets garbage--- collected. Returns the pointer to the underlying `BoxedObject`.-disownBoxed :: (HasCallStack, BoxedObject a) => a -> IO (Ptr a)+-- collected. Returns the pointer to the underlying `GBoxed`.+disownBoxed :: (HasCallStack, GBoxed a) => a -> IO (Ptr a) disownBoxed = disownManagedPtr -- | Wrap a pointer, taking ownership of it.-wrapPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a-wrapPtr constructor ptr = do- fPtr <- case wrappedPtrFree of- Nothing -> newManagedPtr_ ptr- Just finalizer -> newManagedPtr' finalizer ptr+wrapPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapPtr constructor ptr = mfix $ \wrapped -> do+ fPtr <- newManagedPtr ptr (boxedPtrFree wrapped) return $! constructor fPtr -- | Wrap a pointer, making a copy of the data.-newPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a+newPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a newPtr constructor ptr = do tmpWrap <- newManagedPtr_ ptr- ptr' <- wrappedPtrCopy (constructor tmpWrap)+ ptr' <- boxedPtrCopy (constructor tmpWrap) return $! ptr' -- | Make a copy of a wrapped pointer using @memcpy@ into a freshly -- allocated memory region of the given size.-copyBytes :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)+copyBytes :: (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a) copyBytes size ptr = do- ptr' <- wrappedPtrCalloc+ ptr' <- boxedPtrCalloc memcpy ptr' ptr size return ptr' foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ()) --- | Print a debug message for deallocs if the @HASKELL_GI_DEBUG_MEM@--- environment variable has been set.+-- | Same as `dbgDeallocPtr`, but for `ManagedPtr`s, and no callstack+-- needs to be provided. dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO () dbgDealloc m = do env <- lookupEnv "HASKELL_GI_DEBUG_MEM" case env of Nothing -> return () Just _ -> do- let mPtr = coerce m :: ManagedPtr ()+ let mPtr = toManagedPtr m ptr = (unsafeForeignPtrToPtr . managedForeignPtr) mPtr threadPtr <- g_thread_self hPutStrLn stderr ("Releasing <" ++ show ptr ++ "> from thread ["
Data/GI/Base/Overloading.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds, TypeFamilies, UndecidableInstances, EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, ConstraintKinds,- AllowAmbiguousTypes, FlexibleContexts #-}+ AllowAmbiguousTypes, FlexibleContexts, ScopedTypeVariables,+ TypeApplications, OverloadedStrings #-} -- | Helpers for dealing with overladed properties, signals and -- methods.@@ -29,28 +30,53 @@ -- * Looking up methods in parent types , MethodResolutionFailed , UnsupportedMethodError- , MethodInfo(..)+ , OverloadedMethodInfo(..)+ , OverloadedMethod(..)+ , MethodProxy(..)++ , ResolvedSymbolInfo(..)+ , resolveMethod ) where import Data.Coerce (coerce)+import Data.Kind (Type) import GHC.Exts (Constraint) import GHC.TypeLits import Data.GI.Base.BasicTypes (ManagedPtrNewtype, ManagedPtr(..)) +import Data.Text (Text)+import qualified Data.Text as T+ -- | 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, *)])- (typeError :: ErrorMessage) :: * where+type family FindElement (m :: Symbol) (ms :: [(Symbol, Type)])+ (typeError :: ErrorMessage) :: Type where FindElement m '[] typeError = TypeError typeError FindElement m ('(m, o) ': ms) typeError = o FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError +-- | All the types that are ascendants of this type, including+-- interfaces that the type implements.+type family ParentTypes a :: [Type]++-- | 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 :: Type)++-- | 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+ -- | 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 :: [*]) :: Constraint where+type family CheckForAncestorType t (a :: Type) (as :: [Type]) :: Constraint where CheckForAncestorType t a '[] = TypeError ('Text "Required ancestor ‘" ':<>: 'ShowType a ':<>: 'Text "’ not found for type ‘"@@ -60,27 +86,11 @@ -- | Check that a type is in the list of `ParentTypes` of another -- type.-type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where+type family IsDescendantOf (parent :: Type) (descendant :: Type) :: Constraint where -- Every object is defined to be a descendant of itself. IsDescendantOf d d = () IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) --- | 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- -- | Safe coercions to a parent class. For instance: -- -- > #show $ label `asA` Gtk.Widget@@ -95,7 +105,7 @@ -- of the attribute, and the second the type encoding the information -- of the attribute. This type will be an instance of -- `Data.GI.Base.Attributes.AttrInfo`.-type family AttributeList a :: [(Symbol, *)]+type family AttributeList a :: [(Symbol, Type)] -- | A constraint on a type, to be fulfilled whenever it has a type -- instance for `AttributeList`. This is here for nicer error@@ -111,7 +121,7 @@ -- | Return the type encoding the attribute information for a given -- type and attribute.-type family ResolveAttribute (s :: Symbol) (o :: *) :: * where+type family ResolveAttribute (s :: Symbol) (o :: Type) :: Type where ResolveAttribute s o = FindElement s (AttributeList o) ('Text "Unknown attribute ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>:@@ -119,14 +129,14 @@ -- | 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)+type family IsElem (e :: Symbol) (es :: [(Symbol, Type)]) (success :: k) (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 -- | A constraint imposing that the given object has the given attribute.-type family HasAttribute (attr :: Symbol) (o :: *) :: Constraint where+type family HasAttribute (attr :: Symbol) (o :: Type) :: Constraint where HasAttribute attr o = IsElem attr (AttributeList o) (() :: Constraint) -- success ('Text "Attribute ‘" ':<>: 'Text attr ':<>:@@ -134,7 +144,7 @@ 'ShowType o ':<>: 'Text "’.") -- | A constraint that enforces that the given type has a given attribute.-class HasAttr (attr :: Symbol) (o :: *)+class HasAttr (attr :: Symbol) (o :: Type) instance HasAttribute attr o => HasAttr attr o -- | The list of signals defined for a given type. Each element of the@@ -142,11 +152,11 @@ -- 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, *)]+type family SignalList a :: [(Symbol, Type)] -- | Return the type encoding the signal information for a given -- type and signal.-type family ResolveSignal (s :: Symbol) (o :: *) :: * where+type family ResolveSignal (s :: Symbol) (o :: Type) :: Type where ResolveSignal s o = FindElement s (SignalList o) ('Text "Unknown signal ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>:@@ -154,7 +164,7 @@ -- | A constraint enforcing that the signal exists for the given -- object, or one of its ancestors.-type family HasSignal (s :: Symbol) (o :: *) :: Constraint where+type family HasSignal (s :: Symbol) (o :: Type) :: Constraint where HasSignal s o = IsElem s (SignalList o) (() :: Constraint) -- success ('Text "Signal ‘" ':<>: 'Text s ':<>:@@ -163,7 +173,7 @@ -- | A constraint that always fails with a type error, for -- documentation purposes.-type family UnsupportedMethodError (s :: Symbol) (o :: *) :: * where+type family UnsupportedMethodError (s :: Symbol) (o :: Type) :: Type where UnsupportedMethodError s o = TypeError ('Text "Unsupported method ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>:@@ -171,7 +181,7 @@ -- | Returned when the method is not found, hopefully making -- the resulting error messages somewhat clearer.-type family MethodResolutionFailed (method :: Symbol) (o :: *) where+type family MethodResolutionFailed (method :: Symbol) (o :: Type) where MethodResolutionFailed m o = TypeError ('Text "Unknown method ‘" ':<>: 'Text m ':<>: 'Text "’ for type ‘" ':<>:@@ -179,5 +189,35 @@ -- | Class for types containing the information about an overloaded -- method of type @o -> s@.-class MethodInfo i o s where- overloadedMethod :: o -> s+class OverloadedMethod i o s where+ overloadedMethod :: o -> s -- ^ The actual method being invoked.++-- | Information about a fully resolved symbol, for debugging+-- purposes.+data ResolvedSymbolInfo = ResolvedSymbolInfo {+ resolvedSymbolName :: Text+ , resolvedSymbolURL :: Text+ }++instance Show ResolvedSymbolInfo where+ -- Format as a hyperlink on modern terminals (older+ -- terminals should ignore the hyperlink part).+ show info = T.unpack ("\ESC]8;;" <> resolvedSymbolURL info+ <> "\ESC\\" <> resolvedSymbolName info+ <> "\ESC]8;;\ESC\\")++-- | This is for debugging purposes, see `resolveMethod` below.+class OverloadedMethodInfo i o where+ overloadedMethodInfo :: Maybe ResolvedSymbolInfo++-- | A proxy for carrying the types `MethodInfoName` needs (this is used+-- for `resolveMethod`, see below).+data MethodProxy (info :: Type) (obj :: Type) = MethodProxy++-- | Return the fully qualified method name that a given overloaded+-- method call resolves to (mostly useful for debugging).+--+-- > resolveMethod widget #show+resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) =>+ obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo+resolveMethod _o _p = overloadedMethodInfo @info @obj
Data/GI/Base/Overloading.hs-boot view
@@ -1,3 +1,3 @@ module Data.GI.Base.Overloading (HasParentTypes) where -class HasParentTypes o+class HasParentTypes a
Data/GI/Base/Properties.hsc view
@@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} module Data.GI.Base.Properties- ( setObjectPropertyString+ ( setObjectPropertyIsGValueInstance+ , setObjectPropertyString , setObjectPropertyStringArray , setObjectPropertyPtr , setObjectPropertyInt@@ -27,7 +28,10 @@ , setObjectPropertyHash , setObjectPropertyCallback , setObjectPropertyGError+ , setObjectPropertyGValue+ , setObjectPropertyParamSpec + , getObjectPropertyIsGValueInstance , getObjectPropertyString , getObjectPropertyStringArray , getObjectPropertyPtr@@ -54,7 +58,10 @@ , getObjectPropertyHash , getObjectPropertyCallback , getObjectPropertyGError+ , getObjectPropertyGValue+ , getObjectPropertyParamSpec + , constructObjectPropertyIsGValueInstance , constructObjectPropertyString , constructObjectPropertyStringArray , constructObjectPropertyPtr@@ -81,6 +88,8 @@ , constructObjectPropertyHash , constructObjectPropertyCallback , constructObjectPropertyGError+ , constructObjectPropertyGValue+ , constructObjectPropertyParamSpec ) where #if !MIN_VERSION_base(4,8,0)@@ -90,7 +99,6 @@ import qualified Data.ByteString.Char8 as B import Data.Text (Text)-import Data.Proxy (Proxy(..)) import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions@@ -112,273 +120,267 @@ foreign import ccall "g_object_set_property" g_object_set_property :: Ptr a -> CString -> Ptr GValue -> IO () -setObjectProperty :: GObject a => a -> String -> b ->- (GValue -> b -> IO ()) -> GType -> IO ()-setObjectProperty obj propName propValue setter (GType gtype) = do- gvalue <- buildGValue (GType gtype) setter propValue+-- | Set a property on an object to the given `GValue`.+gobjectSetProperty :: GObject a => a -> String -> GValue -> IO ()+gobjectSetProperty obj propName gvalue = withManagedPtr obj $ \objPtr -> withCString propName $ \cPropName -> withManagedPtr gvalue $ \gvalueptr -> g_object_set_property objPtr cPropName gvalueptr +-- | A convenience wrapper over `gobjectSetProperty` that does the+-- wrapping of a value into a `GValue`.+setObjectProperty :: GObject a => a -> String -> b ->+ (Ptr GValue -> b -> IO ()) -> GType -> IO ()+setObjectProperty obj propName propValue setter (GType gtype) = do+ gvalue <- buildGValue (GType gtype) setter propValue+ gobjectSetProperty obj propName gvalue+ foreign import ccall "g_object_get_property" g_object_get_property :: Ptr a -> CString -> Ptr GValue -> IO () -getObjectProperty :: GObject a => a -> String ->- (GValue -> IO b) -> GType -> IO b-getObjectProperty obj propName getter gtype = do+-- | Get the `GValue` for the given property.+gobjectGetProperty :: GObject a => a -> String -> GType -> IO GValue+gobjectGetProperty obj propName gtype = do gvalue <- newGValue gtype withManagedPtr obj $ \objPtr -> withCString propName $ \cPropName -> withManagedPtr gvalue $ \gvalueptr -> g_object_get_property objPtr cPropName gvalueptr- getter gvalue+ return gvalue -constructObjectProperty :: String -> b -> (GValue -> b -> IO ()) ->+-- | A convenience wrapper over `gobjectGetProperty` that unwraps the+-- `GValue` into a Haskell value.+getObjectProperty :: GObject a => a -> String ->+ (Ptr GValue -> IO b) -> GType -> IO b+getObjectProperty obj propName getter gtype = do+ gv <- gobjectGetProperty obj propName gtype+ withManagedPtr gv getter++constructObjectProperty :: String -> b -> (Ptr GValue -> b -> IO ()) -> GType -> IO (GValueConstruct o) constructObjectProperty propName propValue setter gtype = do gvalue <- buildGValue gtype setter propValue return (GValueConstruct propName gvalue) +-- | Set a property for a type with a `IsGValue` instance.+setObjectPropertyIsGValueInstance :: (GObject a, IsGValue b) =>+ a -> String -> b -> IO ()+setObjectPropertyIsGValueInstance obj propName maybeVal = do+ gvalue <- toGValue maybeVal+ gobjectSetProperty obj propName gvalue++-- | Construct a property for a type with a `IsGValue` instance.+constructObjectPropertyIsGValueInstance :: IsGValue b => String -> b -> IO (GValueConstruct o)+constructObjectPropertyIsGValueInstance propName maybeVal = do+ gvalue <- toGValue maybeVal+ return (GValueConstruct propName gvalue)++-- | Get a nullable property for a type with a `IsGValue` instance.+getObjectPropertyIsGValueInstance :: forall a b. (GObject a, IsGValue b) =>+ a -> String -> IO b+getObjectPropertyIsGValueInstance obj propName = do+ gtype <- gvalueGType_ @b+ gv <- gobjectGetProperty obj propName gtype+ fromGValue gv+ setObjectPropertyString :: GObject a => a -> String -> Maybe Text -> IO ()-setObjectPropertyString obj propName str =- setObjectProperty obj propName str set_string gtypeString+setObjectPropertyString = setObjectPropertyIsGValueInstance constructObjectPropertyString :: String -> Maybe Text -> IO (GValueConstruct o)-constructObjectPropertyString propName str =- constructObjectProperty propName str set_string gtypeString+constructObjectPropertyString = constructObjectPropertyIsGValueInstance getObjectPropertyString :: GObject a => a -> String -> IO (Maybe Text)-getObjectPropertyString obj propName =- getObjectProperty obj propName get_string gtypeString+getObjectPropertyString = getObjectPropertyIsGValueInstance setObjectPropertyPtr :: GObject a => a -> String -> Ptr b -> IO ()-setObjectPropertyPtr obj propName ptr =- setObjectProperty obj propName ptr set_pointer gtypePointer+setObjectPropertyPtr = setObjectPropertyIsGValueInstance constructObjectPropertyPtr :: String -> Ptr b -> IO (GValueConstruct o)-constructObjectPropertyPtr propName ptr =- constructObjectProperty propName ptr set_pointer gtypePointer+constructObjectPropertyPtr = constructObjectPropertyIsGValueInstance getObjectPropertyPtr :: GObject a => a -> String -> IO (Ptr b)-getObjectPropertyPtr obj propName =- getObjectProperty obj propName get_pointer gtypePointer+getObjectPropertyPtr = getObjectPropertyIsGValueInstance setObjectPropertyInt :: GObject a => a -> String -> CInt -> IO ()-setObjectPropertyInt obj propName int =- setObjectProperty obj propName int set_int gtypeInt+setObjectPropertyInt = setObjectPropertyIsGValueInstance constructObjectPropertyInt :: String -> CInt -> IO (GValueConstruct o)-constructObjectPropertyInt propName int =- constructObjectProperty propName int set_int gtypeInt+constructObjectPropertyInt = constructObjectPropertyIsGValueInstance getObjectPropertyInt :: GObject a => a -> String -> IO CInt-getObjectPropertyInt obj propName =- getObjectProperty obj propName get_int gtypeInt+getObjectPropertyInt = getObjectPropertyIsGValueInstance setObjectPropertyUInt :: GObject a => a -> String -> CUInt -> IO ()-setObjectPropertyUInt obj propName uint =- setObjectProperty obj propName uint set_uint gtypeUInt+setObjectPropertyUInt = setObjectPropertyIsGValueInstance constructObjectPropertyUInt :: String -> CUInt -> IO (GValueConstruct o)-constructObjectPropertyUInt propName uint =- constructObjectProperty propName uint set_uint gtypeUInt+constructObjectPropertyUInt = constructObjectPropertyIsGValueInstance getObjectPropertyUInt :: GObject a => a -> String -> IO CUInt-getObjectPropertyUInt obj propName =- getObjectProperty obj propName get_uint gtypeUInt+getObjectPropertyUInt = getObjectPropertyIsGValueInstance setObjectPropertyLong :: GObject a => a -> String -> CLong -> IO ()-setObjectPropertyLong obj propName int =- setObjectProperty obj propName int set_long gtypeLong+setObjectPropertyLong = setObjectPropertyIsGValueInstance constructObjectPropertyLong :: String -> CLong -> IO (GValueConstruct o)-constructObjectPropertyLong propName int =- constructObjectProperty propName int set_long gtypeLong+constructObjectPropertyLong = constructObjectPropertyIsGValueInstance getObjectPropertyLong :: GObject a => a -> String -> IO CLong-getObjectPropertyLong obj propName =- getObjectProperty obj propName get_long gtypeLong+getObjectPropertyLong = getObjectPropertyIsGValueInstance setObjectPropertyULong :: GObject a => a -> String -> CULong -> IO ()-setObjectPropertyULong obj propName uint =- setObjectProperty obj propName uint set_ulong gtypeULong+setObjectPropertyULong = setObjectPropertyIsGValueInstance constructObjectPropertyULong :: String -> CULong -> IO (GValueConstruct o)-constructObjectPropertyULong propName uint =- constructObjectProperty propName uint set_ulong gtypeULong+constructObjectPropertyULong = constructObjectPropertyIsGValueInstance getObjectPropertyULong :: GObject a => a -> String -> IO CULong-getObjectPropertyULong obj propName =- getObjectProperty obj propName get_ulong gtypeULong+getObjectPropertyULong = getObjectPropertyIsGValueInstance setObjectPropertyInt32 :: GObject a => a -> String -> Int32 -> IO ()-setObjectPropertyInt32 obj propName int32 =- setObjectProperty obj propName int32 set_int32 gtypeInt+setObjectPropertyInt32 = setObjectPropertyIsGValueInstance constructObjectPropertyInt32 :: String -> Int32 -> IO (GValueConstruct o)-constructObjectPropertyInt32 propName int32 =- constructObjectProperty propName int32 set_int32 gtypeInt+constructObjectPropertyInt32 = constructObjectPropertyIsGValueInstance getObjectPropertyInt32 :: GObject a => a -> String -> IO Int32-getObjectPropertyInt32 obj propName =- getObjectProperty obj propName get_int32 gtypeInt+getObjectPropertyInt32 = getObjectPropertyIsGValueInstance setObjectPropertyUInt32 :: GObject a => a -> String -> Word32 -> IO ()-setObjectPropertyUInt32 obj propName uint32 =- setObjectProperty obj propName uint32 set_uint32 gtypeUInt+setObjectPropertyUInt32 = setObjectPropertyIsGValueInstance constructObjectPropertyUInt32 :: String -> Word32 -> IO (GValueConstruct o)-constructObjectPropertyUInt32 propName uint32 =- constructObjectProperty propName uint32 set_uint32 gtypeUInt+constructObjectPropertyUInt32 = constructObjectPropertyIsGValueInstance getObjectPropertyUInt32 :: GObject a => a -> String -> IO Word32-getObjectPropertyUInt32 obj propName =- getObjectProperty obj propName get_uint32 gtypeUInt+getObjectPropertyUInt32 = getObjectPropertyIsGValueInstance setObjectPropertyInt64 :: GObject a => a -> String -> Int64 -> IO ()-setObjectPropertyInt64 obj propName int64 =- setObjectProperty obj propName int64 set_int64 gtypeInt64+setObjectPropertyInt64 = setObjectPropertyIsGValueInstance constructObjectPropertyInt64 :: String -> Int64 -> IO (GValueConstruct o)-constructObjectPropertyInt64 propName int64 =- constructObjectProperty propName int64 set_int64 gtypeInt64+constructObjectPropertyInt64 = constructObjectPropertyIsGValueInstance getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64-getObjectPropertyInt64 obj propName =- getObjectProperty obj propName get_int64 gtypeInt64+getObjectPropertyInt64 = getObjectPropertyIsGValueInstance setObjectPropertyUInt64 :: GObject a => a -> String -> Word64 -> IO ()-setObjectPropertyUInt64 obj propName uint64 =- setObjectProperty obj propName uint64 set_uint64 gtypeUInt64+setObjectPropertyUInt64 = setObjectPropertyIsGValueInstance constructObjectPropertyUInt64 :: String -> Word64 -> IO (GValueConstruct o)-constructObjectPropertyUInt64 propName uint64 =- constructObjectProperty propName uint64 set_uint64 gtypeUInt64+constructObjectPropertyUInt64 = constructObjectPropertyIsGValueInstance getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64-getObjectPropertyUInt64 obj propName =- getObjectProperty obj propName get_uint64 gtypeUInt64+getObjectPropertyUInt64 = getObjectPropertyIsGValueInstance setObjectPropertyFloat :: GObject a => a -> String -> Float -> IO ()-setObjectPropertyFloat obj propName float =- setObjectProperty obj propName float set_float gtypeFloat+setObjectPropertyFloat = setObjectPropertyIsGValueInstance constructObjectPropertyFloat :: String -> Float -> IO (GValueConstruct o)-constructObjectPropertyFloat propName float =- constructObjectProperty propName float set_float gtypeFloat+constructObjectPropertyFloat = constructObjectPropertyIsGValueInstance getObjectPropertyFloat :: GObject a => a -> String -> IO Float-getObjectPropertyFloat obj propName =- getObjectProperty obj propName get_float gtypeFloat+getObjectPropertyFloat = getObjectPropertyIsGValueInstance setObjectPropertyDouble :: GObject a => a -> String -> Double -> IO ()-setObjectPropertyDouble obj propName double =- setObjectProperty obj propName double set_double gtypeDouble+setObjectPropertyDouble = setObjectPropertyIsGValueInstance constructObjectPropertyDouble :: String -> Double -> IO (GValueConstruct o)-constructObjectPropertyDouble propName double =- constructObjectProperty propName double set_double gtypeDouble+constructObjectPropertyDouble = constructObjectPropertyIsGValueInstance getObjectPropertyDouble :: GObject a => a -> String -> IO Double-getObjectPropertyDouble obj propName =- getObjectProperty obj propName get_double gtypeDouble+getObjectPropertyDouble = getObjectPropertyIsGValueInstance setObjectPropertyBool :: GObject a => a -> String -> Bool -> IO ()-setObjectPropertyBool obj propName bool =- setObjectProperty obj propName bool set_boolean gtypeBoolean+setObjectPropertyBool = setObjectPropertyIsGValueInstance constructObjectPropertyBool :: String -> Bool -> IO (GValueConstruct o)-constructObjectPropertyBool propName bool =- constructObjectProperty propName bool set_boolean gtypeBoolean+constructObjectPropertyBool = constructObjectPropertyIsGValueInstance getObjectPropertyBool :: GObject a => a -> String -> IO Bool-getObjectPropertyBool obj propName =- getObjectProperty obj propName get_boolean gtypeBoolean+getObjectPropertyBool = getObjectPropertyIsGValueInstance setObjectPropertyGType :: GObject a => a -> String -> GType -> IO ()-setObjectPropertyGType obj propName gtype =- setObjectProperty obj propName gtype set_gtype gtypeGType+setObjectPropertyGType = setObjectPropertyIsGValueInstance constructObjectPropertyGType :: String -> GType -> IO (GValueConstruct o)-constructObjectPropertyGType propName bool =- constructObjectProperty propName bool set_gtype gtypeGType+constructObjectPropertyGType = constructObjectPropertyIsGValueInstance getObjectPropertyGType :: GObject a => a -> String -> IO GType-getObjectPropertyGType obj propName =- getObjectProperty obj propName get_gtype gtypeGType+getObjectPropertyGType = getObjectPropertyIsGValueInstance setObjectPropertyObject :: forall a b. (GObject a, GObject b) => a -> String -> Maybe b -> IO () setObjectPropertyObject obj propName maybeObject = do- gtype <- gobjectType @b+ gtype <- glibType @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 @a+ gtype <- glibType @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 @b+ gtype <- glibType @b getObjectProperty obj propName (\val -> (get_object val :: IO (Ptr b)) >>= flip convertIfNonNull (newObject constructor)) gtype -setObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+setObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) => a -> String -> Maybe b -> IO () setObjectPropertyBoxed obj propName maybeBoxed = do- gtype <- boxedType (undefined :: b)+ gtype <- glibType @b maybeWithManagedPtr maybeBoxed $ \boxedPtr -> setObjectProperty obj propName boxedPtr set_boxed gtype -constructObjectPropertyBoxed :: forall a o. (BoxedObject a) =>+constructObjectPropertyBoxed :: forall a o. (GBoxed a) => String -> Maybe a -> IO (GValueConstruct o) constructObjectPropertyBoxed propName maybeBoxed = do- gtype <- boxedType (undefined :: a)+ gtype <- glibType @a maybeWithManagedPtr maybeBoxed $ \boxedPtr -> constructObjectProperty propName boxedPtr set_boxed gtype -getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+getObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) => a -> String -> (ManagedPtr b -> b) -> IO (Maybe b) getObjectPropertyBoxed obj propName constructor = do- gtype <- boxedType (undefined :: b)+ gtype <- glibType @b getObjectProperty obj propName (get_boxed >=> flip convertIfNonNull (newBoxed constructor)) gtype@@ -411,17 +413,17 @@ flip convertIfNonNull unpackZeroTerminatedUTF8CArray) gtypeStrv -setObjectPropertyEnum :: (GObject a, Enum b, BoxedEnum b) =>+setObjectPropertyEnum :: forall a b. (GObject a, Enum b, BoxedEnum b) => a -> String -> b -> IO () setObjectPropertyEnum obj propName enum = do- gtype <- boxedEnumType enum+ gtype <- glibType @b let cEnum = (fromIntegral . fromEnum) enum setObjectProperty obj propName cEnum set_enum gtype -constructObjectPropertyEnum :: (Enum a, BoxedEnum a) =>+constructObjectPropertyEnum :: forall a o. (Enum a, BoxedEnum a) => String -> a -> IO (GValueConstruct o) constructObjectPropertyEnum propName enum = do- gtype <- boxedEnumType enum+ gtype <- glibType @a let cEnum = (fromIntegral . fromEnum) enum constructObjectProperty propName cEnum set_enum gtype @@ -429,7 +431,7 @@ Enum b, BoxedEnum b) => a -> String -> IO b getObjectPropertyEnum obj propName = do- gtype <- boxedEnumType (undefined :: b)+ gtype <- glibType @b getObjectProperty obj propName (\val -> toEnum . fromIntegral <$> get_enum val) gtype@@ -438,20 +440,20 @@ a -> String -> [b] -> IO () setObjectPropertyFlags obj propName flags = do let cFlags = gflagsToWord flags- gtype <- boxedFlagsType (Proxy :: Proxy b)+ gtype <- glibType @b setObjectProperty obj propName cFlags set_flags gtype constructObjectPropertyFlags :: forall a o. (IsGFlag a, BoxedFlags a) => String -> [a] -> IO (GValueConstruct o) constructObjectPropertyFlags propName flags = do let cFlags = gflagsToWord flags- gtype <- boxedFlagsType (Proxy :: Proxy a)+ gtype <- glibType @a constructObjectProperty propName cFlags set_flags gtype getObjectPropertyFlags :: forall a b. (GObject a, IsGFlag b, BoxedFlags b) => a -> String -> IO [b] getObjectPropertyFlags obj propName = do- gtype <- boxedFlagsType (Proxy :: Proxy b)+ gtype <- glibType @b getObjectProperty obj propName (\val -> wordToGFlags <$> get_flags val) gtype@@ -531,7 +533,7 @@ getObjectPropertyPtrGList :: GObject a => a -> String -> IO [Ptr b] getObjectPropertyPtrGList obj propName =- getObjectProperty obj propName (get_pointer >=> unpackGList) gtypePointer+ getObjectProperty obj propName (gvalueGet_ >=> unpackGList) gtypePointer setObjectPropertyHash :: GObject a => a -> String -> b -> IO () setObjectPropertyHash =@@ -547,16 +549,16 @@ setObjectPropertyCallback :: GObject a => a -> String -> FunPtr b -> IO () setObjectPropertyCallback obj propName funPtr =- setObjectProperty obj propName (castFunPtrToPtr funPtr) set_pointer gtypePointer+ setObjectProperty obj propName (castFunPtrToPtr funPtr) gvalueSet_ gtypePointer constructObjectPropertyCallback :: String -> FunPtr b -> IO (GValueConstruct o) constructObjectPropertyCallback propName funPtr =- constructObjectProperty propName (castFunPtrToPtr funPtr) set_pointer gtypePointer+ constructObjectProperty propName (castFunPtrToPtr funPtr) gvalueSet_ gtypePointer getObjectPropertyCallback :: GObject a => a -> String -> (FunPtr b -> c) -> IO (Maybe c) getObjectPropertyCallback obj propName wrapper = do- ptr <- getObjectProperty obj propName get_pointer gtypePointer+ ptr <- getObjectProperty obj propName gvalueGet_ gtypePointer if ptr /= nullPtr then return . Just . wrapper $ castPtrToFunPtr ptr else return Nothing@@ -575,3 +577,32 @@ a -> String -> IO (Maybe GError) getObjectPropertyGError obj propName = getObjectPropertyBoxed obj propName GError++-- | Set a property of type `GValue`.+setObjectPropertyGValue :: forall a. GObject a =>+ a -> String -> Maybe GValue -> IO ()+setObjectPropertyGValue = setObjectPropertyBoxed++-- | Construct a property of type `GValue`.+constructObjectPropertyGValue :: String -> Maybe GValue -> IO (GValueConstruct o)+constructObjectPropertyGValue = constructObjectPropertyBoxed++-- | Get the value of a property of type `GValue`.+getObjectPropertyGValue :: forall a. GObject a =>+ a -> String -> IO (Maybe GValue)+getObjectPropertyGValue obj propName =+ getObjectPropertyBoxed obj propName GValue++-- | Construct a property of type `GParamSpec`.+constructObjectPropertyParamSpec :: String -> Maybe GParamSpec ->+ IO (GValueConstruct o)+constructObjectPropertyParamSpec = constructObjectPropertyIsGValueInstance++-- | Get a property of type `GParamSpec`.+getObjectPropertyParamSpec :: GObject a => a -> String -> IO (Maybe GParamSpec)+getObjectPropertyParamSpec = getObjectPropertyIsGValueInstance++-- | Set a property of type `GParamSpec`.+setObjectPropertyParamSpec :: GObject a =>+ a -> String -> Maybe GParamSpec -> IO ()+setObjectPropertyParamSpec = setObjectPropertyIsGValueInstance
Data/GI/Base/ShortPrelude.hs view
@@ -1,3 +1,6 @@+#if MIN_VERSION_base(4,20,0)+{-# LANGUAGE ExplicitNamespaces #-}+#endif -- | 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,@@ -57,6 +60,9 @@ , when , fromIntegral , realToFrac+#if MIN_VERSION_base(4,20,0)+ , type (~)+#endif ) where import Control.Monad (when, (>=>))
+ Data/GI/Base/Signals.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}++-- | Routines for connecting `GObject`s to signals. There are two+-- basic variants, 'on' and 'after', which correspond to+-- <https://docs.gtk.org/gobject/func.signal_connect.html g_signal_connect> and <https://docs.gtk.org/gobject/func.signal_connect_after.html g_signal_connect_after>, respectively.+--+-- Basic usage is+--+-- @ 'on' widget #signalName $ do ... @+--+-- or+--+-- @ 'after' widget #signalName $ do ... @+--+-- Note that in the Haskell bindings we represent the signal name in+-- camelCase, so a signal like <https://webkitgtk.org/reference/webkit2gtk/stable/WebKitUserContentManager.html#WebKitUserContentManager-script-message-received script-message-received> in the original API becomes <https://hackage.haskell.org/package/gi-webkit2-4.0.24/docs/GI-WebKit2-Objects-UserContentManager.html#g:16 scriptMessageReceived> in the bindings.+--+-- There are two variants of note. If you want to provide a detail+-- when connecting the signal you can use ':::', as follows:+--+-- @ 'on' widget (#scriptMessageReceived ':::' "handlerName") $ do ... @+--+-- On the other hand, if you want to connect to the "<https://hackage.haskell.org/package/gi-gobject-2.0.21/docs/GI-GObject-Objects-Object.html#g:30 notify>" signal for a property of a widget, it is recommended to use instead 'PropertyNotify', as follows:+--+-- @ 'on' widget ('PropertyNotify' #propertyName) $ do ... @+--+-- which has the advantage that it will be checked at compile time+-- that the widget does indeed have the property "@propertyName@".+module Data.GI.Base.Signals+ ( on+ , after+ , SignalProxy(..)+ , SignalConnectMode(..)+ , connectSignalFunPtr+ , disconnectSignalHandler+ , SignalHandlerId+ , SignalInfo(..)+ , GObjectNotifySignalInfo+ , SignalCodeGenError+ , resolveSignal+ , connectGObjectNotify+ ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy(..))+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif++import Foreign+import Foreign.C+#if !MIN_VERSION_base(4,13,0)+import Foreign.Ptr (nullPtr)+#endif++import GHC.TypeLits+import Data.Kind (Type)++import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel),+ AttrGetType, attrGet,+ AttrBaseTypeConstraint)+import Data.GI.Base.BasicConversions (withTextCString)+import Data.GI.Base.BasicTypes+import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)+import Data.GI.Base.ManagedPtr (withManagedPtr, withTransient)+import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute,+ ResolvedSymbolInfo)++import GHC.OverloadedLabels (IsLabel(..))++-- | Type of a `GObject` signal handler id.+type SignalHandlerId = CULong++-- | Support for overloaded signal connectors.+data SignalProxy (object :: Type) (info :: Type) where+ -- | A basic signal name connector.+ SignalProxy :: SignalProxy o info+ -- | A signal connector annotated with a detail.+ (:::) :: forall o info. SignalProxy o info -> Text -> SignalProxy o info+ -- | A signal connector for the @notify@ signal on the given property.+ PropertyNotify :: (info ~ ResolveAttribute propName o,+ AttrInfo info,+ pl ~ AttrLabel info, KnownSymbol pl) =>+ AttrLabelProxy propName ->+ SignalProxy o GObjectNotifySignalInfo+ -- | A signal connector for the @notify@ signal on the given+ -- property, similar to `PropertyNotify`, but it passes the new+ -- value of the property to the callback for convenience.+ PropertySet :: (info ~ ResolveAttribute propName o,+ AttrInfo info,+ AttrBaseTypeConstraint info o,+ b ~ AttrGetType info,+ pl ~ AttrLabel info, KnownSymbol pl) =>+ AttrLabelProxy propName ->+ SignalProxy o (GObjectPropertySetSignalInfo b)++-- | Support for overloaded labels.+instance (info ~ ResolveSignal slot object) =>+ IsLabel slot (SignalProxy object info) where+#if MIN_VERSION_base(4,10,0)+ fromLabel = SignalProxy+#else+ fromLabel _ = SignalProxy+#endif++-- | Information about an overloaded signal.+class SignalInfo (info :: Type) where+ -- | The type for the signal handler.+ type HaskellCallbackType info :: Type+ -- | Connect a Haskell function to a signal of the given `GObject`,+ -- specifying whether the handler will be called before or after the+ -- default handler. Note that the callback being passed here admits+ -- an extra initial parameter with respect to the usual Haskell+ -- callback type. This will be passed as an /implicit/ @?self@+ -- argument to the Haskell callback.+ connectSignal :: GObject o =>+ o ->+ (o -> HaskellCallbackType info) ->+ SignalConnectMode ->+ Maybe Text ->+ IO SignalHandlerId++ -- | Optional extra debug information, for `resolveSignal` below.+ dbgSignalInfo :: Maybe ResolvedSymbolInfo+ dbgSignalInfo = Nothing++-- | Whether to connect a handler to a signal with `connectSignal` so+-- that it runs before/after the default handler for the given signal.+data SignalConnectMode = SignalConnectBefore -- ^ Run before the default handler.+ | SignalConnectAfter -- ^ Run after the default handler.++-- | Connect a signal to a signal handler.+on :: forall object info m.+ (GObject object, MonadIO m, SignalInfo info) =>+ object -> SignalProxy object info+ -> ((?self :: object) => HaskellCallbackType info)+ -> m SignalHandlerId+on o p@(PropertySet (_ :: AttrLabelProxy propName)) cb = liftIO $ do+ let wrapped = wrapPropertySet (Proxy @propName) (Proxy @object) cb+ cb' <- mkGObjectNotifyCallback wrapped+ connectSignalFunPtr o "notify" cb' SignalConnectBefore (proxyDetail p)+on o p c =+ liftIO $ connectSignal @info o w SignalConnectBefore (proxyDetail p)+ where w :: object -> HaskellCallbackType info+ w parent = let ?self = parent in c++-- | Wrap a @b -> IO ()@ callback into a property notify callback on+-- the C side, by adding some code that reads the current value of the+-- property before invoking the callback.+wrapPropertySet :: forall info prop obj.+ (info ~ ResolveAttribute prop obj,+ AttrBaseTypeConstraint info obj,+ AttrInfo info,+ GObject obj) =>+ Proxy (prop :: Symbol) -> Proxy obj ->+ ((?self :: obj) => AttrGetType info -> IO ()) ->+ Ptr obj -> Ptr GParamSpec -> Ptr () -> IO ()+wrapPropertySet _ _ cb objPtr _pspec _data =+ withTransient objPtr $ \self -> do+ val <- attrGet @(ResolveAttribute prop obj) self+ let ?self = self in cb val++-- | Connect a signal to a handler, running the handler after the default one.+after :: forall object info m.+ (GObject object, MonadIO m, SignalInfo info) =>+ object -> SignalProxy object info+ -> ((?self :: object) => HaskellCallbackType info)+ -> m SignalHandlerId+after o p c =+ liftIO $ connectSignal @info o w SignalConnectAfter (proxyDetail p)+ where w :: object -> HaskellCallbackType info+ w parent = let ?self = parent in c++-- | Given a signal proxy, determine the corresponding detail.+proxyDetail :: forall object info. SignalProxy object info -> Maybe Text+proxyDetail p = case p of+ SignalProxy -> Nothing+ (_ ::: detail) -> Just detail+ PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) ->+ Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))+ PropertySet (AttrLabelProxy :: AttrLabelProxy propName) ->+ Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))++-- Connecting GObjects to signals+foreign import ccall g_signal_connect_data ::+ Ptr a -> -- instance+ CString -> -- detailed_signal+ FunPtr b -> -- c_handler+ Ptr () -> -- data+ FunPtr c -> -- destroy_data+ 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 -> Text -> FunPtr a -> SignalConnectMode ->+ Maybe Text -> IO SignalHandlerId+connectSignalFunPtr object signal fn mode maybeDetail = do+ let flags = case mode of+ SignalConnectAfter -> 1+ SignalConnectBefore -> 0+ signalSpec = case maybeDetail of+ Nothing -> signal+ Just detail -> signal <> "::" <> detail+ withTextCString signalSpec $ \csignal ->+ withManagedPtr object $ \objPtr ->+ 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).+data GObjectNotifySignalInfo+instance SignalInfo GObjectNotifySignalInfo where+ type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback+ connectSignal = connectGObjectNotify++-- | Type for a `GObject` "notify" callback.+type GObjectNotifyCallback = GParamSpec -> IO ()++gobjectNotifyCallbackWrapper :: GObject o =>+ (o -> GObjectNotifyCallback) -> GObjectNotifyCallbackC o+gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do+ pspec' <- newGParamSpecFromPtr pspec+ withTransient (castPtr selfPtr) $ \self -> cb self pspec'++type GObjectNotifyCallbackC o = Ptr o -> Ptr GParamSpec -> Ptr () -> IO ()++foreign import ccall "wrapper"+ mkGObjectNotifyCallback :: GObjectNotifyCallbackC o -> IO (FunPtr (GObjectNotifyCallbackC o))++-- | Connect the given notify callback for a GObject.+connectGObjectNotify :: GObject o =>+ o -> (o -> GObjectNotifyCallback) ->+ SignalConnectMode ->+ Maybe Text ->+ IO SignalHandlerId+connectGObjectNotify obj cb mode detail = do+ cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)+ connectSignalFunPtr obj "notify" cb' mode detail++data GObjectPropertySetSignalInfo (b :: Type)+instance SignalInfo (GObjectPropertySetSignalInfo b) where+ type HaskellCallbackType (GObjectPropertySetSignalInfo b) = b -> IO ()+ connectSignal = undefined -- We connect these separately++-- | Generate an informative type error whenever one tries to use a+-- signal for which code generation has failed.+type family SignalCodeGenError (signalName :: Symbol) :: Type where+ SignalCodeGenError signalName = TypeError+ ('Text "The signal ‘"+ ':<>: 'Text signalName+ ':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings."+ ':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.")++-- | Return the fully qualified signal name that a given overloaded+-- signal resolves to (mostly useful for debugging).+--+-- > resolveSignal #childNotify button+resolveSignal :: forall object info. (GObject object, SignalInfo info) =>+ object -> SignalProxy object info -> Maybe ResolvedSymbolInfo+resolveSignal _o _p = dbgSignalInfo @info
+ Data/GI/Base/Signals.hs-boot view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}++module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after,+ connectGObjectNotify, SignalConnectMode(..)) where++import Data.GI.Base.Overloading (ResolvedSymbolInfo)+import Data.GI.Base.BasicTypes (GObject, GParamSpec)+import Control.Monad.IO.Class (MonadIO)+import Foreign.C (CULong)+import Data.Text (Text)++data SignalConnectMode = SignalConnectBefore+ | SignalConnectAfter++class SignalInfo info where+ type HaskellCallbackType info+ connectSignal :: GObject o =>+ o ->+ (o -> HaskellCallbackType info) ->+ SignalConnectMode ->+ Maybe Text ->+ IO SignalHandlerId+ dbgSignalInfo :: Maybe ResolvedSymbolInfo+ dbgSignalInfo = Nothing++type role SignalProxy nominal nominal+data SignalProxy object info where++type SignalHandlerId = CULong++on :: forall object info m.+ (GObject object, MonadIO m, SignalInfo info) =>+ object -> SignalProxy object info+ -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId++after :: forall object info m.+ (GObject object, MonadIO m, SignalInfo info) =>+ object -> SignalProxy object info+ -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId++type GObjectNotifyCallback = GParamSpec -> IO ()++connectGObjectNotify :: GObject o =>+ o -> (o -> GObjectNotifyCallback) ->+ SignalConnectMode ->+ Maybe Text ->+ IO SignalHandlerId
− Data/GI/Base/Signals.hsc
@@ -1,226 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}---- | Routines for connecting `GObject`s to signals. There are two--- basic variants, 'on' and 'after', which correspond to--- <https://developer.gnome.org/gobject/stable/gobject-Signals.html#g-signal-connect g_signal_connect> and <https://developer.gnome.org/gobject/stable/gobject-Signals.html#g-signal-connect-after g_signal_connect_after>, respectively.------ Basic usage is------ @ 'on' widget #signalName $ do ... @------ or------ @ 'after' widget #signalName $ do ... @------ Note that in the Haskell bindings we represent the signal name in--- camelCase, so a signal like <https://webkitgtk.org/reference/webkit2gtk/stable/WebKitUserContentManager.html#WebKitUserContentManager-script-message-received script-message-received> in the original API becomes <https://hackage.haskell.org/package/gi-webkit2-4.0.24/docs/GI-WebKit2-Objects-UserContentManager.html#g:16 scriptMessageReceived> in the bindings.------ There are two variants of note. If you want to provide a detail--- when connecting the signal you can use ':::', as follows:------ @ 'on' widget (#scriptMessageReceived ':::' "handlerName") $ do ... @------ On the other hand, if you want to connect to the "<https://hackage.haskell.org/package/gi-gobject-2.0.21/docs/GI-GObject-Objects-Object.html#g:30 notify>" signal for a property of a widget, it is recommended to use instead 'PropertyNotify', as follows:------ @ 'on' widget ('PropertyNotify' #propertyName) $ do ... @------ which has the advantage that it will be checked at compile time--- that the widget does indeed have the property "@propertyName@".-module Data.GI.Base.Signals- ( on- , after- , SignalProxy(..)- , SignalConnectMode(..)- , connectSignalFunPtr- , disconnectSignalHandler- , SignalHandlerId- , SignalInfo(..)- , GObjectNotifySignalInfo- , SignalCodeGenError- ) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Proxy (Proxy(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif--import Foreign-import Foreign.C-#if !MIN_VERSION_base(4,13,0)-import Foreign.Ptr (nullPtr)-#endif--import GHC.TypeLits--import qualified Data.Text as T-import Data.Text (Text)--import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel))-import Data.GI.Base.BasicConversions (withTextCString)-import Data.GI.Base.BasicTypes-import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)-import Data.GI.Base.ManagedPtr (withManagedPtr)-import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute)--import GHC.OverloadedLabels (IsLabel(..))---- | Type of a `GObject` signal handler id.-type SignalHandlerId = CULong---- | Support for overloaded signal connectors.-data SignalProxy (object :: *) (info :: *) where- -- | A basic signal name connector.- SignalProxy :: SignalProxy o info- -- | A signal connector annotated with a detail.- (:::) :: forall o info. SignalProxy o info -> Text -> SignalProxy o info- -- | A signal connector for the @notify@ signal on the given property.- PropertyNotify :: (info ~ ResolveAttribute propName o,- AttrInfo info,- pl ~ AttrLabel info, KnownSymbol pl) =>- AttrLabelProxy propName ->- SignalProxy o GObjectNotifySignalInfo---- | Support for overloaded labels.-instance (info ~ ResolveSignal slot object) =>- IsLabel slot (SignalProxy object info) where-#if MIN_VERSION_base(4,10,0)- fromLabel = SignalProxy-#else- fromLabel _ = SignalProxy-#endif---- | Information about an overloaded signal.-class SignalInfo (info :: *) where- -- | The type for the signal handler.- type HaskellCallbackType info :: *- -- | Connect a Haskell function to a signal of the given- -- `GObject`, specifying whether the handler will be called before- -- or after the default handler.- connectSignal :: GObject o =>- o ->- HaskellCallbackType info ->- SignalConnectMode ->- Maybe Text ->- IO SignalHandlerId---- | Whether to connect a handler to a signal with `connectSignal` so--- that it runs before/after the default handler for the given signal.-data SignalConnectMode = SignalConnectBefore -- ^ Run before the default handler.- | SignalConnectAfter -- ^ Run after the default handler.---- | Connect a signal to a signal handler.-on :: forall object info m.- (GObject object, MonadIO m, SignalInfo info) =>- object -> SignalProxy object info- -> HaskellCallbackType info -> m SignalHandlerId-on o p c =- liftIO $ connectSignal @info o c SignalConnectBefore (proxyDetail p)---- | Connect a signal to a handler, running the handler after the default one.-after :: forall object info m.- (GObject object, MonadIO m, SignalInfo info) =>- object -> SignalProxy object info- -> HaskellCallbackType info -> m SignalHandlerId-after o p c =- liftIO $ connectSignal @info o c SignalConnectAfter (proxyDetail p)---- | Given a signal proxy, determine the corresponding detail.-proxyDetail :: forall object info. SignalProxy object info -> Maybe Text-proxyDetail p = case p of- SignalProxy -> Nothing- (_ ::: detail) -> Just detail- PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) ->- Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))---- Connecting GObjects to signals-foreign import ccall g_signal_connect_data ::- Ptr a -> -- instance- CString -> -- detailed_signal- FunPtr b -> -- c_handler- Ptr () -> -- data- FunPtr c -> -- destroy_data- 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 -> Text -> FunPtr a -> SignalConnectMode ->- Maybe Text -> IO SignalHandlerId-connectSignalFunPtr object signal fn mode maybeDetail = do- let flags = case mode of- SignalConnectAfter -> 1- SignalConnectBefore -> 0- signalSpec = case maybeDetail of- Nothing -> signal- Just detail -> signal <> "::" <> detail- withTextCString signalSpec $ \csignal ->- withManagedPtr object $ \objPtr ->- 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).-data GObjectNotifySignalInfo-instance SignalInfo GObjectNotifySignalInfo where- type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback- connectSignal = connectGObjectNotify---- | Type for a `GObject` "notify" callback.-type GObjectNotifyCallback = GParamSpec -> IO ()--gobjectNotifyCallbackWrapper ::- GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()-gobjectNotifyCallbackWrapper _cb _ pspec _ = do- pspec' <- newGParamSpecFromPtr pspec- _cb pspec'--type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()--foreign import ccall "wrapper"- mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)---- | Connect the given notify callback for a GObject.-connectGObjectNotify :: GObject o =>- o -> GObjectNotifyCallback ->- SignalConnectMode ->- Maybe Text ->- IO SignalHandlerId-connectGObjectNotify obj cb mode detail = do- cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)- connectSignalFunPtr obj "notify" cb' mode detail---- | Generate an informative type error whenever one tries to use a--- signal for which code generation has failed.-type family SignalCodeGenError (signalName :: Symbol) :: * where- SignalCodeGenError signalName = TypeError- ('Text "The signal ‘"- ':<>: 'Text signalName- ':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings."- ':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.")
Data/GI/Base/Utils.hsc view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings,- FlexibleContexts, ConstraintKinds #-}+ FlexibleContexts, ConstraintKinds, TypeApplications #-} {- | Assorted utility functions for bindings. -} module Data.GI.Base.Utils ( whenJust@@ -21,6 +21,7 @@ , memcpy , safeFreeFunPtr , safeFreeFunPtrPtr+ , safeFreeFunPtrPtr' , maybeReleaseFunPtr , checkUnexpectedReturnNULL , checkUnexpectedNothing@@ -46,7 +47,8 @@ import Foreign.Ptr (Ptr, nullPtr, FunPtr, nullFunPtr, freeHaskellFunPtr) import Foreign.Storable (Storable(..)) -import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..),+import Data.GI.Base.BasicTypes (GType(..), CGType, GBoxed,+ TypedObject(glibType), UnexpectedNullPointerReturn(..)) import Data.GI.Base.CallStack (HasCallStack, callStack, prettyCallStack) @@ -127,10 +129,10 @@ -- in particular may well be different from a plain g_malloc. In -- particular g_slice_alloc is often used for allocating boxed -- objects, which are then freed using g_slice_free.-callocBoxedBytes :: forall a. BoxedObject a => Int -> IO (Ptr a)+callocBoxedBytes :: forall a. GBoxed a => Int -> IO (Ptr a) callocBoxedBytes n = do ptr <- callocBytes n- GType cgtype <- boxedType (undefined :: a)+ GType cgtype <- glibType @a result <- g_boxed_copy cgtype ptr freeMem ptr return result@@ -170,6 +172,12 @@ -- | A pointer to `safeFreeFunPtr`. foreign import ccall "& safeFreeFunPtr" safeFreeFunPtrPtr :: FunPtr (Ptr a -> IO ())++-- | Similar to 'safeFreeFunPtrPtr', but accepts an additional+-- (ignored) argument. The first argument is interpreted as a+-- 'FunPtr', and released.+foreign import ccall "& safeFreeFunPtr2" safeFreeFunPtrPtr' ::+ FunPtr (Ptr a -> Ptr b -> IO ()) -- | If given a pointer to the memory location, free the `FunPtr` at -- that location, and then the pointer itself. Useful for freeing the
− c/hsgclosure.c
@@ -1,363 +0,0 @@-#define _GNU_SOURCE--/* GHC's semi-public Rts API */-#include <Rts.h>--#include <stdarg.h>-#include <stdlib.h>-#include <string.h>-#include <pthread.h>--#include <glib-object.h>-#include <glib.h>--static int print_debug_info ()-{- static int __print_debug_info = -1;-- if (__print_debug_info == -1) {- __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL;- }-- return __print_debug_info;-}--/*- A mutex protecting the log file handle. We make it recursive,- i.e. refcounted, so it is OK to lock repeatedly in the same thread.-*/-static pthread_mutex_t log_mutex-#if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP)- = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;-#elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER)- = PTHREAD_RECURSIVE_MUTEX_INITIALIZER;-#else- ;-__attribute__ ((constructor)) static void init_log_mutex()-{- pthread_mutexattr_t attr;- pthread_mutexattr_init(&attr);- pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);- pthread_mutex_init(&log_mutex, &attr);- pthread_mutexattr_destroy(&attr);-}-#endif--/* Give the current thread exclusive access to the log */-static void lock_log()-{- pthread_mutex_lock(&log_mutex);-}--/* Decrease the refcount of the mutex protecting access to the log- from other threads */-static void unlock_log()-{- pthread_mutex_unlock(&log_mutex);-}--/* Print the given message to the log. The passed in string does not- need to be zero-terminated. The message is only printed if the- HASKELL_GI_DEBUG_MEM variable is set. */-void dbg_log_with_len (const char *msg, int len)-{- if (print_debug_info()) {- lock_log();- fwrite(msg, len, 1, stderr);- unlock_log();- }-}--/* Print the given printf-style message to the log. The message is- only printed if the HASKELL_GI_DEBUG_MEM variable is set. */-__attribute__ ((format (printf, 1, 2)))-static void dbg_log (const char *msg, ...)-{- va_list args;-- va_start(args, msg);-- if (print_debug_info()) {- lock_log();- vfprintf(stderr, msg, args);- unlock_log();- }-- va_end(args);-}--int check_object_type(void *instance, GType type)-{- int result;-- if (instance != NULL) {- result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);- } else {- result = 0;- dbg_log("Check failed: got a null pointer\n");- }-- return result;-}--/* Information about a boxed type to free */-typedef struct {- GType gtype;- gpointer boxed;-} BoxedFreeInfo;--/* Auxiliary function for freeing boxed types in the main loop. See- the annotation in g_object_unref_in_main_loop() below. */-static gboolean main_loop_boxed_free_helper (gpointer _info)-{- BoxedFreeInfo *info = (BoxedFreeInfo*)_info;-- if (print_debug_info()) {- GThread *self = g_thread_self ();- lock_log();- dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n",- info->boxed, self);- dbg_log("\tIt is of type %s\n", g_type_name(info->gtype));- }-- g_boxed_free (info->gtype, info->boxed);-- if (print_debug_info()) {- dbg_log("\tdone freeing %p.\n", info->boxed);- unlock_log();- }-- g_free(info);-- return FALSE; /* Do not invoke again */-}--void boxed_free_helper (GType gtype, void *boxed)-{- BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo));-- info->gtype = gtype;- info->boxed = boxed;-- g_idle_add (main_loop_boxed_free_helper, info);-}--void dbg_g_object_disown (GObject *obj)-{- GType gtype;-- if (print_debug_info()) {- lock_log();- GThread *self = g_thread_self();- dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self);- gtype = G_TYPE_FROM_INSTANCE (obj);- dbg_log("\tIt is of type %s\n", g_type_name(gtype));- dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count);- unlock_log();- }-}--static void print_object_dbg_info (GObject *obj)-{- GThread *self = g_thread_self();- GType gtype;-- dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self);- gtype = G_TYPE_FROM_INSTANCE (obj);- dbg_log("\tIt is of type %s\n", g_type_name(gtype));- dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count);-}--/*- We schedule all GObject deletions to happen in the main loop. The- reason is that for some types the destructor is not thread safe, and- assumes that it is being run from the same thread as the main loop- that created the object.- */-static gboolean-g_object_unref_in_main_loop (gpointer obj)-{- if (print_debug_info()) {- lock_log();- print_object_dbg_info ((GObject*)obj);- }-- g_object_unref (obj);-- if (print_debug_info()) {- fprintf(stderr, "\tUnref done\n");- unlock_log();- }-- return FALSE; /* Do not invoke again */-}--void dbg_g_object_unref (GObject *obj)-{- g_idle_add(g_object_unref_in_main_loop, obj);-}--/**- * dbg_g_object_new:- * @gtype: #GType for the object to construct.- * @n_props: Number of parameters for g_object_new_with_properties().- * @names: Names of the properties to be set.- * @values: Parameters for g_object_new_with_properties().- *- * Allocate a #GObject of #GType @gtype, with the given @params. The- * returned object is never floating, and we always own a reference to- * it. (It might not be the only existing to the object, but it is in- * any case safe to call g_object_unref() when we are not wrapping the- * object ourselves anymore.)- *- * Returns: A new #GObject.- */-gpointer dbg_g_object_new (GType gtype, guint n_props,- const char *names[], const GValue values[])-{- gpointer result;-- if (print_debug_info()) {- GThread *self = g_thread_self();-- lock_log();- dbg_log("Creating a new GObject of type %s [thread: %p]\n",- g_type_name(gtype), self);- }--#if GLIB_CHECK_VERSION(2,54,0)- result = g_object_new_with_properties (gtype, n_props, names, values);-#else- { GParameter params[n_props];- int i;-- for (i=0; i<n_props; i++) {- memcpy (¶ms[i].value, &values[i], sizeof(GValue));- params[i].name = names[i];- }-- result = g_object_newv (gtype, n_props, params);- }-#endif-- /*- Initially unowned GObjects can be either floating or not after- construction. They are generally floating, but GtkWindow for- instance is not floating after construction.-- In either case we want to call g_object_ref_sink(): if the object- is floating to take ownership of the reference, and otherwise to- add a reference that we own.-- If the object is not initially unowned we simply take control of- the initial reference (implicitly).- */- if (G_IS_INITIALLY_UNOWNED (result)) {- g_object_ref_sink (result);- }-- if (print_debug_info()) {- dbg_log("\tdone, got a pointer at %p\n", result);- unlock_log();- }-- return result;-}--/* Same as freeHaskellFunctionPtr, but it does nothing when given a- null pointer, instead of crashing */-void safeFreeFunPtr(void *ptr)-{- 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 HsStablePtr duplicateStablePtr(HsStablePtr stable_ptr)-{- return getStablePtr(deRefStablePtr(stable_ptr));-}--GType haskell_gi_StablePtr_get_type (void)-{- static volatile gsize g_define_type_id__volatile = 0;-- if (g_once_init_enter (&g_define_type_id__volatile))- {- GType g_define_type_id =- g_boxed_type_register_static (g_intern_static_string ("HaskellGIStablePtr"),- duplicateStablePtr,- hs_free_stable_ptr);-- g_once_init_leave (&g_define_type_id__volatile, g_define_type_id);- }-- return g_define_type_id__volatile;-}--/* 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();-}--/* Check whether the given closure is floating */-gboolean-haskell_gi_g_closure_is_floating (GClosure *closure)-{- return !!(closure->floating);-}
+ csrc/hsgclosure.c view
@@ -0,0 +1,477 @@+#define _GNU_SOURCE++/* GHC's semi-public Rts API */+#include <Rts.h>++#include <stdarg.h>+#include <stdlib.h>+#include <string.h>+#include <pthread.h>++#include <glib-object.h>+#include <glib.h>++static int print_debug_info ()+{+ static int __print_debug_info = -1;++ if (__print_debug_info == -1) {+ __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL;+ }++ return __print_debug_info;+}++/*+ A mutex protecting the log file handle. We make it recursive,+ i.e. refcounted, so it is OK to lock repeatedly in the same thread.+*/+static pthread_mutex_t log_mutex+#if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP)+ = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;+#elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER)+ = PTHREAD_RECURSIVE_MUTEX_INITIALIZER;+#else+ ;+__attribute__ ((constructor)) static void init_log_mutex()+{+ pthread_mutexattr_t attr;+ pthread_mutexattr_init(&attr);+ pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);+ pthread_mutex_init(&log_mutex, &attr);+ pthread_mutexattr_destroy(&attr);+}+#endif++/* Give the current thread exclusive access to the log */+static void lock_log()+{+ pthread_mutex_lock(&log_mutex);+}++/* Decrease the refcount of the mutex protecting access to the log+ from other threads */+static void unlock_log()+{+ pthread_mutex_unlock(&log_mutex);+}++/* Print the given message to the log. The passed in string does not+ need to be zero-terminated. The message is only printed if the+ HASKELL_GI_DEBUG_MEM variable is set. */+void dbg_log_with_len (const char *msg, int len)+{+ if (print_debug_info()) {+ lock_log();+ fwrite(msg, len, 1, stderr);+ unlock_log();+ }+}++/* Print the given printf-style message to the log. The message is+ only printed if the HASKELL_GI_DEBUG_MEM variable is set. */+__attribute__ ((format (printf, 1, 2)))+static void dbg_log (const char *msg, ...)+{+ va_list args;++ va_start(args, msg);++ if (print_debug_info()) {+ lock_log();+ vfprintf(stderr, msg, args);+ unlock_log();+ }++ va_end(args);+}++int check_object_type (void *instance, GType type)+{+ int result;++ if (instance != NULL) {+ result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);+ } else {+ result = 0;+ dbg_log("Check failed: got a null pointer\n");+ }++ return result;+}++GType _haskell_gi_g_value_get_type (GValue *gvalue)+{+ return G_VALUE_TYPE (gvalue);+}++/* Information about a boxed type to free */+typedef struct {+ GType gtype;+ gpointer boxed;+} BoxedFreeInfo;++/* Auxiliary function for freeing boxed types in the main loop. See+ the annotation in g_object_unref_in_main_loop() below. */+static gboolean main_loop_boxed_free_helper (gpointer _info)+{+ BoxedFreeInfo *info = (BoxedFreeInfo*)_info;++ if (print_debug_info()) {+ GThread *self = g_thread_self ();+ lock_log();+ dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n",+ info->boxed, self);+ dbg_log("\tIt is of type %s\n", g_type_name(info->gtype));+ }++ g_boxed_free (info->gtype, info->boxed);++ if (print_debug_info()) {+ dbg_log("\tdone freeing %p.\n", info->boxed);+ unlock_log();+ }++ g_free(info);++ return FALSE; /* Do not invoke again */+}++void boxed_free_helper (GType gtype, void *boxed)+{+ BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo));++ info->gtype = gtype;+ info->boxed = boxed;++ g_idle_add (main_loop_boxed_free_helper, info);+}++void dbg_g_object_disown (GObject *obj)+{+ GType gtype;++ if (print_debug_info()) {+ lock_log();+ GThread *self = g_thread_self();+ dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self);+ gtype = G_TYPE_FROM_INSTANCE (obj);+ dbg_log("\tIt is of type %s\n", g_type_name(gtype));+ dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count);+ unlock_log();+ }+}++static void print_object_dbg_info (GObject *obj)+{+ GThread *self = g_thread_self();+ GType gtype;++ dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self);+ gtype = G_TYPE_FROM_INSTANCE (obj);+ dbg_log("\tIt is of type %s\n", g_type_name(gtype));+ dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count);+}++/*+ We schedule all GObject deletions to happen in the main loop. The+ reason is that for some types the destructor is not thread safe, and+ assumes that it is being run from the same thread as the main loop+ that created the object.+ */+static gboolean+g_object_unref_in_main_loop (gpointer obj)+{+ if (print_debug_info()) {+ lock_log();+ print_object_dbg_info ((GObject*)obj);+ }++ g_object_unref (obj);++ if (print_debug_info()) {+ fprintf(stderr, "\tUnref done\n");+ unlock_log();+ }++ return FALSE; /* Do not invoke again */+}++void dbg_g_object_unref (GObject *obj)+{+ g_idle_add(g_object_unref_in_main_loop, obj);+}++static gboolean gvalue_unref_in_main_loop(void *gv)+{+ g_boxed_free(G_TYPE_VALUE, gv);++ return FALSE; /* Do not invoke again */+}++void haskell_gi_gvalue_free(GValue *gv)+{+ g_idle_add(gvalue_unref_in_main_loop, gv);+}++/**+ * dbg_g_object_new:+ * @gtype: #GType for the object to construct.+ * @n_props: Number of parameters for g_object_new_with_properties().+ * @names: Names of the properties to be set.+ * @values: Parameters for g_object_new_with_properties().+ *+ * Allocate a #GObject of #GType @gtype, with the given @params. The+ * returned object is never floating, and we always own a reference to+ * it. (It might not be the only existing to the object, but it is in+ * any case safe to call g_object_unref() when we are not wrapping the+ * object ourselves anymore.)+ *+ * Returns: A new #GObject.+ */+gpointer dbg_g_object_new (GType gtype, guint n_props,+ const char *names[], const GValue values[])+{+ gpointer result;++ if (print_debug_info()) {+ GThread *self = g_thread_self();++ lock_log();+ dbg_log("Creating a new GObject of type %s [thread: %p]\n",+ g_type_name(gtype), self);+ }++#if GLIB_CHECK_VERSION(2,54,0)+ result = g_object_new_with_properties (gtype, n_props, names, values);+#else+ { GParameter params[n_props];+ int i;++ for (i=0; i<n_props; i++) {+ memcpy (¶ms[i].value, &values[i], sizeof(GValue));+ params[i].name = names[i];+ }++ result = g_object_newv (gtype, n_props, params);+ }+#endif++ /*+ Initially unowned GObjects can be either floating or not after+ construction. They are generally floating, but GtkWindow for+ instance is not floating after construction.++ In either case we want to call g_object_ref_sink(): if the object+ is floating to take ownership of the reference, and otherwise to+ add a reference that we own.++ If the object is not initially unowned we simply take control of+ the initial reference (implicitly).+ */+ if (G_IS_INITIALLY_UNOWNED (result)) {+ g_object_ref_sink (result);+ }++ if (print_debug_info()) {+ dbg_log("\tdone, got a pointer at %p\n", result);+ unlock_log();+ }++ return result;+}++/* Same as freeHaskellFunctionPtr, but it does nothing when given a+ null pointer, instead of crashing */+void safeFreeFunPtr(void *ptr)+{+ if (ptr != NULL)+ freeHaskellFunctionPtr(ptr);+}++/* Same as safeFreeFunPtr, but it accepts (but ignores) an extra argument */+void safeFreeFunPtr2(void *ptr, void *unused)+{+ safeFreeFunPtr(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;++typedef struct {+ GType gtype;+ GInterfaceInfo *info;+} CombinedInterfaceInfo;++/* 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,+ GSList* interfaces)+{+ 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);+ while (interfaces != NULL) {+ CombinedInterfaceInfo *info = (CombinedInterfaceInfo*) interfaces->data;+ g_type_add_interface_static (result, info->gtype, info->info);+ interfaces = interfaces -> next;+ }+ } 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);++ while (interfaces != NULL) {+ CombinedInterfaceInfo *info = (CombinedInterfaceInfo*) interfaces->data;+ hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_init);+ if (info -> info -> interface_finalize)+ hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_finalize);+ interfaces = interfaces -> next;+ }+ }+ pthread_mutex_unlock(>ypes_mutex);++ return result;+}++static HsStablePtr duplicateStablePtr(HsStablePtr stable_ptr)+{+ return getStablePtr(deRefStablePtr(stable_ptr));+}++GType haskell_gi_StablePtr_get_type (void)+{+ static gsize g_define_type_id = 0;++ if (g_once_init_enter (&g_define_type_id))+ {+ GType type_id =+ g_boxed_type_register_static (g_intern_static_string ("HaskellGIStablePtr"),+ duplicateStablePtr,+ hs_free_stable_ptr);++ g_once_init_leave (&g_define_type_id, type_id);+ }++ return g_define_type_id;+}++/* This is identical to haskell_gi_StablePtr_get_type, other than the+ type name. The reason for this is that we want two different types,+ to distinguish between GValues wrapping generic StablePtrs, and+ those wrapping specifically wrapping StablePtrs to Dynamic+ values. */+GType haskell_gi_HaskellValue_get_type (void)+{+ static gsize g_define_type_id = 0;++ if (g_once_init_enter (&g_define_type_id))+ {+ GType type_id =+ g_boxed_type_register_static (g_intern_static_string ("HaskellGIHaskellValue"),+ duplicateStablePtr,+ hs_free_stable_ptr);++ g_once_init_leave (&g_define_type_id, type_id);+ }++ return g_define_type_id;+}++/* A safer version of get_boxed, that checks that the GValue contains+ the right boxed type. */+gpointer haskell_gi_safe_get_boxed_haskell_value(const GValue *gv)+{+ if (G_VALUE_TYPE(gv) != haskell_gi_HaskellValue_get_type()) {+ fprintf(stderr, "Unexpected type inside the GValue: ‘%s’\n.",+ G_VALUE_TYPE_NAME(gv));++ return NULL;+ }++ return g_value_get_boxed(gv);+}++/* 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();+}++/* Check whether the given closure is floating */+gboolean+haskell_gi_g_closure_is_floating (GClosure *closure)+{+ return !!(closure->floating);+}++/* GParamSpec* types are registered as GObjects, but they do not have+ an exported type_init function. They only export CPP macros, so+ we have to provide our own. */+#define PARAM_TYPE(CamelCase, UPPERCASE) \+ GType haskell_gi_pspec_type_init_##CamelCase (void) { \+ return G_TYPE_##UPPERCASE; \+ }++PARAM_TYPE(ParamSpec, PARAM);+PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN);+PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED);+PARAM_TYPE(ParamSpecChar, PARAM_CHAR);+PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE);+PARAM_TYPE(ParamSpecEnum, PARAM_ENUM);+PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS);+PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT);+PARAM_TYPE(ParamSpecGType, PARAM_GTYPE);+PARAM_TYPE(ParamSpecInt, PARAM_INT);+PARAM_TYPE(ParamSpecInt64, PARAM_INT64);+PARAM_TYPE(ParamSpecLong, PARAM_LONG);+PARAM_TYPE(ParamSpecObject, PARAM_OBJECT);+PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE);+PARAM_TYPE(ParamSpecParam, PARAM_PARAM);+PARAM_TYPE(ParamSpecPointer, PARAM_POINTER);+PARAM_TYPE(ParamSpecString, PARAM_STRING);+PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR);+PARAM_TYPE(ParamSpecUInt, PARAM_UINT);+PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64);+PARAM_TYPE(ParamSpecULong, PARAM_ULONG);+PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR);+PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT);+/* The following is deprecated, ignore the warning that GLib raises. */+#undef GLIB_DEPRECATED_MACRO+#define GLIB_DEPRECATED_MACRO+PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY);
haskell-gi-base.cabal view
@@ -1,8 +1,8 @@ name: haskell-gi-base-version: 0.23.0+version: 0.26.9 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+homepage: https://github.com/haskell-gi/haskell-gi license: LGPL-2.1 -- or above license-file: LICENSE@@ -19,7 +19,7 @@ source-repository head type: git- location: git://github.com/haskell-gi/haskell-gi-base.git+ location: https://github.com/haskell-gi/haskell-gi.git library exposed-modules: Data.GI.Base,@@ -28,6 +28,7 @@ Data.GI.Base.BasicTypes, Data.GI.Base.CallStack, Data.GI.Base.Constructible,+ Data.GI.Base.GArray, Data.GI.Base.GError, Data.GI.Base.GClosure, Data.GI.Base.GHashTable,@@ -42,19 +43,23 @@ Data.GI.Base.Properties, Data.GI.Base.ShortPrelude, Data.GI.Base.Signals,- Data.GI.Base.Utils+ Data.GI.Base.Utils,+ Data.GI.Base.DynVal,+ Data.GI.Base.Internal.CTypes+ Data.GI.Base.Internal.PathFieldAccess pkgconfig-depends: gobject-2.0 >= 2.42, glib-2.0- build-depends: base >= 4.9 && < 5,+ build-depends: base >= 4.11 && < 5, bytestring, containers,- text >= 1.0+ text >= 1.0,+ optics-core >= 0.4 - ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns+ ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat -Wno-unticked-promoted-constructors - build-tools: hsc2hs+ build-tool-depends: hsc2hs:hsc2hs cc-options: -fPIC default-language: Haskell2010 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds other-extensions: TypeApplications, ScopedTypeVariables- c-sources: c/hsgclosure.c+ c-sources: csrc/hsgclosure.c