haskell-gi-base 0.26.8 → 0.26.9

raw patch · 10 files changed

+539/−36 lines, 10 filesdep +optics-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: optics-core

API changes (from Hackage documentation)

Files

• Data/GI/Base.hs +2/−1
• Data/GI/Base/Attributes.hs +197/−12
• Data/GI/Base/BasicTypes.hsc +1/−3
• Data/GI/Base/DynVal.hs +144/−0
• Data/GI/Base/GError.hs +1/−3
• Data/GI/Base/GObject.hsc +56/−7
• Data/GI/Base/Internal/PathFieldAccess.hs +76/−0
• Data/GI/Base/Signals.hs +44/−4
• Data/GI/Base/Signals.hs-boot +11/−2
• haskell-gi-base.cabal +7/−4

@@ -29,5 +29,6 @@ import Data.GI.Base.GValue (GValue(..), fromGValue, toGValue, IsGValue(..)) import Data.GI.Base.GVariant import Data.GI.Base.ManagedPtr-import Data.GI.Base.Signals (on, after, SignalProxy(PropertyNotify, (:::)))+import Data.GI.Base.Signals (on, after,+                             SignalProxy(PropertyNotify, PropertySet, (:::))) import Data.GI.Base.Overloading (asA)

@@ -1,8 +1,19 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,-  TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,-  UndecidableInstances, FlexibleInstances, TypeApplications,-  DefaultSignatures, PolyKinds, AllowAmbiguousTypes,-  ImplicitParams, RankNTypes #-}+{-# 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 #-}  -- | --@@ -146,29 +157,41 @@    AttrLabelProxy(..), -  resolveAttr+  resolveAttr,+  bindPropToField,++  EqMaybe(..)   ) where -import Control.Monad (void)+import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO)  import Data.GI.Base.BasicTypes (GObject)+import Data.GI.Base.DynVal (DynVal(..), ModelProxy, DVKey(..),+                            modelProxyCurrentValue, modelProxyRegisterHandler,+                            modelProxyUpdate, dvKeys, dvRead) import Data.GI.Base.GValue (GValueConstruct) import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute,                                  ResolvedSymbolInfo)+import Data.GI.Base.Internal.PathFieldAccess (PathFieldAccess(..), Components) -import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy,-                                            on, after)+import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..),+                                            SignalProxy,+                                            on, after, connectGObjectNotify,+                                            SignalConnectMode(..)) -import Data.Proxy (Proxy(..)) import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import qualified Data.Text as T -import GHC.TypeLits+import GHC.TypeLits (Symbol, KnownSymbol, ErrorMessage(..), TypeError,+                     symbolVal) import GHC.Exts (Constraint)  import GHC.OverloadedLabels (IsLabel(..))+import qualified Optics.Core as O -infixr 0 :=,:~,:=>,:~>+infixr 0 :=,:~,:=>,:~>,:<~,:!<~  -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy@@ -274,6 +297,20 @@                             Proxy o -> b -> IO (AttrTransferType info)     attrTransfer _ = return +    -- | Like `attrSet`, but it uses the same type as the getter. This+    -- is useful for some nullable types, for which the getter returns+    -- @Maybe a@, while the setter takes an @a@. `attrPut` will+    -- instead accept an @Maybe a@.+    attrPut :: AttrBaseTypeConstraint info o =>+               o -> AttrGetType info -> IO ()+    default attrPut :: -- Make sure that a non-default method+                       -- implementation is provided if AttrSet+                       -- is set.+                        CheckNotElem 'AttrPut (AttrAllowedOps info)+                         (PutNotProvidedError info) =>+                       o -> AttrGetType info -> IO ()+    attrPut = undefined+     -- | Return some information about the overloaded attribute,     -- useful for debugging. See `resolveAttr` for how to access this     -- conveniently.@@ -341,6 +378,11 @@ type family SetNotProvidedError (info :: o) :: ErrorMessage where   SetNotProvidedError info = OpNotProvidedError info 'AttrSet "attrSet" +-- | Error to be raised when AttrSet is allowed, but an `attrPut`+-- implementation has not been provided.+type family PutNotProvidedError (info :: o) :: ErrorMessage where+  PutNotProvidedError info = OpNotProvidedError info 'AttrSet "attrPut"+ -- | Error to be raised when AttrConstruct is allowed, but an -- implementation has not been provided. type family ConstructNotProvidedError (info :: o) :: ErrorMessage where@@ -366,6 +408,9 @@                | AttrClear                -- ^ It is possible to clear the value of the                -- (nullable) attribute with `clear`.+               | AttrPut+               -- ^ It is possible to set a value of the same type as+               -- the one returned by `get`.   deriving (Eq, Ord, Enum, Bounded, Show)  -- | A user friendly description of the `AttrOpTag`, useful when@@ -375,6 +420,7 @@     AttrOpText 'AttrSet = "settable"     AttrOpText 'AttrConstruct = "constructible"     AttrOpText 'AttrClear = "nullable"+    AttrOpText 'AttrPut = "puttable"  -- | Constraint on a @obj@\/@attr@ pair so that `set` works on values -- of type @value@.@@ -450,6 +496,61 @@               (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@@ -461,6 +562,16 @@           -> ((?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@@ -484,6 +595,26 @@      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 @@ -524,3 +655,57 @@                  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)+

@@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,-  DeriveDataTypeable, TypeFamilies, ScopedTypeVariables,+  TypeFamilies, ScopedTypeVariables,   MultiParamTypeClasses, DataKinds, TypeOperators, UndecidableInstances,   AllowAmbiguousTypes #-} @@ -49,7 +49,6 @@ import Data.Coerce (coerce, Coercible) import Data.IORef (IORef) import qualified Data.Text as T-import Data.Typeable (Typeable) import Data.Int import Data.Word @@ -163,7 +162,6 @@ -- an unexpected `Foreign.Ptr.nullPtr`. data UnexpectedNullPointerReturn =     UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text }-                                deriving (Typeable)  instance Show UnexpectedNullPointerReturn where   show r = T.unpack (nullPtrErrorMsg r)

@@ -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)

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies, DataKinds #-}  -- | To catch GError exceptions use the@@ -65,7 +65,6 @@ import Control.Exception import Data.Text (Text) import qualified Data.Text as T-import Data.Typeable (Typeable)  import System.IO.Unsafe (unsafePerformIO) @@ -83,7 +82,6 @@ -- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and -- 'gerrorMessage' below. newtype GError = GError (ManagedPtr GError)-    deriving (Typeable)  instance Show GError where     show gerror = unsafePerformIO $ do

@@ -1,11 +1,13 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  -- | This module constains helpers for dealing with `GObject`-derived -- types.@@ -39,7 +41,7 @@     ) where  import Data.Maybe (catMaybes)-import Control.Monad (void)+import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO)  import Data.Proxy (Proxy(..))@@ -58,9 +60,11 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Optics.Core as O+ import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy,                                 attrConstruct, attrTransfer,-                                AttrInfo(..))+                                AttrInfo(..), EqMaybe(..), bindPropToField) import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, GSList,                                 GDestroyNotify, ManagedPtr(..), GParamSpec(..),                                 TypedObject(glibType),@@ -68,6 +72,8 @@ 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(..),@@ -82,6 +88,7 @@ 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> @@ -99,6 +106,7 @@   props <- catMaybes <$> mapM construct attrs   obj <- doConstructGObject constructor props   mapM_ (setSignal obj) attrs+  mapM_ (registerHandlers obj) attrs   return obj   where     construct :: AttrOp o 'AttrConstruct ->@@ -113,6 +121,30 @@       (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 @@ -120,6 +152,23 @@     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.

@@ -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)+

@@ -54,6 +54,7 @@     , GObjectNotifySignalInfo     , SignalCodeGenError     , resolveSignal+    , connectGObjectNotify     ) where  import Control.Monad.IO.Class (MonadIO, liftIO)@@ -74,7 +75,9 @@ import qualified Data.Text as T import Data.Text (Text) -import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel))+import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel),+                                AttrGetType, attrGet,+                                AttrBaseTypeConstraint) import Data.GI.Base.BasicConversions (withTextCString) import Data.GI.Base.BasicTypes import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)@@ -99,6 +102,16 @@                      pl ~ AttrLabel info, KnownSymbol pl) =>                     AttrLabelProxy propName ->                     SignalProxy o GObjectNotifySignalInfo+  -- | A signal connector for the @notify@ signal on the given+  -- property, similar to `PropertyNotify`, but it passes the new+  -- value of the property to the callback for convenience.+  PropertySet :: (info ~ ResolveAttribute propName o,+                  AttrInfo info,+                  AttrBaseTypeConstraint info o,+                  b ~ AttrGetType info,+                  pl ~ AttrLabel info, KnownSymbol pl) =>+                 AttrLabelProxy propName ->+                 SignalProxy o (GObjectPropertySetSignalInfo b)  -- | Support for overloaded labels. instance (info ~ ResolveSignal slot object) =>@@ -141,11 +154,31 @@       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) =>@@ -164,6 +197,8 @@   (_ ::: detail) -> Just detail   PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) ->     Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))+  PropertySet (AttrLabelProxy :: AttrLabelProxy propName) ->+    Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object)))  -- Connecting GObjects to signals foreign import ccall g_signal_connect_data ::@@ -214,15 +249,15 @@ type GObjectNotifyCallback = GParamSpec -> IO ()  gobjectNotifyCallbackWrapper :: GObject o =>-  (o -> GObjectNotifyCallback) -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()+  (o -> GObjectNotifyCallback) -> GObjectNotifyCallbackC o gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do     pspec' <- newGParamSpecFromPtr pspec     withTransient (castPtr selfPtr) $ \self -> cb self pspec' -type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()+type GObjectNotifyCallbackC o = Ptr o -> Ptr GParamSpec -> Ptr () -> IO ()  foreign import ccall "wrapper"-    mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)+    mkGObjectNotifyCallback :: GObjectNotifyCallbackC o -> IO (FunPtr (GObjectNotifyCallbackC o))  -- | Connect the given notify callback for a GObject. connectGObjectNotify :: GObject o =>@@ -233,6 +268,11 @@ 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.

@@ -6,10 +6,11 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RankNTypes #-} -module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after) where+module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after,+       connectGObjectNotify, SignalConnectMode(..)) where  import Data.GI.Base.Overloading (ResolvedSymbolInfo)-import Data.GI.Base.BasicTypes (GObject)+import Data.GI.Base.BasicTypes (GObject, GParamSpec) import Control.Monad.IO.Class (MonadIO) import Foreign.C (CULong) import Data.Text (Text)@@ -42,3 +43,11 @@       (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

@@ -1,5 +1,5 @@ name:                haskell-gi-base-version:             0.26.8+version:             0.26.9 synopsis:            Foundation for libraries generated by haskell-gi description:         Foundation for libraries generated by haskell-gi homepage:            https://github.com/haskell-gi/haskell-gi@@ -19,7 +19,7 @@  source-repository head   type: git-  location: git://github.com/haskell-gi/haskell-gi.git+  location: https://github.com/haskell-gi/haskell-gi.git  library   exposed-modules:     Data.GI.Base,@@ -44,15 +44,18 @@                        Data.GI.Base.ShortPrelude,                        Data.GI.Base.Signals,                        Data.GI.Base.Utils,+                       Data.GI.Base.DynVal,                        Data.GI.Base.Internal.CTypes+                       Data.GI.Base.Internal.PathFieldAccess    pkgconfig-depends:   gobject-2.0 >= 2.42, glib-2.0   build-depends:       base >= 4.11 && < 5,                        bytestring,                        containers,-                       text >= 1.0+                       text >= 1.0,+                       optics-core >= 0.4 -  ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat+  ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat -Wno-unticked-promoted-constructors    build-tool-depends:  hsc2hs:hsc2hs   cc-options:          -fPIC