diff --git a/Data/GI/Base.hs b/Data/GI/Base.hs --- a/Data/GI/Base.hs +++ b/Data/GI/Base.hs @@ -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) diff --git a/Data/GI/Base/Attributes.hs b/Data/GI/Base/Attributes.hs --- a/Data/GI/Base/Attributes.hs +++ b/Data/GI/Base/Attributes.hs @@ -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) + diff --git a/Data/GI/Base/BasicTypes.hsc b/Data/GI/Base/BasicTypes.hsc --- a/Data/GI/Base/BasicTypes.hsc +++ b/Data/GI/Base/BasicTypes.hsc @@ -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) diff --git a/Data/GI/Base/DynVal.hs b/Data/GI/Base/DynVal.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/DynVal.hs @@ -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) diff --git a/Data/GI/Base/GError.hs b/Data/GI/Base/GError.hs --- a/Data/GI/Base/GError.hs +++ b/Data/GI/Base/GError.hs @@ -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 diff --git a/Data/GI/Base/GObject.hsc b/Data/GI/Base/GObject.hsc --- a/Data/GI/Base/GObject.hsc +++ b/Data/GI/Base/GObject.hsc @@ -1,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 @@ -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. diff --git a/Data/GI/Base/Internal/PathFieldAccess.hs b/Data/GI/Base/Internal/PathFieldAccess.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Internal/PathFieldAccess.hs @@ -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) + diff --git a/Data/GI/Base/Signals.hs b/Data/GI/Base/Signals.hs --- a/Data/GI/Base/Signals.hs +++ b/Data/GI/Base/Signals.hs @@ -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. diff --git a/Data/GI/Base/Signals.hs-boot b/Data/GI/Base/Signals.hs-boot --- a/Data/GI/Base/Signals.hs-boot +++ b/Data/GI/Base/Signals.hs-boot @@ -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 diff --git a/haskell-gi-base.cabal b/haskell-gi-base.cabal --- a/haskell-gi-base.cabal +++ b/haskell-gi-base.cabal @@ -1,5 +1,5 @@ name: haskell-gi-base -version: 0.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