packages feed

haskell-gi-base 0.21.5 → 0.26.9

raw patch · 35 files changed

Files

ChangeLog.md view
@@ -1,3 +1,45 @@+### 0.24.8+++ Make the StablePtr IsGValue instance make a copy in fromGValue.++### 0.24.7+++ Add a mechanism for marshalling generic Haskell values into `GValue`s.++### 0.24.4+++ Add a workaround for old hsc2hs versions, so drop the constraint on hsc2hs.++### 0.24.3+++ Require hsc2hs version 0.68.6 or higher++### 0.24.2+++ Provide type init functions for GParamSpec types.++### 0.24.1+++ Support for allocating `GArray`s.++### 0.24.0+++ Support for non-GObject objects. As part of this work the GObject hierarchy has been slightly reworked. The main change is that 'gobjectType' has now become [glibType](https://hackage.haskell.org/package/haskell-gi-base-0.24.0/docs/Data-GI-Base-BasicTypes.html#v:glibType) (part of the [TypedObject](https://hackage.haskell.org/package/haskell-gi-base-0.24.0/docs/Data-GI-Base-BasicTypes.html#t:TypedObject) typeclass).++### 0.22.2+++ Reinstate the new' method.++### 0.22.1+++ Fix a memory allocation error in [GClosure](https://hackage.haskell.org/package/haskell-gi-base-0.22.0/docs/Data-GI-Base.html#t:GClosure) that could lead to crashes.++### 0.22.0+++ Require base >= 0.4.9 (GHC version >= 8.0), so that we can use TypeApplications.+++ Make [GClosure](https://hackage.haskell.org/package/haskell-gi-base-0.22.0/docs/Data-GI-Base.html#t:GClosure) a primitive type, and make it depend on a phantom parameter to increase type safety.+ ### 0.21.5  + Add [releaseObject](https://hackage.haskell.org/package/haskell-gi-base-0.21.5/docs/Data-GI-Base-ManagedPtr.html#v:releaseObject), a function useful for manually releasing memory associated to GObjects.
Data/GI/Base.hs view
@@ -8,26 +8,27 @@     ( module Data.GI.Base.Attributes     , module Data.GI.Base.BasicConversions     , module Data.GI.Base.BasicTypes-    , module Data.GI.Base.Closure+    , module Data.GI.Base.GClosure     , module Data.GI.Base.Constructible     , module Data.GI.Base.GError     , module Data.GI.Base.GHashTable-    , module Data.GI.Base.GObject     , module Data.GI.Base.GValue     , module Data.GI.Base.GVariant     , module Data.GI.Base.ManagedPtr     , module Data.GI.Base.Signals+    , module Data.GI.Base.Overloading     ) where  import Data.GI.Base.Attributes (get, set, AttrOp(..)) import Data.GI.Base.BasicConversions import Data.GI.Base.BasicTypes-import Data.GI.Base.Closure+import Data.GI.Base.GClosure (GClosure) import Data.GI.Base.Constructible (new) import Data.GI.Base.GError import Data.GI.Base.GHashTable-import Data.GI.Base.GObject (new')-import Data.GI.Base.GValue (GValue(..), IsGValue(..))+import Data.GI.Base.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,6 +1,19 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,-  TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,-  UndecidableInstances, FlexibleInstances #-}+{-# 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 #-}  -- | --@@ -95,7 +108,7 @@ -- 'IO' monad rather than being pure. -- -- Attributes can also be set during construction of a--- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.new`+-- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Constructible.new` -- -- > button <- new Button [_label := "Can't touch this!", _sensitive := False] --@@ -105,7 +118,7 @@ -- `set` afterwards. That these invariants hold is also checked during -- compile time. ----- == Nullable atributes+-- == Nullable attributes -- -- Whenever the attribute is represented as a pointer in the C side, -- it is often the case that the underlying C representation admits or@@ -114,7 +127,7 @@ -- representing the @NULL@ pointer value (notable exceptions are -- `Data.GI.Base.BasicTypes.GList` and -- `Data.GI.Base.BasicTypes.GSList`, for which @NULL@ is represented--- simply as he empty list). This can be overriden in the+-- simply as the empty list). This can be overridden in the -- introspection data, since sometimes attributes are non-nullable, -- even if the type would allow for @NULL@. --@@ -142,81 +155,170 @@   set,   clear, -  AttrLabelProxy(..)+  AttrLabelProxy(..),++  resolveAttr,+  bindPropToField,++  EqMaybe(..)   ) where +import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Proxy (Proxy(..))-+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, IsLabelProxy(..))+import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute,+                                 ResolvedSymbolInfo)+import Data.GI.Base.Internal.PathFieldAccess (PathFieldAccess(..), Components) -import GHC.TypeLits+import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..),+                                            SignalProxy,+                                            on, after, connectGObjectNotify,+                                            SignalConnectMode(..))++import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T++import GHC.TypeLits (Symbol, KnownSymbol, ErrorMessage(..), TypeError,+                     symbolVal) import GHC.Exts (Constraint) -#if MIN_VERSION_base(4,9,0) import GHC.OverloadedLabels (IsLabel(..))-#endif+import qualified Optics.Core as O -infixr 0 :=,:~,:=>,:~>+infixr 0 :=,:~,:=>,:~>,:<~,:!<~  -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy --- | Support for overloaded labels.-instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where-    fromLabelProxy _ = AttrLabelProxy- #if MIN_VERSION_base(4,10,0) instance a ~ x => IsLabel x (AttrLabelProxy a) where     fromLabel = AttrLabelProxy-#elif MIN_VERSION_base(4,9,0)+#else instance a ~ x => IsLabel x (AttrLabelProxy a) where     fromLabel _ = AttrLabelProxy #endif  -- | Info describing an attribute.-class AttrInfo (info :: *) where+class AttrInfo (info :: Type) where     -- | The operations that are allowed on the attribute.     type AttrAllowedOps info :: [AttrOpTag]-    -- | Constraint on the value being set.-    type AttrSetTypeConstraint info :: * -> Constraint+     -- | Constraint on the type for which we are allowed to     -- create\/set\/get the attribute.-    type AttrBaseTypeConstraint info :: * -> Constraint+    type AttrBaseTypeConstraint info :: Type -> Constraint+     -- | Type returned by `attrGet`.     type AttrGetType info++    -- | Constraint on the value being set.+    type AttrSetTypeConstraint info :: Type -> Constraint+    type AttrSetTypeConstraint info = (~) (AttrGetType info)++    -- | Constraint on the value being set, with allocation allowed+    -- (see ':&=' below).+    type AttrTransferTypeConstraint info :: Type -> Constraint+    type AttrTransferTypeConstraint info = (~) (AttrTransferType info)++    -- | Type resulting from the allocation.+    type AttrTransferType info :: Type+    type AttrTransferType info = AttrGetType info+     -- | Name of the attribute.     type AttrLabel info :: Symbol+     -- | Type which introduces the attribute.     type AttrOrigin info+     -- | Get the value of the given attribute.     attrGet :: AttrBaseTypeConstraint info o =>-               Proxy info -> o -> IO (AttrGetType info)+               o -> IO (AttrGetType info)+    default attrGet :: -- Make sure that a non-default method+                       -- implementation is provided if AttrGet+                       -- is set.+                        CheckNotElem 'AttrGet (AttrAllowedOps info)+                         (GetNotProvidedError info) =>+                       o -> IO (AttrGetType info)+    attrGet = undefined+     -- | Set the value of the given attribute, after the object having     -- the attribute has already been created.     attrSet :: (AttrBaseTypeConstraint info o,                 AttrSetTypeConstraint info b) =>-               Proxy info -> o -> b -> IO ()+               o -> b -> IO ()+    default attrSet :: -- Make sure that a non-default method+                        -- implementation is provided if AttrSet+                        -- is set.+                        CheckNotElem 'AttrSet (AttrAllowedOps info)+                         (SetNotProvidedError info) =>+                       o -> b -> IO ()+    attrSet = undefined+     -- | Set the value of the given attribute to @NULL@ (for nullable     -- attributes).     attrClear :: AttrBaseTypeConstraint info o =>-                 Proxy info -> o -> IO ()-    -- | Build a `GValue` representing the attribute.+                 o -> IO ()+    default attrClear ::  -- Make sure that a non-default method+                          -- implementation is provided if AttrClear+                          -- is set.+                          CheckNotElem 'AttrClear (AttrAllowedOps info)+                                       (ClearNotProvidedError info) =>+                      o -> IO ()+    attrClear = undefined++    -- | Build a `Data.GI.Base.GValue.GValue` representing the attribute.     attrConstruct :: (AttrBaseTypeConstraint info o,                       AttrSetTypeConstraint info b) =>-                     Proxy info -> b -> IO (GValueConstruct o)+                     b -> IO (GValueConstruct o)+    default attrConstruct :: -- Make sure that a non-default method+                             -- implementation is provided if AttrConstruct+                             -- is set.+                             CheckNotElem 'AttrConstruct (AttrAllowedOps info)+                               (ConstructNotProvidedError info) =>+                      b -> IO (GValueConstruct o)+    attrConstruct = undefined --- | Result of checking whether an op is allowed on an attribute.-data OpAllowed tag attrName definingType useType =-    OpIsAllowed-#if !MIN_VERSION_base(4,9,0)-        | AttrOpNotAllowed Symbol tag Symbol definingType Symbol attrName-#endif+    -- | Allocate memory as necessary to generate a settable type from+    -- the transfer type. This is useful for types which needs+    -- allocations for marshalling from Haskell to C, this makes the+    -- allocation explicit.+    attrTransfer :: forall o b. (AttrBaseTypeConstraint info o,+                               AttrTransferTypeConstraint info b) =>+                    Proxy o -> b -> IO (AttrTransferType info)+    default attrTransfer :: forall o b. (AttrBaseTypeConstraint info o,+                             AttrTransferTypeConstraint info b,+                             b ~ AttrGetType info,+                             b ~ AttrTransferType info) =>+                            Proxy o -> b -> IO (AttrTransferType info)+    attrTransfer _ = return -#if MIN_VERSION_base(4,9,0)+    -- | 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     TypeOriginInfo definingType definingType =         'Text "‘" ':<>: 'ShowType definingType ':<>: 'Text "’"@@ -224,35 +326,93 @@         'Text "‘" ':<>: 'ShowType useType ':<>:         'Text "’ (inherited from parent type ‘" ':<>:         'ShowType definingType ':<>: 'Text "’)"-#endif  -- | Look in the given list to see if the given `AttrOp` is a member, -- if not return an error type.-type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: *) (useType :: *) :: OpAllowed AttrOpTag Symbol * * where+type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: Type) (useType :: Type) :: Constraint where     AttrOpIsAllowed tag '[] label definingType useType =-#if !MIN_VERSION_base(4,9,0)-        'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute " definingType "." label-#else         TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>:                    'Text "’ for type " ':<>:                    TypeOriginInfo definingType useType ':<>:                    'Text " is not " ':<>:                    'Text (AttrOpText tag) ':<>: 'Text ".")-#endif-    AttrOpIsAllowed tag (tag ': ops) label definingType useType = 'OpIsAllowed+    AttrOpIsAllowed tag (tag ': ops) label definingType useType = ()     AttrOpIsAllowed tag (other ': ops) label definingType useType = AttrOpIsAllowed tag ops label definingType useType  -- | Whether a given `AttrOpTag` is allowed on an attribute, given the -- info type.-type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) (useType :: *) :: Constraint where+type family AttrOpAllowed (tag :: AttrOpTag) (info :: Type) (useType :: Type) :: Constraint where     AttrOpAllowed tag info useType =-        AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) (AttrOrigin info) useType ~ 'OpIsAllowed+        AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) (AttrOrigin info) useType +-- | Error to be raised when an operation is allowed, but an+-- implementation has not been provided.+type family OpNotProvidedError (info :: o) (op :: AttrOpTag) (methodName :: Symbol) :: ErrorMessage where+  OpNotProvidedError info op methodName =+    'Text "The attribute ‘" ':<>: 'Text (AttrLabel info) ':<>:+    'Text "’ for type ‘" ':<>:+    'ShowType (AttrOrigin info) ':<>:+    'Text "’ is declared as " ':<>:+    'Text (AttrOpText op) ':<>:+    'Text ", but no implementation of ‘" ':<>:+    'Text methodName ':<>:+    'Text "’ has been provided."+    ':$$: 'Text "Either provide an implementation of ‘" ':<>:+    'Text methodName ':<>:+    'Text "’ or remove ‘" ':<>:+    'ShowType op ':<>:+    'Text "’ from ‘AttrAllowedOps’."++-- | Error to be raised when AttrClear is allowed, but an+-- implementation has not been provided.+type family ClearNotProvidedError (info :: o) :: ErrorMessage where+  ClearNotProvidedError info = OpNotProvidedError info 'AttrClear "attrClear"++-- | Error to be raised when AttrGet is allowed, but an+-- implementation has not been provided.+type family GetNotProvidedError (info :: o) :: ErrorMessage where+  GetNotProvidedError info = OpNotProvidedError info 'AttrGet "attrGet"++-- | Error to be raised when AttrSet is allowed, but an+-- implementation has not been provided.+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+  ConstructNotProvidedError info = OpNotProvidedError info 'AttrConstruct "attrConstruct"++-- | Check if the given element is a member, and if so raise the given+-- error.+type family CheckNotElem (a :: k) (as :: [k]) (msg :: ErrorMessage) :: Constraint where+  CheckNotElem a '[] msg = ()+  CheckNotElem a (a ': rest) msg = TypeError msg+  CheckNotElem a (other ': rest) msg = CheckNotElem a rest msg+ -- | Possible operations on an attribute.-data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear+data AttrOpTag = AttrGet+               -- ^ It is possible to read the value of the attribute+               -- with `get`.+               | AttrSet+               -- ^ It is possible to write the value of the attribute+               -- with `set`.+               | AttrConstruct+               -- ^ It is possible to set the value of the attribute+               -- in `Data.GI.Base.Constructible.new`.+               | 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) -#if MIN_VERSION_base(4,9,0) -- | A user friendly description of the `AttrOpTag`, useful when -- printing type errors. type family AttrOpText (tag :: AttrOpTag) :: Symbol where@@ -260,7 +420,7 @@     AttrOpText 'AttrSet = "settable"     AttrOpText 'AttrConstruct = "constructible"     AttrOpText 'AttrClear = "nullable"-#endif+    AttrOpText 'AttrPut = "puttable"  -- | Constraint on a @obj@\/@attr@ pair so that `set` works on values -- of type @value@.@@ -271,8 +431,8 @@                                      AttrOpAllowed 'AttrSet info obj,                                      (AttrSetTypeConstraint info) value) --- | Constraint on a @obj@\/@value@ pair so that `new` works on values--- of type @@value@.+-- | Constraint on a @obj@\/@value@ pair so that+-- `Data.GI.Base.Constructible.new` works on values of type @value@. type AttrConstructC info obj attr value = (HasAttributeList obj,                                            info ~ ResolveAttribute attr obj,                                            AttrInfo info,@@ -320,22 +480,144 @@               (AttrSetTypeConstraint info) b,               a ~ (AttrGetType info)) =>              AttrLabelProxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag+    -- | Assign a value to an attribute, allocating any necessary+    -- memory for representing the Haskell value as a C value. Note+    -- that it is the responsibility of the caller to make sure that+    -- the memory is freed when no longer used, otherwise there will+    -- be a memory leak. In the majority of cases you probably want to+    -- use ':=' instead, which has no potential memory leaks (at the+    -- cost of sometimes requiring some explicit Haskell -> C+    -- marshalling).+    (:&=) :: (HasAttributeList obj,+              info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              AttrOpAllowed tag info obj,+              (AttrTransferTypeConstraint info) b,+              AttrSetTypeConstraint info (AttrTransferType info)) =>+             AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag+    -- | Bind a property to the given `DynVal`, so that the property+    -- is changed whenever the `DynVal` is. This requires the implicit+    -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@ to be set.+    (:!<~) :: (HasAttributeList obj,+              info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              AttrOpAllowed tag info obj,+              (AttrSetTypeConstraint info) b,+              ?_haskell_gi_modelProxy :: ModelProxy model+             ) =>+             AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj ta+    -- | Bind a property to the given `DynVal`, so that the property+    -- is changed whenever the `DynVal` is. This requires the implicit+    -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@+    -- to be set. This will only actually set the property whenever+    -- the `DynVal` changes if the new value of the `DynVal` is+    -- different from the actual value of the property. If you want to+    -- set the property without checking equality you can use `:!<~`+    -- instead.+    (:<~) :: (HasAttributeList obj,+              info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              AttrOpAllowed tag info obj,+              (AttrSetTypeConstraint info) b,+              AttrOpAllowed 'AttrGet info obj,+              EqMaybe b (AttrGetType info),+              ?_haskell_gi_modelProxy :: ModelProxy model+             ) =>+             AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj tag+    -- | Given an AttrLabelProxy, bind the given attribute to the+    -- corresponding field in the model proxy (if there's one), so+    -- that changes in the attribute are reflected back into changes+    -- of the model.+    Bind :: (HasAttributeList obj,+             GObject obj,+             info ~ ResolveAttribute propName obj,+             AttrInfo info,+             KnownSymbol (AttrLabel info),+             AttrBaseTypeConstraint info obj,+             AttrOpAllowed tag info obj,+             AttrOpAllowed 'AttrPut info obj,+             ?_haskell_gi_modelProxy :: ModelProxy model,+             outType ~ AttrGetType info,+             (AttrSetTypeConstraint info) outType,+             components ~ Components fieldName,+             PathFieldAccess components model outType,+             KnownSymbol fieldName,+             Eq outType+            ) =>+            AttrLabelProxy (propName :: Symbol) ->+            AttrLabelProxy (fieldName :: Symbol) ->+            AttrOp obj tag +    -- | Connect the given signal to a signal handler.+    On    :: (GObject obj, SignalInfo info) =>+             SignalProxy obj info+          -> ((?self :: obj) => HaskellCallbackType info)+          -> AttrOp obj tag+    -- | Like 'On', but connect after the default signal.+    After :: (GObject obj, SignalInfo info) =>+             SignalProxy obj info+          -> ((?self :: obj) => HaskellCallbackType info)+          -> AttrOp obj tag++class EqMaybe a b where+  eqMaybe :: a -> b -> Bool++instance Eq a => EqMaybe a a where+  eqMaybe x y = x == y++instance Eq a => EqMaybe a (Maybe a) where+  eqMaybe _ Nothing = False+  eqMaybe x (Just y) = x == y+ -- | Set a number of properties for some object. set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m () set obj = liftIO . mapM_ app  where-   resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)-   resolve _ = Proxy-    app :: AttrOp o 'AttrSet -> IO ()-   app (attr :=  x) = attrSet (resolve attr) obj x-   app (attr :=> x) = x >>= attrSet (resolve attr) obj-   app (attr :~  f) = attrGet (resolve attr) obj >>=-                      \v -> attrSet (resolve attr) obj (f v)-   app (attr :~> f) = attrGet (resolve attr) obj >>= f >>=-                      attrSet (resolve attr) obj+   app ((_attr :: AttrLabelProxy label) :=  x) =+     attrSet @(ResolveAttribute label o) obj x +   app ((_attr :: AttrLabelProxy label) :=> x) =+     x >>= attrSet @(ResolveAttribute label o) obj++   app ((_attr :: AttrLabelProxy label) :~  f) =+     attrGet @(ResolveAttribute label o) obj >>=+     \v -> attrSet @(ResolveAttribute label o) obj (f v)++   app ((_attr :: AttrLabelProxy label) :~> f) =+     attrGet @(ResolveAttribute label o) obj >>= f >>=+     attrSet @(ResolveAttribute label o) obj++   app ((_attr :: AttrLabelProxy label) :&= x) =+     attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>=+     attrSet @(ResolveAttribute label o) obj++   app ((_attr :: AttrLabelProxy label) :!<~ dv) = do+     model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+     attrSet @(ResolveAttribute label o) obj (dvRead dv model)+     modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel ->+       attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel)++   app ((_attr :: AttrLabelProxy label) :<~ dv) = do+     model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+     currentValue <- attrGet @(ResolveAttribute label o) obj+     let newValue = dvRead dv model+     when (not $ newValue `eqMaybe` currentValue) $ do+       attrSet @(ResolveAttribute label o) obj newValue+     modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do+       current <- attrGet @(ResolveAttribute label o) obj+       let modifiedValue = dvRead dv modifiedModel+       when (not $ modifiedValue `eqMaybe` current) $+         attrSet @(ResolveAttribute label o) obj modifiedValue++   app (Bind pattr fattr) = bindPropToField (Proxy @'AttrSet) obj pattr fattr++   app (On signal callback) = void $ on obj signal callback+   app (After signal callback) = void $ after obj signal callback+ -- | Constraints on a @obj@\/@attr@ pair so `get` is possible, -- producing a value of type @result@. type AttrGetC info obj attr result = (HasAttributeList obj,@@ -349,7 +631,7 @@ get :: forall info attr obj result m.        (AttrGetC info obj attr result, MonadIO m) =>         obj -> AttrLabelProxy (attr :: Symbol) -> m result-get o _ = liftIO $ attrGet (Proxy :: Proxy info) o+get o _ = liftIO $ attrGet @info o  -- | Constraint on a @obj@\/@attr@ pair so that `clear` is allowed. type AttrClearC info obj attr = (HasAttributeList obj,@@ -362,4 +644,68 @@ clear :: forall info attr obj m.          (AttrClearC info obj attr, MonadIO m) =>          obj -> AttrLabelProxy (attr :: Symbol) -> m ()-clear o _ = liftIO $ attrClear (Proxy :: Proxy info) o+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)@@ -115,11 +114,11 @@ foreign import ccall "g_list_prepend" g_list_prepend ::     Ptr (GList (Ptr a)) -> Ptr a -> IO (Ptr (GList (Ptr a))) --- Given a Haskell list of items, construct a GList with those values.+-- | Given a Haskell list of items, construct a GList with those values. packGList   :: [Ptr a] -> IO (Ptr (GList (Ptr a))) packGList l = foldM g_list_prepend nullPtr $ reverse l --- Given a GSList construct the corresponding Haskell list.+-- | Given a GSList construct the corresponding Haskell list. unpackGList   :: Ptr (GList (Ptr a)) -> IO [Ptr a] unpackGList gsl     | gsl == nullPtr = return []@@ -134,11 +133,11 @@ foreign import ccall "g_slist_prepend" g_slist_prepend ::     Ptr (GSList (Ptr a)) -> Ptr a -> IO (Ptr (GSList (Ptr a))) --- Given a Haskell list of items, construct a GSList with those values.+-- | Given a Haskell list of items, construct a GSList with those values. packGSList   :: [Ptr a] -> IO (Ptr (GSList (Ptr a))) packGSList l = foldM g_slist_prepend nullPtr $ reverse l --- Given a GSList construct the corresponding Haskell list.+-- | Given a GSList construct the corresponding Haskell list. unpackGSList   :: Ptr (GSList (Ptr a)) -> IO [Ptr a] unpackGSList gsl = unpackGList (castPtr gsl) @@ -169,7 +168,7 @@   dataPtr <- peek (castPtr array :: Ptr (Ptr a))   nitems <- peek (array `plusPtr` sizeOf dataPtr)   go dataPtr nitems-    where go :: Ptr a -> Int -> IO [a]+    where go :: Ptr a -> CUInt -> IO [a]           go _ 0 = return []           go ptr n = do             x <- peek ptr@@ -201,7 +200,7 @@   dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a)))   nitems <- peek (array `plusPtr` sizeOf dataPtr)   go dataPtr nitems-    where go :: Ptr (Ptr a) -> Int -> IO [Ptr a]+    where go :: Ptr (Ptr a) -> CUInt -> IO [Ptr a]           go _ 0 = return []           go ptr n = do             x <- peek ptr@@ -558,7 +557,7 @@             buf <- g_memdup ptr (fromIntegral size)             (buf :) <$> go size (n-1) (ptr `plusPtr` size) -unpackBoxedArrayWithLength :: forall a b. (Integral a, BoxedObject b) =>+unpackBoxedArrayWithLength :: forall a b. (Integral a, GBoxed b) =>                               Int -> a -> Ptr b -> IO [Ptr b] unpackBoxedArrayWithLength size n ptr = go size (fromIntegral n) ptr     where go       :: Int -> Int -> Ptr b -> IO [Ptr b]
− Data/GI/Base/BasicTypes.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,-  DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif-#if MIN_VERSION_base(4,9,0)-{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}-#endif--- | Basic types used in the bindings.-module Data.GI.Base.BasicTypes-    (-      -- * GType related-      module Data.GI.Base.GType         -- reexported for convenience--     -- * Memory management-    , ManagedPtr(..)-    , ManagedPtrNewtype-    , BoxedObject(..)-    , BoxedEnum(..)-    , BoxedFlags(..)-    , GObject(..)-    , WrappedPtr(..)-    , UnexpectedNullPointerReturn(..)-    , NullToNothing(..)--    -- * Basic GLib \/ GObject types-    , GVariant(..)-    , GParamSpec(..)--    , GArray(..)-    , GPtrArray(..)-    , GByteArray(..)-    , GHashTable(..)-    , GList(..)-    , g_list_free-    , GSList(..)-    , g_slist_free--    , IsGFlag--    , PtrWrapped(..)-    , GDestroyNotify-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Exception (Exception, catch)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Coerce (Coercible)-import Data.IORef (IORef)-import Data.Proxy (Proxy)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Foreign.Ptr (Ptr, FunPtr)-import Foreign.ForeignPtr (ForeignPtr)--import Data.GI.Base.CallStack (CallStack)-import Data.GI.Base.GType---- | Thin wrapper over `ForeignPtr`, supporting the extra notion of--- `disowning`, that is, not running the finalizers associated with--- the foreign ptr.-data ManagedPtr a = ManagedPtr {-      managedForeignPtr :: ForeignPtr a-    , managedPtrAllocCallStack :: Maybe CallStack-    -- ^ `CallStack` for the call that created the pointer.-    , managedPtrIsDisowned :: IORef (Maybe CallStack)-    -- ^ When disowned, the `CallStack` for the disowning call.-    }---- | A constraint ensuring that the given type is coercible to a--- ManagedPtr. It will hold for newtypes of the form------ > newtype Foo = Foo (ManagedPtr Foo)------ which is the typical shape of wrapped 'GObject's.-type ManagedPtrNewtype a = Coercible a (ManagedPtr ())--- Notice that the Coercible here is to ManagedPtr (), instead of--- "ManagedPtr a", which would be the most natural thing. Both are--- representationally equivalent, so this is not a big deal. This is--- to work around a problem in ghc 7.10:--- https://ghc.haskell.org/trac/ghc/ticket/10715---- | Wrapped boxed structures, identified by their `GType`.-class ManagedPtrNewtype a => BoxedObject a where-    boxedType :: a -> IO GType -- This should not use the value of its-                               -- argument.---- | Enums with an associated `GType`.-class BoxedEnum a where-    boxedEnumType :: a -> IO GType---- | Flags with an associated `GType`.-class BoxedFlags a where-    boxedFlagsType :: Proxy a -> IO GType---- | Pointers to structs/unions without an associated `GType`.-class ManagedPtrNewtype a => WrappedPtr a where-    -- | Allocate a zero-initialized block of memory for the given type.-    wrappedPtrCalloc :: IO (Ptr a)-    -- | Make a copy of the given `WrappedPtr`.-    wrappedPtrCopy   :: a -> IO a-    -- | A pointer to a function for freeing the given pointer, or-    -- `Nothing` is the memory associated to the pointer does not need-    -- to be freed.-    wrappedPtrFree   :: Maybe (FunPtr (Ptr a -> IO ()))---- | A wrapped `GObject`.-class ManagedPtrNewtype a => GObject a where-    -- | The `GType` for this object.-    gobjectType :: a -> IO GType---- | A common omission in the introspection data is missing (nullable)--- annotations for return types, when they clearly are nullable. (A--- common idiom is "Returns: valid value, or %NULL if something went--- wrong.")------ Haskell wrappers will raise this exception if the return value is--- an unexpected `Foreign.Ptr.nullPtr`.-data UnexpectedNullPointerReturn =-    UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text }-                                deriving (Typeable)--instance Show UnexpectedNullPointerReturn where-  show r = T.unpack (nullPtrErrorMsg r)--instance Exception UnexpectedNullPointerReturn--type family UnMaybe a :: * where-    UnMaybe (Maybe a) = a-    UnMaybe a         = a--{-# DEPRECATED nullToNothing ["This will be removed in future versions of haskell-gi.", "If you know of wrong introspection data in a binding please report it as an issue at", "http://github.com/haskell-gi/haskell-gi", "so that it can be fixed."] #-}-class NullToNothing a where-    -- | Some functions are not marked as having a nullable return type-    -- in the introspection data.  The result is that they currently do-    -- not return a Maybe type.  This functions lets you work around this-    -- in a way that will not break when the introspection data is fixed.-    ---    -- When you want to call a `someHaskellGIFunction` that may return null-    -- wrap the call like this.-    ---    -- > nullToNothing (someHaskellGIFunction x y)-    ---    -- The result will be a Maybe type even if the introspection data has-    -- not been fixed for `someHaskellGIFunction` yet.-    nullToNothing :: MonadIO m => IO a -> m (Maybe (UnMaybe a))--instance-#if MIN_VERSION_base(4,8,0)-    {-# OVERLAPPABLE #-}-#endif-    a ~ UnMaybe a => NullToNothing a where-        nullToNothing f = liftIO $-            (Just <$> f) `catch` (\(_::UnexpectedNullPointerReturn) -> return Nothing)--instance NullToNothing (Maybe a) where-    nullToNothing = liftIO---- | A <https://developer.gnome.org/glib/stable/glib-GVariant.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.-newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec)---- | 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.-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.-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.-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.-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".-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".-data GSList a = GSList (Ptr (GSList a))---- | Some APIs, such as `GHashTable`, pass around scalar types--- wrapped into a pointer. We encode such a type as follows.-newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a}---- | Destroy the memory associated with a given pointer.-type GDestroyNotify a = FunPtr (Ptr a -> IO ())---- | Free the given 'GList'.-foreign import ccall "g_list_free" g_list_free ::-    Ptr (GList a) -> IO ()---- | Free the given 'GSList'.-foreign import ccall "g_slist_free" g_slist_free ::-    Ptr (GSList a) -> IO ()
+ Data/GI/Base/BasicTypes.hsc view
@@ -0,0 +1,221 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,+  TypeFamilies, ScopedTypeVariables,+  MultiParamTypeClasses, DataKinds, TypeOperators, UndecidableInstances,+  AllowAmbiguousTypes #-}++-- | Basic types used in the bindings.+module Data.GI.Base.BasicTypes+    (+     -- * Memory management+      ManagedPtr(..)+    , ManagedPtrNewtype(..)+    , BoxedPtr(..)+    , CallocPtr(..)+    , UnexpectedNullPointerReturn(..)++    -- * Basic GLib \/ GObject types+    , TypedObject(..)+    , GObject+    , GType(..)+    , CGType+    , gtypeName+    , GVariant(..)+    , GBoxed+    , BoxedEnum+    , BoxedFlags+    , GParamSpec(..)+    , noGParamSpec++    , GArray(..)+    , GPtrArray(..)+    , GByteArray(..)+    , GHashTable(..)+    , GList(..)+    , g_list_free+    , GSList(..)+    , g_slist_free++    , IsGFlag++    , PtrWrapped(..)+    , GDestroyNotify++    , GHashFunc+    , GEqualFunc+    ) where++import Control.Exception (Exception)++import Data.Coerce (coerce, Coercible)+import Data.IORef (IORef)+import qualified Data.Text as T+import Data.Int+import Data.Word++import Foreign.C (CString, peekCString)+import Foreign.Ptr (Ptr, FunPtr)+import Foreign.ForeignPtr (ForeignPtr)++import {-# SOURCE #-} Data.GI.Base.Overloading (HasParentTypes)+import Data.GI.Base.CallStack (CallStack)++#include <glib-object.h>++-- | Thin wrapper over `ForeignPtr`, supporting the extra notion of+-- `disowning`, that is, not running the finalizers associated with+-- the foreign ptr.+data ManagedPtr a = ManagedPtr {+      managedForeignPtr :: ForeignPtr a+    , managedPtrAllocCallStack :: Maybe CallStack+    -- ^ `CallStack` for the call that created the pointer.+    , managedPtrIsDisowned :: IORef (Maybe CallStack)+    -- ^ When disowned, the `CallStack` for the disowning call.+    }++-- | Two 'ManagedPtr's are equal if they wrap the same underlying+-- C 'Ptr'.+instance Eq (ManagedPtr a) where+  a == b = managedForeignPtr a == managedForeignPtr b++-- | A constraint ensuring that the given type is a newtype over a+-- `ManagedPtr`.+class Coercible a (ManagedPtr ()) => ManagedPtrNewtype a where+  toManagedPtr :: a -> ManagedPtr a++-- | A default instance for `IsManagedPtr` for newtypes over `ManagedPtr`.+instance {-# OVERLAPPABLE #-} Coercible a (ManagedPtr ()) => ManagedPtrNewtype a where+  toManagedPtr = coerce+-- Notice that the Coercible here above to ManagedPtr (), instead of+-- "ManagedPtr a", which would be the most natural thing. Both are+-- representationally equivalent, so this is not a big deal. This is+-- to work around a problem in ghc 7.10:+-- https://ghc.haskell.org/trac/ghc/ticket/10715+--+-- Additionally, a simpler approach would be to simply do+--+-- > type IsManagedPtr a = Coercible a (ManagedPtr ())+--+-- but this requires the constructor of the datatype to be in scope,+-- which is cumbersome (for instance, one often wants to call `castTo`+-- on the results of `Gtk.builderGetObject`, which is a `GObject`,+-- whose constructor is not necessarily in scope when using `GI.Gtk`).+--+-- When we make the bindings we will always add explicit instances,+-- which cannot be hidden, avoiding the issue. We keep the default+-- instance for convenience when writing new object types.++-- | Pointers to chunks of memory which we know how to copy and+-- release.+class ManagedPtrNewtype a => BoxedPtr a where+  -- | Make a copy of the given `BoxedPtr`.+  boxedPtrCopy   :: a -> IO a+  -- | A pointer to a function for freeing the given pointer.+  boxedPtrFree   :: a -> IO ()++-- | A ptr to a memory block which we know how to allocate and fill+-- with zero.+class BoxedPtr a => CallocPtr a where+  -- | Allocate a zero-initialized block of memory for the given type.+  boxedPtrCalloc :: IO (Ptr a)++-- | A wrapped object that has an associated GLib type. This does not+-- necessarily descend from `GObject`, that constraint is implemented+-- by `GObject` below.+class HasParentTypes a => TypedObject a where+  -- | The `GType` for this object.+  glibType :: IO GType++-- | Chunks of memory whose allocation/deallocation info has been+-- registered with the GLib type system.+class (ManagedPtrNewtype a, TypedObject a) => GBoxed a++-- | A wrapped `GObject`, or any other type that descends from it.+class (ManagedPtrNewtype a, TypedObject a) => GObject a++-- | Enums with an associated `GType`.+class TypedObject a => BoxedEnum a++-- | Flags with an associated `GType`.+class TypedObject a => BoxedFlags a++-- | A type identifier in the GLib type system. This is the low-level+-- type associated with the representation in memory, when using this+-- on the Haskell side use `GType` below.+type CGType = #type GType++-- | A newtype for use on the Haskell side.+newtype GType = GType {gtypeToCGType :: CGType}+  deriving (Eq, Show)++foreign import ccall "g_type_name" g_type_name :: GType -> IO CString++-- | Get the name assigned to the given `GType`.+gtypeName :: GType -> IO String+gtypeName gtype = g_type_name gtype >>= peekCString++-- | A common omission in the introspection data is missing (nullable)+-- annotations for return types, when they clearly are nullable. (A+-- common idiom is "Returns: valid value, or %NULL if something went+-- wrong.")+--+-- Haskell wrappers will raise this exception if the return value is+-- an unexpected `Foreign.Ptr.nullPtr`.+data UnexpectedNullPointerReturn =+    UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text }++instance Show UnexpectedNullPointerReturn where+  show r = T.unpack (nullPtrErrorMsg r)++instance Exception UnexpectedNullPointerReturn++-- | 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://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@.+noGParamSpec :: Maybe GParamSpec+noGParamSpec = Nothing++-- | An enum usable as a flag for a function.+class Enum a => IsGFlag a++-- | 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://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://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://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://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://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 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 ::+    Ptr (GList a) -> IO ()++-- | 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/Closure.hs 
@@ -1,41 +0,0 @@--- Some helper functions to create closures.-module Data.GI.Base.Closure-    ( Closure(..)-    , newCClosure-    , noClosure-    ) where--import Foreign--import Data.GI.Base.BasicTypes-import Data.GI.Base.ManagedPtr (wrapBoxed)-import Data.GI.Base.Utils (safeFreeFunPtrPtr)--newtype Closure = Closure (ManagedPtr Closure)--noClosure :: Maybe Closure-noClosure = Nothing--foreign import ccall "g_closure_get_type" c_g_closure_get_type ::-    IO GType--instance BoxedObject Closure where-    boxedType _ = c_g_closure_get_type---foreign import ccall "g_cclosure_new" g_cclosure_new-    :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure)--foreign import ccall "g_closure_ref" g_closure_ref-    :: Ptr Closure -> IO (Ptr Closure)--foreign import ccall "g_closure_sink" g_closure_sink-    :: Ptr Closure -> IO ()--newCClosure :: FunPtr a -> IO Closure-newCClosure ptr = do-  closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr-  -- The Haskell runtime will manage the memory associated to the-  -- closure, so ref and sink to let GLib know this.-  g_closure_ref closure >>= g_closure_sink-  wrapBoxed Closure closure
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@@ -20,12 +20,10 @@  -- | Constructible types, i.e. those which can be allocated by `new`. class Constructible a (tag :: AttrOpTag) where-    new :: MonadIO m => (ManagedPtr a -> a) -> [AttrOp a tag] -> m a+  -- | Allocate a new instance of the given type, with the given attributes.+  new :: MonadIO m => (ManagedPtr a -> a) -> [AttrOp a tag] -> m a  -- | Default instance, assuming we have a `GObject`.-instance-#if MIN_VERSION_base(4,8,0)-    {-# OVERLAPPABLE #-}-#endif+instance {-# OVERLAPPABLE #-}     (GObject a, tag ~ 'AttrConstruct) => Constructible a tag where         new = constructGObject
+ Data/GI/Base/DynVal.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|++This is an __experimental__ module that introduces support for dynamic+values: these are functions from a record @model@ to some type @a@+which keep track of which selectors of @model@ does the result depend+on. For example, for a record of the form++> data Example = Example {+>     first  :: Int,+>     second :: Bool,+>     third  :: Float+> }++a `DynVal Example String` could be constructed, assuming that you are+given a @record@ `DynVal` representing the full record, using:++> let format = \f s -> "First is " <> f <> " and second is " <> s+>     formatted = format <$> record.first <*> record.second :: DynVal Example String++Here we are showcasing two properties of `DynVal`s: they can be+conveniently constructed using @OverloadedRecordDot@, and they provide+an `Applicative` instance. The resulting @formatted@ `DynVal` keeps+track of the fact that it depends on the @first@ and @second@ record+selectors.++-}++module Data.GI.Base.DynVal+  ( DynVal(..), DVKey(..), ModelProxy(..), dvKeys, dvRead,+    modelProxyCurrentValue, modelProxyRegisterHandler, modelProxyUpdate) where++import GHC.Records (HasField(..))+import qualified GHC.TypeLits as TL++import Data.Proxy (Proxy(..))+import qualified Data.Set as S+import Data.String (IsString(..))+import qualified Data.Text as T++data DVKey = DVKeyDirect [T.Text]+             -- ^ Direct access to subfields: for example writing+             -- @record.field.subfield@ (using the `HasField`+             -- instance) would lead to @`DVKeyDirect` ["field",+             -- "subfield"]@+           | DVKeyDerived (S.Set [T.Text])+             -- ^ Value derived from a direct key, by acting with the+             -- functor or applicative instances.+  deriving (Eq, Ord, Show)++-- | A `DynVal` is a way of extracting values of type @a@ from+-- @model@, which keeps track of which fields (parameterised by+-- `dvKeys`) in @model@ are needed for computing the `DynVal`.+data DynVal model a = DynVal DVKey (model -> a)++-- | Keys to fields in the model that this `DynVal` depends on.+dvKeys :: DynVal model a -> DVKey+dvKeys (DynVal s _) = s++-- | Compute the actual value given a model.+dvRead :: DynVal model a -> model -> a+dvRead (DynVal _ r) = r++-- | Turn a key into a derived one.+toDerived :: DVKey -> DVKey+toDerived (DVKeyDirect d) = DVKeyDerived (S.singleton d)+toDerived derived = derived++-- | Joining of keys always produces derived ones.+instance Semigroup DVKey where+  DVKeyDirect a <> DVKeyDirect b = DVKeyDerived $ S.fromList [a,b]+  (DVKeyDirect a) <> (DVKeyDerived b) =+    DVKeyDerived $ S.insert a b+  (DVKeyDerived a) <> (DVKeyDirect b) =+    DVKeyDerived $ S.insert b a+  (DVKeyDerived a) <> (DVKeyDerived b) =+    DVKeyDerived $ S.union a b++instance Functor (DynVal model) where+  fmap f dv = DynVal (toDerived $ dvKeys dv) (f . dvRead dv)++instance Applicative (DynVal model) where+  pure x = DynVal (DVKeyDerived S.empty) (const x)+  dF <*> dA = DynVal (dvKeys dF <> dvKeys dA)+                     (\m -> let f = dvRead dF m+                            in f (dvRead dA m))++instance IsString (DynVal model T.Text) where+  fromString s = pure (T.pack s)++{-+-- If we make dvKeys :: model -> S.Set DVKey we can also produce a+-- Monad instance, but the set of resulting keys might depend on the+-- specific model passed, which could lead to subtle bugs.++instance Monad (DynVal model) where+  dv >>= gen = let runGen = \m -> gen (dvRead dv m)+               in DynVal {dvKeys = \m -> S.union (dvKeys dv m)+                                         (dvKeys (runGen m) m)+                         , dvRead = \m -> dvRead (runGen m) m+                         }+-}++-- | A `ModelProxy` is a way of obtaining records of type `model`,+-- which allows for registering for notifications whenever certain+-- keys (typically associated to record fields) get modified, and+-- allows to modify fields of the model.+data ModelProxy model = ModelProxy (IO model) (DVKey -> (model -> IO ()) -> IO ()) ([T.Text] -> (model -> Maybe model) -> IO ())++-- The following would be most naturally field accessors, but because+-- we introduce HasField instances for proxies we need to make these+-- ordinary functions instead.++-- | Obtain the current value of the model.+modelProxyCurrentValue :: ModelProxy model -> IO model+modelProxyCurrentValue (ModelProxy m _ _) = m++-- | Register a handler that will be executed whenever any of the+-- fields in the model pointed to by the keys is modified.+modelProxyRegisterHandler :: ModelProxy model -> DVKey -> (model -> IO ()) -> IO ()+modelProxyRegisterHandler (ModelProxy _ r _) = r++-- | Modify the given keys in the proxy, using the given update+-- function, of type (model -> Maybe model). If this function returns+-- Nothing no modification will be performed, otherwise the modified+-- model will be stored in the ModelProxy, and any listeners will be+-- notified of a change.+modelProxyUpdate :: ModelProxy model -> [T.Text] -> (model -> Maybe model)+                 -> IO ()+modelProxyUpdate (ModelProxy _ _ u) = u++instance (HasField fieldName field a,+          TL.KnownSymbol fieldName) =>+  HasField fieldName (DynVal model field) (DynVal model a) where+  getField dv = let fn = T.pack . TL.symbolVal $ (Proxy :: Proxy fieldName)+                    key = case dvKeys dv of+                      derived@(DVKeyDerived _) -> derived+                      DVKeyDirect direct -> DVKeyDirect (direct <> [fn])+                in DynVal key (getField @fieldName . dvRead dv)
+ Data/GI/Base/GArray.hs view
@@ -0,0 +1,16 @@+-- | Utilities for dealing with `GArray` types.+module Data.GI.Base.GArray+  ( allocGArray+  ) where++import Foreign.C (CInt(..), CUInt(..))+import Foreign.Ptr (Ptr)++import Data.GI.Base.BasicTypes (GArray(..))++-- | Args are zero_terminated, clear_, element_size+foreign import ccall g_array_new :: CInt -> CInt -> CUInt -> IO (Ptr (GArray a))++-- | Allocate a `GArray` with elements of the given size.+allocGArray :: CUInt -> IO (Ptr (GArray a))+allocGArray size = g_array_new 0 1 size
+ Data/GI/Base/GClosure.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TypeFamilies, DataKinds #-}+-- | Some helper functions for dealing with @GClosure@s.+module Data.GI.Base.GClosure+    ( GClosure(..)+    , newGClosure+    , wrapGClosurePtr+    , newGClosureFromPtr+    , noGClosure+    , unrefGClosure+    , disownGClosure+    ) where++import Foreign.Ptr (Ptr, FunPtr, nullPtr)+import Foreign.C (CInt(..))++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.GI.Base.BasicTypes+import Data.GI.Base.CallStack (HasCallStack)+import Data.GI.Base.ManagedPtr (newBoxed, newManagedPtr',+                                disownManagedPtr, withManagedPtr)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)++-- | The basic type. This corresponds to a wrapped @GClosure@ on the C+-- side, which is a boxed object.+newtype GClosure a = GClosure (ManagedPtr (GClosure a))++-- | A convenience alias for @Nothing :: Maybe (GClosure a)@.+noGClosure :: Maybe (GClosure a)+noGClosure = Nothing++foreign import ccall "g_closure_get_type" c_g_closure_get_type ::+    IO GType++-- | There are no types in the bindings that a closure can be safely+-- cast to.+type instance ParentTypes (GClosure a) = '[]+instance HasParentTypes (GClosure a)++-- | Find the associated `GType` for the given closure.+instance TypedObject (GClosure a) where+  glibType = c_g_closure_get_type++-- | `GClosure`s are registered as boxed in the GLib type system.+instance GBoxed (GClosure a)++foreign import ccall "g_cclosure_new" g_cclosure_new+    :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr (GClosure a))++-- Releasing the `FunPtr` for the signal handler.+foreign import ccall "& haskell_gi_release_signal_closure"+    ptr_to_release_closure :: FunPtr (Ptr () -> Ptr () -> IO ())++-- | Create a new `GClosure` holding the given `FunPtr`. Note that+-- after calling this the `FunPtr` will be freed whenever the+-- `GClosure` is garbage collected, so it is generally not safe to+-- refer to the generated `FunPtr` after this function returns.+newGClosure :: MonadIO m => FunPtr a -> m (GClosure a)+newGClosure ptr = liftIO $ do+  closure <- g_cclosure_new ptr nullPtr ptr_to_release_closure+  wrapGClosurePtr closure++foreign import ccall g_closure_ref :: Ptr (GClosure a) -> IO (Ptr (GClosure a))+foreign import ccall g_closure_sink :: Ptr (GClosure a) -> IO ()+foreign import ccall g_closure_unref :: Ptr (GClosure a) -> IO ()+foreign import ccall "&g_closure_unref" ptr_to_g_closure_unref ::+        FunPtr (Ptr (GClosure a) -> IO ())++foreign import ccall "haskell_gi_g_closure_is_floating" g_closure_is_floating ::+        Ptr (GClosure a) -> IO CInt++-- | Take ownership of a passed in 'Ptr' to a 'GClosure'.+wrapGClosurePtr :: Ptr (GClosure a) -> IO (GClosure a)+wrapGClosurePtr closurePtr = do+  floating <- g_closure_is_floating closurePtr+  when (floating /= 0) $ do+    _ <- g_closure_ref closurePtr+    g_closure_sink closurePtr+  fPtr <- newManagedPtr' ptr_to_g_closure_unref closurePtr+  return $! GClosure fPtr++-- | Construct a Haskell wrapper for the 'GClosure', without assuming+-- ownership.+newGClosureFromPtr :: Ptr (GClosure a) -> IO (GClosure a)+newGClosureFromPtr = newBoxed GClosure++-- | Decrease the reference count of the given 'GClosure'. If the+-- reference count reaches 0 the memory will be released.+unrefGClosure :: (HasCallStack, MonadIO m) => GClosure a -> m ()+unrefGClosure closure = liftIO $ withManagedPtr closure g_closure_unref++-- | Disown (that is, remove from te purview of the Haskell Garbage+-- Collector) the given 'GClosure'.+disownGClosure :: GClosure a -> IO (Ptr (GClosure a))+disownGClosure = disownManagedPtr
+ Data/GI/Base/GError.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, DataKinds #-}++-- | To catch GError exceptions use the+-- catchGError* or handleGError* functions. They work in a similar+-- way to the standard 'Control.Exception.catch' and+-- 'Control.Exception.handle' functions.+--+-- To catch just a single specific error use 'catchGErrorJust' \/+-- 'handleGErrorJust'. To catch any error in a particular error domain+-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'+--+-- For convenience, generated code also includes specialized variants+-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For+-- example, for errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> one could+-- invoke <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#v:catchPixbufError catchPixbufError> \/+-- <https://hackage.haskell.org/package/gi-gdkpixbuf-2.0.14/docs/GI-GdkPixbuf-Enums.html#v:handlePixbufError handlePixbufError>. The definition is simply+--+-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a+-- > catchPixbufError = catchGErrorJustDomain+--+-- Notice that the type is suitably specialized, so only+-- errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> will be caught.+module Data.GI.Base.GError+    (+    -- * Unpacking GError+    --+      GError(..)+    , gerrorDomain+    , gerrorCode+    , gerrorMessage++    , GErrorDomain+    , GErrorCode+    , GErrorMessage++    -- * Catching GError exceptions+    , catchGErrorJust+    , catchGErrorJustDomain++    , handleGErrorJust+    , handleGErrorJustDomain++    -- * Creating new 'GError's+    , gerrorNew++    -- * Implementation specific details+    -- | The following are used in the implementation+    -- of the bindings, and are in general not necessary for using the+    -- API.+    , GErrorClass(..)++    , propagateGError+    , checkGError+    , maybePokeGError+    ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Foreign (poke, peek)+import Foreign.Ptr (Ptr, plusPtr, nullPtr)+import Foreign.C+import Control.Exception+import Data.Text (Text)+import qualified Data.Text as T++import System.IO.Unsafe (unsafePerformIO)++import Data.GI.Base.BasicTypes (GType(..), ManagedPtr, TypedObject(..),+                                GBoxed)+import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.ManagedPtr (withManagedPtr, wrapBoxed, copyBoxed)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)+import Data.GI.Base.Utils (allocMem, freeMem)++import Data.GI.Base.Internal.CTypes (GQuark, C_gint, gerror_domain_offset,+                                     gerror_code_offset, gerror_message_offset)++-- | A GError, consisting of a domain, code and a human readable+-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and+-- 'gerrorMessage' below.+newtype GError = GError (ManagedPtr GError)++instance Show GError where+    show gerror = unsafePerformIO $ do+                       code <- gerrorCode gerror+                       message <- gerrorMessage gerror+                       return $ T.unpack message ++ " (" ++ show code ++ ")"++instance Exception GError++-- | There are no types in the bindings that a `GError` can be safely+-- cast to.+type instance ParentTypes GError = '[]+instance HasParentTypes GError++foreign import ccall "g_error_get_type" g_error_get_type :: IO GType++instance TypedObject GError where+  glibType = g_error_get_type++-- | `GError`s are registered as boxed in the GLib type system.+instance GBoxed GError++-- | A code used to identify the "namespace" of the error. Within each error+--   domain all the error codes are defined in an enumeration. Each gtk\/gnome+--   module that uses GErrors has its own error domain. The rationale behind+--   using error domains is so that each module can organise its own error codes+--   without having to coordinate on a global error code list.+type GErrorDomain  = GQuark++-- | A code to identify a specific error within a given 'GErrorDomain'. Most of+--   time you will not need to deal with this raw code since there is an+--   enumeration type for each error domain. Of course which enumeration to use+--   depends on the error domain, but if you use 'catchGErrorJustDomain' or+--   'handleGErrorJustDomain', this is worked out for you automatically.+type GErrorCode = C_gint++-- | A human readable error message.+type GErrorMessage = Text++foreign import ccall "g_error_new_literal" g_error_new_literal ::+    GQuark -> GErrorCode -> CString -> IO (Ptr GError)++-- | Create a new 'GError'.+gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError+gerrorNew domain code message =+    withTextCString message $ \cstring ->+        g_error_new_literal domain code cstring >>= wrapBoxed GError++-- | Return the domain for the given `GError`. This is a GQuark, a+-- textual representation can be obtained with+-- `GI.GLib.quarkToString`.+gerrorDomain :: GError -> IO GQuark+gerrorDomain gerror =+    withManagedPtr gerror $ \ptr ->+      peek $ ptr `plusPtr` gerror_domain_offset++-- | The numeric code for the given `GError`.+gerrorCode :: GError -> IO GErrorCode+gerrorCode gerror =+    withManagedPtr gerror $ \ptr ->+        peek $ ptr `plusPtr` gerror_code_offset++-- | A text message describing the `GError`.+gerrorMessage :: GError -> IO GErrorMessage+gerrorMessage gerror =+    withManagedPtr gerror $ \ptr ->+      (peek $ ptr `plusPtr` gerror_message_offset) >>= cstringToText++-- | Each error domain's error enumeration type should be an instance of this+--   class. This class helps to hide the raw error and domain codes from the+--   user.+--+-- Example for <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError>:+--+-- > instance GErrorClass PixbufError where+-- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"+--+class Enum err => GErrorClass err where+  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its+                                     -- parameter so that it is safe to pass+                                     -- 'undefined'.++foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::+    CString -> IO GQuark++-- | Given the string representation of an error domain returns the+--   corresponding error quark.+gErrorQuarkFromDomain :: Text -> IO GQuark+gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string++-- | This will catch just a specific GError exception. If you need to catch a+--   range of related errors, 'catchGErrorJustDomain' is probably more+--   appropriate. Example:+--+-- > do image <- catchGErrorJust PixbufErrorCorruptImage+-- >               loadImage+-- >               (\errorMessage -> do log errorMessage+-- >                                    return mssingImagePlaceholder)+--+catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch+                -> IO a                    -- ^ The computation to run+                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if+                                           -- an exception is raised+                -> IO a+catchGErrorJust code action handler = catch action handler'+  where handler' gerror = do+          quark <- gErrorQuarkFromDomain (gerrorClassDomain code)+          domain <- gerrorDomain gerror+          code' <- gerrorCode gerror+          if domain == quark && code' == (fromIntegral . fromEnum) code+          then gerrorMessage gerror >>= handler+          else throw gerror -- Pass it on++-- | Catch all GErrors from a particular error domain. The handler function+--   should just deal with one error enumeration type. If you need to catch+--   errors from more than one error domain, use this function twice with an+--   appropriate handler functions for each.+--+-- > catchGErrorJustDomain+-- >   loadImage+-- >   (\err message -> case err of+-- >       PixbufErrorCorruptImage -> ...+-- >       PixbufErrorInsufficientMemory -> ...+-- >       PixbufErrorUnknownType -> ...+-- >       _ -> ...)+--+catchGErrorJustDomain :: forall err a. GErrorClass err =>+                         IO a        -- ^ The computation to run+                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised+                      -> IO a+catchGErrorJustDomain action handler = catch action handler'+  where handler' gerror = do+          quark <- gErrorQuarkFromDomain (gerrorClassDomain (undefined :: err))+          domain <- gerrorDomain gerror+          if domain == quark+          then do+            code <- (toEnum . fromIntegral) <$> gerrorCode gerror+            msg <- gerrorMessage gerror+            handler code msg+          else throw gerror++-- | A verson of 'handleGErrorJust' with the arguments swapped around.+handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJust code = flip (catchGErrorJust code)++-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.+handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a+handleGErrorJustDomain = flip catchGErrorJustDomain++-- | Run the given function catching possible 'GError's in its+-- execution. If a 'GError' is emitted this throws the corresponding+-- exception.+propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a+propagateGError f = checkGError f throw++-- | Like 'propagateGError', but allows to specify a custom handler+-- instead of just throwing the exception.+checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a+checkGError f handler = do+  gerrorPtr <- allocMem+  poke gerrorPtr nullPtr+  result <- f gerrorPtr+  gerror <- peek gerrorPtr+  freeMem gerrorPtr+  if gerror /= nullPtr+  then wrapBoxed GError gerror >>= handler+  else return result++-- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a+-- copy in the passed in pointer, unless the pointer is `nullPtr`.+maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()+maybePokeGError _ Nothing = return ()+maybePokeGError ptrPtr (Just gerror)+  | ptrPtr == nullPtr = return ()+  | otherwise = copyBoxed gerror >>= poke ptrPtr
− Data/GI/Base/GError.hsc 
@@ -1,254 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}---- | To catch GError exceptions use the--- catchGError* or handleGError* functions. They work in a similar--- way to the standard 'Control.Exception.catch' and--- 'Control.Exception.handle' functions.------ To catch just a single specific error use 'catchGErrorJust' \/--- 'handleGErrorJust'. To catch any error in a particular error domain--- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'------ For convenience, generated code also includes specialized variants--- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For--- example, for errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> one could--- invoke <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#v:catchPixbufError catchPixbufError> \/--- <https://hackage.haskell.org/package/gi-gdkpixbuf-2.0.14/docs/GI-GdkPixbuf-Enums.html#v:handlePixbufError handlePixbufError>. The definition is simply------ > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a--- > catchPixbufError = catchGErrorJustDomain------ Notice that the type is suitably specialized, so only--- errors of type <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError> will be caught.-module Data.GI.Base.GError-    (-    -- * Unpacking GError-    ---      GError(..)-    , gerrorDomain-    , gerrorCode-    , gerrorMessage--    , GErrorDomain-    , GErrorCode-    , GErrorMessage--    -- * Catching GError exceptions-    , catchGErrorJust-    , catchGErrorJustDomain--    , handleGErrorJust-    , handleGErrorJustDomain--    -- * Creating new 'GError's-    , gerrorNew--    -- * Implementation specific details-    -- | The following are used in the implementation-    -- of the bindings, and are in general not necessary for using the-    -- API.-    , GErrorClass(..)--    , propagateGError-    , checkGError-    , maybePokeGError-    ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif--import Foreign (poke, peek)-import Foreign.Ptr (Ptr, plusPtr, nullPtr)-import Foreign.C-import Control.Exception-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Data.Int-import Data.Word--import System.IO.Unsafe (unsafePerformIO)--import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), ManagedPtr)-import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr, copyBoxed)-import Data.GI.Base.Utils (allocMem, freeMem)--#include <glib.h>---- | A GError, consisting of a domain, code and a human readable--- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and--- 'gerrorMessage' below.-newtype GError = GError (ManagedPtr GError)-    deriving (Typeable)--instance Show GError where-    show gerror = unsafePerformIO $ do-                       code <- gerrorCode gerror-                       message <- gerrorMessage gerror-                       return $ T.unpack message ++ " (" ++ show code ++ ")"--instance Exception GError--foreign import ccall "g_error_get_type" g_error_get_type :: IO GType--instance BoxedObject GError where-    boxedType _ = g_error_get_type---- | A GQuark.-type GQuark = #type GQuark---- | A code used to identify the "namespace" of the error. Within each error---   domain all the error codes are defined in an enumeration. Each gtk\/gnome---   module that uses GErrors has its own error domain. The rationale behind---   using error domains is so that each module can organise its own error codes---   without having to coordinate on a global error code list.-type GErrorDomain  = GQuark---- | A code to identify a specific error within a given 'GErrorDomain'. Most of---   time you will not need to deal with this raw code since there is an---   enumeration type for each error domain. Of course which enumeration to use---   depends on the error domain, but if you use 'catchGErrorJustDomain' or---   'handleGErrorJustDomain', this is worked out for you automatically.-type GErrorCode = #type gint---- | A human readable error message.-type GErrorMessage = Text--foreign import ccall "g_error_new_literal" g_error_new_literal ::-    GQuark -> GErrorCode -> CString -> IO (Ptr GError)---- | Create a new 'GError'.-gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError-gerrorNew domain code message =-    withTextCString message $ \cstring ->-        g_error_new_literal domain code cstring >>= wrapBoxed GError---- | Return the domain for the given `GError`. This is a GQuark, a--- textual representation can be obtained with--- `GI.GLib.quarkToString`.-gerrorDomain :: GError -> IO GQuark-gerrorDomain gerror =-    withManagedPtr gerror $ \ptr ->-      peek $ ptr `plusPtr` #{offset GError, domain}---- | The numeric code for the given `GError`.-gerrorCode :: GError -> IO GErrorCode-gerrorCode gerror =-    withManagedPtr gerror $ \ptr ->-        peek $ ptr `plusPtr` #{offset GError, code}---- | A text message describing the `GError`.-gerrorMessage :: GError -> IO GErrorMessage-gerrorMessage gerror =-    withManagedPtr gerror $ \ptr ->-      (peek $ ptr `plusPtr` #{offset GError, message}) >>= cstringToText---- | Each error domain's error enumeration type should be an instance of this---   class. This class helps to hide the raw error and domain codes from the---   user.------ Example for <https://hackage.haskell.org/package/gi-gdkpixbuf/docs/GI-GdkPixbuf-Enums.html#t:PixbufError PixbufError>:------ > instance GErrorClass PixbufError where--- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"----class Enum err => GErrorClass err where-  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its-                                     -- parameter so that it is safe to pass-                                     -- 'undefined'.--foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::-    CString -> IO GQuark---- | Given the string representation of an error domain returns the---   corresponding error quark.-gErrorQuarkFromDomain :: Text -> IO GQuark-gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string---- | This will catch just a specific GError exception. If you need to catch a---   range of related errors, 'catchGErrorJustDomain' is probably more---   appropriate. Example:------ > do image <- catchGErrorJust PixbufErrorCorruptImage--- >               loadImage--- >               (\errorMessage -> do log errorMessage--- >                                    return mssingImagePlaceholder)----catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch-                -> IO a                    -- ^ The computation to run-                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if-                                           -- an exception is raised-                -> IO a-catchGErrorJust code action handler = catch action handler'-  where handler' gerror = do-          quark <- gErrorQuarkFromDomain (gerrorClassDomain code)-          domain <- gerrorDomain gerror-          code' <- gerrorCode gerror-          if domain == quark && code' == (fromIntegral . fromEnum) code-          then gerrorMessage gerror >>= handler-          else throw gerror -- Pass it on---- | Catch all GErrors from a particular error domain. The handler function---   should just deal with one error enumeration type. If you need to catch---   errors from more than one error domain, use this function twice with an---   appropriate handler functions for each.------ > catchGErrorJustDomain--- >   loadImage--- >   (\err message -> case err of--- >       PixbufErrorCorruptImage -> ...--- >       PixbufErrorInsufficientMemory -> ...--- >       PixbufErrorUnknownType -> ...--- >       _ -> ...)----catchGErrorJustDomain :: forall err a. GErrorClass err =>-                         IO a        -- ^ The computation to run-                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised-                      -> IO a-catchGErrorJustDomain action handler = catch action handler'-  where handler' gerror = do-          quark <- gErrorQuarkFromDomain (gerrorClassDomain (undefined :: err))-          domain <- gerrorDomain gerror-          if domain == quark-          then do-            code <- (toEnum . fromIntegral) <$> gerrorCode gerror-            msg <- gerrorMessage gerror-            handler code msg-          else throw gerror---- | A verson of 'handleGErrorJust' with the arguments swapped around.-handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a-handleGErrorJust code = flip (catchGErrorJust code)---- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.-handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a-handleGErrorJustDomain = flip catchGErrorJustDomain---- | Run the given function catching possible 'GError's in its--- execution. If a 'GError' is emitted this throws the corresponding--- exception.-propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a-propagateGError f = checkGError f throw---- | Like 'propagateGError', but allows to specify a custom handler--- instead of just throwing the exception.-checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a-checkGError f handler = do-  gerrorPtr <- allocMem-  poke gerrorPtr nullPtr-  result <- f gerrorPtr-  gerror <- peek gerrorPtr-  freeMem gerrorPtr-  if gerror /= nullPtr-  then wrapBoxed GError gerror >>= handler-  else return result---- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a--- copy in the passed in pointer, unless the pointer is `nullPtr`.-maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO ()-maybePokeGError _ Nothing = return ()-maybePokeGError ptrPtr (Just gerror)-  | ptrPtr == nullPtr = return ()-  | otherwise = copyBoxed gerror >>= poke ptrPtr
Data/GI/Base/GHashTable.hsc view
@@ -21,24 +21,18 @@     , gStrEqual     , cstringPackPtr     , cstringUnpackPtr+    , gvaluePackPtr+    , gvalueUnpackPtr     ) where -import Data.Int-import Data.Word- import Foreign.C-import Foreign.Ptr (Ptr, castPtr, FunPtr)+import Foreign.Ptr (Ptr, castPtr) -import Data.GI.Base.BasicTypes (PtrWrapped(..))+import Data.GI.Base.BasicTypes (PtrWrapped(..), GHashFunc, GEqualFunc)+import Data.GI.Base.GValue (GValue)  #include <glib-object.h> --- | A pointer to a hashing function on the C side.-type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})---- | A pointer to an equality checking function on the C side.-type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})- -- | Compute the hash for a `Ptr`. foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a) @@ -66,3 +60,12 @@ -- | Extract a `CString` wrapped into a `Ptr` coming from a `GHashTable`. cstringUnpackPtr :: PtrWrapped CString -> CString cstringUnpackPtr = ptrUnpackPtr++-- | Pack a `Ptr` to `GValue` into a `Ptr` than can go into a `GHashTable`.+gvaluePackPtr :: Ptr GValue -> PtrWrapped (Ptr GValue)+gvaluePackPtr = ptrPackPtr++-- | Extract a `Ptr` to `GValue` wrapped into a `Ptr` coming from a+-- `GHashTable`.+gvalueUnpackPtr :: PtrWrapped (Ptr GValue) -> Ptr GValue+gvalueUnpackPtr = ptrUnpackPtr
Data/GI/Base/GObject.hsc view
@@ -1,22 +1,94 @@-{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} +-- | This module constains helpers for dealing with `GObject`-derived+-- types.+ module Data.GI.Base.GObject-    ( constructGObject+    ( -- * Constructing new `GObject`s+      constructGObject     , new'++    -- * User data+    , gobjectGetUserData+    , gobjectSetUserData+    , gobjectModifyUserData++    -- * Deriving new object types+    , DerivedGObject(..)+    , registerGType+    , gobjectGetPrivateData+    , gobjectSetPrivateData+    , gobjectModifyPrivateData++    , GObjectClass(..)+    , gtypeFromClass+    , gtypeFromInstance++    -- * Installing properties for derived objects+    , gobjectInstallProperty+    , gobjectInstallCIntProperty+    , gobjectInstallCStringProperty+    , gobjectInstallGBooleanProperty     ) where +import Data.Maybe (catMaybes)+import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO)+ import Data.Proxy (Proxy(..))+import Data.Coerce (coerce)  import Foreign.C (CUInt(..), CString, newCString)-import Foreign+import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, nullFunPtr)+import Foreign.StablePtr (newStablePtr, deRefStablePtr,+                          castStablePtrToPtr, castPtrToStablePtr)+import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf))+import Foreign (mallocBytes, copyBytes, free) +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+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)-import Data.GI.Base.BasicTypes (GType(..), GObject(..), ManagedPtr)+                                attrConstruct, attrTransfer,+                                AttrInfo(..), EqMaybe(..), bindPropToField)+import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, GSList,+                                GDestroyNotify, ManagedPtr(..), GParamSpec(..),+                                TypedObject(glibType),+                                gtypeName, g_slist_free)+import Data.GI.Base.BasicConversions (withTextCString, cstringToText,+                                      packGSList, mapGSList)+import Data.GI.Base.CallStack (HasCallStack, prettyCallStack)+import Data.GI.Base.DynVal (modelProxyCurrentValue, modelProxyRegisterHandler,+                            dvKeys, dvRead)+import Data.GI.Base.GParamSpec (PropertyInfo(..),+                                gParamSpecValue,+                                CIntPropertyInfo(..), CStringPropertyInfo(..),+                                GBooleanPropertyInfo(..),+                                gParamSpecCInt, gParamSpecCString, gParamSpecGBoolean,+                                getGParamSpecGetterSetter,+                                PropGetSetter(..))+import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString) import Data.GI.Base.GValue (GValue(..), GValueConstruct(..))-import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject)+import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject,+                                newObject) import Data.GI.Base.Overloading (ResolveAttribute)+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> @@ -24,32 +96,97 @@     GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b)  -- | Construct a GObject given the constructor and a list of settable--- attributes.+-- attributes. See `Data.GI.Base.Constructible.new` for a more general+-- version. constructGObject :: forall o m. (GObject o, MonadIO m)     => (ManagedPtr o -> o)     -> [AttrOp o 'AttrConstruct]     -> m o constructGObject constructor attrs = liftIO $ do-  props <- mapM construct attrs-  doConstructGObject constructor props+  props <- catMaybes <$> mapM construct attrs+  obj <- doConstructGObject constructor props+  mapM_ (setSignal obj) attrs+  mapM_ (registerHandlers obj) attrs+  return obj   where-    resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)-    resolve _ = Proxy-     construct :: AttrOp o 'AttrConstruct ->-                 IO (GValueConstruct o)-    construct (attr := x) = attrConstruct (resolve attr) x-    construct (attr :=> x) = x >>= attrConstruct (resolve attr)+                 IO (Maybe (GValueConstruct o))+    construct ((_attr :: AttrLabelProxy label) := x) =+      Just <$> attrConstruct @(ResolveAttribute label o) x +    construct ((_attr :: AttrLabelProxy label) :=> x) =+      Just <$> (x >>= attrConstruct @(ResolveAttribute label o))++    construct ((_attr :: AttrLabelProxy label) :&= x) = Just <$>+      (attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>=+       attrConstruct @(ResolveAttribute label o))++    construct ((_attr :: AttrLabelProxy label) :!<~ dv) = do+      model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+      Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model)++    construct (Bind (_pattr :: AttrLabelProxy prop)+                    (_fattr :: AttrLabelProxy field)) = do+      model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+      let lens = getLens (Proxy @field) model+          value = O.view lens model+      Just <$> attrConstruct @(ResolveAttribute prop o) value+        where getLens :: forall path components model value.+                         (components ~ Components path,+                          PathFieldAccess components model value) =>+                         Proxy path -> model -> O.Lens' model value+              getLens _ _ = let+                (lens, _) = pathFieldAccess (Proxy @components) (Proxy @model)+                in lens++    -- Since we are constructing the object there's nothing to compare+    -- to, so we just set the value.+    construct ((_attr :: AttrLabelProxy label) :<~ dv) = do+      model <- modelProxyCurrentValue ?_haskell_gi_modelProxy+      Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model)++    construct (On _ _) = return Nothing+    construct (After _ _) = return Nothing++    setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()+    setSignal obj (On signal callback) = void $ on obj signal callback+    setSignal obj (After signal callback) = void $ after obj signal callback+    setSignal _ _ = return ()++    registerHandlers :: GObject o => o -> AttrOp o 'AttrConstruct -> IO ()+    registerHandlers obj ((_attr :: AttrLabelProxy label) :!<~ dv) =+      modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel ->+        attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel)++    registerHandlers obj ((_attr :: AttrLabelProxy label) :<~ dv) =+      modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do+      current <- attrGet @(ResolveAttribute label o) obj+      let modifiedValue = dvRead dv modifiedModel+      when (not $ eqMaybe modifiedValue current) $+         attrSet @(ResolveAttribute label o) obj modifiedValue++    registerHandlers obj (Bind pattr fattr) =+      bindPropToField (Proxy @'AttrConstruct) obj pattr fattr++    registerHandlers _ _ = pure ()++-- | Construct the given `GObject`, given a set of actions+-- constructing desired `GValue`s to set at construction time.+new' :: (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   names <- mallocBytes (nprops * sizeOf nullPtr)   values <- mallocBytes (nprops * gvalueSize)   fill names values props-  gtype <- gobjectType (undefined :: o)+  gtype <- glibType @o   result <- g_object_new gtype (fromIntegral nprops) names values   freeStrings nprops names   free values@@ -89,10 +226,300 @@         do peek namePtr >>= free            freeStrings (n-1) (namePtr `plusPtr` sizeOf nullPtr) --- | Construct the given `GObject`, given a set of actions--- constructing desired `GValue`s to set at construction time.-new' :: (MonadIO m, GObject o) =>-        (ManagedPtr o -> o) -> [IO (GValueConstruct o)] -> m o-new' constructor actions = do-  props <- liftIO $ sequence (actions)-  doConstructGObject constructor props+-- | Wrapper around @GObjectClass@ on the C-side.+newtype GObjectClass = GObjectClass (Ptr GObjectClass)++-- | This typeclass contains the data necessary for defining a new+-- `GObject` type from Haskell.+class GObject a => DerivedGObject a where+  -- | The parent type+  type GObjectParentType a+  -- | Type of the private data for each instance.+  type GObjectPrivateData a++  -- | Name of the type, it should be unique.+  objectTypeName     :: Text++  -- | Code to run when the class is inited. This is a good place to+  -- register signals and properties for the type.+  objectClassInit    :: GObjectClass -> IO ()++  -- | Code to run when each instance of the type is+  -- constructed. Returns the private data to be associated with the+  -- new instance (use `gobjectGetPrivateData` and+  -- `gobjectSetPrivateData` to manipulate this further).+  objectInstanceInit :: GObjectClass -> 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)++type CGTypeInstanceInit o = Ptr o -> GObjectClass -> IO ()+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) -> Ptr (GSList a) -> IO CGType++foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class ::+        GObjectClass -> IO CGType++-- | Find the `GType` associated to a given `GObjectClass`.+gtypeFromClass :: GObjectClass -> IO GType+gtypeFromClass klass = GType <$> gtype_from_class klass++foreign import ccall "haskell_gi_gtype_from_instance" gtype_from_instance ::+        Ptr o -> IO CGType++-- | Find the `GType` for a given `GObject`.+gtypeFromInstance :: GObject o => o -> IO GType+gtypeFromInstance obj = withManagedPtr obj $ \objPtr ->+                            (GType <$> gtype_from_instance objPtr)++foreign import ccall g_param_spec_get_name ::+   Ptr GParamSpec -> IO CString++type CPropertyGetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO ()++foreign import ccall "wrapper"+        mkPropertyGetter :: CPropertyGetter o -> IO (FunPtr (CPropertyGetter o))++type CPropertySetter o = Ptr o -> CUInt -> Ptr GValue -> Ptr GParamSpec -> IO ()++foreign import ccall "wrapper"+        mkPropertySetter :: CPropertySetter o -> IO (FunPtr (CPropertySetter o))++-- | Register the given type into the @GObject@ type system and return+-- the resulting `GType`, if it has not been registered already. If+-- the type has been registered already the existing `GType` will be+-- returned instead.+--+-- Note that for this function to work the type must be an instance of+-- `DerivedGObject`.+registerGType :: forall o. (HasCallStack, DerivedGObject o,+                            GObject (GObjectParentType o),+                            GObject o) =>+                 (ManagedPtr o -> o) -> IO GType+registerGType construct = withTextCString (objectTypeName @o) $ \cTypeName -> do+  cgtype <- g_type_from_name cTypeName+  if cgtype /= 0+    then return (GType cgtype)  -- Already registered+    else do+      classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o)+      instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o)+      (GType parentCGType) <- glibType @(GObjectParentType o)+      interfaces <- mapM packInterface (objectInterfaces @o) >>= packGSList+      gtype <- GType <$> register_gtype parentCGType cTypeName classInit instanceInit interfaces+      mapGSList freeInterfaceInfo interfaces+      g_slist_free interfaces+      return gtype++   where+     unwrapInstanceInit :: (GObjectClass -> o -> IO (GObjectPrivateData o)) ->+                           CGTypeInstanceInit o+     unwrapInstanceInit instanceInit objPtr klass = do+       privateData <- do+         obj <- newObject construct (castPtr objPtr :: Ptr o)+         instanceInit klass obj+       instanceSetPrivateData objPtr privateData++     unwrapClassInit :: (GObjectClass -> IO ()) -> CGTypeClassInit+     unwrapClassInit classInit klass@(GObjectClass klassPtr) = do+       getFunPtr <- mkPropertyGetter marshallGetter+       (#poke GObjectClass, get_property) klassPtr getFunPtr+       setFunPtr <- mkPropertySetter marshallSetter+       (#poke GObjectClass, set_property) klassPtr setFunPtr+       classInit klass++     marshallSetter :: CPropertySetter o+     marshallSetter objPtr _ gvPtr pspecPtr = do+       maybeGetSet <- getGParamSpecGetterSetter pspecPtr+       case maybeGetSet of+         Nothing -> do+           pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText+           typeName <- glibType @o >>= gtypeName+           dbgLog $ "WARNING: Attempting to set unknown property \""+                    <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"."+         Just pgs -> (propSetter pgs) objPtr gvPtr++     marshallGetter :: CPropertyGetter o+     marshallGetter objPtr _ destGValuePtr pspecPtr = do+       maybeGetSet <- getGParamSpecGetterSetter pspecPtr+       case maybeGetSet of+         Nothing -> do+           pspecName <- g_param_spec_get_name pspecPtr >>= cstringToText+           typeName <- glibType @o >>= gtypeName+           dbgLog $ "WARNING: Attempting to get unknown property \""+                    <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"."+         Just pgs -> (propGetter pgs) objPtr destGValuePtr++     packInterface :: (IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))+                   -> IO (Ptr CGType)+     packInterface (ifaceGTypeConstruct, initHs, maybeFinalize) = do+       gtype <- ifaceGTypeConstruct+       info <- callocBytes #{size GInterfaceInfo}+       initFn <- mkInterfaceInit (unwrapInit initHs)+       finalizeFn <- case maybeFinalize of+                     Just finalizeHs -> mkInterfaceFinalize (unwrapFinalize finalizeHs)+                     Nothing -> pure nullFunPtr+       #{poke GInterfaceInfo, interface_init} info initFn+       #{poke GInterfaceInfo, interface_finalize} info finalizeFn++       combined <- callocBytes (#{size GType} + #{size gpointer})+       poke combined (gtypeToCGType gtype)+       poke (combined `plusPtr` #{size GType}) info+       return combined++     unwrapInit :: (Ptr () -> IO ()) -> CGTypeInterfaceInit+     unwrapInit f ptr _data = f ptr++     unwrapFinalize :: (Ptr () -> IO ()) -> CGTypeInterfaceFinalize+     unwrapFinalize = unwrapInit++     freeInterfaceInfo :: Ptr CGType -> IO ()+     freeInterfaceInfo combinedPtr = do+       info <- peek (combinedPtr `plusPtr` #{size GType})+       freeMem info+       freeMem combinedPtr++-- | Quark with the key to the private data for this object type.+privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o))+privateKey = gQuarkFromString $ objectTypeName @o <> "::haskell-gi-private-data"++-- | Get the private data associated with the given object.+gobjectGetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>+                            o -> IO (GObjectPrivateData o)+gobjectGetPrivateData obj = do+  key <- privateKey @o+  maybePriv <- gobjectGetUserData obj key+  case maybePriv of+    Just priv -> return priv+    Nothing -> do+      case managedPtrAllocCallStack (coerce obj) of+        Nothing -> error ("Failed to get private data pointer!\n"+                          <> "Set the env var HASKELL_GI_DEBUG_MEM=1 to get more info.")+        Just cs -> withManagedPtr obj $ \objPtr -> do+          let errMsg = "Failed to get private data pointer for" <> show objPtr <> "!\n"+                       <> "Callstack for allocation was:\n"+                       <> prettyCallStack cs <> "\n\n"+          error errMsg++foreign import ccall g_object_get_qdata ::+   Ptr a -> GQuark b -> IO (Ptr c)++-- | Get the value of a given key for the object.+gobjectGetUserData :: (HasCallStack, GObject o) => o -> GQuark a -> IO (Maybe a)+gobjectGetUserData obj key = do+  dataPtr <- withManagedPtr obj $ \objPtr ->+                 g_object_get_qdata objPtr key+  if dataPtr /= nullPtr+    then Just <$> deRefStablePtr (castPtrToStablePtr dataPtr)+    else return Nothing++foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr ::+        GDestroyNotify (Ptr ())++foreign import ccall g_object_set_qdata_full ::+        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+-- freed when the object is destroyed, or the value is replaced.+gobjectSetUserData :: (HasCallStack, GObject o) =>+                   o -> GQuark a -> a -> IO ()+gobjectSetUserData obj key value = withManagedPtr obj $ \objPtr ->+  instanceSetUserData objPtr key value++-- | A combination of `gobjectGetUserData` and `gobjectSetUserData`,+-- for convenience.+gobjectModifyUserData :: (HasCallStack, GObject o) =>+                   o -> GQuark a -> (Maybe a -> a) -> IO ()+gobjectModifyUserData obj key transform = do+  userData <- gobjectGetUserData obj key+  gobjectSetUserData obj key (transform userData)++-- | Like `gobjectSetUserData`, but it works on the raw object pointer.+-- Note that this is unsafe, unless used in a context where we are sure that+-- the GC will not release the object while we run.+instanceSetUserData :: (HasCallStack, GObject o) =>+                    Ptr o -> GQuark a -> a -> IO ()+instanceSetUserData objPtr key value = do+  stablePtr <- newStablePtr value+  g_object_set_qdata_full objPtr key (castStablePtrToPtr stablePtr)+                             ptr_to_hs_free_stable_ptr++-- | Set the private data associated with the given object.+gobjectSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>+                         o -> GObjectPrivateData o -> IO ()+gobjectSetPrivateData obj value = withManagedPtr obj $ \objPtr ->+  instanceSetPrivateData objPtr value++-- | Set the private data for a given instance.+instanceSetPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>+                          Ptr o -> GObjectPrivateData o -> IO ()+instanceSetPrivateData objPtr priv = do+  key <- privateKey @o+  instanceSetUserData objPtr key priv++foreign import ccall g_object_class_install_property ::+   GObjectClass -> CUInt -> Ptr GParamSpec -> IO ()++-- | Modify the private data for the given object.+gobjectModifyPrivateData :: forall o. (HasCallStack, DerivedGObject o) =>+                         o -> (GObjectPrivateData o -> GObjectPrivateData o)+                         -> IO ()+gobjectModifyPrivateData obj transform = do+  private <- gobjectGetPrivateData obj+  gobjectSetPrivateData obj (transform private)++-- | Add a Haskell object-valued property to the given object class.+gobjectInstallProperty :: DerivedGObject o =>+                            GObjectClass -> PropertyInfo o a -> IO ()+gobjectInstallProperty klass propInfo = do+  pspec <- gParamSpecValue propInfo+  withManagedPtr pspec $ \pspecPtr ->+    g_object_class_install_property klass 1 pspecPtr++-- | Add a `Foreign.C.CInt`-valued property to the given object class.+gobjectInstallCIntProperty :: DerivedGObject o =>+                              GObjectClass -> CIntPropertyInfo o -> IO ()+gobjectInstallCIntProperty klass propInfo = do+  pspec <- gParamSpecCInt propInfo+  withManagedPtr pspec $ \pspecPtr ->+    g_object_class_install_property klass 1 pspecPtr++-- | Add a `CString`-valued property to the given object class.+gobjectInstallCStringProperty :: DerivedGObject o =>+                              GObjectClass -> CStringPropertyInfo o -> IO ()+gobjectInstallCStringProperty klass propInfo = do+  pspec <- gParamSpecCString propInfo+  withManagedPtr pspec $ \pspecPtr ->+    g_object_class_install_property klass 1 pspecPtr++-- | 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
@@ -1,23 +1,57 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Management of `GParamSpec`s. module Data.GI.Base.GParamSpec-    ( noGParamSpec+  ( -- * Memory management+    wrapGParamSpecPtr+  , newGParamSpecFromPtr+  , unrefGParamSpec+  , disownGParamSpec -    , wrapGParamSpecPtr-    , newGParamSpecFromPtr-    , unrefGParamSpec-    , disownGParamSpec-    ) where+  -- * GParamSpec building+  , PropertyInfo(..)+  , gParamSpecValue+  , CStringPropertyInfo(..)+  , gParamSpecCString+  , CIntPropertyInfo(..)+  , gParamSpecCInt+  , GBooleanPropertyInfo(..)+  , gParamSpecGBoolean+  , GParamFlag(..) -import Foreign.Ptr+  -- * Get\/Set+  , PropGetSetter(..)+  , getGParamSpecGetterSetter+  ) where++import Foreign.C (CInt(..), CString)+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)+import Foreign.StablePtr (newStablePtr, deRefStablePtr,+                          castStablePtrToPtr, castPtrToStablePtr) import Control.Monad (void)+import Data.Coerce (coerce)+import Data.Int+import Data.Maybe (fromMaybe)+import Data.Text (Text) -import Data.GI.Base.ManagedPtr (newManagedPtr', withManagedPtr, disownManagedPtr)-import Data.GI.Base.BasicTypes (GParamSpec(..))+import Data.GI.Base.ManagedPtr (newManagedPtr', withManagedPtr,+                                disownManagedPtr,+                                newObject, withTransient)+import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString)+import Data.GI.Base.BasicTypes (GObject, GParamSpec(..),+                                GType(..), IsGFlag, ManagedPtr)+import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString)+import Data.GI.Base.GType (gtypeStablePtr)+import qualified Data.GI.Base.GValue as GV+import Data.GI.Base.GValue (GValue(..), IsGValue(..), take_stablePtr)  #include <glib-object.h> -noGParamSpec :: Maybe GParamSpec-noGParamSpec = Nothing- foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink ::     Ptr GParamSpec -> IO (Ptr GParamSpec) foreign import ccall "g_param_spec_ref" g_param_spec_ref ::@@ -50,3 +84,318 @@ -- collected. disownGParamSpec :: GParamSpec -> IO (Ptr GParamSpec) disownGParamSpec = disownManagedPtr++{- | Flags controlling the behaviour of the the parameters. -}+data GParamFlag = GParamReadable+                 {- ^ the parameter is readable -}+                 | GParamWritable+                 {- ^ the parameter is writable -}+                 | GParamConstruct+                 {- ^ the parameter will be set upon object construction -}+                 | GParamConstructOnly+                 {- ^ the parameter can only be set upon object construction -}+                 | GParamExplicitNotify+                 {- ^ calls to 'GI.GObject.Objects.Object.objectSetProperty' for this+property will not automatically result in a \"notify\" signal being+emitted: the implementation must call+'GI.GObject.Objects.Object.objectNotify' themselves in case the+property actually changes. -}+                 | AnotherGParamFlag Int+                 -- ^ Catch-all for unknown values+                 deriving (Show, Eq)++instance Enum GParamFlag where+    fromEnum GParamReadable = #const G_PARAM_READABLE+    fromEnum GParamWritable = #const G_PARAM_WRITABLE+    fromEnum GParamConstruct = #const G_PARAM_CONSTRUCT+    fromEnum GParamConstructOnly = #const G_PARAM_CONSTRUCT_ONLY+    fromEnum GParamExplicitNotify = #const G_PARAM_EXPLICIT_NOTIFY+    fromEnum (AnotherGParamFlag k) = k++    toEnum (#const G_PARAM_READABLE) = GParamReadable+    toEnum (#const G_PARAM_WRITABLE) = GParamWritable+    toEnum (#const G_PARAM_CONSTRUCT) = GParamConstruct+    toEnum (#const G_PARAM_CONSTRUCT_ONLY) = GParamConstructOnly+    toEnum (#const G_PARAM_EXPLICIT_NOTIFY) = GParamExplicitNotify+    toEnum k = AnotherGParamFlag k++instance Ord GParamFlag where+    compare a b = compare (fromEnum a) (fromEnum b)++instance IsGFlag GParamFlag++-- | Default set of flags when constructing properties.+defaultFlags :: Num a => a+defaultFlags = gflagsToWord [GParamReadable, GParamWritable,+                             GParamExplicitNotify]++-- | Low-level getter and setter for the property.+data PropGetSetter o = PropGetSetter+  { propGetter :: Ptr o -> Ptr GValue -> IO ()+  , propSetter :: Ptr o -> Ptr GValue -> IO ()+  }++-- | The `GQuark` pointing to the setter and getter of the property.+pspecQuark :: IO (GQuark (PropGetSetter o))+pspecQuark = gQuarkFromString "haskell-gi-get-set"++-- | The basic constructor for a GObject. They are all isomorphic.+newtype GObjectConstructor = GObjectConstructor (ManagedPtr GObjectConstructor)++-- | Construct a copy of the object from the given pointer.+objectFromPtr :: forall a o. GObject o => Ptr a -> IO o+objectFromPtr objPtr = newObject @o @o (coerce @_ @(ManagedPtr o -> o) GObjectConstructor) (castPtr objPtr)++-- | Wrap a Haskell getter/setter into a lower level one.+wrapGetSet :: forall o a. (GObject o, IsGValue a) =>+              (o -> IO a)       -- ^ Haskell side getter+           -> (o -> a -> IO ()) -- ^ Haskell side setter+           -> (Ptr GValue -> a -> IO ()) -- ^ Setter for the `GValue`+           -> PropGetSetter o+wrapGetSet getter setter gvalueSetter = PropGetSetter {+  propGetter = \objPtr destPtr -> do+      value <- objectFromPtr objPtr >>= getter+      gvalueSetter destPtr value+  , propSetter = \objPtr newGValuePtr ->+      withTransient newGValuePtr $ \newGValue -> do+        obj <- objectFromPtr objPtr+        value <- GV.fromGValue newGValue+        setter obj value+  }++-- | Information on a property encoding a Haskell value. Note that+-- from the C side this property will appear as an opaque pointer. Use+-- the specialized constructors below for creating properties+-- meaningful from the C side.+--+-- A property name consists of segments consisting of ASCII letters+-- and digits, separated by either the \'-\' or \'_\' character. The+-- first character of a property name must be a letter. Names which+-- violate these rules lead to undefined behaviour.+--+-- When creating and looking up a property, either separator can be+-- used, but they cannot be mixed. Using \'-\' is considerably more+-- efficient and in fact required when using property names as detail+-- strings for signals.+--+-- Beyond the name, properties have two more descriptive strings+-- associated with them, the @nick@, which should be suitable for use+-- as a label for the property in a property editor, and the @blurb@,+-- which should be a somewhat longer description, suitable for e.g. a+-- tooltip. The @nick@ and @blurb@ should ideally be localized.+data PropertyInfo o a = PropertyInfo+  { name    :: Text              -- ^ Identifier for the property.+  , nick    :: Text              -- ^ Identifier for display to the user.+  , blurb   :: Text              -- ^ Description of the property.+  , setter :: o -> a -> IO ()    -- ^ Handler invoked when the+                                 -- property is being set.+  , getter :: o -> IO a          -- ^ Handler that returns the current+                                 -- value of the property.+  , flags   :: Maybe [GParamFlag] -- ^ Set of flags, or `Nothing` for+                                 -- the default set of flags.+  }++foreign import ccall g_param_spec_boxed ::+  CString -> CString -> CString -> GType -> CInt -> IO (Ptr GParamSpec)++-- | Create a `GParamSpec` for a Haskell value.+gParamSpecValue :: forall o a. GObject o => PropertyInfo o a -> IO GParamSpec+gParamSpecValue (PropertyInfo {..}) =+  withTextCString name $ \cname ->+    withTextCString nick $ \cnick ->+      withTextCString blurb $ \cblurb -> do+        pspecPtr <- g_param_spec_boxed cname cnick cblurb+                       gtypeStablePtr+                       (maybe defaultFlags gflagsToWord flags)+        quark <- pspecQuark @o+        gParamSpecSetQData pspecPtr quark+          (PropGetSetter { propGetter = getter', propSetter = setter'})+        wrapGParamSpecPtr pspecPtr+  where+    getter' :: Ptr o -> Ptr GValue -> IO ()+    getter' objPtr destPtr = do+      stablePtr <- objectFromPtr objPtr >>= getter >>= newStablePtr+      take_stablePtr destPtr stablePtr++    setter' :: Ptr o -> (Ptr GValue) -> IO ()+    setter' objPtr gvPtr = withTransient gvPtr $ \gv -> do+      obj <- objectFromPtr objPtr+      val <- GV.fromGValue gv >>= deRefStablePtr+      setter obj val++-- | Information on a property of type `CInt` to be registered. A+-- property name consists of segments consisting of ASCII letters and+-- digits, separated by either the \'-\' or \'_\' character. The first+-- character of a property name must be a letter. Names which violate+-- these rules lead to undefined behaviour.+--+-- When creating and looking up a property, either separator can be+-- used, but they cannot be mixed. Using \'-\' is considerably more+-- efficient and in fact required when using property names as detail+-- strings for signals.+--+-- Beyond the name, properties have two more descriptive strings+-- associated with them, the @nick@, which should be suitable for use+-- as a label for the property in a property editor, and the @blurb@,+-- which should be a somewhat longer description, suitable for e.g. a+-- tooltip. The @nick@ and @blurb@ should ideally be localized.+data CIntPropertyInfo o = CIntPropertyInfo+  { name    :: Text              -- ^ Identifier for the property.+  , nick    :: Text              -- ^ Identifier for display to the user.+  , blurb   :: Text              -- ^ Description of the property.+  , defaultValue :: CInt         -- ^ Default value.+  , setter :: o -> CInt -> IO () -- ^ Handler invoked when the+                                 -- property is being set.+  , getter :: o -> IO CInt       -- ^ Handler that returns the current+                                 -- value of the property.+  , flags   :: Maybe [GParamFlag] -- ^ Set of flags, or `Nothing` for+                                 -- the default set of flags.+  , minValue :: Maybe CInt       -- ^ Minimum value, or `Nothing`,+                                 -- which would be replaced by+                                 -- @MININT@.+  , maxValue :: Maybe CInt       -- ^ Maximum value, or `Nothing`,+                                 -- which would be replaced by+                                 -- @MAXINT@.+  }++foreign import ccall g_param_spec_int ::+   CString -> CString -> CString -> CInt -> CInt -> CInt -> CInt+        -> IO (Ptr GParamSpec)++-- | Create a `GParamSpec` for an integer param.+gParamSpecCInt :: GObject o => CIntPropertyInfo o -> IO GParamSpec+gParamSpecCInt (CIntPropertyInfo {..}) =+  withTextCString name $ \cname ->+    withTextCString nick $ \cnick ->+      withTextCString blurb $ \cblurb -> do+        pspecPtr <- g_param_spec_int cname cnick cblurb+                                     (fromMaybe minBound minValue)+                                     (fromMaybe maxBound maxValue)+                                     defaultValue+                                     (maybe defaultFlags gflagsToWord flags)+        quark <- pspecQuark+        gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_)+        wrapGParamSpecPtr pspecPtr++-- | Information on a property of type `Text` to be registered. A+-- property name consists of segments consisting of ASCII letters and+-- digits, separated by either the \'-\' or \'_\' character. The first+-- character of a property name must be a letter. Names which violate+-- these rules lead to undefined behaviour.+--+-- When creating and looking up a property, either separator can be+-- used, but they cannot be mixed. Using \'-\' is considerably more+-- efficient and in fact required when using property names as detail+-- strings for signals.+--+-- Beyond the name, properties have two more descriptive strings+-- associated with them, the @nick@, which should be suitable for use+-- as a label for the property in a property editor, and the @blurb@,+-- which should be a somewhat longer description, suitable for e.g. a+-- tooltip. The @nick@ and @blurb@ should ideally be localized.+data CStringPropertyInfo o = CStringPropertyInfo+  { name   :: Text+  , nick   :: Text+  , blurb  :: Text+  , defaultValue :: Maybe Text+  , flags  :: Maybe [GParamFlag]+  , setter :: o -> Maybe Text -> IO ()+  , getter :: o -> IO (Maybe Text)+  }++foreign import ccall g_param_spec_string ::+  CString -> CString -> CString -> CString -> CInt -> IO (Ptr GParamSpec)++-- | Create a `GParamSpec` for a string param.+gParamSpecCString :: GObject o => CStringPropertyInfo o -> IO GParamSpec+gParamSpecCString (CStringPropertyInfo {..}) =+  withTextCString name $ \cname ->+    withTextCString nick $ \cnick ->+      withTextCString blurb $ \cblurb -> do+        pspecPtr <- case defaultValue of+          Nothing -> g_param_spec_string cname cnick cblurb nullPtr+                          (maybe defaultFlags gflagsToWord flags)+          Just value ->+            withTextCString value $ \cdefault ->+              g_param_spec_string cname cnick cblurb cdefault+                    (maybe defaultFlags gflagsToWord flags)+        quark <- pspecQuark+        gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_)+        wrapGParamSpecPtr pspecPtr++-- | Information on a property of type `type gboolean` to be registered. A+-- property name consists of segments consisting of ASCII letters and+-- digits, separated by either the \'-\' or \'_\' character. The first+-- character of a property name must be a letter. Names which violate+-- these rules lead to undefined behaviour.+--+-- When creating and looking up a property, either separator can be+-- used, but they cannot be mixed. Using \'-\' is considerably more+-- efficient and in fact required when using property names as detail+-- strings for signals.+--+-- Beyond the name, properties have two more descriptive strings+-- associated with them, the @nick@, which should be suitable for use+-- as a label for the property in a property editor, and the @blurb@,+-- which should be a somewhat longer description, suitable for e.g. a+-- tooltip. The @nick@ and @blurb@ should ideally be localized.+data GBooleanPropertyInfo o = GBooleanPropertyInfo+  { name   :: Text+  , nick   :: Text+  , blurb  :: Text+  , defaultValue :: Bool+  , flags  :: Maybe [GParamFlag]+  , setter :: o -> Bool -> IO ()+  , getter :: o -> IO (Bool)+  }++foreign import ccall g_param_spec_boolean ::+  CString -> CString -> CString -> #{type gboolean} -> CInt -> IO (Ptr GParamSpec)++-- | Create a `GParamSpec` for a bool param.+gParamSpecGBoolean :: GObject o => GBooleanPropertyInfo o -> IO GParamSpec+gParamSpecGBoolean (GBooleanPropertyInfo {..}) =+  withTextCString name $ \cname ->+    withTextCString nick $ \cnick ->+      withTextCString blurb $ \cblurb -> do+        pspecPtr <- g_param_spec_boolean cname cnick cblurb+                        ((fromIntegral . fromEnum) defaultValue)+                        (maybe defaultFlags gflagsToWord flags)+        quark <- pspecQuark+        gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_)+        wrapGParamSpecPtr pspecPtr++foreign import ccall g_param_spec_set_qdata_full ::+  Ptr GParamSpec -> GQuark a -> Ptr b -> FunPtr (Ptr c -> IO ()) -> IO ()++foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr ::+        FunPtr (Ptr a -> IO ())++-- | Set the given user data on the `GParamSpec`.+gParamSpecSetQData :: Ptr GParamSpec -> GQuark a -> a -> IO ()+gParamSpecSetQData pspecPtr quark d = do+  ptr <- newStablePtr d+  g_param_spec_set_qdata_full pspecPtr quark+                              (castStablePtrToPtr ptr)+                              ptr_to_hs_free_stable_ptr++foreign import ccall g_param_spec_get_qdata ::+  Ptr GParamSpec -> GQuark a -> IO (Ptr b)++-- | Get the user data for the given `GQuark` on the `GParamSpec`.+gParamSpecGetQData :: Ptr GParamSpec -> GQuark a -> IO (Maybe a)+gParamSpecGetQData pspecPtr quark = do+  ptr <- g_param_spec_get_qdata pspecPtr quark+  if ptr /= nullPtr+    then Just <$> deRefStablePtr (castPtrToStablePtr ptr)+    else return Nothing++-- | Attempt to get the Haskell setter and getter for the given+-- `GParamSpec`. This will only be possible if the `GParamSpec` was+-- created with one of the functions above, if this is not the case+-- the function will return `Nothing`.+getGParamSpecGetterSetter :: forall o. Ptr GParamSpec ->+                              IO (Maybe (PropGetSetter o))+getGParamSpecGetterSetter pspecPtr = do+  quark <- pspecQuark @o+  gParamSpecGetQData pspecPtr quark
+ Data/GI/Base/GQuark.hsc view
@@ -0,0 +1,22 @@+-- | Basic support for `GQuark`s.+module Data.GI.Base.GQuark+  ( GQuark(..)+  , gQuarkFromString+  ) where++import Data.Text (Text)+import Data.Word+import Foreign.C (CString)++import Data.GI.Base.BasicConversions (withTextCString)++#include <glib-object.h>++-- | A `GQuark`, which is simply an integer.+newtype GQuark a = GQuark (#type GQuark)++foreign import ccall g_quark_from_string :: CString -> IO (GQuark a)++-- | Construct a GQuark from the given string.+gQuarkFromString :: Text -> IO (GQuark a)+gQuarkFromString text = withTextCString text g_quark_from_string
Data/GI/Base/GType.hsc view
@@ -1,11 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | Basic `GType`s. module Data.GI.Base.GType-    ( GType(..)-    , CGType--    , gtypeName--    , gtypeString+    ( gtypeString     , gtypePointer     , gtypeInt     , gtypeUInt@@ -16,6 +13,7 @@     , gtypeFloat     , gtypeDouble     , gtypeBoolean+    , gtypeError     , gtypeGType     , gtypeStrv     , gtypeBoxed@@ -23,27 +21,16 @@     , gtypeVariant     , gtypeByteArray     , gtypeInvalid+    , gtypeParam++    , gtypeStablePtr+    , gtypeHValue     ) where -import Data.Word-import Foreign.C.String (CString, peekCString)+import Data.GI.Base.BasicTypes (GType(..), CGType)  #include <glib-object.h> --- | A type identifier in the GLib type system. This is the low-level--- type associated with the representation in memory, when using this--- on the Haskell side use `GType` below.-type CGType = #type GType---- | A newtype for use on the haskell side.-newtype GType = GType {gtypeToCGType :: CGType}--foreign import ccall "g_type_name" g_type_name :: GType -> IO CString---- | Get the name assigned to the given `GType`.-gtypeName :: GType -> IO String-gtypeName gtype = g_type_name gtype >>= peekCString- {-| [Note: compile-time vs run-time GTypes]  Notice that there are two types of GType's: the fundamental ones,@@ -68,19 +55,19 @@ gtypePointer :: GType gtypePointer = GType #const G_TYPE_POINTER --- | `GType` for signed integers (`gint` or `gint32`).+-- | `GType` for signed integers (@gint@ or @gint32@). gtypeInt :: GType gtypeInt = GType #const G_TYPE_INT --- | `GType` for unsigned integers (`guint` or `guint32`).+-- | `GType` for unsigned integers (@guint@ or @guint32@). gtypeUInt :: GType gtypeUInt = GType #const G_TYPE_UINT --- | `GType` for `glong`.+-- | `GType` for @glong@. gtypeLong :: GType gtypeLong = GType #const G_TYPE_LONG --- | `GType` for `gulong`.+-- | `GType` for @gulong@. gtypeULong :: GType gtypeULong = GType #const G_TYPE_ULONG @@ -104,11 +91,11 @@ gtypeBoolean :: GType gtypeBoolean = GType #const G_TYPE_BOOLEAN --- | `GType` corresponding to a `BoxedObject`.+-- | `GType` corresponding to a boxed object. gtypeBoxed :: GType gtypeBoxed = GType #const G_TYPE_BOXED --- | `GType` corresponding to a `GObject`.+-- | `GType` corresponding to a @GObject@. gtypeObject :: GType gtypeObject = GType #const G_TYPE_OBJECT @@ -117,10 +104,14 @@ gtypeInvalid :: GType gtypeInvalid = GType #const G_TYPE_INVALID --- | The `GType` corresponding to a `GVariant`.+-- | The `GType` corresponding to a @GVariant@. gtypeVariant :: GType gtypeVariant = GType #const G_TYPE_VARIANT +-- | The `GType` corresponding to 'Data.GI.Base.BasicTypes.GParamSpec'.+gtypeParam :: GType+gtypeParam = GType #const G_TYPE_PARAM+ {- Run-time types -}  foreign import ccall "g_gtype_get_type" g_gtype_get_type :: CGType@@ -137,6 +128,24 @@  foreign import ccall "g_byte_array_get_type" g_byte_array_get_type :: CGType --- | `GType` for a boxed type holding a `GByteArray`.+-- | `GType` for a boxed type holding a @GByteArray@. gtypeByteArray :: GType gtypeByteArray = GType g_byte_array_get_type++foreign import ccall haskell_gi_StablePtr_get_type :: CGType++-- | The `GType` for boxed `StablePtr`s.+gtypeStablePtr :: GType+gtypeStablePtr = GType haskell_gi_StablePtr_get_type++foreign import ccall haskell_gi_HaskellValue_get_type :: CGType++-- | The `GType` for a generic Haskell value.+gtypeHValue :: GType+gtypeHValue = GType haskell_gi_HaskellValue_get_type++foreign import ccall "g_error_get_type" g_error_get_type :: CGType++-- | The `GType` corresponding to 'Data.GI.Base.GError.GError'.+gtypeError :: GType+gtypeError = GType g_error_get_type
+ Data/GI/Base/GValue.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.GI.Base.GValue+    (+    -- * Constructing GValues+      GValue(..)+    , IsGValue(..)+    , toGValue+    , fromGValue+    , GValueConstruct(..)+    , ptr_to_gvalue_free++    , newGValue+    , buildGValue+    , disownGValue+    , noGValue+    , newGValueFromPtr+    , wrapGValuePtr+    , unsetGValue+    , gvalueType++    -- * Packing GValues into arrays+    , packGValueArray+    , unpackGValueArrayWithLength+    , mapGValueArrayWithLength++    -- * Packing Haskell values into GValues+    , HValue(..)++    -- * Setters and getters+    , set_object+    , get_object+    , set_boxed+    , get_boxed+    , set_variant+    , get_variant+    , set_enum+    , get_enum+    , set_flags+    , get_flags+    , set_stablePtr+    , get_stablePtr+    , take_stablePtr+    , set_param+    , get_param+    , set_hvalue+    , get_hvalue+    ) where++import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.Coerce (coerce)+import Data.Word+import Data.Int+import Data.Text (Text, pack, unpack)++import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),+                        CLong(..), CULong(..))+import Foreign.C.String (CString)+import Foreign.Ptr (Ptr, nullPtr, plusPtr, FunPtr)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr,+                          newStablePtr, deRefStablePtr)+import Type.Reflection (typeRep, TypeRep)+import System.IO (hPutStrLn, stderr)++import Data.Dynamic (toDyn, fromDynamic, Typeable)+import Data.GI.Base.BasicTypes+import Data.GI.Base.BasicConversions (cstringToText, textToCString)+import Data.GI.Base.GType+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Utils (callocBytes, freeMem)+import Data.GI.Base.Internal.CTypes (cgvalueSize)+import Data.GI.Base.Overloading (ParentTypes, HasParentTypes)++-- | Haskell-side representation of a @GValue@.+newtype GValue = GValue (ManagedPtr GValue)++-- | A pointer to a function freeing GValues.+foreign import ccall "&haskell_gi_gvalue_free" ptr_to_gvalue_free ::+    FunPtr (Ptr GValue -> IO ())++-- | There are no types in the bindings that a `GValue` can be safely+-- cast to.+type instance ParentTypes GValue = '[]+instance HasParentTypes GValue++foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::+    IO GType++-- | Find the associated `GType` for `GValue`.+instance TypedObject GValue where+  glibType = c_g_value_get_type++-- | `GValue`s are registered as boxed in the GLib type system.+instance GBoxed GValue++foreign import ccall "g_value_init" g_value_init ::+    Ptr GValue -> CGType -> IO (Ptr GValue)++-- | A type holding a `GValue` with an associated label. It is+-- parameterized by a phantom type encoding the target type for the+-- `GValue` (useful when constructing properties).+data GValueConstruct o = GValueConstruct String GValue++-- | Build a new, empty, `GValue` of the given type.+newGValue :: GType -> IO GValue+newGValue (GType gtype) = do+  gvptr <- callocBytes cgvalueSize+  _ <- g_value_init gvptr gtype+  gv <- wrapBoxed GValue gvptr+  return $! gv++-- | Take ownership of a passed in 'Ptr'.+wrapGValuePtr :: Ptr GValue -> IO GValue+wrapGValuePtr ptr = wrapBoxed GValue ptr++-- | Construct a Haskell wrapper for the given 'GValue', making a+-- copy.+newGValueFromPtr :: Ptr GValue -> IO GValue+newGValueFromPtr ptr = newBoxed GValue ptr++-- | A convenience function for building a new GValue and setting the+-- initial value.+buildGValue :: GType -> (Ptr GValue -> a -> IO ()) -> a -> IO GValue+buildGValue gtype setter val = do+  gv <- newGValue gtype+  withManagedPtr gv $ \gvPtr -> setter gvPtr val+  return gv++-- | Disown a `GValue`, i.e. do not unref the underlying object when+-- the Haskell object is garbage collected.+disownGValue :: GValue -> IO (Ptr GValue)+disownGValue = disownManagedPtr++foreign import ccall "_haskell_gi_g_value_get_type" g_value_get_type :: Ptr GValue -> IO CGType++-- | Return the `GType` contained by a `GValue`.+gvalueType :: GValue -> IO GType+gvalueType gv = withManagedPtr gv $ \gvptr -> do+  cgtype <- g_value_get_type gvptr+  return (GType cgtype)++foreign import ccall "g_value_unset" g_value_unset :: Ptr GValue -> IO ()++-- | Unset the `GValue`, freeing all resources associated to it.+unsetGValue :: Ptr GValue -> IO ()+unsetGValue = g_value_unset++-- | A convenient alias for @Nothing :: Maybe GValue@.+noGValue :: Maybe GValue+noGValue = Nothing++-- | Class for types that can be marshaled back and forth between+-- Haskell values and `GValue`s. These are low-level methods, you+-- might want to use `toGValue` and `fromGValue` instead for a higher+-- level interface.+class IsGValue a where+  gvalueGType_ :: IO GType     -- ^ `GType` for the `GValue`+                               -- containing values of this type.+  gvalueSet_   :: Ptr GValue -> a -> IO ()  -- ^ Set the `GValue` to+                                            -- the given Haskell+                                            -- value.+  gvalueGet_   :: Ptr GValue -> IO a -- ^ Get the Haskel value inside+                                     -- the `GValue`.++-- | Create a `GValue` from the given Haskell value.+toGValue :: forall a m. (IsGValue a, MonadIO m) => a -> m GValue+toGValue val = liftIO $ do+  gvptr <- callocBytes cgvalueSize+  GType gtype <- gvalueGType_ @a+  _ <- g_value_init gvptr gtype+  gvalueSet_ gvptr val+  gv <- wrapBoxed GValue gvptr+  return $! gv++-- | Create a Haskell object out of the given `GValue`.+fromGValue :: (IsGValue a, MonadIO m) => GValue -> m a+fromGValue gv = liftIO $ withManagedPtr gv gvalueGet_++instance IsGValue (Maybe String) where+  gvalueGType_ = return gtypeString+  gvalueSet_ gvPtr mstr = set_string gvPtr (pack <$> mstr)+  gvalueGet_ v = (fmap unpack) <$> get_string v++instance IsGValue (Maybe Text) where+  gvalueGType_ = return gtypeString+  gvalueSet_ = set_string+  gvalueGet_ = get_string++instance IsGValue (Ptr a) where+  gvalueGType_ = return gtypePointer+  gvalueSet_ = set_pointer+  gvalueGet_ = get_pointer++instance IsGValue Int32 where+  gvalueGType_ = return gtypeInt+  gvalueSet_ = set_int32+  gvalueGet_ = get_int32++instance IsGValue Word32 where+  gvalueGType_ = return gtypeUInt+  gvalueSet_ = set_uint32+  gvalueGet_ = get_uint32++instance IsGValue CInt where+  gvalueGType_ = return gtypeInt+  gvalueSet_ = set_int+  gvalueGet_ = get_int++instance IsGValue CUInt where+  gvalueGType_ = return gtypeUInt+  gvalueSet_ = set_uint+  gvalueGet_ = get_uint++instance IsGValue CLong where+  gvalueGType_ = return gtypeLong+  gvalueSet_ = set_long+  gvalueGet_ = get_long++instance IsGValue CULong where+  gvalueGType_ = return gtypeULong+  gvalueSet_ = set_ulong+  gvalueGet_ = get_ulong++instance IsGValue Int64 where+  gvalueGType_ = return gtypeInt64+  gvalueSet_ = set_int64+  gvalueGet_ = get_int64++instance IsGValue Word64 where+  gvalueGType_ = return gtypeUInt64+  gvalueSet_ = set_uint64+  gvalueGet_ = get_uint64++instance IsGValue Float where+  gvalueGType_ = return gtypeFloat+  gvalueSet_ = set_float+  gvalueGet_ = get_float++instance IsGValue Double where+  gvalueGType_ = return gtypeDouble+  gvalueSet_ = set_double+  gvalueGet_ = get_double++instance IsGValue Bool where+  gvalueGType_ = return gtypeBoolean+  gvalueSet_ = set_boolean+  gvalueGet_ = get_boolean++instance IsGValue GType where+  gvalueGType_ = return gtypeGType+  gvalueSet_ = set_gtype+  gvalueGet_ = get_gtype++instance IsGValue (StablePtr a) where+  gvalueGType_ = return gtypeStablePtr+  gvalueSet_ = set_stablePtr+  gvalueGet_ = get_stablePtr++instance IsGValue (Maybe GParamSpec) where+  gvalueGType_ = return gtypeParam+  gvalueSet_ = set_param+  gvalueGet_ = get_param++instance Typeable a => IsGValue (HValue a) where+  gvalueGType_ = return gtypeHValue+  gvalueSet_ = set_hvalue+  gvalueGet_ = get_hvalue++foreign import ccall "g_value_set_string" _set_string ::+    Ptr GValue -> CString -> IO ()+foreign import ccall "g_value_get_string" _get_string ::+    Ptr GValue -> IO CString++set_string :: Ptr GValue -> Maybe Text -> IO ()+set_string ptr maybeStr = do+  cstr <- case maybeStr of+            Just str -> textToCString str+            Nothing -> return nullPtr+  _set_string ptr cstr+  freeMem cstr++get_string :: Ptr GValue -> IO (Maybe Text)+get_string gvptr = do+  cstr <- _get_string gvptr+  if cstr /= nullPtr+    then Just <$> cstringToText cstr+    else return Nothing++foreign import ccall unsafe "g_value_set_pointer" set_pointer ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall unsafe "g_value_get_pointer" get_pointer ::+    Ptr GValue -> IO (Ptr b)++foreign import ccall unsafe "g_value_set_int" set_int ::+    Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_int" get_int ::+    Ptr GValue -> IO CInt++set_int32 :: Ptr GValue -> Int32 -> IO ()+set_int32 gv n = set_int gv (coerce n)++get_int32 :: Ptr GValue -> IO Int32+get_int32 gv = coerce <$> get_int gv++foreign import ccall unsafe "g_value_set_uint" set_uint ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_uint" get_uint ::+    Ptr GValue -> IO CUInt++set_uint32 :: Ptr GValue -> Word32 -> IO ()+set_uint32 gv n = set_uint gv (coerce n)++get_uint32 :: Ptr GValue -> IO Word32+get_uint32 gv = coerce <$> get_uint gv++foreign import ccall unsafe "g_value_set_long" set_long ::+    Ptr GValue -> CLong -> IO ()+foreign import ccall unsafe "g_value_get_long" get_long ::+    Ptr GValue -> IO CLong++foreign import ccall unsafe "g_value_set_ulong" set_ulong ::+    Ptr GValue -> CULong -> IO ()+foreign import ccall unsafe "g_value_get_ulong" get_ulong ::+    Ptr GValue -> IO CULong++foreign import ccall unsafe "g_value_set_int64" set_int64 ::+    Ptr GValue -> Int64 -> IO ()+foreign import ccall unsafe "g_value_get_int64" get_int64 ::+    Ptr GValue -> IO Int64++foreign import ccall unsafe "g_value_set_uint64" set_uint64 ::+    Ptr GValue -> Word64 -> IO ()+foreign import ccall unsafe "g_value_get_uint64" get_uint64 ::+    Ptr GValue -> IO Word64++foreign import ccall unsafe "g_value_set_float" _set_float ::+    Ptr GValue -> CFloat -> IO ()+foreign import ccall unsafe "g_value_get_float" _get_float ::+    Ptr GValue -> IO CFloat++set_float :: Ptr GValue -> Float -> IO ()+set_float gv f = _set_float gv (realToFrac f)++get_float :: Ptr GValue -> IO Float+get_float gv = realToFrac <$> _get_float gv++foreign import ccall unsafe "g_value_set_double" _set_double ::+    Ptr GValue -> CDouble -> IO ()+foreign import ccall unsafe "g_value_get_double" _get_double ::+    Ptr GValue -> IO CDouble++set_double :: Ptr GValue -> Double -> IO ()+set_double gv d = _set_double gv (realToFrac d)++get_double :: Ptr GValue -> IO Double+get_double gv = realToFrac <$> _get_double gv++foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::+    Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::+    Ptr GValue -> IO CInt++set_boolean :: Ptr GValue -> Bool -> IO ()+set_boolean gv b = _set_boolean gv (fromIntegral $ fromEnum b)++get_boolean :: Ptr GValue -> IO Bool+get_boolean gv = (/= 0) <$> _get_boolean gv++foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::+    Ptr GValue -> CGType -> IO ()+foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::+    Ptr GValue -> IO CGType++set_gtype :: Ptr GValue -> GType -> IO ()+set_gtype gv (GType g) = _set_gtype gv g++get_gtype :: Ptr GValue -> IO GType+get_gtype gv = GType <$> _get_gtype gv++foreign import ccall "g_value_set_object" _set_object ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_object" _get_object ::+    Ptr GValue -> IO (Ptr a)++set_object :: GObject a => Ptr GValue -> Ptr a -> IO ()+set_object = _set_object++get_object :: GObject a => Ptr GValue -> IO (Ptr a)+get_object = _get_object++foreign import ccall "g_value_set_boxed" set_boxed ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_boxed" get_boxed ::+    Ptr GValue -> IO (Ptr b)+foreign import ccall "g_value_dup_boxed" dup_boxed ::+    Ptr GValue -> IO (Ptr b)++foreign import ccall "g_value_set_variant" set_variant ::+    Ptr GValue -> Ptr GVariant -> IO ()+foreign import ccall "g_value_get_variant" get_variant ::+    Ptr GValue -> IO (Ptr GVariant)++foreign import ccall unsafe "g_value_set_enum" set_enum ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_enum" get_enum ::+    Ptr GValue -> IO CUInt++foreign import ccall unsafe "g_value_set_flags" set_flags ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_flags" get_flags ::+    Ptr GValue -> IO CUInt++-- | Set the value of `GValue` containing a `StablePtr`+set_stablePtr :: Ptr GValue -> StablePtr a -> IO ()+set_stablePtr gv ptr = set_boxed gv (castStablePtrToPtr ptr)++foreign import ccall g_value_take_boxed :: Ptr GValue -> Ptr a -> IO ()++-- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr`+take_stablePtr :: Ptr GValue -> StablePtr a -> IO ()+take_stablePtr gvPtr stablePtr =+  g_value_take_boxed gvPtr (castStablePtrToPtr stablePtr)++-- | Get (a freshly allocated copy of) the value of a `GValue`+-- containing a `StablePtr`+get_stablePtr :: Ptr GValue -> IO (StablePtr a)+get_stablePtr gv = castPtrToStablePtr <$> dup_boxed gv++foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO ()++-- | Pack the given list of GValues contiguously into a C array+packGValueArray :: [GValue] -> IO (Ptr GValue)+packGValueArray gvalues = withManagedPtrList gvalues $ \ptrs -> do+  let nitems = length ptrs+  mem <- callocBytes $ cgvalueSize * nitems+  fill mem ptrs+  return mem+  where fill :: Ptr GValue -> [Ptr GValue] -> IO ()+        fill _ [] = return ()+        fill ptr (x:xs) = do+          gtype <- g_value_get_type x+          _ <- g_value_init ptr gtype+          g_value_copy x ptr+          fill (ptr `plusPtr` cgvalueSize) xs++-- | Unpack an array of contiguous GValues into a list of GValues.+unpackGValueArrayWithLength :: Integral a =>+                               a -> Ptr GValue -> IO [GValue]+unpackGValueArrayWithLength nitems gvalues = go (fromIntegral nitems) gvalues+  where go :: Int -> Ptr GValue -> IO [GValue]+        go 0 _ = return []+        go n ptr = do+          gv <- callocBytes cgvalueSize+          gtype <- g_value_get_type ptr+          _ <- g_value_init gv gtype+          g_value_copy ptr gv+          wrapped <- wrapGValuePtr gv+          (wrapped :) <$> go (n-1) (ptr `plusPtr` cgvalueSize)++-- | Map over the `GValue`s inside a C array.+mapGValueArrayWithLength :: Integral a =>+                            a -> (Ptr GValue -> IO c) -> Ptr GValue -> IO ()+mapGValueArrayWithLength nvalues f arrayPtr+  | (arrayPtr == nullPtr) = return ()+  | (nvalues <= 0) = return ()+  | otherwise = go (fromIntegral nvalues) arrayPtr+  where go :: Int -> Ptr GValue -> IO ()+        go 0 _ = return ()+        go n ptr = do+          _ <- f ptr+          go (n-1) (ptr `plusPtr` cgvalueSize)++foreign import ccall unsafe "g_value_set_param" _set_param ::+    Ptr GValue -> Ptr GParamSpec -> IO ()+foreign import ccall unsafe "g_value_get_param" _get_param ::+    Ptr GValue -> IO (Ptr GParamSpec)++-- | Set the value of `GValue` containing a `GParamSpec`+set_param :: Ptr GValue -> Maybe GParamSpec -> IO ()+set_param gv (Just ps) = withManagedPtr ps (_set_param gv)+set_param gv Nothing = _set_param gv nullPtr++foreign import ccall "g_param_spec_ref" g_param_spec_ref ::+    Ptr GParamSpec -> IO (Ptr GParamSpec)+foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref ::+    FunPtr (Ptr GParamSpec -> IO ())++-- | Get the value of a `GValue` containing a `GParamSpec`+get_param :: Ptr GValue -> IO (Maybe GParamSpec)+get_param gv = do+  ptr <- _get_param gv+  if ptr == nullPtr+    then return Nothing+    else do+    fPtr <- g_param_spec_ref ptr >>= newManagedPtr' ptr_to_g_param_spec_unref+    return . Just $! GParamSpec fPtr++-- | A type isomorphic to `Maybe a`, used to indicate to+-- `fromGValue`/`toGValue` that we are packing a native Haskell value,+-- without attempting to marshall it to the corresponding C type.+data HValue a = HValue a -- ^ A packed value of type `a`+              | NoHValue -- ^ An empty `HValue`+  deriving (Show, Eq)++-- | Set the `GValue` to the given Haskell value.+set_hvalue :: Typeable a => Ptr GValue -> HValue a -> IO ()+set_hvalue gvPtr NoHValue = set_boxed gvPtr nullPtr+set_hvalue gvPtr (HValue v) = do+  sPtr <- newStablePtr (toDyn v)+  g_value_take_boxed gvPtr (castStablePtrToPtr sPtr)++-- | Get the value in the GValue, checking that the type is+-- `gtypeHValue`. Will return NULL and print a warning if the GValue+-- is of the wrong type.+foreign import ccall "haskell_gi_safe_get_boxed_haskell_value" safe_get_boxed_hvalue ::+    Ptr GValue -> IO (Ptr b)++-- | Read the Haskell value of the given type from the `GValue`. If+-- the `GValue` contains no value of the expected type, `NoHValue`+-- will be returned instead, and an error will be printed to stderr.+get_hvalue :: forall a. Typeable a => Ptr GValue -> IO (HValue a)+get_hvalue gvPtr = do+  hvaluePtr <- safe_get_boxed_hvalue gvPtr+  if hvaluePtr == nullPtr+    then return NoHValue+    else do+      dyn <- deRefStablePtr (castPtrToStablePtr hvaluePtr)+      case fromDynamic dyn of+        Nothing -> do+          hPutStrLn stderr ("HASKELL-GI: Unexpected type ‘" <> show dyn+                             <> "’ inside the GValue at ‘" <> show gvPtr+                             <> "’.\n\tExpected ‘" <> show (typeRep :: TypeRep a)+                             <> "’.")+          return NoHValue+        Just val -> return (HValue val)
− Data/GI/Base/GValue.hsc 
@@ -1,386 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Data.GI.Base.GValue-    (-    -- * Constructing GValues-      GValue(..)-    , IsGValue(..)-    , GValueConstruct(..)--    , newGValue-    , buildGValue-    , noGValue--    -- * Setters and getters-    , set_string-    , get_string-    , set_pointer-    , get_pointer-    , set_int-    , get_int-    , set_uint-    , get_uint-    , set_long-    , get_long-    , set_ulong-    , get_ulong-    , set_int32-    , get_int32-    , set_uint32-    , get_uint32-    , set_int64-    , get_int64-    , set_uint64-    , get_uint64-    , set_float-    , get_float-    , set_double-    , get_double-    , set_boolean-    , get_boolean-    , set_gtype-    , get_gtype-    , set_object-    , get_object-    , set_boxed-    , get_boxed-    , set_variant-    , get_variant-    , set_enum-    , get_enum-    , set_flags-    , get_flags-    ) where--#include <glib-object.h>--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Data.Coerce (coerce)-import Data.Word-import Data.Int-import Data.Text (Text, pack, unpack)--import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),-                        CLong(..), CULong(..))-import Foreign.C.String (CString)-import Foreign.Ptr (Ptr, nullPtr)--import Data.GI.Base.BasicTypes-import Data.GI.Base.BasicConversions (cstringToText, textToCString)--import Data.GI.Base.ManagedPtr-import Data.GI.Base.Utils (callocBytes, freeMem)--newtype GValue = GValue (ManagedPtr GValue)---- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@.-noGValue :: Maybe GValue-noGValue = Nothing--foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::-    IO CGType--instance BoxedObject GValue where-    boxedType _ = GType <$> c_g_value_get_type--foreign import ccall "g_value_init" g_value_init ::-    Ptr GValue -> CGType -> IO (Ptr GValue)---- | A type holding a `GValue` with an associated label. It is--- parameterized by a phantom type encoding the target type for the--- `GValue` (useful when constructing properties).-data GValueConstruct o = GValueConstruct String GValue---- | Build a new, empty, `GValue` of the given type.-newGValue :: GType -> IO GValue-newGValue (GType gtype) = do-  gvptr <- callocBytes (#size GValue)-  _ <- g_value_init gvptr gtype-  gv <- wrapBoxed GValue gvptr-  return $! gv---- | A convenience function for building a new GValue and setting the--- initial value.-buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue-buildGValue gtype setter val = do-  gv <- newGValue gtype-  setter gv val-  return gv---- | A convenience class for marshaling back and forth between Haskell--- values and `GValue`s.-class IsGValue a where-    toGValue :: a -> IO GValue-    fromGValue :: GValue -> IO a--instance IsGValue (Maybe String) where-    toGValue = buildGValue gtypeString set_string . fmap pack-    fromGValue v = (fmap unpack) <$> get_string v--instance IsGValue (Maybe Text) where-    toGValue = buildGValue gtypeString set_string-    fromGValue = get_string--instance IsGValue (Ptr a) where-    toGValue = buildGValue gtypePointer set_pointer-    fromGValue = get_pointer--instance IsGValue Int32 where-    toGValue = buildGValue gtypeInt set_int32-    fromGValue = get_int32--instance IsGValue Word32 where-    toGValue = buildGValue gtypeUInt set_uint32-    fromGValue = get_uint32--instance IsGValue CInt where-    toGValue = buildGValue gtypeInt set_int-    fromGValue = get_int--instance IsGValue CUInt where-    toGValue = buildGValue gtypeUInt set_uint-    fromGValue = get_uint--instance IsGValue CLong where-    toGValue = buildGValue gtypeLong set_long-    fromGValue = get_long--instance IsGValue CULong where-    toGValue = buildGValue gtypeULong set_ulong-    fromGValue = get_ulong--instance IsGValue Int64 where-    toGValue = buildGValue gtypeInt64 set_int64-    fromGValue = get_int64--instance IsGValue Word64 where-    toGValue = buildGValue gtypeUInt64 set_uint64-    fromGValue = get_uint64--instance IsGValue Float where-    toGValue = buildGValue gtypeFloat set_float-    fromGValue = get_float--instance IsGValue Double where-    toGValue = buildGValue gtypeDouble set_double-    fromGValue = get_double--instance IsGValue Bool where-    toGValue = buildGValue gtypeBoolean set_boolean-    fromGValue = get_boolean--instance IsGValue GType where-    toGValue = buildGValue gtypeGType set_gtype-    fromGValue = get_gtype--foreign import ccall "g_value_set_string" _set_string ::-    Ptr GValue -> CString -> IO ()-foreign import ccall "g_value_get_string" _get_string ::-    Ptr GValue -> IO CString--set_string :: GValue -> Maybe Text -> IO ()-set_string gv maybeStr =-    withManagedPtr gv $ \ptr -> do-      cstr <- case maybeStr of-                Just str -> textToCString str-                Nothing -> return nullPtr-      _set_string ptr cstr-      freeMem cstr--get_string :: GValue -> IO (Maybe Text)-get_string gv = withManagedPtr gv $ \gvptr -> do-                  cstr <- _get_string gvptr-                  if cstr /= nullPtr-                  then Just <$> cstringToText cstr-                  else return Nothing--foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::-    Ptr GValue -> IO (Ptr b)--set_pointer :: GValue -> Ptr a -> IO ()-set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr--get_pointer :: GValue -> IO (Ptr b)-get_pointer gv = withManagedPtr gv _get_pointer--foreign import ccall unsafe "g_value_set_int" _set_int ::-    Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_int" _get_int ::-    Ptr GValue -> IO CInt--set_int32 :: GValue -> Int32 -> IO ()-set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n)--get_int32 :: GValue -> IO Int32-get_int32 gv = coerce <$> withManagedPtr gv _get_int--set_int :: GValue -> CInt -> IO ()-set_int gv n = withManagedPtr gv $ flip _set_int n--get_int :: GValue -> IO CInt-get_int gv = withManagedPtr gv _get_int--foreign import ccall unsafe "g_value_set_uint" _set_uint ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_uint" _get_uint ::-    Ptr GValue -> IO CUInt--set_uint32 :: GValue -> Word32 -> IO ()-set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n)--get_uint32 :: GValue -> IO Word32-get_uint32 gv = coerce <$> withManagedPtr gv _get_uint--set_uint :: GValue -> CUInt -> IO ()-set_uint gv n = withManagedPtr gv $ flip _set_uint n--get_uint :: GValue -> IO CUInt-get_uint gv = withManagedPtr gv _get_uint--foreign import ccall unsafe "g_value_set_long" _set_long ::-    Ptr GValue -> CLong -> IO ()-foreign import ccall unsafe "g_value_get_long" _get_long ::-    Ptr GValue -> IO CLong--set_long :: GValue -> CLong -> IO ()-set_long gv n = withManagedPtr gv $ flip _set_long n--get_long :: GValue -> IO CLong-get_long gv = withManagedPtr gv _get_long--foreign import ccall unsafe "g_value_set_ulong" _set_ulong ::-    Ptr GValue -> CULong -> IO ()-foreign import ccall unsafe "g_value_get_ulong" _get_ulong ::-    Ptr GValue -> IO CULong--set_ulong :: GValue -> CULong -> IO ()-set_ulong gv n = withManagedPtr gv $ flip _set_ulong n--get_ulong :: GValue -> IO CULong-get_ulong gv = withManagedPtr gv _get_ulong--foreign import ccall unsafe "g_value_set_int64" _set_int64 ::-    Ptr GValue -> Int64 -> IO ()-foreign import ccall unsafe "g_value_get_int64" _get_int64 ::-    Ptr GValue -> IO Int64--set_int64 :: GValue -> Int64 -> IO ()-set_int64 gv n = withManagedPtr gv $ flip _set_int64 n--get_int64 :: GValue -> IO Int64-get_int64 gv = withManagedPtr gv _get_int64--foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::-    Ptr GValue -> Word64 -> IO ()-foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::-    Ptr GValue -> IO Word64--set_uint64 :: GValue -> Word64 -> IO ()-set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n--get_uint64 :: GValue -> IO Word64-get_uint64 gv = withManagedPtr gv _get_uint64--foreign import ccall unsafe "g_value_set_float" _set_float ::-    Ptr GValue -> CFloat -> IO ()-foreign import ccall unsafe "g_value_get_float" _get_float ::-    Ptr GValue -> IO CFloat--set_float :: GValue -> Float -> IO ()-set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)--get_float :: GValue -> IO Float-get_float gv = realToFrac <$> withManagedPtr gv _get_float--foreign import ccall unsafe "g_value_set_double" _set_double ::-    Ptr GValue -> CDouble -> IO ()-foreign import ccall unsafe "g_value_get_double" _get_double ::-    Ptr GValue -> IO CDouble--set_double :: GValue -> Double -> IO ()-set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)--get_double :: GValue -> IO Double-get_double gv = realToFrac <$> withManagedPtr gv _get_double--foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::-    Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::-    Ptr GValue -> IO CInt--set_boolean :: GValue -> Bool -> IO ()-set_boolean gv b = withManagedPtr gv $ \ptr ->-                   _set_boolean ptr (fromIntegral $ fromEnum b)--get_boolean :: GValue -> IO Bool-get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr--foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::-    Ptr GValue -> CGType -> IO ()-foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::-    Ptr GValue -> IO CGType--set_gtype :: GValue -> GType -> IO ()-set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g--get_gtype :: GValue -> IO GType-get_gtype gv = GType <$> withManagedPtr gv _get_gtype--foreign import ccall "g_value_set_object" _set_object ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_object" _get_object ::-    Ptr GValue -> IO (Ptr a)--set_object :: GObject a => GValue -> Ptr a -> IO ()-set_object gv o = withManagedPtr gv $ flip _set_object o--get_object :: GObject b => GValue -> IO (Ptr b)-get_object gv = withManagedPtr gv _get_object--foreign import ccall "g_value_set_boxed" _set_boxed ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_boxed" _get_boxed ::-    Ptr GValue -> IO (Ptr b)--set_boxed :: GValue -> Ptr a -> IO ()-set_boxed gv b = withManagedPtr gv $ flip _set_boxed b--get_boxed :: GValue -> IO (Ptr b)-get_boxed gv = withManagedPtr gv _get_boxed--foreign import ccall "g_value_set_variant" _set_variant ::-    Ptr GValue -> Ptr GVariant -> IO ()-foreign import ccall "g_value_get_variant" _get_variant ::-    Ptr GValue -> IO (Ptr GVariant)--set_variant :: GValue -> Ptr GVariant -> IO ()-set_variant gv v = withManagedPtr gv $ flip _set_variant v--get_variant :: GValue -> IO (Ptr GVariant)-get_variant gv = withManagedPtr gv _get_variant--foreign import ccall unsafe "g_value_set_enum" _set_enum ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_enum" _get_enum ::-    Ptr GValue -> IO CUInt--set_enum :: GValue -> CUInt -> IO ()-set_enum gv e = withManagedPtr gv $ flip _set_enum e--get_enum :: GValue -> IO CUInt-get_enum gv = withManagedPtr gv _get_enum--foreign import ccall unsafe "g_value_set_flags" _set_flags ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_flags" _get_flags ::-    Ptr GValue -> IO CUInt--set_flags :: GValue -> CUInt -> IO ()-set_flags gv f = withManagedPtr gv $ flip _set_flags f--get_flags :: GValue -> IO CUInt-get_flags gv = withManagedPtr gv _get_flags
Data/GI/Base/GVariant.hsc view
@@ -133,9 +133,6 @@  #include <glib-object.h> -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif import Control.Monad (when, void, (>=>)) import Control.Exception.Base (bracket) @@ -144,7 +141,9 @@ import qualified Data.ByteString as B import Data.Word import Data.Int+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Maybe (isJust, fromJust) import qualified Data.Map as M @@ -239,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 =@@ -644,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@@ -830,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@@ -855,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@@ -887,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@@ -924,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@@ -966,17 +969,17 @@ gvariantToFiveTuple variant = do   let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e))   maybeChildren <- withExplicitType expectedType gvariant_get_children variant-  if isJust maybeChildren-  then do-    let (Just [a1,a2,a3,a4,a5]) = maybeChildren-    (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1-                                        <*> fromGVariant a2-                                        <*> fromGVariant a3-                                        <*> fromGVariant a4-                                        <*> fromGVariant a5-    return $ if isJust ma1 && isJust ma2 && isJust ma3 &&-                              isJust ma4 && isJust ma5-             then Just (fromJust ma1, fromJust ma2, fromJust ma3,-                        fromJust ma4, fromJust ma5)-             else Nothing-  else return Nothing+  case maybeChildren of+    Just [a1,a2,a3,a4,a5] -> do+      (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1+                                   <*> fromGVariant a2+                                   <*> fromGVariant a3+                                   <*> fromGVariant a4+                                   <*> fromGVariant a5+      return $ if isJust ma1 && isJust ma2 && isJust ma3 &&+                  isJust ma4 && isJust ma5+               then Just (fromJust ma1, fromJust ma2, fromJust ma3,+                          fromJust ma4, fromJust ma5)+               else Nothing+    Just _ -> error "gvariantToFiveTuple :: the impossible happened, this is a bug."+    Nothing -> return Nothing
+ Data/GI/Base/Internal/CTypes.hsc view
@@ -0,0 +1,40 @@+-- | Versions of hsc2hs older than 0.68.6 cannot deal with Haskell+-- code including promoted constructors, so isolate the required types+-- in here.+--+-- /Warning/: This module is internal, and might disappear in the future.+module Data.GI.Base.Internal.CTypes+  ( GQuark+  , C_gint+  , cgvalueSize+  , gerror_domain_offset+  , gerror_code_offset+  , gerror_message_offset+  ) where++#include <glib-object.h>++import Data.Int+import Data.Word++-- | The size in bytes of a GValue struct in C.+cgvalueSize :: Int+cgvalueSize = #size GValue++-- | The Haskell type corresponding to a GQuark on the C side.+type GQuark = #{type GQuark}++-- | The Haskell type corresponding to a gint on the C side.+type C_gint = #{type gint}++-- | The offset in bytes inside a `GError` of its @domain@ field.+gerror_domain_offset :: Int+gerror_domain_offset = #{offset GError, domain}++-- | The offset in bytes inside a `GError` of its @code@ field.+gerror_code_offset :: Int+gerror_code_offset = #{offset GError, code}++-- | The offset in bytes inside a `GError` of its @emssage@ field.+gerror_message_offset :: Int+gerror_message_offset = #{offset GError, message}
+ Data/GI/Base/Internal/PathFieldAccess.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Support for creating lenses from overloaded labels of the type+-- @#fieldName@, or @#"fieldName.subfield"@.++module Data.GI.Base.Internal.PathFieldAccess+  ( Components, PathFieldAccess(..)) where++import qualified GHC.TypeLits as TL+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import qualified Optics.Core as O+import qualified Optics.Internal.Generic as OG++-- The Char class was introduced in GHC 9.2 (base 4.16), if this is+-- not available we fall back to an implementation that does not allow+-- for nested access. Note that overloaded labels of the form+-- #"record.subrecord" only became valid syntax in GHC 9.6, so this is+-- only really useful from that version.+#if MIN_VERSION_base(4,16,0)+type family AppendChar (s :: TL.Symbol) (c :: Char) where+  AppendChar s c = TL.AppendSymbol s (TL.ConsSymbol c "")++type family DoSplit (c :: Char) (acc :: TL.Symbol) (uncons :: Maybe (Char, TL.Symbol)) where+  DoSplit _ acc Nothing = '[acc]+  DoSplit c acc (Just '(c, rest)) = acc : DoSplit c "" (TL.UnconsSymbol rest)+  DoSplit c acc (Just '(k, rest)) = DoSplit c (AppendChar acc k) (TL.UnconsSymbol rest)++type family SplitByChar (c :: Char) (s :: TL.Symbol) :: [TL.Symbol] where+  SplitByChar c s = DoSplit c "" (TL.UnconsSymbol s)++type family Components (s :: TL.Symbol) :: [TL.Symbol] where+  Components s = SplitByChar '.' s+#else+type family Components (s :: TL.Symbol) :: [TL.Symbol] where+  Components s = '[s]+#endif++-- | Check that the given symbol is not the empty string. If it is,+-- raise a TypeError with the given msg.+type family NonEmpty (s :: TL.Symbol) (msg :: TL.ErrorMessage) :: Constraint where+  NonEmpty "" msg = TL.TypeError msg+  NonEmpty _ _ = ()++-- | Create a lens for the given path, and return it together with the+-- path split into components.+class PathFieldAccess (path :: [TL.Symbol]) (model :: Type) (val :: Type) | path model -> val where+  pathFieldAccess :: Proxy path -> Proxy model -> (O.Lens' model val, [T.Text])++instance {-# OVERLAPPING #-}+  (OG.GFieldImpl fieldName model model val val,+   NonEmpty fieldName (TL.Text "Field names cannot be empty"),+   TL.KnownSymbol fieldName) =>+  PathFieldAccess (fieldName : '[]) model val where+  pathFieldAccess _ _ = (OG.gfieldImpl @fieldName @model @model @val @val,+                         [T.pack $ TL.symbolVal (Proxy @fieldName)])++instance (OG.GFieldImpl fieldName model model val val,+          TL.KnownSymbol fieldName,+          PathFieldAccess rest val inner) =>+         PathFieldAccess (fieldName : rest) model inner where+  pathFieldAccess _ _ =+    let (innerLens, innerPath) = pathFieldAccess (Proxy @rest) (Proxy @val)+        outerLens = OG.gfieldImpl @fieldName @model @model @val @val+        outerName = T.pack $ TL.symbolVal (Proxy @fieldName)+    in (outerLens O.% innerLens, outerName : innerPath)+
Data/GI/Base/ManagedPtr.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -- For HasCallStack compatibility {-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-}+{-# LANGUAGE TypeApplications #-}  -- | We wrap most objects in a "managed pointer", which is basically a -- 'ForeignPtr' of the appropriate type together with a notion of@@ -27,9 +28,11 @@     -- * Safe casting     , castTo     , unsafeCastTo+    , checkInstanceType      -- * Wrappers     , newObject+    , withNewObject     , wrapObject     , releaseObject     , unrefObject@@ -49,6 +52,7 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (when, void)+import Control.Monad.Fix (mfix)  import Data.Coerce (coerce) import Data.IORef (newIORef, readIORef, writeIORef, IORef)@@ -95,9 +99,12 @@ ownedFinalizer finalizer ptr allocCallStack callStackRef = do   cs <- readIORef callStackRef   -- cs will be @Just cs@ whenever the pointer has been disowned.-  when (isNothing cs) $ do-    maybe (return ()) (printAllocDebug ptr) allocCallStack-    finalizer+  when (isNothing cs) $ case allocCallStack of+                          Just acs -> do+                            printAllocDebug ptr acs+                            finalizer+                            dbgLog (T.pack "Released successfully.\n")+                          Nothing -> finalizer  -- | Print some debug diagnostics for an allocation. printAllocDebug :: Ptr a -> CallStack -> IO ()@@ -127,12 +134,12 @@  -- | Do not run the finalizers upon garbage collection of the -- `ManagedPtr`.-disownManagedPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)+disownManagedPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b) disownManagedPtr managed = do   ptr <- unsafeManagedPtrGetPtr managed   writeIORef (managedPtrIsDisowned c) (Just callStack)-  return ptr-    where c = coerce managed :: ManagedPtr ()+  return (castPtr ptr)+    where c = toManagedPtr managed  -- | Perform an IO action on the 'Ptr' inside a managed pointer. withManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c@@ -160,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@@ -182,7 +189,7 @@ unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) =>                            a -> IO (Ptr b) unsafeManagedPtrCastPtr m = do-    let c = coerce m :: ManagedPtr ()+    let c = toManagedPtr m         ptr = (castPtr . unsafeForeignPtrToPtr . managedForeignPtr) c     disowned <- readIORef (managedPtrIsDisowned c)     maybe (return ptr) (notOwnedWarning ptr) disowned@@ -202,40 +209,53 @@ -- (i.e. it has not been garbage collected by the runtime) at the -- point that this is called. touchManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO ()-touchManagedPtr m = let c = coerce m :: ManagedPtr ()+touchManagedPtr m = let c = toManagedPtr m                     in (touchForeignPtr . managedForeignPtr) c  -- Safe casting machinery foreign import ccall unsafe "check_object_type"-    c_check_object_type :: Ptr o -> CGType -> CInt+    c_check_object_type :: Ptr o -> CGType -> IO CInt --- | Cast to the given type, checking that the cast is valid. If it is--- not, we return `Nothing`. Usage:+-- | Check whether the given object is an instance of the given type.+checkInstanceType :: (ManagedPtrNewtype o, TypedObject o) =>+                     o -> GType -> IO Bool+checkInstanceType obj (GType cgtype) = withManagedPtr obj $ \objPtr -> do+  check <- c_check_object_type objPtr cgtype+  return $ check /= 0++-- | Cast from one object type to another, checking that the cast is+-- valid. If it is not, we return `Nothing`. Usage: -- -- > maybeWidget <- castTo Widget label-castTo :: forall o o'. (GObject o, GObject o') =>+castTo :: forall o o'. (HasCallStack,+                        ManagedPtrNewtype o, TypedObject o,+                        ManagedPtrNewtype o', TypedObject o',+                        GObject o') =>           (ManagedPtr o' -> o') -> o -> IO (Maybe o')-castTo constructor obj =-    withManagedPtr obj $ \objPtr -> do-      GType t <- gobjectType (undefined :: o')-      if c_check_object_type objPtr t /= 1-        then return Nothing-        else Just <$> newObject constructor objPtr+castTo constructor obj = do+  gtype <- glibType @o'+  isInstance <- checkInstanceType obj gtype+  if isInstance+    then return . Just . constructor . coerce $ toManagedPtr obj+    else return Nothing --- | Cast to the given type, assuming that the cast will succeed. This--- function will call `error` if the cast is illegal.-unsafeCastTo :: forall o o'. (HasCallStack, GObject o, GObject o') =>+-- | Cast a typed object to a new type (without any assumption that+-- both types descend from `GObject`), assuming that the cast will+-- succeed. This function will call `error` if the cast is illegal.+unsafeCastTo :: forall o o'. (HasCallStack,+                              ManagedPtrNewtype o, TypedObject o,+                              ManagedPtrNewtype o', TypedObject o') =>                 (ManagedPtr o' -> o') -> o -> IO o'-unsafeCastTo constructor obj =-  withManagedPtr obj $ \objPtr -> do-    GType t <- gobjectType (undefined :: o')-    if c_check_object_type objPtr t /= 1+unsafeCastTo constructor obj = do+    gtype <- glibType @o'+    isInstance <- checkInstanceType obj gtype+    if not isInstance       then do-      srcType <- gobjectType obj >>= gtypeName-      destType <- gobjectType (undefined :: o') >>= gtypeName+      srcType <- glibType @o >>= gtypeName+      destType <- glibType @o' >>= gtypeName       error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to "         ++ destType ++ " requested."-      else newObject constructor objPtr+      else return (constructor $ coerce $ toManagedPtr obj)  -- Reference counting for constructors foreign import ccall "&dbg_g_object_unref"@@ -268,6 +288,16 @@   fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr   return $! constructor fPtr +-- | Perform the given IO action with a wrapped copy of the given ptr+-- to a GObject. Note that this increases the reference count of the+-- wrapped GObject, similarly to 'newObject'.+withNewObject :: (HasCallStack, GObject o)+                  => Ptr o -> (o -> IO b) -> IO b+withNewObject ptr action = do+  void $ g_object_ref_sink ptr+  managed <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr+  action (coerce managed)+ -- | Same as 'newObject', but we steal ownership of the object. wrapObject :: forall a b. (HasCallStack, GObject a, GObject b) =>               (ManagedPtr a -> a) -> Ptr b -> IO a@@ -326,32 +356,32 @@  -- | Construct a Haskell wrapper for the given boxed object. We make a -- copy of the object.-newBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a+newBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a newBoxed constructor ptr = do-  GType gtype <- boxedType (undefined :: a)+  GType gtype <- glibType @a   ptr' <- g_boxed_copy gtype ptr   fPtr <- newManagedPtr ptr' (boxed_free_helper gtype ptr')   return $! constructor fPtr  -- | Like 'newBoxed', but we do not make a copy (we "steal" the passed -- object, so now it is managed by the Haskell runtime).-wrapBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a wrapBoxed constructor ptr = do-  GType gtype <- boxedType (undefined :: a)+  GType gtype <- glibType @a   fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr)   return $! constructor fPtr  -- | Make a copy of the given boxed object.-copyBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO (Ptr a)+copyBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO (Ptr a) copyBoxed b = do-  GType gtype <- boxedType b+  GType gtype <- glibType @a   withManagedPtr b (g_boxed_copy gtype)  -- | Like 'copyBoxed', but acting directly on a pointer, instead of a -- managed pointer.-copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)+copyBoxedPtr :: forall a. GBoxed a => Ptr a -> IO (Ptr a) copyBoxedPtr ptr = do-  GType gtype <- boxedType (undefined :: a)+  GType gtype <- glibType @a   g_boxed_copy gtype ptr  foreign import ccall "g_boxed_free" g_boxed_free ::@@ -359,53 +389,51 @@  -- | Free the memory associated with a boxed object. Note that this -- disowns the associated `ManagedPtr` via `disownManagedPtr`.-freeBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO ()+freeBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO () freeBoxed boxed = do-  GType gtype <- boxedType (undefined :: a)+  GType gtype <- glibType @a   ptr <- disownManagedPtr boxed   dbgDealloc boxed   g_boxed_free gtype ptr  -- | Disown a boxed object, that is, do not free the associated -- foreign GBoxed when the Haskell object gets garbage--- collected. Returns the pointer to the underlying `BoxedObject`.-disownBoxed :: (HasCallStack, BoxedObject a) => a -> IO (Ptr a)+-- collected. Returns the pointer to the underlying `GBoxed`.+disownBoxed :: (HasCallStack, GBoxed a) => a -> IO (Ptr a) disownBoxed = disownManagedPtr  -- | Wrap a pointer, taking ownership of it.-wrapPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a-wrapPtr constructor ptr = do-  fPtr <- case wrappedPtrFree of-            Nothing -> newManagedPtr_ ptr-            Just finalizer -> newManagedPtr' finalizer ptr+wrapPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapPtr constructor ptr = mfix $ \wrapped -> do+  fPtr <- newManagedPtr ptr (boxedPtrFree wrapped)   return $! constructor fPtr  -- | Wrap a pointer, making a copy of the data.-newPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a+newPtr :: (HasCallStack, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a newPtr constructor ptr = do   tmpWrap <- newManagedPtr_ ptr-  ptr' <- wrappedPtrCopy (constructor tmpWrap)+  ptr' <- boxedPtrCopy (constructor tmpWrap)   return $! ptr'  -- | Make a copy of a wrapped pointer using @memcpy@ into a freshly -- allocated memory region of the given size.-copyBytes :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)+copyBytes :: (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a) copyBytes size ptr = do-  ptr' <- wrappedPtrCalloc+  ptr' <- boxedPtrCalloc   memcpy ptr' ptr size   return ptr'  foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ()) --- | Print a debug message for deallocs if the @HASKELL_GI_DEBUG_MEM@--- environment variable has been set.+-- | Same as `dbgDeallocPtr`, but for `ManagedPtr`s, and no callstack+-- needs to be provided. dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO () dbgDealloc m = do   env <- lookupEnv "HASKELL_GI_DEBUG_MEM"   case env of     Nothing -> return ()     Just _ -> do-      let mPtr = coerce m :: ManagedPtr ()+      let mPtr = toManagedPtr m           ptr = (unsafeForeignPtrToPtr . managedForeignPtr) mPtr       threadPtr <- g_thread_self       hPutStrLn stderr ("Releasing <" ++ show ptr ++ "> from thread ["
Data/GI/Base/Overloading.hs view
@@ -1,17 +1,20 @@ {-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds,              TypeFamilies, UndecidableInstances, EmptyDataDecls,-             MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}+             MultiParamTypeClasses, FlexibleInstances, ConstraintKinds,+             AllowAmbiguousTypes, FlexibleContexts, ScopedTypeVariables,+             TypeApplications, OverloadedStrings #-} --- | Helpers for dealing with `GObject`s.+-- | Helpers for dealing with overladed properties, signals and+-- methods.  module Data.GI.Base.Overloading     ( -- * Type level inheritance       ParentTypes+    , HasParentTypes     , IsDescendantOf-#if MIN_VERSION_base(4,9,0)-    , UnknownAncestorError-#endif +    , asA+     -- * Looking up attributes in parent types     , AttributeList     , HasAttributeList@@ -25,239 +28,196 @@     , HasSignal      -- * Looking up methods in parent types-    , MethodInfo(..)-    , MethodProxy(..)     , MethodResolutionFailed--    -- * Overloaded labels-    , IsLabelProxy(..)+    , UnsupportedMethodError+    , OverloadedMethodInfo(..)+    , OverloadedMethod(..)+    , MethodProxy(..) -#if MIN_VERSION_base(4,9,0)-    , module GHC.OverloadedLabels       -- Reexported for convenience-#endif+    , ResolvedSymbolInfo(..)+    , resolveMethod     ) where +import Data.Coerce (coerce)+import Data.Kind (Type)+ import GHC.Exts (Constraint) import GHC.TypeLits-import Data.Proxy (Proxy) -#if MIN_VERSION_base(4,9,0)-import GHC.OverloadedLabels (IsLabel(..))-#endif---- | Support for overloaded labels in ghc < 8.0. This is like the--- `IsLabel` class introduced in ghc 8.0 (for use with the--- OverloadedLabels extension) with the difference that the `Proxy`--- argument is lifted. (Using the unlifted Proxy# type in user code is--- a bit of a pain, hence the choice.)-class IsLabelProxy (x :: Symbol) a where-  fromLabelProxy :: Proxy x -> a+import Data.GI.Base.BasicTypes (ManagedPtrNewtype, ManagedPtr(..)) --- | Join two lists.-type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where-    JoinLists '[] bs = bs-    JoinLists (a ': as) bs = a ': JoinLists as bs+import Data.Text (Text)+import qualified Data.Text as T  -- | Look in the given list of (symbol, tag) tuples for the tag -- corresponding to the given symbol. If not found raise the given -- type error.-type family FindElement (m :: Symbol) (ms :: [(Symbol, *)])-#if !MIN_VERSION_base(4,9,0)-    (typeError :: *)-#else-    (typeError :: ErrorMessage)-#endif-    :: * where-    FindElement m '[] typeError =-#if !MIN_VERSION_base(4,9,0)-        typeError-#else-        TypeError typeError-#endif+type family FindElement (m :: Symbol) (ms :: [(Symbol, Type)])+    (typeError :: ErrorMessage) :: Type where+    FindElement m '[] typeError = TypeError typeError     FindElement m ('(m, o) ': ms) typeError = o     FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError --- | Result of a ancestor check. Basically a Bool type with a bit of--- extra info in order to improve typechecker error messages.-data AncestorCheck t a = HasAncestor a t-#if !MIN_VERSION_base(4,9,0)-                       | DoesNotHaveRequiredAncestor Symbol t Symbol a-#endif+-- | All the types that are ascendants of this type, including+-- interfaces that the type implements.+type family ParentTypes a :: [Type] -#if MIN_VERSION_base(4,9,0)--- | Type error to be generated when an ancestor check fails.-type family UnknownAncestorError (a :: *) (t :: *) where-    UnknownAncestorError a t =-        TypeError ('Text "Required ancestor ‘" ':<>: 'ShowType a-                   ':<>: 'Text "’ not found for type ‘"-                   ':<>: 'ShowType t ':<>: 'Text "’.")-#endif+-- | A constraint on a type, to be fulfilled whenever it has a type+-- instance for `ParentTypes`. This leads to nicer errors, thanks to+-- the overlappable instance below.+class HasParentTypes (o :: Type) +-- | Default instance, which will give rise to an error for types+-- without an associated `ParentTypes` instance.+instance {-# OVERLAPPABLE #-}+    TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:+               'Text "’ does not have any known parent types.")+    => HasParentTypes a+ -- | Check whether a type appears in a list. We specialize the -- names/types a bit so the error messages are more informative.-type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where-    CheckForAncestorType t a '[] =-#if !MIN_VERSION_base(4,9,0)-        'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t-#else-        UnknownAncestorError a t-#endif-    CheckForAncestorType t a (a ': as) = 'HasAncestor a t-    CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as+type family CheckForAncestorType t (a :: Type) (as :: [Type]) :: Constraint where+  CheckForAncestorType t a '[] = TypeError ('Text "Required ancestor ‘"+                                            ':<>: 'ShowType a+                                            ':<>: 'Text "’ not found for type ‘"+                                            ':<>: 'ShowType t ':<>: 'Text "’.")+  CheckForAncestorType t a (a ': as) = ()+  CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as --- | Check that a type is in the list of `GObjectParents` of another--- `GObject`-derived type.-type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where+-- | Check that a type is in the list of `ParentTypes` of another+-- type.+type family IsDescendantOf (parent :: Type) (descendant :: Type) :: Constraint where     -- Every object is defined to be a descendant of itself.-    IsDescendantOf d d = () ~ ()-    IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) ~ 'HasAncestor p d+    IsDescendantOf d d = ()+    IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) --- | The direct parents of this object: its direct parent type, if any,--- and the interfaces it implements. The interfaces inherited from--- parent types can be omitted.-type family ParentTypes a :: [*]+-- | Safe coercions to a parent class. For instance:+--+-- > #show $ label `asA` Gtk.Widget+--+asA :: (ManagedPtrNewtype a, ManagedPtrNewtype b,+        HasParentTypes b, IsDescendantOf a b)+    => b -> (ManagedPtr a -> a) -> a+asA obj _constructor = coerce obj  -- | The list of attributes defined for a given type. Each element of -- the list is a tuple, with the first element of the tuple the name -- of the attribute, and the second the type encoding the information--- of the attribute. This type will be an instance of `AttrInfo`.-type family AttributeList a :: [(Symbol, *)]+-- of the attribute. This type will be an instance of+-- `Data.GI.Base.Attributes.AttrInfo`.+type family AttributeList a :: [(Symbol, Type)]  -- | A constraint on a type, to be fulfilled whenever it has a type -- instance for `AttributeList`. This is here for nicer error -- reporting. class HasAttributeList a -#if MIN_VERSION_base(4,9,0)--- Default instance, which will give rise to an error for types+-- | Default instance, which will give rise to an error for types -- without an associated `AttributeList`. instance {-# OVERLAPPABLE #-}     TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:                'Text "’ does not have any known attributes.")     => HasAttributeList a-#endif -#if !MIN_VERSION_base(4,9,0)--- | Datatype returned when the attribute is not found, hopefully making--- the resulting error messages somewhat clearer.-data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)-#endif- -- | Return the type encoding the attribute information for a given -- type and attribute.-type family ResolveAttribute (s :: Symbol) (o :: *) :: * where+type family ResolveAttribute (s :: Symbol) (o :: Type) :: Type where     ResolveAttribute s o = FindElement s (AttributeList o)-#if !MIN_VERSION_base(4,9,0)-                           (UnknownAttribute "Error: could not find attribute" s "for object" o)-#else                            ('Text "Unknown attribute ‘" ':<>:                             'Text s ':<>: 'Text "’ for object ‘" ':<>:                             'ShowType o ':<>: 'Text "’.")-#endif  -- | Whether a given type is in the given list. If found, return -- @success@, otherwise return @failure@.-type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k)-#if !MIN_VERSION_base(4,9,0)-    (failure :: k)-#else-    (failure :: ErrorMessage)-#endif-        :: k where-    IsElem e '[] success failure =-#if !MIN_VERSION_base(4,9,0)-        failure-#else-        TypeError failure-#endif+type family IsElem (e :: Symbol) (es :: [(Symbol, Type)]) (success :: k)+    (failure :: ErrorMessage) :: k where+    IsElem e '[] success failure = TypeError failure     IsElem e ( '(e, t) ': es) success failure = success     IsElem e ( '(other, t) ': es) s f = IsElem e es s f --- | Isomorphic to Bool, but having some extra debug information.-data AttributeCheck a t = HasAttribute-#if !MIN_VERSION_base(4,9,0)-                        | DoesNotHaveAttribute Symbol a Symbol t-#endif- -- | A constraint imposing that the given object has the given attribute.-type family HasAttribute (attr :: Symbol) (o :: *) where+type family HasAttribute (attr :: Symbol) (o :: Type) :: Constraint where     HasAttribute attr o = IsElem attr (AttributeList o)-                          'HasAttribute-#if !MIN_VERSION_base(4,9,0)-                          ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o)-#else+                          (() :: Constraint) -- success                           ('Text "Attribute ‘" ':<>: 'Text attr ':<>:                            'Text "’ not found for type ‘" ':<>:                            'ShowType o ':<>: 'Text "’.")-#endif-                          ~ 'HasAttribute  -- | A constraint that enforces that the given type has a given attribute.-class HasAttr (attr :: Symbol) (o :: *)+class HasAttr (attr :: Symbol) (o :: Type) instance HasAttribute attr o => HasAttr attr o --- | The list of signals defined for a given type. Each element of--- the list is a tuple, with the first element of the tuple the name--- of the signal, and the second the type encoding the information of--- the signal. This type will be an instance of `SignalInfo`.-type family SignalList a :: [(Symbol, *)]--#if !MIN_VERSION_base(4,9,0)--- | Datatype returned when the signal is not found, hopefully making--- the resulting error messages somewhat clearer.-data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)-#endif+-- | The list of signals defined for a given type. Each element of the+-- list is a tuple, with the first element of the tuple the name of+-- the signal, and the second the type encoding the information of the+-- signal. This type will be an instance of+-- `Data.GI.Base.Signals.SignalInfo`.+type family SignalList a :: [(Symbol, Type)]  -- | Return the type encoding the signal information for a given -- type and signal.-type family ResolveSignal (s :: Symbol) (o :: *) :: * where+type family ResolveSignal (s :: Symbol) (o :: Type) :: Type where     ResolveSignal s o = FindElement s (SignalList o)-#if !MIN_VERSION_base(4,9,0)-                        (UnknownSignal "Error: could not find signal" s "for object" o)-#else                         ('Text "Unknown signal ‘" ':<>:                          'Text s ':<>: 'Text "’ for object ‘" ':<>:                          'ShowType o ':<>: 'Text "’.")-#endif --- | Isomorphic to Bool, but having some extra debug information.-data SignalCheck s t = HasSignal-#if !MIN_VERSION_base(4,9,0)-                     | DoesNotHaveSignal Symbol s Symbol t-#endif- -- | A constraint enforcing that the signal exists for the given -- object, or one of its ancestors.-type family HasSignal (s :: Symbol) (o :: *) where+type family HasSignal (s :: Symbol) (o :: Type) :: Constraint where     HasSignal s o = IsElem s (SignalList o)-                    'HasSignal-#if !MIN_VERSION_base(4,9,0)-                    ('DoesNotHaveSignal "Error: signal" s "not found for type" o)-#else+                    (() :: Constraint) -- success                     ('Text "Signal ‘" ':<>: 'Text s ':<>:                      'Text "’ not found for type ‘" ':<>:                      'ShowType o ':<>: 'Text "’.")-#endif-                    ~ 'HasSignal --- | Class for types containing the information about an overloaded--- method of type `o -> s`.-class MethodInfo i o s where-    overloadedMethod :: MethodProxy i -> o -> s---- | Proxy for passing a type to `overloadedMethod`. We do not use--- `Data.Proxy.Proxy` directly since it clashes with types defined in--- the autogenerated bindings.-data MethodProxy a = MethodProxy+-- | A constraint that always fails with a type error, for+-- documentation purposes.+type family UnsupportedMethodError (s :: Symbol) (o :: Type) :: Type where+  UnsupportedMethodError s o =+    TypeError ('Text "Unsupported method ‘" ':<>:+               'Text s ':<>: 'Text "’ for object ‘" ':<>:+               'ShowType o ':<>: 'Text "’.") -#if !MIN_VERSION_base(4,9,0)--- | Datatype returned when the method is not found, hopefully making+-- | Returned when the method is not found, hopefully making -- the resulting error messages somewhat clearer.-data MethodResolutionFailed (label :: Symbol) (o :: *)-#else-type family MethodResolutionFailed (method :: Symbol) (o :: *) where+type family MethodResolutionFailed (method :: Symbol) (o :: Type) where     MethodResolutionFailed m o =         TypeError ('Text "Unknown method ‘" ':<>:                    'Text m ':<>: 'Text "’ for type ‘" ':<>:                    'ShowType o ':<>: 'Text "’.")-#endif++-- | Class for types containing the information about an overloaded+-- method of type @o -> s@.+class OverloadedMethod i o s where+  overloadedMethod :: o -> s -- ^ The actual method being invoked.++-- | Information about a fully resolved symbol, for debugging+-- purposes.+data ResolvedSymbolInfo = ResolvedSymbolInfo {+  resolvedSymbolName      :: Text+  , resolvedSymbolURL     :: Text+  }++instance Show ResolvedSymbolInfo where+  -- Format as a hyperlink on modern terminals (older+  -- terminals should ignore the hyperlink part).+  show info = T.unpack ("\ESC]8;;" <> resolvedSymbolURL info+                         <> "\ESC\\" <> resolvedSymbolName info+                         <> "\ESC]8;;\ESC\\")++-- | This is for debugging purposes, see `resolveMethod` below.+class OverloadedMethodInfo i o where+  overloadedMethodInfo :: Maybe ResolvedSymbolInfo++-- | A proxy for carrying the types `MethodInfoName` needs (this is used+-- for `resolveMethod`, see below).+data MethodProxy (info :: Type) (obj :: Type) = MethodProxy++-- | Return the fully qualified method name that a given overloaded+-- method call resolves to (mostly useful for debugging).+--+-- > resolveMethod widget #show+resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) =>+                 obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo+resolveMethod _o _p = overloadedMethodInfo @info @obj
+ Data/GI/Base/Overloading.hs-boot view
@@ -0,0 +1,3 @@+module Data.GI.Base.Overloading (HasParentTypes) where++class HasParentTypes a
Data/GI/Base/Properties.hsc view
@@ -1,7 +1,8 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}  module Data.GI.Base.Properties-    ( setObjectPropertyString+    ( setObjectPropertyIsGValueInstance+    , setObjectPropertyString     , setObjectPropertyStringArray     , setObjectPropertyPtr     , setObjectPropertyInt@@ -20,12 +21,17 @@     , setObjectPropertyBoxed     , setObjectPropertyEnum     , setObjectPropertyFlags+    , setObjectPropertyClosure     , setObjectPropertyVariant     , setObjectPropertyByteArray     , setObjectPropertyPtrGList     , setObjectPropertyHash     , setObjectPropertyCallback+    , setObjectPropertyGError+    , setObjectPropertyGValue+    , setObjectPropertyParamSpec +    , getObjectPropertyIsGValueInstance     , getObjectPropertyString     , getObjectPropertyStringArray     , getObjectPropertyPtr@@ -45,12 +51,17 @@     , getObjectPropertyBoxed     , getObjectPropertyEnum     , getObjectPropertyFlags+    , getObjectPropertyClosure     , getObjectPropertyVariant     , getObjectPropertyByteArray     , getObjectPropertyPtrGList     , getObjectPropertyHash     , getObjectPropertyCallback+    , getObjectPropertyGError+    , getObjectPropertyGValue+    , getObjectPropertyParamSpec +    , constructObjectPropertyIsGValueInstance     , constructObjectPropertyString     , constructObjectPropertyStringArray     , constructObjectPropertyPtr@@ -70,11 +81,15 @@     , constructObjectPropertyBoxed     , constructObjectPropertyEnum     , constructObjectPropertyFlags+    , constructObjectPropertyClosure     , constructObjectPropertyVariant     , constructObjectPropertyByteArray     , constructObjectPropertyPtrGList     , constructObjectPropertyHash     , constructObjectPropertyCallback+    , constructObjectPropertyGError+    , constructObjectPropertyGValue+    , constructObjectPropertyParamSpec     ) where  #if !MIN_VERSION_base(4,8,0)@@ -84,12 +99,14 @@  import qualified Data.ByteString.Char8 as B import Data.Text (Text)-import Data.Proxy (Proxy(..))  import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions import Data.GI.Base.ManagedPtr+import Data.GI.Base.GError (GError(..)) import Data.GI.Base.GValue+import Data.GI.Base.GType+import Data.GI.Base.GClosure (GClosure(..)) import Data.GI.Base.GVariant (newGVariantFromPtr) import Data.GI.Base.Utils (freeMem, convertIfNonNull) @@ -103,273 +120,267 @@ foreign import ccall "g_object_set_property" g_object_set_property ::     Ptr a -> CString -> Ptr GValue -> IO () -setObjectProperty :: GObject a => a -> String -> b ->-                     (GValue -> b -> IO ()) -> GType -> IO ()-setObjectProperty obj propName propValue setter (GType gtype) = do-  gvalue <- buildGValue (GType gtype) setter propValue+-- | Set a property on an object to the given `GValue`.+gobjectSetProperty :: GObject a => a -> String -> GValue -> IO ()+gobjectSetProperty obj propName gvalue =   withManagedPtr obj $ \objPtr ->       withCString propName $ \cPropName ->           withManagedPtr gvalue $ \gvalueptr ->               g_object_set_property objPtr cPropName gvalueptr +-- | A convenience wrapper over `gobjectSetProperty` that does the+-- wrapping of a value into a `GValue`.+setObjectProperty :: GObject a => a -> String -> b ->+                     (Ptr GValue -> b -> IO ()) -> GType -> IO ()+setObjectProperty obj propName propValue setter (GType gtype) = do+  gvalue <- buildGValue (GType gtype) setter propValue+  gobjectSetProperty obj propName gvalue+ foreign import ccall "g_object_get_property" g_object_get_property ::     Ptr a -> CString -> Ptr GValue -> IO () -getObjectProperty :: GObject a => a -> String ->-                     (GValue -> IO b) -> GType -> IO b-getObjectProperty obj propName getter gtype = do+-- | Get the `GValue` for the given property.+gobjectGetProperty :: GObject a => a -> String -> GType -> IO GValue+gobjectGetProperty obj propName gtype = do   gvalue <- newGValue gtype   withManagedPtr obj $ \objPtr ->       withCString propName $ \cPropName ->           withManagedPtr gvalue $ \gvalueptr ->               g_object_get_property objPtr cPropName gvalueptr-  getter gvalue+  return gvalue -constructObjectProperty :: String -> b -> (GValue -> b -> IO ()) ->+-- | A convenience wrapper over `gobjectGetProperty` that unwraps the+-- `GValue` into a Haskell value.+getObjectProperty :: GObject a => a -> String ->+                     (Ptr GValue -> IO b) -> GType -> IO b+getObjectProperty obj propName getter gtype = do+  gv <- gobjectGetProperty obj propName gtype+  withManagedPtr gv getter++constructObjectProperty :: String -> b -> (Ptr GValue -> b -> IO ()) ->                            GType -> IO (GValueConstruct o) constructObjectProperty propName propValue setter gtype = do   gvalue <- buildGValue gtype setter propValue   return (GValueConstruct propName gvalue) +-- | Set a property for a type with a `IsGValue` instance.+setObjectPropertyIsGValueInstance :: (GObject a, IsGValue b) =>+                                     a -> String -> b -> IO ()+setObjectPropertyIsGValueInstance obj propName maybeVal = do+  gvalue <- toGValue maybeVal+  gobjectSetProperty obj propName gvalue++-- | Construct a property for a type with a `IsGValue` instance.+constructObjectPropertyIsGValueInstance :: IsGValue b => String -> b -> IO (GValueConstruct o)+constructObjectPropertyIsGValueInstance propName maybeVal = do+  gvalue <- toGValue maybeVal+  return (GValueConstruct propName gvalue)++-- | Get a nullable property for a type with a `IsGValue` instance.+getObjectPropertyIsGValueInstance :: forall a b. (GObject a, IsGValue b) =>+                       a -> String -> IO b+getObjectPropertyIsGValueInstance obj propName = do+  gtype <- gvalueGType_ @b+  gv <- gobjectGetProperty obj propName gtype+  fromGValue gv+ setObjectPropertyString :: GObject a =>                            a -> String -> Maybe Text -> IO ()-setObjectPropertyString obj propName str =-    setObjectProperty obj propName str set_string gtypeString+setObjectPropertyString = setObjectPropertyIsGValueInstance  constructObjectPropertyString :: String -> Maybe Text ->                                  IO (GValueConstruct o)-constructObjectPropertyString propName str =-    constructObjectProperty propName str set_string gtypeString+constructObjectPropertyString = constructObjectPropertyIsGValueInstance  getObjectPropertyString :: GObject a =>                            a -> String -> IO (Maybe Text)-getObjectPropertyString obj propName =-    getObjectProperty obj propName get_string gtypeString+getObjectPropertyString = getObjectPropertyIsGValueInstance  setObjectPropertyPtr :: GObject a =>                         a -> String -> Ptr b -> IO ()-setObjectPropertyPtr obj propName ptr =-    setObjectProperty obj propName ptr set_pointer gtypePointer+setObjectPropertyPtr = setObjectPropertyIsGValueInstance  constructObjectPropertyPtr :: String -> Ptr b ->                               IO (GValueConstruct o)-constructObjectPropertyPtr propName ptr =-    constructObjectProperty propName ptr set_pointer gtypePointer+constructObjectPropertyPtr = constructObjectPropertyIsGValueInstance  getObjectPropertyPtr :: GObject a =>                         a -> String -> IO (Ptr b)-getObjectPropertyPtr obj propName =-    getObjectProperty obj propName get_pointer gtypePointer+getObjectPropertyPtr = getObjectPropertyIsGValueInstance  setObjectPropertyInt :: GObject a =>                          a -> String -> CInt -> IO ()-setObjectPropertyInt obj propName int =-    setObjectProperty obj propName int set_int gtypeInt+setObjectPropertyInt = setObjectPropertyIsGValueInstance  constructObjectPropertyInt :: String -> CInt ->                               IO (GValueConstruct o)-constructObjectPropertyInt propName int =-    constructObjectProperty propName int set_int gtypeInt+constructObjectPropertyInt = constructObjectPropertyIsGValueInstance  getObjectPropertyInt :: GObject a => a -> String -> IO CInt-getObjectPropertyInt obj propName =-    getObjectProperty obj propName get_int gtypeInt+getObjectPropertyInt = getObjectPropertyIsGValueInstance  setObjectPropertyUInt :: GObject a =>                           a -> String -> CUInt -> IO ()-setObjectPropertyUInt obj propName uint =-    setObjectProperty obj propName uint set_uint gtypeUInt+setObjectPropertyUInt = setObjectPropertyIsGValueInstance  constructObjectPropertyUInt :: String -> CUInt ->                                 IO (GValueConstruct o)-constructObjectPropertyUInt propName uint =-    constructObjectProperty propName uint set_uint gtypeUInt+constructObjectPropertyUInt = constructObjectPropertyIsGValueInstance  getObjectPropertyUInt :: GObject a => a -> String -> IO CUInt-getObjectPropertyUInt obj propName =-    getObjectProperty obj propName get_uint gtypeUInt+getObjectPropertyUInt = getObjectPropertyIsGValueInstance  setObjectPropertyLong :: GObject a =>                          a -> String -> CLong -> IO ()-setObjectPropertyLong obj propName int =-    setObjectProperty obj propName int set_long gtypeLong+setObjectPropertyLong = setObjectPropertyIsGValueInstance  constructObjectPropertyLong :: String -> CLong ->                                IO (GValueConstruct o)-constructObjectPropertyLong propName int =-    constructObjectProperty propName int set_long gtypeLong+constructObjectPropertyLong = constructObjectPropertyIsGValueInstance  getObjectPropertyLong :: GObject a => a -> String -> IO CLong-getObjectPropertyLong obj propName =-    getObjectProperty obj propName get_long gtypeLong+getObjectPropertyLong = getObjectPropertyIsGValueInstance  setObjectPropertyULong :: GObject a =>                           a -> String -> CULong -> IO ()-setObjectPropertyULong obj propName uint =-    setObjectProperty obj propName uint set_ulong gtypeULong+setObjectPropertyULong = setObjectPropertyIsGValueInstance  constructObjectPropertyULong :: String -> CULong ->                                 IO (GValueConstruct o)-constructObjectPropertyULong propName uint =-    constructObjectProperty propName uint set_ulong gtypeULong+constructObjectPropertyULong = constructObjectPropertyIsGValueInstance  getObjectPropertyULong :: GObject a => a -> String -> IO CULong-getObjectPropertyULong obj propName =-    getObjectProperty obj propName get_ulong gtypeULong+getObjectPropertyULong = getObjectPropertyIsGValueInstance  setObjectPropertyInt32 :: GObject a =>                           a -> String -> Int32 -> IO ()-setObjectPropertyInt32 obj propName int32 =-    setObjectProperty obj propName int32 set_int32 gtypeInt+setObjectPropertyInt32 = setObjectPropertyIsGValueInstance  constructObjectPropertyInt32 :: String -> Int32 ->                                 IO (GValueConstruct o)-constructObjectPropertyInt32 propName int32 =-    constructObjectProperty propName int32 set_int32 gtypeInt+constructObjectPropertyInt32 = constructObjectPropertyIsGValueInstance  getObjectPropertyInt32 :: GObject a => a -> String -> IO Int32-getObjectPropertyInt32 obj propName =-    getObjectProperty obj propName get_int32 gtypeInt+getObjectPropertyInt32 = getObjectPropertyIsGValueInstance  setObjectPropertyUInt32 :: GObject a =>                           a -> String -> Word32 -> IO ()-setObjectPropertyUInt32 obj propName uint32 =-    setObjectProperty obj propName uint32 set_uint32 gtypeUInt+setObjectPropertyUInt32 = setObjectPropertyIsGValueInstance  constructObjectPropertyUInt32 :: String -> Word32 ->                                  IO (GValueConstruct o)-constructObjectPropertyUInt32 propName uint32 =-    constructObjectProperty propName uint32 set_uint32 gtypeUInt+constructObjectPropertyUInt32 = constructObjectPropertyIsGValueInstance  getObjectPropertyUInt32 :: GObject a => a -> String -> IO Word32-getObjectPropertyUInt32 obj propName =-    getObjectProperty obj propName get_uint32 gtypeUInt+getObjectPropertyUInt32 = getObjectPropertyIsGValueInstance  setObjectPropertyInt64 :: GObject a =>                           a -> String -> Int64 -> IO ()-setObjectPropertyInt64 obj propName int64 =-    setObjectProperty obj propName int64 set_int64 gtypeInt64+setObjectPropertyInt64 = setObjectPropertyIsGValueInstance  constructObjectPropertyInt64 :: String -> Int64 ->                                 IO (GValueConstruct o)-constructObjectPropertyInt64 propName int64 =-    constructObjectProperty propName int64 set_int64 gtypeInt64+constructObjectPropertyInt64 = constructObjectPropertyIsGValueInstance  getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64-getObjectPropertyInt64 obj propName =-    getObjectProperty obj propName get_int64 gtypeInt64+getObjectPropertyInt64 = getObjectPropertyIsGValueInstance  setObjectPropertyUInt64 :: GObject a =>                           a -> String -> Word64 -> IO ()-setObjectPropertyUInt64 obj propName uint64 =-    setObjectProperty obj propName uint64 set_uint64 gtypeUInt64+setObjectPropertyUInt64 = setObjectPropertyIsGValueInstance  constructObjectPropertyUInt64 :: String -> Word64 ->                                  IO (GValueConstruct o)-constructObjectPropertyUInt64 propName uint64 =-    constructObjectProperty propName uint64 set_uint64 gtypeUInt64+constructObjectPropertyUInt64 = constructObjectPropertyIsGValueInstance  getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64-getObjectPropertyUInt64 obj propName =-    getObjectProperty obj propName get_uint64 gtypeUInt64+getObjectPropertyUInt64 = getObjectPropertyIsGValueInstance  setObjectPropertyFloat :: GObject a =>                            a -> String -> Float -> IO ()-setObjectPropertyFloat obj propName float =-    setObjectProperty obj propName float set_float gtypeFloat+setObjectPropertyFloat = setObjectPropertyIsGValueInstance  constructObjectPropertyFloat :: String -> Float ->                                  IO (GValueConstruct o)-constructObjectPropertyFloat propName float =-    constructObjectProperty propName float set_float gtypeFloat+constructObjectPropertyFloat = constructObjectPropertyIsGValueInstance  getObjectPropertyFloat :: GObject a =>                            a -> String -> IO Float-getObjectPropertyFloat obj propName =-    getObjectProperty obj propName get_float gtypeFloat+getObjectPropertyFloat = getObjectPropertyIsGValueInstance  setObjectPropertyDouble :: GObject a =>                             a -> String -> Double -> IO ()-setObjectPropertyDouble obj propName double =-    setObjectProperty obj propName double set_double gtypeDouble+setObjectPropertyDouble = setObjectPropertyIsGValueInstance  constructObjectPropertyDouble :: String -> Double ->                                   IO (GValueConstruct o)-constructObjectPropertyDouble propName double =-    constructObjectProperty propName double set_double gtypeDouble+constructObjectPropertyDouble = constructObjectPropertyIsGValueInstance  getObjectPropertyDouble :: GObject a =>                             a -> String -> IO Double-getObjectPropertyDouble obj propName =-    getObjectProperty obj propName get_double gtypeDouble+getObjectPropertyDouble = getObjectPropertyIsGValueInstance  setObjectPropertyBool :: GObject a =>                          a -> String -> Bool -> IO ()-setObjectPropertyBool obj propName bool =-    setObjectProperty obj propName bool set_boolean gtypeBoolean+setObjectPropertyBool = setObjectPropertyIsGValueInstance  constructObjectPropertyBool :: String -> Bool -> IO (GValueConstruct o)-constructObjectPropertyBool propName bool =-    constructObjectProperty propName bool set_boolean gtypeBoolean+constructObjectPropertyBool = constructObjectPropertyIsGValueInstance  getObjectPropertyBool :: GObject a => a -> String -> IO Bool-getObjectPropertyBool obj propName =-    getObjectProperty obj propName get_boolean gtypeBoolean+getObjectPropertyBool = getObjectPropertyIsGValueInstance  setObjectPropertyGType :: GObject a =>                          a -> String -> GType -> IO ()-setObjectPropertyGType obj propName gtype =-    setObjectProperty obj propName gtype set_gtype gtypeGType+setObjectPropertyGType = setObjectPropertyIsGValueInstance  constructObjectPropertyGType :: String -> GType -> IO (GValueConstruct o)-constructObjectPropertyGType propName bool =-    constructObjectProperty propName bool set_gtype gtypeGType+constructObjectPropertyGType = constructObjectPropertyIsGValueInstance  getObjectPropertyGType :: GObject a => a -> String -> IO GType-getObjectPropertyGType obj propName =-    getObjectProperty obj propName get_gtype gtypeGType+getObjectPropertyGType = getObjectPropertyIsGValueInstance  setObjectPropertyObject :: forall a b. (GObject a, GObject b) =>                            a -> String -> Maybe b -> IO () setObjectPropertyObject obj propName maybeObject = do-  gtype <- gobjectType (undefined :: b)+  gtype <- glibType @b   maybeWithManagedPtr maybeObject $ \objectPtr ->       setObjectProperty obj propName objectPtr set_object gtype  constructObjectPropertyObject :: forall a o. GObject a =>                                  String -> Maybe a -> IO (GValueConstruct o) constructObjectPropertyObject propName maybeObject = do-  gtype <- gobjectType (undefined :: a)+  gtype <- glibType @a   maybeWithManagedPtr maybeObject $ \objectPtr ->       constructObjectProperty propName objectPtr set_object gtype  getObjectPropertyObject :: forall a b. (GObject a, GObject b) =>                            a -> String -> (ManagedPtr b -> b) -> IO (Maybe b) getObjectPropertyObject obj propName constructor = do-  gtype <- gobjectType (undefined :: b)+  gtype <- glibType @b   getObjectProperty obj propName                         (\val -> (get_object val :: IO (Ptr b))                             >>= flip convertIfNonNull (newObject constructor))                       gtype -setObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+setObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) =>                           a -> String -> Maybe b -> IO () setObjectPropertyBoxed obj propName maybeBoxed = do-  gtype <- boxedType (undefined :: b)+  gtype <- glibType @b   maybeWithManagedPtr maybeBoxed $ \boxedPtr ->         setObjectProperty obj propName boxedPtr set_boxed gtype -constructObjectPropertyBoxed :: forall a o. (BoxedObject a) =>+constructObjectPropertyBoxed :: forall a o. (GBoxed a) =>                                 String -> Maybe a -> IO (GValueConstruct o) constructObjectPropertyBoxed propName maybeBoxed = do-  gtype <- boxedType (undefined :: a)+  gtype <- glibType @a   maybeWithManagedPtr maybeBoxed $ \boxedPtr ->       constructObjectProperty propName boxedPtr set_boxed gtype -getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+getObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) =>                           a -> String -> (ManagedPtr b -> b) -> IO (Maybe b) getObjectPropertyBoxed obj propName constructor = do-  gtype <- boxedType (undefined :: b)+  gtype <- glibType @b   getObjectProperty obj propName (get_boxed >=>                                   flip convertIfNonNull (newBoxed constructor))                     gtype@@ -402,17 +413,17 @@                        flip convertIfNonNull unpackZeroTerminatedUTF8CArray)                       gtypeStrv -setObjectPropertyEnum :: (GObject a, Enum b, BoxedEnum b) =>+setObjectPropertyEnum :: forall a b. (GObject a, Enum b, BoxedEnum b) =>                          a -> String -> b -> IO () setObjectPropertyEnum obj propName enum = do-  gtype <- boxedEnumType enum+  gtype <- glibType @b   let cEnum = (fromIntegral . fromEnum) enum   setObjectProperty obj propName cEnum set_enum gtype -constructObjectPropertyEnum :: (Enum a, BoxedEnum a) =>+constructObjectPropertyEnum :: forall a o. (Enum a, BoxedEnum a) =>                                String -> a -> IO (GValueConstruct o) constructObjectPropertyEnum propName enum = do-  gtype <- boxedEnumType enum+  gtype <- glibType @a   let cEnum = (fromIntegral . fromEnum) enum   constructObjectProperty propName cEnum set_enum gtype @@ -420,7 +431,7 @@                                       Enum b, BoxedEnum b) =>                          a -> String -> IO b getObjectPropertyEnum obj propName = do-  gtype <- boxedEnumType (undefined :: b)+  gtype <- glibType @b   getObjectProperty obj propName                     (\val -> toEnum . fromIntegral <$> get_enum val)                     gtype@@ -429,24 +440,36 @@                           a -> String -> [b] -> IO () setObjectPropertyFlags obj propName flags = do   let cFlags = gflagsToWord flags-  gtype <- boxedFlagsType (Proxy :: Proxy b)+  gtype <- glibType @b   setObjectProperty obj propName cFlags set_flags gtype  constructObjectPropertyFlags :: forall a o. (IsGFlag a, BoxedFlags a)                                 => String -> [a] -> IO (GValueConstruct o) constructObjectPropertyFlags propName flags = do   let cFlags = gflagsToWord flags-  gtype <- boxedFlagsType (Proxy :: Proxy a)+  gtype <- glibType @a   constructObjectProperty propName cFlags set_flags gtype  getObjectPropertyFlags :: forall a b. (GObject a, IsGFlag b, BoxedFlags b) =>                           a -> String -> IO [b] getObjectPropertyFlags obj propName = do-  gtype <- boxedFlagsType (Proxy :: Proxy b)+  gtype <- glibType @b   getObjectProperty obj propName                         (\val -> wordToGFlags <$> get_flags val)                         gtype +setObjectPropertyClosure :: forall a b. GObject a =>+                          a -> String -> Maybe (GClosure b) -> IO ()+setObjectPropertyClosure = setObjectPropertyBoxed++constructObjectPropertyClosure :: String -> Maybe (GClosure a) -> IO (GValueConstruct o)+constructObjectPropertyClosure = constructObjectPropertyBoxed++getObjectPropertyClosure :: forall a b. GObject a =>+                            a -> String -> IO (Maybe (GClosure b))+getObjectPropertyClosure obj propName =+  getObjectPropertyBoxed obj propName GClosure+ setObjectPropertyVariant :: GObject a =>                             a -> String -> Maybe GVariant -> IO () setObjectPropertyVariant obj propName maybeVariant =@@ -510,7 +533,7 @@ getObjectPropertyPtrGList :: GObject a =>                               a -> String -> IO [Ptr b] getObjectPropertyPtrGList obj propName =-    getObjectProperty obj propName (get_pointer >=> unpackGList) gtypePointer+  getObjectProperty obj propName (gvalueGet_ >=> unpackGList) gtypePointer  setObjectPropertyHash :: GObject a => a -> String -> b -> IO () setObjectPropertyHash =@@ -526,16 +549,60 @@  setObjectPropertyCallback :: GObject a => a -> String -> FunPtr b -> IO () setObjectPropertyCallback obj propName funPtr =-    setObjectProperty obj propName (castFunPtrToPtr funPtr) set_pointer gtypePointer+    setObjectProperty obj propName (castFunPtrToPtr funPtr) gvalueSet_ gtypePointer  constructObjectPropertyCallback :: String -> FunPtr b -> IO (GValueConstruct o) constructObjectPropertyCallback propName funPtr =-  constructObjectProperty propName (castFunPtrToPtr funPtr) set_pointer gtypePointer+  constructObjectProperty propName (castFunPtrToPtr funPtr) gvalueSet_ gtypePointer  getObjectPropertyCallback :: GObject a => a -> String ->                              (FunPtr b -> c) -> IO (Maybe c) getObjectPropertyCallback obj propName wrapper = do-  ptr <- getObjectProperty obj propName get_pointer gtypePointer+  ptr <- getObjectProperty obj propName gvalueGet_ gtypePointer   if ptr /= nullPtr     then return . Just . wrapper $ castPtrToFunPtr ptr     else return Nothing++-- | Set a property of type `GError`.+setObjectPropertyGError :: forall a. GObject a =>+                          a -> String -> Maybe GError -> IO ()+setObjectPropertyGError = setObjectPropertyBoxed++-- | Construct a property of type `GError`.+constructObjectPropertyGError :: String -> Maybe GError -> IO (GValueConstruct o)+constructObjectPropertyGError = constructObjectPropertyBoxed++-- | Get the value of a property of type `GError`.+getObjectPropertyGError :: forall a. GObject a =>+                            a -> String -> IO (Maybe GError)+getObjectPropertyGError obj propName =+  getObjectPropertyBoxed obj propName GError++-- | Set a property of type `GValue`.+setObjectPropertyGValue :: forall a. GObject a =>+                           a -> String -> Maybe GValue -> IO ()+setObjectPropertyGValue = setObjectPropertyBoxed++-- | Construct a property of type `GValue`.+constructObjectPropertyGValue :: String -> Maybe GValue -> IO (GValueConstruct o)+constructObjectPropertyGValue = constructObjectPropertyBoxed++-- | Get the value of a property of type `GValue`.+getObjectPropertyGValue :: forall a. GObject a =>+                           a -> String -> IO (Maybe GValue)+getObjectPropertyGValue obj propName =+  getObjectPropertyBoxed obj propName GValue++-- | Construct a property of type `GParamSpec`.+constructObjectPropertyParamSpec :: String -> Maybe GParamSpec ->+                                    IO (GValueConstruct o)+constructObjectPropertyParamSpec = constructObjectPropertyIsGValueInstance++-- | Get a property of type `GParamSpec`.+getObjectPropertyParamSpec :: GObject a => a -> String -> IO (Maybe GParamSpec)+getObjectPropertyParamSpec = getObjectPropertyIsGValueInstance++-- | Set a property of type `GParamSpec`.+setObjectPropertyParamSpec :: GObject a =>+                          a -> String -> Maybe GParamSpec -> IO ()+setObjectPropertyParamSpec = setObjectPropertyIsGValueInstance
Data/GI/Base/ShortPrelude.hs view
@@ -1,3 +1,6 @@+#if MIN_VERSION_base(4,20,0)+{-# LANGUAGE ExplicitNamespaces #-}+#endif -- | The Haskell Prelude exports a number of symbols that can easily -- collide with functions appearing in bindings. The generated code -- requires just a small subset of the functions in the Prelude,@@ -20,7 +23,7 @@     , module Data.GI.Base.Attributes     , module Data.GI.Base.BasicTypes     , module Data.GI.Base.BasicConversions-    , module Data.GI.Base.Closure+    , module Data.GI.Base.GClosure     , module Data.GI.Base.Constructible     , module Data.GI.Base.GError     , module Data.GI.Base.GHashTable@@ -29,7 +32,6 @@     , module Data.GI.Base.GVariant     , module Data.GI.Base.GValue     , module Data.GI.Base.ManagedPtr-    , module Data.GI.Base.Properties     , module Data.GI.Base.Signals     , module Data.GI.Base.Utils @@ -46,7 +48,7 @@     , (++)     , (=<<)     , (>=>)-    , Bool(..)+    , Bool()     , Float     , Double     , undefined@@ -58,6 +60,9 @@     , when     , fromIntegral     , realToFrac+#if MIN_VERSION_base(4,20,0)+    , type (~)+#endif     ) where  import Control.Monad (when, (>=>))@@ -78,8 +83,8 @@ import Data.GI.Base.Attributes hiding (get, set) import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions-import Data.GI.Base.Closure import Data.GI.Base.Constructible+import Data.GI.Base.GClosure (GClosure) import Data.GI.Base.GError import Data.GI.Base.GHashTable import Data.GI.Base.GObject@@ -87,7 +92,6 @@ import Data.GI.Base.GVariant import Data.GI.Base.GValue import Data.GI.Base.ManagedPtr-import Data.GI.Base.Properties import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo) import Data.GI.Base.Utils
+ Data/GI/Base/Signals.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}++-- | Routines for connecting `GObject`s to signals. There are two+-- basic variants, 'on' and 'after', which correspond to+-- <https://docs.gtk.org/gobject/func.signal_connect.html g_signal_connect> and <https://docs.gtk.org/gobject/func.signal_connect_after.html g_signal_connect_after>, respectively.+--+-- Basic usage is+--+-- @ 'on' widget #signalName $ do ... @+--+-- or+--+-- @ 'after' widget #signalName $ do ... @+--+-- Note that in the Haskell bindings we represent the signal name in+-- camelCase, so a signal like <https://webkitgtk.org/reference/webkit2gtk/stable/WebKitUserContentManager.html#WebKitUserContentManager-script-message-received script-message-received> in the original API becomes <https://hackage.haskell.org/package/gi-webkit2-4.0.24/docs/GI-WebKit2-Objects-UserContentManager.html#g:16 scriptMessageReceived> in the bindings.+--+-- There are two variants of note. If you want to provide a detail+-- when connecting the signal you can use ':::', as follows:+--+-- @ 'on' widget (#scriptMessageReceived ':::' "handlerName") $ do ... @+--+-- On the other hand, if you want to connect to the "<https://hackage.haskell.org/package/gi-gobject-2.0.21/docs/GI-GObject-Objects-Object.html#g:30 notify>" signal for a property of a widget, it is recommended to use instead 'PropertyNotify', as follows:+--+-- @ 'on' widget ('PropertyNotify' #propertyName) $ do ... @+--+-- which has the advantage that it will be checked at compile time+-- that the widget does indeed have the property "@propertyName@".+module Data.GI.Base.Signals+    ( on+    , after+    , SignalProxy(..)+    , SignalConnectMode(..)+    , connectSignalFunPtr+    , disconnectSignalHandler+    , SignalHandlerId+    , SignalInfo(..)+    , GObjectNotifySignalInfo+    , SignalCodeGenError+    , resolveSignal+    , connectGObjectNotify+    ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy(..))+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif++import Foreign+import Foreign.C+#if !MIN_VERSION_base(4,13,0)+import Foreign.Ptr (nullPtr)+#endif++import GHC.TypeLits+import Data.Kind (Type)++import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel),+                                AttrGetType, attrGet,+                                AttrBaseTypeConstraint)+import Data.GI.Base.BasicConversions (withTextCString)+import Data.GI.Base.BasicTypes+import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)+import Data.GI.Base.ManagedPtr (withManagedPtr, withTransient)+import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute,+                                 ResolvedSymbolInfo)++import GHC.OverloadedLabels (IsLabel(..))++-- | Type of a `GObject` signal handler id.+type SignalHandlerId = CULong++-- | Support for overloaded signal connectors.+data SignalProxy (object :: Type) (info :: Type) where+  -- | A basic signal name connector.+  SignalProxy :: SignalProxy o info+  -- | A signal connector annotated with a detail.+  (:::) :: forall o info. SignalProxy o info -> Text -> SignalProxy o info+  -- | A signal connector for the @notify@ signal on the given property.+  PropertyNotify :: (info ~ ResolveAttribute propName o,+                     AttrInfo info,+                     pl ~ AttrLabel info, KnownSymbol pl) =>+                    AttrLabelProxy propName ->+                    SignalProxy o GObjectNotifySignalInfo+  -- | A signal connector for the @notify@ signal on the given+  -- property, similar to `PropertyNotify`, but it passes the new+  -- value of the property to the callback for convenience.+  PropertySet :: (info ~ ResolveAttribute propName o,+                  AttrInfo info,+                  AttrBaseTypeConstraint info o,+                  b ~ AttrGetType info,+                  pl ~ AttrLabel info, KnownSymbol pl) =>+                 AttrLabelProxy propName ->+                 SignalProxy o (GObjectPropertySetSignalInfo b)++-- | Support for overloaded labels.+instance (info ~ ResolveSignal slot object) =>+    IsLabel slot (SignalProxy object info) where+#if MIN_VERSION_base(4,10,0)+    fromLabel = SignalProxy+#else+    fromLabel _ = SignalProxy+#endif++-- | Information about an overloaded signal.+class SignalInfo (info :: Type) where+  -- | The type for the signal handler.+  type HaskellCallbackType info :: Type+  -- | Connect a Haskell function to a signal of the given `GObject`,+  -- specifying whether the handler will be called before or after the+  -- default handler. Note that the callback being passed here admits+  -- an extra initial parameter with respect to the usual Haskell+  -- callback type. This will be passed as an /implicit/ @?self@+  -- argument to the Haskell callback.+  connectSignal :: GObject o =>+                   o ->+                   (o -> HaskellCallbackType info) ->+                   SignalConnectMode ->+                   Maybe Text ->+                   IO SignalHandlerId++  -- | Optional extra debug information, for `resolveSignal` below.+  dbgSignalInfo :: Maybe ResolvedSymbolInfo+  dbgSignalInfo = Nothing++-- | Whether to connect a handler to a signal with `connectSignal` so+-- that it runs before/after the default handler for the given signal.+data SignalConnectMode = SignalConnectBefore  -- ^ Run before the default handler.+        | SignalConnectAfter -- ^ Run after the default handler.++-- | Connect a signal to a signal handler.+on :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+      object -> SignalProxy object info+   -> ((?self :: object) => HaskellCallbackType info)+   -> m SignalHandlerId+on o p@(PropertySet (_ :: AttrLabelProxy propName)) cb = liftIO $ do+  let wrapped = wrapPropertySet (Proxy @propName) (Proxy @object) cb+  cb' <- mkGObjectNotifyCallback wrapped+  connectSignalFunPtr o "notify" cb' SignalConnectBefore (proxyDetail p)+on o p c =+  liftIO $ connectSignal @info o w SignalConnectBefore (proxyDetail p)+  where w :: object -> HaskellCallbackType info+        w parent = let ?self = parent in c++-- | Wrap a @b -> IO ()@ callback into a property notify callback on+-- the C side, by adding some code that reads the current value of the+-- property before invoking the callback.+wrapPropertySet :: forall info prop obj.+                   (info ~ ResolveAttribute prop obj,+                    AttrBaseTypeConstraint info obj,+                    AttrInfo info,+                    GObject obj) =>+                   Proxy (prop :: Symbol) -> Proxy obj ->+                   ((?self :: obj) => AttrGetType info -> IO ()) ->+                   Ptr obj -> Ptr GParamSpec -> Ptr () -> IO ()+wrapPropertySet _ _ cb objPtr _pspec _data =+  withTransient objPtr $ \self -> do+    val <- attrGet @(ResolveAttribute prop obj) self+    let ?self = self in cb val++-- | Connect a signal to a handler, running the handler after the default one.+after :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+      object -> SignalProxy object info+      -> ((?self :: object) => HaskellCallbackType info)+      -> m SignalHandlerId+after o p c =+  liftIO $ connectSignal @info o w SignalConnectAfter (proxyDetail p)+  where w :: object -> HaskellCallbackType info+        w parent = let ?self = parent in c++-- | Given a signal proxy, determine the corresponding detail.+proxyDetail :: forall object info. SignalProxy object info -> Maybe Text+proxyDetail p = case p of+  SignalProxy -> Nothing+  (_ ::: detail) -> Just detail+  PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) ->+    Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))+  PropertySet (AttrLabelProxy :: AttrLabelProxy propName) ->+    Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))++-- Connecting GObjects to signals+foreign import ccall g_signal_connect_data ::+    Ptr a ->                            -- instance+    CString ->                          -- detailed_signal+    FunPtr b ->                         -- c_handler+    Ptr () ->                           -- data+    FunPtr c ->                         -- destroy_data+    CUInt ->                            -- connect_flags+    IO SignalHandlerId++-- Releasing the `FunPtr` for the signal handler.+foreign import ccall "& haskell_gi_release_signal_closure"+    ptr_to_release_closure :: FunPtr (Ptr () -> Ptr () -> IO ())++-- | Connect a signal to a handler, given as a `FunPtr`.+connectSignalFunPtr :: GObject o =>+                  o -> Text -> FunPtr a -> SignalConnectMode ->+                  Maybe Text -> IO SignalHandlerId+connectSignalFunPtr object signal fn mode maybeDetail = do+  let flags = case mode of+                SignalConnectAfter -> 1+                SignalConnectBefore -> 0+      signalSpec = case maybeDetail of+                     Nothing -> signal+                     Just detail -> signal <> "::" <> detail+  withTextCString signalSpec $ \csignal ->+    withManagedPtr object $ \objPtr ->+      g_signal_connect_data objPtr csignal fn nullPtr ptr_to_release_closure flags++foreign import ccall g_signal_handler_disconnect :: Ptr o -> SignalHandlerId -> IO ()++-- | Disconnect a previously connected signal.+disconnectSignalHandler :: GObject o => o -> SignalHandlerId -> IO ()+disconnectSignalHandler obj handlerId =+  withManagedPtr obj $ \objPtr ->+        g_signal_handler_disconnect objPtr handlerId++-- | Connection information for a "notify" signal indicating that a+-- specific property changed (see `PropertyNotify` for the relevant+-- constructor).+data GObjectNotifySignalInfo+instance SignalInfo GObjectNotifySignalInfo where+  type HaskellCallbackType GObjectNotifySignalInfo = GObjectNotifyCallback+  connectSignal = connectGObjectNotify++-- | Type for a `GObject` "notify" callback.+type GObjectNotifyCallback = GParamSpec -> IO ()++gobjectNotifyCallbackWrapper :: GObject o =>+  (o -> GObjectNotifyCallback) -> GObjectNotifyCallbackC o+gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do+    pspec' <- newGParamSpecFromPtr pspec+    withTransient (castPtr selfPtr) $ \self -> cb self pspec'++type GObjectNotifyCallbackC o = Ptr o -> Ptr GParamSpec -> Ptr () -> IO ()++foreign import ccall "wrapper"+    mkGObjectNotifyCallback :: GObjectNotifyCallbackC o -> IO (FunPtr (GObjectNotifyCallbackC o))++-- | Connect the given notify callback for a GObject.+connectGObjectNotify :: GObject o =>+                        o -> (o -> GObjectNotifyCallback) ->+                        SignalConnectMode ->+                        Maybe Text ->+                        IO SignalHandlerId+connectGObjectNotify obj cb mode detail = do+  cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)+  connectSignalFunPtr obj "notify" cb' mode detail++data GObjectPropertySetSignalInfo (b :: Type)+instance SignalInfo (GObjectPropertySetSignalInfo b) where+  type HaskellCallbackType (GObjectPropertySetSignalInfo b) = b -> IO ()+  connectSignal = undefined -- We connect these separately++-- | Generate an informative type error whenever one tries to use a+-- signal for which code generation has failed.+type family SignalCodeGenError (signalName :: Symbol) :: Type where+  SignalCodeGenError signalName = TypeError+    ('Text "The signal ‘"+     ':<>: 'Text signalName+     ':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings."+    ':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.")++-- | Return the fully qualified signal name that a given overloaded+-- signal resolves to (mostly useful for debugging).+--+-- > resolveSignal #childNotify button+resolveSignal :: forall object info. (GObject object, SignalInfo info) =>+                 object -> SignalProxy object info -> Maybe ResolvedSymbolInfo+resolveSignal _o _p = dbgSignalInfo @info
+ Data/GI/Base/Signals.hs-boot view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}++module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after,+       connectGObjectNotify, SignalConnectMode(..)) where++import Data.GI.Base.Overloading (ResolvedSymbolInfo)+import Data.GI.Base.BasicTypes (GObject, GParamSpec)+import Control.Monad.IO.Class (MonadIO)+import Foreign.C (CULong)+import Data.Text (Text)++data SignalConnectMode = SignalConnectBefore+        | SignalConnectAfter++class SignalInfo info where+  type HaskellCallbackType info+  connectSignal :: GObject o =>+                     o ->+                     (o -> HaskellCallbackType info) ->+                     SignalConnectMode ->+                     Maybe Text ->+                     IO SignalHandlerId+  dbgSignalInfo :: Maybe ResolvedSymbolInfo+  dbgSignalInfo = Nothing++type role SignalProxy nominal nominal+data SignalProxy object info where++type SignalHandlerId = CULong++on :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+       object -> SignalProxy object info+             -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId++after :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+       object -> SignalProxy object info+             -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId++type GObjectNotifyCallback = GParamSpec -> IO ()++connectGObjectNotify :: GObject o =>+                        o -> (o -> GObjectNotifyCallback) ->+                        SignalConnectMode ->+                        Maybe Text ->+                        IO SignalHandlerId
− Data/GI/Base/Signals.hsc 
@@ -1,174 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE UndecidableInstances #-}---- | Routines for connecting `GObject`s to signals.-module Data.GI.Base.Signals-    ( on-    , after-    , SignalProxy(..)-    , SignalConnectMode(..)-    , connectSignalFunPtr-    , SignalHandlerId-    , SignalInfo(..)-    , GObjectNotifySignalInfo-    ) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Proxy (Proxy(..))--import Foreign-import Foreign.C--import GHC.TypeLits--import Data.GI.Base.Attributes (AttrLabelProxy, AttrInfo(AttrLabel))-import Data.GI.Base.BasicTypes-import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)-import Data.GI.Base.ManagedPtr (withManagedPtr)-import Data.GI.Base.Overloading (ResolveSignal,-                                 IsLabelProxy(..), ResolveAttribute)-import Data.GI.Base.Utils (safeFreeFunPtrPtr)--#if MIN_VERSION_base(4,9,0)-import GHC.OverloadedLabels (IsLabel(..))-#else-import Data.GI.Base.Overloading (HasSignal)-#endif---- | Type of a `GObject` signal handler id.-type SignalHandlerId = CULong---- | A class that provides a constraint satisfied by every type.-class NoConstraint a-instance NoConstraint a---- | Support for overloaded signal connectors.-data SignalProxy (object :: *) (info :: *) where-    SignalProxy :: SignalProxy o info-    PropertyNotify :: (info ~ ResolveAttribute propName o,-                       AttrInfo info,-                       pl ~ AttrLabel info) =>-                      AttrLabelProxy propName ->-                      SignalProxy o (GObjectNotifySignalInfo pl)---- | Support for overloaded labels.-instance-#if !MIN_VERSION_base(4,9,0)-    -- This gives better error reporting in ghc < 8.0.-       (HasSignal slot object, info ~ ResolveSignal slot object)-#else-       info ~ ResolveSignal slot object-#endif-    => IsLabelProxy slot (SignalProxy object info) where-    fromLabelProxy _ = SignalProxy--#if MIN_VERSION_base(4,10,0)-instance info ~ ResolveSignal slot object =>-    IsLabel slot (SignalProxy object info) where-    fromLabel = SignalProxy-#elif MIN_VERSION_base(4,9,0)-instance info ~ ResolveSignal slot object =>-    IsLabel slot (SignalProxy object info) where-    fromLabel _ = SignalProxy-#endif---- | Information about an overloaded signal.-class SignalInfo (info :: *) where-    type HaskellCallbackType info-    -- | Connect a Haskell function to a signal of the given `GObject`,-    -- specifying whether the handler will be called before or after-    -- the default handler.-    connectSignal :: GObject o =>-                     SignalProxy o info ->-                     o ->-                     HaskellCallbackType info ->-                     SignalConnectMode ->-                     IO SignalHandlerId---- | Whether to connect a handler to a signal with `connectSignal` so--- that it runs before/after the default handler for the given signal.-data SignalConnectMode = SignalConnectBefore  -- ^ Run before the default handler.-        | SignalConnectAfter -- ^ Run after the default handler.---- | Same as `connectSignal`, specifying from the beginning that the--- handler is to be run before the default handler.------ > on object signal handler = liftIO $ connectSignal signal object handler SignalConnectBefore-on :: forall object info m.-      (GObject object, MonadIO m, SignalInfo info) =>-      object -> SignalProxy object info-             -> HaskellCallbackType info -> m SignalHandlerId-on o p c = liftIO $ connectSignal p o c SignalConnectBefore---- | Connect a signal to a handler, running the handler after the default one.------ > after object signal handler = liftIO $ connectSignal signal object handler SignalConnectAfter-after :: forall object info m.-      (GObject object, MonadIO m, SignalInfo info) =>-      object -> SignalProxy object info-             -> HaskellCallbackType info -> m SignalHandlerId-after o p c = liftIO $ connectSignal p o c SignalConnectAfter---- Connecting GObjects to signals-foreign import ccall "g_signal_connect_data" g_signal_connect_data ::-    Ptr a ->                            -- instance-    CString ->                          -- detailed_signal-    FunPtr b ->                         -- c_handler-    Ptr () ->                           -- data-    FunPtr c ->                         -- destroy_data-    CUInt ->                            -- connect_flags-    IO SignalHandlerId---- | Connect a signal to a handler, given as a `FunPtr`.-connectSignalFunPtr :: GObject o =>-                  o -> String -> FunPtr a -> SignalConnectMode -> IO SignalHandlerId-connectSignalFunPtr object signal fn mode = do-  let flags = case mode of-                SignalConnectAfter -> 1-                SignalConnectBefore -> 0-  withCString signal $ \csignal ->-    withManagedPtr object $ \objPtr ->-        g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags---- | Connection information for a "notify" signal indicating that a--- specific property changed (see `PropertyNotify` for the relevant--- constructor).-data GObjectNotifySignalInfo (propName :: Symbol)-instance KnownSymbol propName =>-    SignalInfo (GObjectNotifySignalInfo propName) where-  type HaskellCallbackType (GObjectNotifySignalInfo propName) = GObjectNotifyCallback-  connectSignal = connectGObjectNotify (symbolVal (Proxy :: Proxy propName))---- | Type for a `GObject` `notify` callback.-type GObjectNotifyCallback = GParamSpec -> IO ()--gobjectNotifyCallbackWrapper ::-    GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()-gobjectNotifyCallbackWrapper _cb _ pspec _ = do-    pspec' <- newGParamSpecFromPtr pspec-    _cb  pspec'--type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()--foreign import ccall "wrapper"-    mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)---- | Connect the given notify callback for a GObject.-connectGObjectNotify :: forall o i. GObject o =>-                        String ->-                        SignalProxy o (i :: *) ->-                        o -> GObjectNotifyCallback ->-                        SignalConnectMode -> IO SignalHandlerId-connectGObjectNotify propName _ obj cb mode = do-  cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)-  let signalName = "notify::" ++ propName-  connectSignalFunPtr obj signalName cb' mode
Data/GI/Base/Utils.hsc view
@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings,-    FlexibleContexts, ConstraintKinds #-}+    FlexibleContexts, ConstraintKinds, TypeApplications #-} {- | Assorted utility functions for bindings. -} module Data.GI.Base.Utils     ( whenJust@@ -21,6 +21,7 @@     , memcpy     , safeFreeFunPtr     , safeFreeFunPtrPtr+    , safeFreeFunPtrPtr'     , maybeReleaseFunPtr     , checkUnexpectedReturnNULL     , checkUnexpectedNothing@@ -29,23 +30,25 @@  #include <glib-object.h> -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative, pure, (<$>), (<*>))-#endif import Control.Exception (throwIO) import Control.Monad (void)  import qualified Data.Text as T import qualified Data.Text.Foreign as TF+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Word +#if !MIN_VERSION_base(4,13,0) import Foreign (peek)+#endif import Foreign.C.Types (CSize(..), CChar) import Foreign.Ptr (Ptr, nullPtr, FunPtr, nullFunPtr, freeHaskellFunPtr) import Foreign.Storable (Storable(..)) -import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..),+import Data.GI.Base.BasicTypes (GType(..), CGType, GBoxed,+                                TypedObject(glibType),                                 UnexpectedNullPointerReturn(..)) import Data.GI.Base.CallStack (HasCallStack, callStack, prettyCallStack) @@ -126,10 +129,10 @@ -- in particular may well be different from a plain g_malloc. In -- particular g_slice_alloc is often used for allocating boxed -- objects, which are then freed using g_slice_free.-callocBoxedBytes :: forall a. BoxedObject a => Int -> IO (Ptr a)+callocBoxedBytes :: forall a. GBoxed a => Int -> IO (Ptr a) callocBoxedBytes n = do   ptr <- callocBytes n-  GType cgtype <- boxedType (undefined :: a)+  GType cgtype <- glibType @a   result <- g_boxed_copy cgtype ptr   freeMem ptr   return result@@ -170,6 +173,12 @@ foreign import ccall "& safeFreeFunPtr" safeFreeFunPtrPtr ::     FunPtr (Ptr a -> IO ()) +-- | Similar to 'safeFreeFunPtrPtr', but accepts an additional+-- (ignored) argument. The first argument is interpreted as a+-- 'FunPtr', and released.+foreign import ccall "& safeFreeFunPtr2" safeFreeFunPtrPtr' ::+    FunPtr (Ptr a -> Ptr b -> IO ())+ -- | If given a pointer to the memory location, free the `FunPtr` at -- that location, and then the pointer itself. Useful for freeing the -- memory associated to callbacks which are called just once, with no@@ -188,7 +197,8 @@         throwIO (UnexpectedNullPointerReturn {                    nullPtrErrorMsg = "Received unexpected nullPtr in \""                                      <> fnName <> "\".\n" <>-                                     "This is a bug in the introspection data, please report it at\nhttps://github.com/haskell-gi/haskell-gi/issues\n" <>+                                     "This might be a bug in the introspection data, or perhaps a use-after-free bug.\n" <>+                                     "If in doubt, please report it at\n\thttps://github.com/haskell-gi/haskell-gi/issues\n" <>                                      T.pack (prettyCallStack callStack)                  })     | otherwise = return ()@@ -201,9 +211,10 @@   case result of     Just r -> return r     Nothing -> throwIO (UnexpectedNullPointerReturn {-                 nullPtrErrorMsg = "Received unexpected nullPtr in \""+                 nullPtrErrorMsg = "Received unexpected Nothing in \""                                      <> fnName <> "\".\n" <>-                                     "This is a bug in the introspection data, please report it at\nhttps://github.com/haskell-gi/haskell-gi/issues\n" <>+                                     "This might be a bug in the introspection data, or perhaps a use-after-free bug.\n" <>+                                     "If in doubt, please report it at\n\thttps://github.com/haskell-gi/haskell-gi/issues\n" <>                                      T.pack (prettyCallStack callStack)                  })
− c/hsgclosure.c 
@@ -1,273 +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 (gnu_printf, 1, 2)))-static void dbg_log (const char *msg, ...)-{-  va_list args;--  va_start(args, msg);--  if (print_debug_info()) {-    lock_log();-    vfprintf(stderr, msg, args);-    unlock_log();-  }--  va_end(args);-}--int check_object_type(void *instance, GType type)-{-  int result;--  if (instance != NULL) {-     result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);-  } else {-    result = 0;-    dbg_log("Check failed: got a null pointer\n");-  }--  return result;-}--/* Information about a boxed type to free */-typedef struct {-  GType gtype;-  gpointer boxed;-} BoxedFreeInfo;--/* Auxiliary function for freeing boxed types in the main loop. See-   the annotation in g_object_unref_in_main_loop() below. */-static gboolean main_loop_boxed_free_helper (gpointer _info)-{-  BoxedFreeInfo *info = (BoxedFreeInfo*)_info;--  if (print_debug_info()) {-    GThread *self = g_thread_self ();-    lock_log();-    dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n",-            info->boxed, self);-    dbg_log("\tIt is of type %s\n", g_type_name(info->gtype));-  }--  g_boxed_free (info->gtype, info->boxed);--  if (print_debug_info()) {-    dbg_log("\tdone freeing %p.\n", info->boxed);-    unlock_log();-  }--  g_free(info);--  return FALSE; /* Do not invoke again */-}--void boxed_free_helper (GType gtype, void *boxed)-{-  BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo));--  info->gtype = gtype;-  info->boxed = boxed;--  g_idle_add (main_loop_boxed_free_helper, info);-}--void dbg_g_object_disown (GObject *obj)-{-  GType gtype;--  if (print_debug_info()) {-    lock_log();-    GThread *self = g_thread_self();-    dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self);-    gtype = G_TYPE_FROM_INSTANCE (obj);-    dbg_log("\tIt is of type %s\n", g_type_name(gtype));-    dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count);-    unlock_log();-  }-}--static void print_object_dbg_info (GObject *obj)-{-  GThread *self = g_thread_self();-  GType gtype;--  dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self);-  gtype = G_TYPE_FROM_INSTANCE (obj);-  dbg_log("\tIt is of type %s\n", g_type_name(gtype));-  dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count);-}--/*-  We schedule all GObject deletions to happen in the main loop. The-  reason is that for some types the destructor is not thread safe, and-  assumes that it is being run from the same thread as the main loop-  that created the object.- */-static gboolean-g_object_unref_in_main_loop (gpointer obj)-{-  if (print_debug_info()) {-    lock_log();-    print_object_dbg_info ((GObject*)obj);-  }--  g_object_unref (obj);--  if (print_debug_info()) {-    fprintf(stderr, "\tUnref done\n");-    unlock_log();-  }--  return FALSE; /* Do not invoke again */-}--void dbg_g_object_unref (GObject *obj)-{-  g_idle_add(g_object_unref_in_main_loop, obj);-}--/**- * dbg_g_object_new:- * @gtype: #GType for the object to construct.- * @n_props: Number of parameters for g_object_new_with_properties().- * @names: Names of the properties to be set.- * @values: Parameters for g_object_new_with_properties().- *- * Allocate a #GObject of #GType @gtype, with the given @params. The- * returned object is never floating, and we always own a reference to- * it. (It might not be the only existing to the object, but it is in- * any case safe to call g_object_unref() when we are not wrapping the- * object ourselves anymore.)- *- * Returns: A new #GObject.- */-gpointer dbg_g_object_new (GType gtype, guint n_props,-                           const char *names[], const GValue values[])-{-  gpointer result;--  if (print_debug_info()) {-    GThread *self = g_thread_self();--    lock_log();-    dbg_log("Creating a new GObject of type %s [thread: %p]\n",-            g_type_name(gtype), self);-  }--#if GLIB_CHECK_VERSION(2,54,0)-  result = g_object_new_with_properties (gtype, n_props, names, values);-#else-  { GParameter params[n_props];-    int i;--    for (i=0; i<n_props; i++) {-      memcpy (&params[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);-}
+ 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 (&params[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(&gtypes_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(&gtypes_mutex);++  return result;+}++static HsStablePtr duplicateStablePtr(HsStablePtr stable_ptr)+{+  return getStablePtr(deRefStablePtr(stable_ptr));+}++GType haskell_gi_StablePtr_get_type (void)+{+  static gsize g_define_type_id = 0;++  if (g_once_init_enter (&g_define_type_id))+    {+      GType type_id =+        g_boxed_type_register_static (g_intern_static_string ("HaskellGIStablePtr"),+                                      duplicateStablePtr,+                                      hs_free_stable_ptr);++      g_once_init_leave (&g_define_type_id, type_id);+    }++  return g_define_type_id;+}++/* This is identical to haskell_gi_StablePtr_get_type, other than the+   type name. The reason for this is that we want two different types,+   to distinguish between GValues wrapping generic StablePtrs, and+   those wrapping specifically wrapping StablePtrs to Dynamic+   values. */+GType haskell_gi_HaskellValue_get_type (void)+{+  static gsize g_define_type_id = 0;++  if (g_once_init_enter (&g_define_type_id))+    {+      GType type_id =+        g_boxed_type_register_static (g_intern_static_string ("HaskellGIHaskellValue"),+                                      duplicateStablePtr,+                                      hs_free_stable_ptr);++      g_once_init_leave (&g_define_type_id, type_id);+    }++  return g_define_type_id;+}++/* A safer version of get_boxed, that checks that the GValue contains+   the right boxed type. */+gpointer haskell_gi_safe_get_boxed_haskell_value(const GValue *gv)+{+  if (G_VALUE_TYPE(gv) != haskell_gi_HaskellValue_get_type()) {+    fprintf(stderr, "Unexpected type inside the GValue: ‘%s’\n.",+            G_VALUE_TYPE_NAME(gv));++    return NULL;+  }++  return g_value_get_boxed(gv);+}++/* Release the FunPtr allocated for a Haskell signal handler */+void+haskell_gi_release_signal_closure (gpointer unused,+                                   GCClosure *closure)+{+  lock_log();+  dbg_log("Releasing a signal closure %p\n", closure->callback);++  hs_free_fun_ptr (closure->callback);++  dbg_log("\tDone.\n");+  unlock_log();+}++/* Check whether the given closure is floating */+gboolean+haskell_gi_g_closure_is_floating (GClosure *closure)+{+  return !!(closure->floating);+}++/* GParamSpec* types are registered as GObjects, but they do not have+   an exported type_init function. They only export CPP macros, so+   we have to provide our own. */+#define PARAM_TYPE(CamelCase, UPPERCASE) \+  GType haskell_gi_pspec_type_init_##CamelCase (void) { \+    return G_TYPE_##UPPERCASE;                          \+  }++PARAM_TYPE(ParamSpec, PARAM);+PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN);+PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED);+PARAM_TYPE(ParamSpecChar, PARAM_CHAR);+PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE);+PARAM_TYPE(ParamSpecEnum, PARAM_ENUM);+PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS);+PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT);+PARAM_TYPE(ParamSpecGType, PARAM_GTYPE);+PARAM_TYPE(ParamSpecInt, PARAM_INT);+PARAM_TYPE(ParamSpecInt64, PARAM_INT64);+PARAM_TYPE(ParamSpecLong, PARAM_LONG);+PARAM_TYPE(ParamSpecObject, PARAM_OBJECT);+PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE);+PARAM_TYPE(ParamSpecParam, PARAM_PARAM);+PARAM_TYPE(ParamSpecPointer, PARAM_POINTER);+PARAM_TYPE(ParamSpecString, PARAM_STRING);+PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR);+PARAM_TYPE(ParamSpecUInt, PARAM_UINT);+PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64);+PARAM_TYPE(ParamSpecULong, PARAM_ULONG);+PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR);+PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT);+/* The following is deprecated, ignore the warning that GLib raises. */+#undef GLIB_DEPRECATED_MACRO+#define GLIB_DEPRECATED_MACRO+PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY);
haskell-gi-base.cabal view
@@ -1,8 +1,8 @@ name:                haskell-gi-base-version:             0.21.5+version:             0.26.9 synopsis:            Foundation for libraries generated by haskell-gi description:         Foundation for libraries generated by haskell-gi-homepage:            https://github.com/haskell-gi/haskell-gi-base+homepage:            https://github.com/haskell-gi/haskell-gi license:             LGPL-2.1                      -- or above license-file:        LICENSE@@ -13,13 +13,13 @@ stability:           Experimental category:            Development build-type:          Simple-cabal-version:       >=1.8+cabal-version:       2.0  extra-source-files: ChangeLog.md  source-repository head   type: git-  location: git://github.com/haskell-gi/haskell-gi-base.git+  location: https://github.com/haskell-gi/haskell-gi.git  library   exposed-modules:     Data.GI.Base,@@ -27,11 +27,13 @@                        Data.GI.Base.BasicConversions,                        Data.GI.Base.BasicTypes,                        Data.GI.Base.CallStack,-                       Data.GI.Base.Closure,                        Data.GI.Base.Constructible,+                       Data.GI.Base.GArray,                        Data.GI.Base.GError,+                       Data.GI.Base.GClosure,                        Data.GI.Base.GHashTable,                        Data.GI.Base.GObject,+                       Data.GI.Base.GQuark,                        Data.GI.Base.GType,                        Data.GI.Base.GValue,                        Data.GI.Base.GVariant,@@ -41,23 +43,23 @@                        Data.GI.Base.Properties,                        Data.GI.Base.ShortPrelude,                        Data.GI.Base.Signals,-                       Data.GI.Base.Utils+                       Data.GI.Base.Utils,+                       Data.GI.Base.DynVal,+                       Data.GI.Base.Internal.CTypes+                       Data.GI.Base.Internal.PathFieldAccess -  pkgconfig-depends:   gobject-2.0 >= 2.32, glib-2.0-  build-depends:       base >= 4.7 && < 5,+  pkgconfig-depends:   gobject-2.0 >= 2.42, glib-2.0+  build-depends:       base >= 4.11 && < 5,                        bytestring,                        containers,-                       text >= 1.0--  if !impl(ghc >= 8.0)-    build-depends:     transformers+                       text >= 1.0,+                       optics-core >= 0.4 -  if impl(ghc >= 8.0)-    ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns-  else-    ghc-options: -Wall -fwarn-incomplete-patterns+  ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat -Wno-unticked-promoted-constructors -  build-tools:         hsc2hs+  build-tool-depends:  hsc2hs:hsc2hs   cc-options:          -fPIC-  extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds-  c-sources:           c/hsgclosure.c+  default-language:    Haskell2010+  default-extensions:  CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds+  other-extensions:    TypeApplications, ScopedTypeVariables+  c-sources:           csrc/hsgclosure.c