haskell-gi-base 0.25.0 → 0.26.9
raw patch · 25 files changed
Files
- ChangeLog.md +8/−0
- Data/GI/Base.hs +2/−1
- Data/GI/Base/Attributes.hs +226/−12
- Data/GI/Base/BasicConversions.hsc +1/−2
- Data/GI/Base/BasicTypes.hsc +22/−14
- Data/GI/Base/Constructible.hs +1/−1
- Data/GI/Base/DynVal.hs +144/−0
- Data/GI/Base/GError.hs +1/−3
- Data/GI/Base/GHashTable.hsc +14/−11
- Data/GI/Base/GObject.hsc +134/−20
- Data/GI/Base/GParamSpec.hsc +47/−2
- Data/GI/Base/GType.hsc +17/−3
- Data/GI/Base/GValue.hs +113/−18
- Data/GI/Base/GVariant.hsc +51/−47
- Data/GI/Base/Internal/PathFieldAccess.hs +76/−0
- Data/GI/Base/ManagedPtr.hs +15/−4
- Data/GI/Base/Overloading.hs +30/−28
- Data/GI/Base/Overloading.hs-boot +1/−1
- Data/GI/Base/Properties.hsc +17/−0
- Data/GI/Base/ShortPrelude.hs +6/−0
- Data/GI/Base/Signals.hs +91/−26
- Data/GI/Base/Signals.hs-boot +23/−4
- c/hsgclosure.c +0/−410
- csrc/hsgclosure.c +477/−0
- haskell-gi-base.cabal +9/−6
ChangeLog.md view
@@ -1,3 +1,11 @@+### 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.
Data/GI/Base.hs view
@@ -29,5 +29,6 @@ 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 #-} -- | --@@ -143,27 +155,43 @@ set, clear, - AttrLabelProxy(..)+ AttrLabelProxy(..),++ resolveAttr,+ bindPropToField,++ EqMaybe(..) ) where -import Control.Monad (void)+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)+import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..),+ SignalProxy,+ on, after, connectGObjectNotify,+ SignalConnectMode(..)) -import Data.Proxy (Proxy(..)) 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@@ -269,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@@ -330,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@@ -355,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@@ -364,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@.@@ -439,10 +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 -> HaskellCallbackType info -> AttrOp obj tag+ 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@@ -466,7 +595,28 @@ 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@.@@ -495,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
Data/GI/Base/BasicTypes.hsc view
@@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,- DeriveDataTypeable, TypeFamilies, ScopedTypeVariables,+ TypeFamilies, ScopedTypeVariables, MultiParamTypeClasses, DataKinds, TypeOperators, UndecidableInstances, AllowAmbiguousTypes #-} @@ -39,6 +39,9 @@ , PtrWrapped(..) , GDestroyNotify++ , GHashFunc+ , GEqualFunc ) where import Control.Exception (Exception)@@ -46,15 +49,15 @@ import Data.Coerce (coerce, Coercible) import Data.IORef (IORef) 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> @@ -159,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@.@@ -179,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 ::@@ -211,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/GError.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies, DataKinds #-} -- | To catch GError exceptions use the@@ -65,7 +65,6 @@ import Control.Exception import Data.Text (Text) import qualified Data.Text as T-import Data.Typeable (Typeable) import System.IO.Unsafe (unsafePerformIO) @@ -83,7 +82,6 @@ -- 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
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,17 +37,18 @@ , gobjectInstallProperty , gobjectInstallCIntProperty , gobjectInstallCStringProperty+ , gobjectInstallGBooleanProperty ) where import Data.Maybe (catMaybes)-import Control.Monad (void)+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)-import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr)+import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, nullFunPtr) import Foreign.StablePtr (newStablePtr, deRefStablePtr, castStablePtrToPtr, castPtrToStablePtr) import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf))@@ -57,19 +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(..), TypedObject(glibType),- gtypeName)-import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+ 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)@@ -77,8 +86,9 @@ import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject, newObject) import Data.GI.Base.Overloading (ResolveAttribute)-import Data.GI.Base.Signals (on)-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> @@ -96,6 +106,7 @@ props <- catMaybes <$> mapM construct attrs obj <- doConstructGObject constructor props mapM_ (setSignal obj) attrs+ mapM_ (registerHandlers obj) attrs return obj where construct :: AttrOp o 'AttrConstruct ->@@ -110,22 +121,65 @@ (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) =>+new' :: (HasCallStack, MonadIO m, GObject o) => (ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o new' constructor actions = do 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@@ -185,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)@@ -202,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@@ -255,7 +328,11 @@ classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o) instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o) (GType parentCGType) <- glibType @(GObjectParentType o)- GType <$> register_gtype parentCGType cTypeName classInit instanceInit+ 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)) ->@@ -296,6 +373,35 @@ <> 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"@@ -331,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@@ -407,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,8 @@ , gParamSpecCString , CIntPropertyInfo(..) , gParamSpecCInt+ , GBooleanPropertyInfo(..)+ , gParamSpecGBoolean , GParamFlag(..) -- * Get\/Set@@ -33,6 +35,7 @@ castStablePtrToPtr, castPtrToStablePtr) import Control.Monad (void) import Data.Coerce (coerce)+import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -154,7 +157,7 @@ value <- objectFromPtr objPtr >>= getter gvalueSetter destPtr value , propSetter = \objPtr newGValuePtr ->- withTransient GValue newGValuePtr $ \newGValue -> do+ withTransient newGValuePtr $ \newGValue -> do obj <- objectFromPtr objPtr value <- GV.fromGValue newGValue setter obj value@@ -215,7 +218,7 @@ 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 <- GV.fromGValue gv >>= deRefStablePtr setter obj val@@ -316,6 +319,48 @@ withTextCString value $ \cdefault -> g_param_spec_string cname cnick cblurb cdefault (maybe defaultFlags gflagsToWord flags)+ quark <- pspecQuark+ 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
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
@@ -13,6 +13,7 @@ , toGValue , fromGValue , GValueConstruct(..)+ , ptr_to_gvalue_free , newGValue , buildGValue@@ -28,6 +29,9 @@ , unpackGValueArrayWithLength , mapGValueArrayWithLength + -- * Packing Haskell values into GValues+ , HValue(..)+ -- * Setters and getters , set_object , get_object@@ -42,9 +46,14 @@ , 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@@ -53,32 +62,36 @@ import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..), CLong(..), CULong(..)) import Foreign.C.String (CString)-import Foreign.Ptr (Ptr, nullPtr, plusPtr)-import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr)+import 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.Overloading (HasParentTypes, ParentTypes) 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 convenience alias for @`Nothing` :: `Maybe` `GValue`@.-noGValue :: Maybe GValue-noGValue = Nothing--foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::- IO GType+-- | 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@@ -138,6 +151,10 @@ 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@@ -152,8 +169,8 @@ -- the `GValue`. -- | Create a `GValue` from the given Haskell value.-toGValue :: forall a. IsGValue a => a -> IO GValue-toGValue val = do+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@@ -162,8 +179,8 @@ return $! gv -- | Create a Haskell object out of the given `GValue`.-fromGValue :: IsGValue a => GValue -> IO a-fromGValue gv = withManagedPtr gv gvalueGet_+fromGValue :: (IsGValue a, MonadIO m) => GValue -> m a+fromGValue gv = liftIO $ withManagedPtr gv gvalueGet_ instance IsGValue (Maybe String) where gvalueGType_ = return gtypeString@@ -245,6 +262,16 @@ 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 ::@@ -371,6 +398,8 @@ 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 ()@@ -391,15 +420,17 @@ 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 -> StablePtr a -> IO ()+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 = g_value_take_boxed+take_stablePtr gvPtr stablePtr =+ g_value_take_boxed gvPtr (castStablePtrToPtr stablePtr) --- | Get the value of a `GValue` containing a `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 <$> get_boxed gv+get_stablePtr gv = castPtrToStablePtr <$> dup_boxed gv foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO () @@ -444,3 +475,67 @@ 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/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/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@@ -166,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@@ -286,6 +287,16 @@ void $ g_object_ref_sink ptr 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) =>
Data/GI/Base/Overloading.hs view
@@ -33,7 +33,8 @@ , OverloadedMethodInfo(..) , OverloadedMethod(..) , MethodProxy(..)- , MethodInfo(..)++ , ResolvedSymbolInfo(..) , resolveMethod ) where @@ -57,6 +58,22 @@ 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 :: Type) (as :: [Type]) :: Constraint where@@ -74,22 +91,6 @@ 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 :: [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- -- | Safe coercions to a parent class. For instance: -- -- > #show $ label `asA` Gtk.Widget@@ -191,22 +192,23 @@ class OverloadedMethod i o s where overloadedMethod :: o -> s -- ^ The actual method being invoked. --- | Information about the method that will be invoked, for debugging+-- | Information about a fully resolved symbol, for debugging -- purposes.-data MethodInfo = MethodInfo { overloadedMethodName :: Text- , overloadedMethodURL :: Text- }+data ResolvedSymbolInfo = ResolvedSymbolInfo {+ resolvedSymbolName :: Text+ , resolvedSymbolURL :: Text+ } -instance Show MethodInfo where+instance Show ResolvedSymbolInfo where -- Format as a hyperlink on modern terminals (older -- terminals should ignore the hyperlink part).- show info = T.unpack ("\ESC]8;;" <> overloadedMethodURL info- <> "\ESC\\" <> overloadedMethodName info+ 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 :: MethodInfo+ overloadedMethodInfo :: Maybe ResolvedSymbolInfo -- | A proxy for carrying the types `MethodInfoName` needs (this is used -- for `resolveMethod`, see below).@@ -215,7 +217,7 @@ -- | Return the fully qualified method name that a given overloaded -- method call resolves to (mostly useful for debugging). ----- > resolveMethod #show widget+-- > resolveMethod widget #show resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) =>- MethodProxy info obj -> obj -> MethodInfo-resolveMethod _p _o = 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
@@ -29,6 +29,7 @@ , setObjectPropertyCallback , setObjectPropertyGError , setObjectPropertyGValue+ , setObjectPropertyParamSpec , getObjectPropertyIsGValueInstance , getObjectPropertyString@@ -58,6 +59,7 @@ , getObjectPropertyCallback , getObjectPropertyGError , getObjectPropertyGValue+ , getObjectPropertyParamSpec , constructObjectPropertyIsGValueInstance , constructObjectPropertyString@@ -87,6 +89,7 @@ , constructObjectPropertyCallback , constructObjectPropertyGError , constructObjectPropertyGValue+ , constructObjectPropertyParamSpec ) where #if !MIN_VERSION_base(4,8,0)@@ -589,3 +592,17 @@ 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
@@ -13,10 +13,12 @@ {-# 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://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.+-- <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 --@@ -51,6 +53,8 @@ , SignalInfo(..) , GObjectNotifySignalInfo , SignalCodeGenError+ , resolveSignal+ , connectGObjectNotify ) where import Control.Monad.IO.Class (MonadIO, liftIO)@@ -71,12 +75,15 @@ import qualified Data.Text as T import Data.Text (Text) -import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel))+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)-import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute)+import Data.GI.Base.ManagedPtr (withManagedPtr, withTransient)+import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute,+ ResolvedSymbolInfo) import GHC.OverloadedLabels (IsLabel(..)) @@ -95,6 +102,16 @@ 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) =>@@ -107,18 +124,25 @@ -- | 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.- connectSignal :: GObject o =>- o ->- HaskellCallbackType info ->- SignalConnectMode ->- Maybe Text ->- IO SignalHandlerId+ -- | 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.@@ -128,17 +152,43 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info- -> HaskellCallbackType info -> m SignalHandlerId+ -> ((?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 c SignalConnectBefore (proxyDetail p)+ 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- -> HaskellCallbackType info -> m SignalHandlerId+ -> ((?self :: object) => HaskellCallbackType info)+ -> m SignalHandlerId after o p c =- liftIO $ connectSignal @info o c SignalConnectAfter (proxyDetail p)+ 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@@ -147,6 +197,8 @@ (_ ::: 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 ::@@ -196,20 +248,20 @@ -- | Type for a `GObject` "notify" callback. type GObjectNotifyCallback = GParamSpec -> IO () -gobjectNotifyCallbackWrapper ::- GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()-gobjectNotifyCallbackWrapper _cb _ pspec _ = do+gobjectNotifyCallbackWrapper :: GObject o =>+ (o -> GObjectNotifyCallback) -> GObjectNotifyCallbackC o+gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do pspec' <- newGParamSpecFromPtr pspec- _cb pspec'+ withTransient (castPtr selfPtr) $ \self -> cb self pspec' -type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()+type GObjectNotifyCallbackC o = Ptr o -> Ptr GParamSpec -> Ptr () -> IO () foreign import ccall "wrapper"- mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)+ mkGObjectNotifyCallback :: GObjectNotifyCallbackC o -> IO (FunPtr (GObjectNotifyCallbackC o)) -- | Connect the given notify callback for a GObject. connectGObjectNotify :: GObject o =>- o -> GObjectNotifyCallback ->+ o -> (o -> GObjectNotifyCallback) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId@@ -217,6 +269,11 @@ 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@@ -225,3 +282,11 @@ ':<>: '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
@@ -3,10 +3,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-} -module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on) where+module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after,+ connectGObjectNotify, SignalConnectMode(..)) where -import Data.GI.Base.BasicTypes (GObject)+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)@@ -18,10 +22,12 @@ type HaskellCallbackType info connectSignal :: GObject o => o ->- HaskellCallbackType info ->+ (o -> HaskellCallbackType info) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId+ dbgSignalInfo :: Maybe ResolvedSymbolInfo+ dbgSignalInfo = Nothing type role SignalProxy nominal nominal data SignalProxy object info where@@ -31,4 +37,17 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info- -> HaskellCallbackType info -> m SignalHandlerId+ -> ((?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
− c/hsgclosure.c
@@ -1,410 +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;-}--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);-}--/**- * 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;--/* 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);-}--/* 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);
+ 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,5 +1,5 @@ name: haskell-gi-base-version: 0.25.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@@ -19,7 +19,7 @@ source-repository head type: git- location: git://github.com/haskell-gi/haskell-gi.git+ location: https://github.com/haskell-gi/haskell-gi.git library exposed-modules: Data.GI.Base,@@ -44,19 +44,22 @@ Data.GI.Base.ShortPrelude, Data.GI.Base.Signals, 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-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