diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +### 0.24.8 + ++ Make the StablePtr IsGValue instance make a copy in fromGValue. + +### 0.24.7 + ++ Add a mechanism for marshalling generic Haskell values into `GValue`s. + ### 0.24.4 + Add a workaround for old hsc2hs versions, so drop the constraint on hsc2hs. 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,7 +1,19 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures, - TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds, - UndecidableInstances, FlexibleInstances, TypeApplications, - DefaultSignatures, PolyKinds, AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- @@ -143,27 +155,43 @@ set, clear, - AttrLabelProxy(..) + AttrLabelProxy(..), + + resolveAttr, + bindPropToField, + + EqMaybe(..) ) where -import Control.Monad (void) +import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.GI.Base.BasicTypes (GObject) +import Data.GI.Base.DynVal (DynVal(..), ModelProxy, DVKey(..), + modelProxyCurrentValue, modelProxyRegisterHandler, + modelProxyUpdate, dvKeys, dvRead) import Data.GI.Base.GValue (GValueConstruct) -import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute) +import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute, + ResolvedSymbolInfo) +import Data.GI.Base.Internal.PathFieldAccess (PathFieldAccess(..), Components) -import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on) +import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), + SignalProxy, + on, after, connectGObjectNotify, + SignalConnectMode(..)) -import Data.Proxy (Proxy(..)) import Data.Kind (Type) +import Data.Proxy (Proxy(..)) +import qualified Data.Text as T -import GHC.TypeLits +import GHC.TypeLits (Symbol, KnownSymbol, ErrorMessage(..), TypeError, + symbolVal) import GHC.Exts (Constraint) import GHC.OverloadedLabels (IsLabel(..)) +import qualified Optics.Core as O -infixr 0 :=,:~,:=>,:~> +infixr 0 :=,:~,:=>,:~>,:<~,:!<~ -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy @@ -269,6 +297,26 @@ Proxy o -> b -> IO (AttrTransferType info) attrTransfer _ = return + -- | Like `attrSet`, but it uses the same type as the getter. This + -- is useful for some nullable types, for which the getter returns + -- @Maybe a@, while the setter takes an @a@. `attrPut` will + -- instead accept an @Maybe a@. + attrPut :: AttrBaseTypeConstraint info o => + o -> AttrGetType info -> IO () + default attrPut :: -- Make sure that a non-default method + -- implementation is provided if AttrSet + -- is set. + CheckNotElem 'AttrPut (AttrAllowedOps info) + (PutNotProvidedError info) => + o -> AttrGetType info -> IO () + attrPut = undefined + + -- | Return some information about the overloaded attribute, + -- useful for debugging. See `resolveAttr` for how to access this + -- conveniently. + dbgAttrInfo :: Maybe ResolvedSymbolInfo + dbgAttrInfo = Nothing + -- | Pretty print a type, indicating the parent type that introduced -- the attribute, if different. type family TypeOriginInfo definingType useType :: ErrorMessage where @@ -330,6 +378,11 @@ type family SetNotProvidedError (info :: o) :: ErrorMessage where SetNotProvidedError info = OpNotProvidedError info 'AttrSet "attrSet" +-- | Error to be raised when AttrSet is allowed, but an `attrPut` +-- implementation has not been provided. +type family PutNotProvidedError (info :: o) :: ErrorMessage where + PutNotProvidedError info = OpNotProvidedError info 'AttrSet "attrPut" + -- | Error to be raised when AttrConstruct is allowed, but an -- implementation has not been provided. type family ConstructNotProvidedError (info :: o) :: ErrorMessage where @@ -355,6 +408,9 @@ | AttrClear -- ^ It is possible to clear the value of the -- (nullable) attribute with `clear`. + | AttrPut + -- ^ It is possible to set a value of the same type as + -- the one returned by `get`. deriving (Eq, Ord, Enum, Bounded, Show) -- | A user friendly description of the `AttrOpTag`, useful when @@ -364,6 +420,7 @@ AttrOpText 'AttrSet = "settable" AttrOpText 'AttrConstruct = "constructible" AttrOpText 'AttrClear = "nullable" + AttrOpText 'AttrPut = "puttable" -- | Constraint on a @obj@\/@attr@ pair so that `set` works on values -- of type @value@. @@ -439,10 +496,82 @@ (AttrTransferTypeConstraint info) b, AttrSetTypeConstraint info (AttrTransferType info)) => AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag + -- | Bind a property to the given `DynVal`, so that the property + -- is changed whenever the `DynVal` is. This requires the implicit + -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@ to be set. + (:!<~) :: (HasAttributeList obj, + info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + AttrOpAllowed tag info obj, + (AttrSetTypeConstraint info) b, + ?_haskell_gi_modelProxy :: ModelProxy model + ) => + AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj ta + -- | Bind a property to the given `DynVal`, so that the property + -- is changed whenever the `DynVal` is. This requires the implicit + -- param @?_haskell_gi_modelProxy@, of type @`ModelProxy` model@ + -- to be set. This will only actually set the property whenever + -- the `DynVal` changes if the new value of the `DynVal` is + -- different from the actual value of the property. If you want to + -- set the property without checking equality you can use `:!<~` + -- instead. + (:<~) :: (HasAttributeList obj, + info ~ ResolveAttribute attr obj, + AttrInfo info, + AttrBaseTypeConstraint info obj, + AttrOpAllowed tag info obj, + (AttrSetTypeConstraint info) b, + AttrOpAllowed 'AttrGet info obj, + EqMaybe b (AttrGetType info), + ?_haskell_gi_modelProxy :: ModelProxy model + ) => + AttrLabelProxy (attr :: Symbol) -> DynVal model b -> AttrOp obj tag + -- | Given an AttrLabelProxy, bind the given attribute to the + -- corresponding field in the model proxy (if there's one), so + -- that changes in the attribute are reflected back into changes + -- of the model. + Bind :: (HasAttributeList obj, + GObject obj, + info ~ ResolveAttribute propName obj, + AttrInfo info, + KnownSymbol (AttrLabel info), + AttrBaseTypeConstraint info obj, + AttrOpAllowed tag info obj, + AttrOpAllowed 'AttrPut info obj, + ?_haskell_gi_modelProxy :: ModelProxy model, + outType ~ AttrGetType info, + (AttrSetTypeConstraint info) outType, + components ~ Components fieldName, + PathFieldAccess components model outType, + KnownSymbol fieldName, + Eq outType + ) => + AttrLabelProxy (propName :: Symbol) -> + AttrLabelProxy (fieldName :: Symbol) -> + AttrOp obj tag + -- | Connect the given signal to a signal handler. On :: (GObject obj, SignalInfo info) => - SignalProxy obj info -> HaskellCallbackType info -> AttrOp obj tag + SignalProxy obj info + -> ((?self :: obj) => HaskellCallbackType info) + -> AttrOp obj tag + -- | Like 'On', but connect after the default signal. + After :: (GObject obj, SignalInfo info) => + SignalProxy obj info + -> ((?self :: obj) => HaskellCallbackType info) + -> AttrOp obj tag +class EqMaybe a b where + eqMaybe :: a -> b -> Bool + +instance Eq a => EqMaybe a a where + eqMaybe x y = x == y + +instance Eq a => EqMaybe a (Maybe a) where + eqMaybe _ Nothing = False + eqMaybe x (Just y) = x == y + -- | Set a number of properties for some object. set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m () set obj = liftIO . mapM_ app @@ -466,7 +595,28 @@ attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>= attrSet @(ResolveAttribute label o) obj + app ((_attr :: AttrLabelProxy label) :!<~ dv) = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + attrSet @(ResolveAttribute label o) obj (dvRead dv model) + modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> + attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel) + + app ((_attr :: AttrLabelProxy label) :<~ dv) = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + currentValue <- attrGet @(ResolveAttribute label o) obj + let newValue = dvRead dv model + when (not $ newValue `eqMaybe` currentValue) $ do + attrSet @(ResolveAttribute label o) obj newValue + modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do + current <- attrGet @(ResolveAttribute label o) obj + let modifiedValue = dvRead dv modifiedModel + when (not $ modifiedValue `eqMaybe` current) $ + attrSet @(ResolveAttribute label o) obj modifiedValue + + app (Bind pattr fattr) = bindPropToField (Proxy @'AttrSet) obj pattr fattr + app (On signal callback) = void $ on obj signal callback + app (After signal callback) = void $ after obj signal callback -- | Constraints on a @obj@\/@attr@ pair so `get` is possible, -- producing a value of type @result@. @@ -495,3 +645,67 @@ (AttrClearC info obj attr, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m () clear o _ = liftIO $ attrClear @info o + +-- | Return the fully qualified attribute name that a given overloaded +-- attribute resolves to (mostly useful for debugging). +-- +-- > resolveAttr #sensitive button +resolveAttr :: forall info attr obj. + (HasAttributeList obj, info ~ ResolveAttribute attr obj, + AttrInfo info) => + obj -> AttrLabelProxy (attr :: Symbol) -> Maybe ResolvedSymbolInfo +resolveAttr _o _p = dbgAttrInfo @info + +-- | Create a binding between the given property of an object and a +-- field in the model. +bindPropToField :: forall o info prop field model outType tag components. + (HasAttributeList o, + GObject o, + info ~ ResolveAttribute prop o, + AttrInfo info, + KnownSymbol (AttrLabel info), + AttrBaseTypeConstraint info o, + AttrOpAllowed tag info o, + AttrOpAllowed 'AttrPut info o, + ?_haskell_gi_modelProxy :: ModelProxy model, + outType ~ AttrGetType info, + (AttrSetTypeConstraint info) outType, + components ~ Components field, + PathFieldAccess components model outType, + KnownSymbol field, + Eq outType + ) => + Proxy tag -> o -> AttrLabelProxy (prop :: Symbol) -> + AttrLabelProxy (field :: Symbol) -> IO () +bindPropToField _ obj _ _ = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + + -- Set the property to the current value in the model. + currentPropValue <- attrGet @(ResolveAttribute prop o) obj + let (lens, components) = pathFieldAccess (Proxy @components) + (Proxy @model) + key = DVKeyDirect components + currentModelValue = O.view lens model + when (currentModelValue /= currentPropValue) $ + attrPut @(ResolveAttribute prop o) obj currentModelValue + + -- Set the property whenever the model changes. + modelProxyRegisterHandler ?_haskell_gi_modelProxy key $ \modifiedModel -> do + let newVal = O.view lens modifiedModel + oldVal <- attrGet @(ResolveAttribute prop o) obj + when (newVal /= oldVal) $ + attrPut @(ResolveAttribute prop o) obj newVal + + -- Change the model whenever the property changes. + let handler = \_parent _psec -> do + newVal <- attrGet @(ResolveAttribute prop o) obj + let doUpdate curModel = + let oldVal = O.view lens curModel + in if newVal == oldVal + then Nothing + else Just $ O.set lens newVal curModel + modelProxyUpdate ?_haskell_gi_modelProxy components doUpdate + propName = T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute prop o))) + + void $ connectGObjectNotify obj handler SignalConnectBefore (Just propName) + diff --git a/Data/GI/Base/BasicConversions.hsc b/Data/GI/Base/BasicConversions.hsc --- a/Data/GI/Base/BasicConversions.hsc +++ b/Data/GI/Base/BasicConversions.hsc @@ -89,7 +89,6 @@ import Data.GI.Base.BasicTypes import Data.GI.Base.CallStack (HasCallStack) -import Data.GI.Base.GHashTable (GEqualFunc, GHashFunc) import Data.GI.Base.ManagedPtr (copyBoxedPtr) import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem, checkUnexpectedReturnNULL) @@ -169,7 +168,7 @@ dataPtr <- peek (castPtr array :: Ptr (Ptr a)) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems - where go :: Ptr a -> Int -> IO [a] + where go :: Ptr a -> CUInt -> IO [a] go _ 0 = return [] go ptr n = do x <- peek ptr 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 #-} @@ -39,6 +39,9 @@ , PtrWrapped(..) , GDestroyNotify + + , GHashFunc + , GEqualFunc ) where import Control.Exception (Exception) @@ -46,15 +49,15 @@ import Data.Coerce (coerce, Coercible) import Data.IORef (IORef) import qualified Data.Text as T -import Data.Typeable (Typeable) +import Data.Int import Data.Word import Foreign.C (CString, peekCString) import Foreign.Ptr (Ptr, FunPtr) import Foreign.ForeignPtr (ForeignPtr) -import Data.GI.Base.CallStack (CallStack) import {-# SOURCE #-} Data.GI.Base.Overloading (HasParentTypes) +import Data.GI.Base.CallStack (CallStack) #include @@ -159,17 +162,16 @@ -- an unexpected `Foreign.Ptr.nullPtr`. data UnexpectedNullPointerReturn = UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text } - deriving (Typeable) instance Show UnexpectedNullPointerReturn where show r = T.unpack (nullPtrErrorMsg r) instance Exception UnexpectedNullPointerReturn --- | A . See "Data.GI.Base.GVariant" for further methods. +-- | A . See "Data.GI.Base.GVariant" for further methods. newtype GVariant = GVariant (ManagedPtr GVariant) --- | A . See "Data.GI.Base.GParamSpec" for further methods. +-- | A . See "Data.GI.Base.GParamSpec" for further methods. newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec) -- | A convenient synonym for @Nothing :: Maybe GParamSpec@. @@ -179,30 +181,30 @@ -- | An enum usable as a flag for a function. class Enum a => IsGFlag a --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +-- | A . 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 . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +-- | A . 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 . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. +-- | A . 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 . It is mapped to a 'Data.Map.Map' on the Haskell side. +-- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. data GHashTable a b = GHashTable (Ptr (GHashTable a b)) --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". data GList a = GList (Ptr (GList a)) --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". data GSList a = GSList (Ptr (GSList a)) -- | Some APIs, such as `GHashTable`, pass around scalar types -- wrapped into a pointer. We encode such a type as follows. newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} --- | Destroy the memory associated with a given pointer. -type GDestroyNotify a = FunPtr (Ptr a -> IO ()) +-- | Destroy the memory pointed to by a given pointer type. +type GDestroyNotify ptr = FunPtr (ptr -> IO ()) -- | Free the given 'GList'. foreign import ccall "g_list_free" g_list_free :: @@ -211,3 +213,9 @@ -- | Free the given 'GSList'. foreign import ccall "g_slist_free" g_slist_free :: Ptr (GSList a) -> IO () + +-- | A pointer to a hashing function on the C side. +type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint}) + +-- | A pointer to an equality checking function on the C side. +type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean}) diff --git a/Data/GI/Base/Constructible.hs b/Data/GI/Base/Constructible.hs --- a/Data/GI/Base/Constructible.hs +++ b/Data/GI/Base/Constructible.hs @@ -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 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/GHashTable.hsc b/Data/GI/Base/GHashTable.hsc --- a/Data/GI/Base/GHashTable.hsc +++ b/Data/GI/Base/GHashTable.hsc @@ -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 --- | 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 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. @@ -35,17 +37,18 @@ , gobjectInstallProperty , gobjectInstallCIntProperty , gobjectInstallCStringProperty + , gobjectInstallGBooleanProperty ) where import Data.Maybe (catMaybes) -import Control.Monad (void) +import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Proxy (Proxy(..)) import Data.Coerce (coerce) import Foreign.C (CUInt(..), CString, newCString) -import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr) +import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, nullFunPtr) import Foreign.StablePtr (newStablePtr, deRefStablePtr, castStablePtrToPtr, castPtrToStablePtr) import Foreign.Storable (Storable(peek, poke, pokeByteOff, sizeOf)) @@ -57,19 +60,25 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Optics.Core as O + import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy, attrConstruct, attrTransfer, - AttrInfo(..)) -import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, + AttrInfo(..), EqMaybe(..), bindPropToField) +import Data.GI.Base.BasicTypes (CGType, GType(..), GObject, GSList, GDestroyNotify, ManagedPtr(..), GParamSpec(..), TypedObject(glibType), - gtypeName) -import Data.GI.Base.BasicConversions (withTextCString, cstringToText) + gtypeName, g_slist_free) +import Data.GI.Base.BasicConversions (withTextCString, cstringToText, + packGSList, mapGSList) import Data.GI.Base.CallStack (HasCallStack, prettyCallStack) +import Data.GI.Base.DynVal (modelProxyCurrentValue, modelProxyRegisterHandler, + dvKeys, dvRead) import Data.GI.Base.GParamSpec (PropertyInfo(..), gParamSpecValue, CIntPropertyInfo(..), CStringPropertyInfo(..), - gParamSpecCInt, gParamSpecCString, + GBooleanPropertyInfo(..), + gParamSpecCInt, gParamSpecCString, gParamSpecGBoolean, getGParamSpecGetterSetter, PropGetSetter(..)) import Data.GI.Base.GQuark (GQuark(..), gQuarkFromString) @@ -77,8 +86,9 @@ import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject, newObject) import Data.GI.Base.Overloading (ResolveAttribute) -import Data.GI.Base.Signals (on) -import Data.GI.Base.Utils (dbgLog) +import Data.GI.Base.Signals (on, after) +import Data.GI.Base.Utils (dbgLog, callocBytes, freeMem) +import Data.GI.Base.Internal.PathFieldAccess (Components, PathFieldAccess(..)) #include @@ -96,6 +106,7 @@ props <- catMaybes <$> mapM construct attrs obj <- doConstructGObject constructor props mapM_ (setSignal obj) attrs + mapM_ (registerHandlers obj) attrs return obj where construct :: AttrOp o 'AttrConstruct -> @@ -110,22 +121,65 @@ (attrTransfer @(ResolveAttribute label o) (Proxy @o) x >>= attrConstruct @(ResolveAttribute label o)) + construct ((_attr :: AttrLabelProxy label) :!<~ dv) = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model) + + construct (Bind (_pattr :: AttrLabelProxy prop) + (_fattr :: AttrLabelProxy field)) = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + let lens = getLens (Proxy @field) model + value = O.view lens model + Just <$> attrConstruct @(ResolveAttribute prop o) value + where getLens :: forall path components model value. + (components ~ Components path, + PathFieldAccess components model value) => + Proxy path -> model -> O.Lens' model value + getLens _ _ = let + (lens, _) = pathFieldAccess (Proxy @components) (Proxy @model) + in lens + + -- Since we are constructing the object there's nothing to compare + -- to, so we just set the value. + construct ((_attr :: AttrLabelProxy label) :<~ dv) = do + model <- modelProxyCurrentValue ?_haskell_gi_modelProxy + Just <$> attrConstruct @(ResolveAttribute label o) (dvRead dv model) + construct (On _ _) = return Nothing + construct (After _ _) = return Nothing setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO () setSignal obj (On signal callback) = void $ on obj signal callback + setSignal obj (After signal callback) = void $ after obj signal callback setSignal _ _ = return () + registerHandlers :: GObject o => o -> AttrOp o 'AttrConstruct -> IO () + registerHandlers obj ((_attr :: AttrLabelProxy label) :!<~ dv) = + modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> + attrSet @(ResolveAttribute label o) obj (dvRead dv modifiedModel) + + registerHandlers obj ((_attr :: AttrLabelProxy label) :<~ dv) = + modelProxyRegisterHandler ?_haskell_gi_modelProxy (dvKeys dv) $ \modifiedModel -> do + current <- attrGet @(ResolveAttribute label o) obj + let modifiedValue = dvRead dv modifiedModel + when (not $ eqMaybe modifiedValue current) $ + attrSet @(ResolveAttribute label o) obj modifiedValue + + registerHandlers obj (Bind pattr fattr) = + bindPropToField (Proxy @'AttrConstruct) obj pattr fattr + + registerHandlers _ _ = pure () + -- | Construct the given `GObject`, given a set of actions -- constructing desired `GValue`s to set at construction time. -new' :: (MonadIO m, GObject o) => +new' :: (HasCallStack, MonadIO m, GObject o) => (ManagedPtr o -> o) -> [m (GValueConstruct o)] -> m o new' constructor actions = do props <- sequence actions doConstructGObject constructor props -- | Construct the `GObject` given the list of `GValueConstruct`s. -doConstructGObject :: forall o m. (GObject o, MonadIO m) +doConstructGObject :: forall o m. (HasCallStack, GObject o, MonadIO m) => (ManagedPtr o -> o) -> [GValueConstruct o] -> m o doConstructGObject constructor props = liftIO $ do let nprops = length props @@ -185,15 +239,26 @@ -- | Name of the type, it should be unique. objectTypeName :: Text + -- | Code to run when the class is inited. This is a good place to -- register signals and properties for the type. objectClassInit :: GObjectClass -> IO () + -- | Code to run when each instance of the type is -- constructed. Returns the private data to be associated with the -- new instance (use `gobjectGetPrivateData` and -- `gobjectSetPrivateData` to manipulate this further). objectInstanceInit :: GObjectClass -> a -> IO (GObjectPrivateData a) + -- | List of interfaces implemented by the type. Each element is a + -- triplet (@gtype@, @interfaceInit@, @interfaceFinalize@), where + -- @gtype :: IO GType@ is a constructor for the type of the + -- interface, @interfaceInit :: Ptr () -> IO ()@ is a function that + -- registers the callbacks in the interface, and @interfaceFinalize + -- :: Maybe (Ptr () -> IO ())@ is the (optional) finalizer. + objectInterfaces :: [(IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ()))] + objectInterfaces = [] + type CGTypeClassInit = GObjectClass -> IO () foreign import ccall "wrapper" mkClassInit :: CGTypeClassInit -> IO (FunPtr CGTypeClassInit) @@ -202,11 +267,19 @@ foreign import ccall "wrapper" mkInstanceInit :: CGTypeInstanceInit o -> IO (FunPtr (CGTypeInstanceInit o)) +type CGTypeInterfaceInit = Ptr () -> Ptr () -> IO () +foreign import ccall "wrapper" + mkInterfaceInit :: CGTypeInterfaceInit -> IO (FunPtr CGTypeInterfaceInit) + +type CGTypeInterfaceFinalize = Ptr () -> Ptr () -> IO () +foreign import ccall "wrapper" + mkInterfaceFinalize :: CGTypeInterfaceFinalize -> IO (FunPtr CGTypeInterfaceFinalize) + foreign import ccall g_type_from_name :: CString -> IO CGType foreign import ccall "haskell_gi_register_gtype" register_gtype :: CGType -> CString -> FunPtr CGTypeClassInit -> - FunPtr (CGTypeInstanceInit o) -> IO CGType + FunPtr (CGTypeInstanceInit o) -> Ptr (GSList a) -> IO CGType foreign import ccall "haskell_gi_gtype_from_class" gtype_from_class :: GObjectClass -> IO CGType @@ -255,7 +328,11 @@ classInit <- mkClassInit (unwrapClassInit $ objectClassInit @o) instanceInit <- mkInstanceInit (unwrapInstanceInit $ objectInstanceInit @o) (GType parentCGType) <- glibType @(GObjectParentType o) - GType <$> register_gtype parentCGType cTypeName classInit instanceInit + interfaces <- mapM packInterface (objectInterfaces @o) >>= packGSList + gtype <- GType <$> register_gtype parentCGType cTypeName classInit instanceInit interfaces + mapGSList freeInterfaceInfo interfaces + g_slist_free interfaces + return gtype where unwrapInstanceInit :: (GObjectClass -> o -> IO (GObjectPrivateData o)) -> @@ -296,6 +373,35 @@ <> pspecName <> "\" of type \"" <> T.pack typeName <> "\"." Just pgs -> (propGetter pgs) objPtr destGValuePtr + packInterface :: (IO GType, Ptr () -> IO (), Maybe (Ptr () -> IO ())) + -> IO (Ptr CGType) + packInterface (ifaceGTypeConstruct, initHs, maybeFinalize) = do + gtype <- ifaceGTypeConstruct + info <- callocBytes #{size GInterfaceInfo} + initFn <- mkInterfaceInit (unwrapInit initHs) + finalizeFn <- case maybeFinalize of + Just finalizeHs -> mkInterfaceFinalize (unwrapFinalize finalizeHs) + Nothing -> pure nullFunPtr + #{poke GInterfaceInfo, interface_init} info initFn + #{poke GInterfaceInfo, interface_finalize} info finalizeFn + + combined <- callocBytes (#{size GType} + #{size gpointer}) + poke combined (gtypeToCGType gtype) + poke (combined `plusPtr` #{size GType}) info + return combined + + unwrapInit :: (Ptr () -> IO ()) -> CGTypeInterfaceInit + unwrapInit f ptr _data = f ptr + + unwrapFinalize :: (Ptr () -> IO ()) -> CGTypeInterfaceFinalize + unwrapFinalize = unwrapInit + + freeInterfaceInfo :: Ptr CGType -> IO () + freeInterfaceInfo combinedPtr = do + info <- peek (combinedPtr `plusPtr` #{size GType}) + freeMem info + freeMem combinedPtr + -- | Quark with the key to the private data for this object type. privateKey :: forall o. DerivedGObject o => IO (GQuark (GObjectPrivateData o)) privateKey = gQuarkFromString $ objectTypeName @o <> "::haskell-gi-private-data" @@ -331,10 +437,10 @@ else return Nothing foreign import ccall "&hs_free_stable_ptr" ptr_to_hs_free_stable_ptr :: - FunPtr (GDestroyNotify a) + GDestroyNotify (Ptr ()) foreign import ccall g_object_set_qdata_full :: - Ptr a -> GQuark b -> Ptr () -> FunPtr (GDestroyNotify ()) -> IO () + Ptr a -> GQuark b -> Ptr () -> GDestroyNotify (Ptr ()) -> IO () -- | Set the value of the user data for the given `GObject` to a -- `StablePtr` to the given Haskell object. The `StablePtr` will be @@ -407,5 +513,13 @@ GObjectClass -> CStringPropertyInfo o -> IO () gobjectInstallCStringProperty klass propInfo = do pspec <- gParamSpecCString propInfo + withManagedPtr pspec $ \pspecPtr -> + g_object_class_install_property klass 1 pspecPtr + +-- | Add a `${type gboolean}`-valued property to the given object class. +gobjectInstallGBooleanProperty :: DerivedGObject o => + GObjectClass -> GBooleanPropertyInfo o -> IO () +gobjectInstallGBooleanProperty klass propInfo = do + pspec <- gParamSpecGBoolean propInfo withManagedPtr pspec $ \pspecPtr -> g_object_class_install_property klass 1 pspecPtr diff --git a/Data/GI/Base/GParamSpec.hsc b/Data/GI/Base/GParamSpec.hsc --- a/Data/GI/Base/GParamSpec.hsc +++ b/Data/GI/Base/GParamSpec.hsc @@ -20,6 +20,8 @@ , gParamSpecCString , CIntPropertyInfo(..) , gParamSpecCInt + , GBooleanPropertyInfo(..) + , gParamSpecGBoolean , GParamFlag(..) -- * Get\/Set @@ -33,6 +35,7 @@ castStablePtrToPtr, castPtrToStablePtr) import Control.Monad (void) import Data.Coerce (coerce) +import Data.Int import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -154,7 +157,7 @@ value <- objectFromPtr objPtr >>= getter gvalueSetter destPtr value , propSetter = \objPtr newGValuePtr -> - withTransient GValue newGValuePtr $ \newGValue -> do + withTransient newGValuePtr $ \newGValue -> do obj <- objectFromPtr objPtr value <- GV.fromGValue newGValue setter obj value @@ -215,7 +218,7 @@ take_stablePtr destPtr stablePtr setter' :: Ptr o -> (Ptr GValue) -> IO () - setter' objPtr gvPtr = withTransient GValue gvPtr $ \gv -> do + setter' objPtr gvPtr = withTransient gvPtr $ \gv -> do obj <- objectFromPtr objPtr val <- GV.fromGValue gv >>= deRefStablePtr setter obj val @@ -316,6 +319,48 @@ withTextCString value $ \cdefault -> g_param_spec_string cname cnick cblurb cdefault (maybe defaultFlags gflagsToWord flags) + quark <- pspecQuark + gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_) + wrapGParamSpecPtr pspecPtr + +-- | Information on a property of type `type gboolean` to be registered. A +-- property name consists of segments consisting of ASCII letters and +-- digits, separated by either the \'-\' or \'_\' character. The first +-- character of a property name must be a letter. Names which violate +-- these rules lead to undefined behaviour. +-- +-- When creating and looking up a property, either separator can be +-- used, but they cannot be mixed. Using \'-\' is considerably more +-- efficient and in fact required when using property names as detail +-- strings for signals. +-- +-- Beyond the name, properties have two more descriptive strings +-- associated with them, the @nick@, which should be suitable for use +-- as a label for the property in a property editor, and the @blurb@, +-- which should be a somewhat longer description, suitable for e.g. a +-- tooltip. The @nick@ and @blurb@ should ideally be localized. +data GBooleanPropertyInfo o = GBooleanPropertyInfo + { name :: Text + , nick :: Text + , blurb :: Text + , defaultValue :: Bool + , flags :: Maybe [GParamFlag] + , setter :: o -> Bool -> IO () + , getter :: o -> IO (Bool) + } + +foreign import ccall g_param_spec_boolean :: + CString -> CString -> CString -> #{type gboolean} -> CInt -> IO (Ptr GParamSpec) + +-- | Create a `GParamSpec` for a bool param. +gParamSpecGBoolean :: GObject o => GBooleanPropertyInfo o -> IO GParamSpec +gParamSpecGBoolean (GBooleanPropertyInfo {..}) = + withTextCString name $ \cname -> + withTextCString nick $ \cnick -> + withTextCString blurb $ \cblurb -> do + pspecPtr <- g_param_spec_boolean cname cnick cblurb + ((fromIntegral . fromEnum) defaultValue) + (maybe defaultFlags gflagsToWord flags) quark <- pspecQuark gParamSpecSetQData pspecPtr quark (wrapGetSet getter setter gvalueSet_) wrapGParamSpecPtr pspecPtr diff --git a/Data/GI/Base/GType.hsc b/Data/GI/Base/GType.hsc --- a/Data/GI/Base/GType.hsc +++ b/Data/GI/Base/GType.hsc @@ -21,8 +21,10 @@ , gtypeVariant , gtypeByteArray , gtypeInvalid + , gtypeParam , gtypeStablePtr + , gtypeHValue ) where import Data.GI.Base.BasicTypes (GType(..), CGType) @@ -106,9 +108,9 @@ gtypeVariant :: GType gtypeVariant = GType #const G_TYPE_VARIANT --- | The `GType` corresponding to 'Data.GI.Base.GError.GError'. -gtypeError :: GType -gtypeError = GType #const G_TYPE_ERROR +-- | The `GType` corresponding to 'Data.GI.Base.BasicTypes.GParamSpec'. +gtypeParam :: GType +gtypeParam = GType #const G_TYPE_PARAM {- Run-time types -} @@ -135,3 +137,15 @@ -- | The `GType` for boxed `StablePtr`s. gtypeStablePtr :: GType gtypeStablePtr = GType haskell_gi_StablePtr_get_type + +foreign import ccall haskell_gi_HaskellValue_get_type :: CGType + +-- | The `GType` for a generic Haskell value. +gtypeHValue :: GType +gtypeHValue = GType haskell_gi_HaskellValue_get_type + +foreign import ccall "g_error_get_type" g_error_get_type :: CGType + +-- | The `GType` corresponding to 'Data.GI.Base.GError.GError'. +gtypeError :: GType +gtypeError = GType g_error_get_type diff --git a/Data/GI/Base/GValue.hs b/Data/GI/Base/GValue.hs --- a/Data/GI/Base/GValue.hs +++ b/Data/GI/Base/GValue.hs @@ -13,6 +13,7 @@ , toGValue , fromGValue , GValueConstruct(..) + , ptr_to_gvalue_free , newGValue , buildGValue @@ -28,6 +29,9 @@ , unpackGValueArrayWithLength , mapGValueArrayWithLength + -- * Packing Haskell values into GValues + , HValue(..) + -- * Setters and getters , set_object , get_object @@ -42,9 +46,14 @@ , set_stablePtr , get_stablePtr , take_stablePtr - + , set_param + , get_param + , set_hvalue + , get_hvalue ) where +import Control.Monad.IO.Class (MonadIO, liftIO) + import Data.Coerce (coerce) import Data.Word import Data.Int @@ -53,32 +62,36 @@ import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..), CLong(..), CULong(..)) import Foreign.C.String (CString) -import Foreign.Ptr (Ptr, nullPtr, plusPtr) -import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr) +import Foreign.Ptr (Ptr, nullPtr, plusPtr, FunPtr) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, + newStablePtr, deRefStablePtr) +import Type.Reflection (typeRep, TypeRep) +import System.IO (hPutStrLn, stderr) +import Data.Dynamic (toDyn, fromDynamic, Typeable) import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions (cstringToText, textToCString) import Data.GI.Base.GType import Data.GI.Base.ManagedPtr -import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Base.Utils (callocBytes, freeMem) import Data.GI.Base.Internal.CTypes (cgvalueSize) +import Data.GI.Base.Overloading (ParentTypes, HasParentTypes) -- | Haskell-side representation of a @GValue@. newtype GValue = GValue (ManagedPtr GValue) --- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@. -noGValue :: Maybe GValue -noGValue = Nothing - -foreign import ccall unsafe "g_value_get_type" c_g_value_get_type :: - IO GType +-- | A pointer to a function freeing GValues. +foreign import ccall "&haskell_gi_gvalue_free" ptr_to_gvalue_free :: + FunPtr (Ptr GValue -> IO ()) -- | There are no types in the bindings that a `GValue` can be safely -- cast to. type instance ParentTypes GValue = '[] instance HasParentTypes GValue +foreign import ccall unsafe "g_value_get_type" c_g_value_get_type :: + IO GType + -- | Find the associated `GType` for `GValue`. instance TypedObject GValue where glibType = c_g_value_get_type @@ -138,6 +151,10 @@ unsetGValue :: Ptr GValue -> IO () unsetGValue = g_value_unset +-- | A convenient alias for @Nothing :: Maybe GValue@. +noGValue :: Maybe GValue +noGValue = Nothing + -- | Class for types that can be marshaled back and forth between -- Haskell values and `GValue`s. These are low-level methods, you -- might want to use `toGValue` and `fromGValue` instead for a higher @@ -152,8 +169,8 @@ -- the `GValue`. -- | Create a `GValue` from the given Haskell value. -toGValue :: forall a. IsGValue a => a -> IO GValue -toGValue val = do +toGValue :: forall a m. (IsGValue a, MonadIO m) => a -> m GValue +toGValue val = liftIO $ do gvptr <- callocBytes cgvalueSize GType gtype <- gvalueGType_ @a _ <- g_value_init gvptr gtype @@ -162,8 +179,8 @@ return $! gv -- | Create a Haskell object out of the given `GValue`. -fromGValue :: IsGValue a => GValue -> IO a -fromGValue gv = withManagedPtr gv gvalueGet_ +fromGValue :: (IsGValue a, MonadIO m) => GValue -> m a +fromGValue gv = liftIO $ withManagedPtr gv gvalueGet_ instance IsGValue (Maybe String) where gvalueGType_ = return gtypeString @@ -245,6 +262,16 @@ gvalueSet_ = set_stablePtr gvalueGet_ = get_stablePtr +instance IsGValue (Maybe GParamSpec) where + gvalueGType_ = return gtypeParam + gvalueSet_ = set_param + gvalueGet_ = get_param + +instance Typeable a => IsGValue (HValue a) where + gvalueGType_ = return gtypeHValue + gvalueSet_ = set_hvalue + gvalueGet_ = get_hvalue + foreign import ccall "g_value_set_string" _set_string :: Ptr GValue -> CString -> IO () foreign import ccall "g_value_get_string" _get_string :: @@ -371,6 +398,8 @@ Ptr GValue -> Ptr a -> IO () foreign import ccall "g_value_get_boxed" get_boxed :: Ptr GValue -> IO (Ptr b) +foreign import ccall "g_value_dup_boxed" dup_boxed :: + Ptr GValue -> IO (Ptr b) foreign import ccall "g_value_set_variant" set_variant :: Ptr GValue -> Ptr GVariant -> IO () @@ -391,15 +420,17 @@ set_stablePtr :: Ptr GValue -> StablePtr a -> IO () set_stablePtr gv ptr = set_boxed gv (castStablePtrToPtr ptr) -foreign import ccall g_value_take_boxed :: Ptr GValue -> StablePtr a -> IO () +foreign import ccall g_value_take_boxed :: Ptr GValue -> Ptr a -> IO () -- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr` take_stablePtr :: Ptr GValue -> StablePtr a -> IO () -take_stablePtr = g_value_take_boxed +take_stablePtr gvPtr stablePtr = + g_value_take_boxed gvPtr (castStablePtrToPtr stablePtr) --- | Get the value of a `GValue` containing a `StablePtr` +-- | Get (a freshly allocated copy of) the value of a `GValue` +-- containing a `StablePtr` get_stablePtr :: Ptr GValue -> IO (StablePtr a) -get_stablePtr gv = castPtrToStablePtr <$> get_boxed gv +get_stablePtr gv = castPtrToStablePtr <$> dup_boxed gv foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO () @@ -444,3 +475,67 @@ go n ptr = do _ <- f ptr go (n-1) (ptr `plusPtr` cgvalueSize) + +foreign import ccall unsafe "g_value_set_param" _set_param :: + Ptr GValue -> Ptr GParamSpec -> IO () +foreign import ccall unsafe "g_value_get_param" _get_param :: + Ptr GValue -> IO (Ptr GParamSpec) + +-- | Set the value of `GValue` containing a `GParamSpec` +set_param :: Ptr GValue -> Maybe GParamSpec -> IO () +set_param gv (Just ps) = withManagedPtr ps (_set_param gv) +set_param gv Nothing = _set_param gv nullPtr + +foreign import ccall "g_param_spec_ref" g_param_spec_ref :: + Ptr GParamSpec -> IO (Ptr GParamSpec) +foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref :: + FunPtr (Ptr GParamSpec -> IO ()) + +-- | Get the value of a `GValue` containing a `GParamSpec` +get_param :: Ptr GValue -> IO (Maybe GParamSpec) +get_param gv = do + ptr <- _get_param gv + if ptr == nullPtr + then return Nothing + else do + fPtr <- g_param_spec_ref ptr >>= newManagedPtr' ptr_to_g_param_spec_unref + return . Just $! GParamSpec fPtr + +-- | A type isomorphic to `Maybe a`, used to indicate to +-- `fromGValue`/`toGValue` that we are packing a native Haskell value, +-- without attempting to marshall it to the corresponding C type. +data HValue a = HValue a -- ^ A packed value of type `a` + | NoHValue -- ^ An empty `HValue` + deriving (Show, Eq) + +-- | Set the `GValue` to the given Haskell value. +set_hvalue :: Typeable a => Ptr GValue -> HValue a -> IO () +set_hvalue gvPtr NoHValue = set_boxed gvPtr nullPtr +set_hvalue gvPtr (HValue v) = do + sPtr <- newStablePtr (toDyn v) + g_value_take_boxed gvPtr (castStablePtrToPtr sPtr) + +-- | Get the value in the GValue, checking that the type is +-- `gtypeHValue`. Will return NULL and print a warning if the GValue +-- is of the wrong type. +foreign import ccall "haskell_gi_safe_get_boxed_haskell_value" safe_get_boxed_hvalue :: + Ptr GValue -> IO (Ptr b) + +-- | Read the Haskell value of the given type from the `GValue`. If +-- the `GValue` contains no value of the expected type, `NoHValue` +-- will be returned instead, and an error will be printed to stderr. +get_hvalue :: forall a. Typeable a => Ptr GValue -> IO (HValue a) +get_hvalue gvPtr = do + hvaluePtr <- safe_get_boxed_hvalue gvPtr + if hvaluePtr == nullPtr + then return NoHValue + else do + dyn <- deRefStablePtr (castPtrToStablePtr hvaluePtr) + case fromDynamic dyn of + Nothing -> do + hPutStrLn stderr ("HASKELL-GI: Unexpected type ‘" <> show dyn + <> "’ inside the GValue at ‘" <> show gvPtr + <> "’.\n\tExpected ‘" <> show (typeRep :: TypeRep a) + <> "’.") + return NoHValue + Just val -> return (HValue val) diff --git a/Data/GI/Base/GVariant.hsc b/Data/GI/Base/GVariant.hsc --- a/Data/GI/Base/GVariant.hsc +++ b/Data/GI/Base/GVariant.hsc @@ -238,7 +238,7 @@ -- | Get the expected type of a 'GVariant', in 'GVariant' -- notation. See --- +-- -- for the meaning of the resulting format string. gvariantGetTypeString :: GVariant -> IO Text gvariantGetTypeString variant = @@ -643,6 +643,12 @@ [0..(n_children-1)] else return [] +-- No type checking is done here, it is assumed that the caller knows +-- that the passed variant is indeed of a container type with at least +-- one child. +gvariant_get_child :: (Ptr GVariant) -> IO GVariant +gvariant_get_child vptr = g_variant_get_child_value vptr 0 >>= wrapGVariantPtr + instance IsGVariant a => IsGVariant (Maybe a) where toGVariant = gvariantFromMaybe fromGVariant = gvariantToMaybe @@ -829,9 +835,7 @@ gvariantToSinglet :: forall a. IsGVariant a => GVariant -> IO (Maybe a) gvariantToSinglet = withExplicitType fmt - (gvariant_get_children - >=> return . head - >=> unsafeFromGVariant) + (gvariant_get_child >=> unsafeFromGVariant) where fmt = toGVariantFormatString (undefined :: GVariantSinglet a) instance (IsGVariant a, IsGVariant b) => IsGVariant (a,b) where @@ -854,14 +858,14 @@ gvariantToTwoTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2]) = maybeChildren - (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2 - return $ if isJust ma1 && isJust ma2 - then Just (fromJust ma1, fromJust ma2) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2] -> do + (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2 + return $ if isJust ma1 && isJust ma2 + then Just (fromJust ma1, fromJust ma2) + else Nothing + Just _ -> error "gvariantToTwoTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c) => IsGVariant (a,b,c) where toGVariant = gvariantFromThreeTuple @@ -886,16 +890,16 @@ gvariantToThreeTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3]) = maybeChildren - (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - return $ if isJust ma1 && isJust ma2 && isJust ma3 - then Just (fromJust ma1, fromJust ma2, fromJust ma3) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3] -> do + (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + return $ if isJust ma1 && isJust ma2 && isJust ma3 + then Just (fromJust ma1, fromJust ma2, fromJust ma3) + else Nothing + Just _ -> error "gvariantToThreeTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => IsGVariant (a,b,c,d) where @@ -923,17 +927,17 @@ gvariantToFourTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3,a4]) = maybeChildren - (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - <*> fromGVariant a4 - return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4 - then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3,a4] -> do + (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4) + else Nothing + Just _ -> error "gvariantToFourTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) => IsGVariant (a,b,c,d,e) where @@ -965,17 +969,17 @@ gvariantToFiveTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3,a4,a5]) = maybeChildren - (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - <*> fromGVariant a4 - <*> fromGVariant a5 - return $ if isJust ma1 && isJust ma2 && isJust ma3 && - isJust ma4 && isJust ma5 - then Just (fromJust ma1, fromJust ma2, fromJust ma3, - fromJust ma4, fromJust ma5) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3,a4,a5] -> do + (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + <*> fromGVariant a5 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && + isJust ma4 && isJust ma5 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, + fromJust ma4, fromJust ma5) + else Nothing + Just _ -> error "gvariantToFiveTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing 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/ManagedPtr.hs b/Data/GI/Base/ManagedPtr.hs --- a/Data/GI/Base/ManagedPtr.hs +++ b/Data/GI/Base/ManagedPtr.hs @@ -32,6 +32,7 @@ -- * Wrappers , newObject + , withNewObject , wrapObject , releaseObject , unrefObject @@ -166,11 +167,11 @@ -- | Perform the IO action with a transient managed pointer. The -- managed pointer will be valid while calling the action, but will be --- disowned as soon as the action finished. +-- disowned as soon as the action finishes. withTransient :: (HasCallStack, ManagedPtrNewtype a) - => (ManagedPtr a -> a) -> Ptr a -> (a -> IO b) -> IO b -withTransient constructor ptr action = do - managed <- constructor <$> newManagedPtr_ ptr + => Ptr a -> (a -> IO b) -> IO b +withTransient ptr action = do + managed <- coerce <$> newManagedPtr_ ptr r <- action managed _ <- disownManagedPtr managed return r @@ -286,6 +287,16 @@ void $ g_object_ref_sink ptr fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr return $! constructor fPtr + +-- | Perform the given IO action with a wrapped copy of the given ptr +-- to a GObject. Note that this increases the reference count of the +-- wrapped GObject, similarly to 'newObject'. +withNewObject :: (HasCallStack, GObject o) + => Ptr o -> (o -> IO b) -> IO b +withNewObject ptr action = do + void $ g_object_ref_sink ptr + managed <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr + action (coerce managed) -- | Same as 'newObject', but we steal ownership of the object. wrapObject :: forall a b. (HasCallStack, GObject a, GObject b) => diff --git a/Data/GI/Base/Overloading.hs b/Data/GI/Base/Overloading.hs --- a/Data/GI/Base/Overloading.hs +++ b/Data/GI/Base/Overloading.hs @@ -33,7 +33,8 @@ , OverloadedMethodInfo(..) , OverloadedMethod(..) , MethodProxy(..) - , MethodInfo(..) + + , ResolvedSymbolInfo(..) , resolveMethod ) where @@ -57,6 +58,22 @@ FindElement m ('(m, o) ': ms) typeError = o FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError +-- | All the types that are ascendants of this type, including +-- interfaces that the type implements. +type family ParentTypes a :: [Type] + +-- | A constraint on a type, to be fulfilled whenever it has a type +-- instance for `ParentTypes`. This leads to nicer errors, thanks to +-- the overlappable instance below. +class HasParentTypes (o :: Type) + +-- | Default instance, which will give rise to an error for types +-- without an associated `ParentTypes` instance. +instance {-# OVERLAPPABLE #-} + TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: + 'Text "’ does not have any known parent types.") + => HasParentTypes a + -- | Check whether a type appears in a list. We specialize the -- names/types a bit so the error messages are more informative. type family CheckForAncestorType t (a :: Type) (as :: [Type]) :: Constraint where @@ -74,22 +91,6 @@ IsDescendantOf d d = () IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) --- | All the types that are ascendants of this type, including --- interfaces that the type implements. -type family ParentTypes a :: [Type] - --- | A constraint on a type, to be fulfilled whenever it has a type --- instance for `ParentTypes`. This leads to nicer errors, thanks to --- the overlappable instance below. -class HasParentTypes (o :: Type) - --- | Default instance, which will give rise to an error for types --- without an associated `ParentTypes` instance. -instance {-# OVERLAPPABLE #-} - TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: - 'Text "’ does not have any known parent types.") - => HasParentTypes a - -- | Safe coercions to a parent class. For instance: -- -- > #show $ label `asA` Gtk.Widget @@ -191,22 +192,23 @@ class OverloadedMethod i o s where overloadedMethod :: o -> s -- ^ The actual method being invoked. --- | Information about the method that will be invoked, for debugging +-- | Information about a fully resolved symbol, for debugging -- purposes. -data MethodInfo = MethodInfo { overloadedMethodName :: Text - , overloadedMethodURL :: Text - } +data ResolvedSymbolInfo = ResolvedSymbolInfo { + resolvedSymbolName :: Text + , resolvedSymbolURL :: Text + } -instance Show MethodInfo where +instance Show ResolvedSymbolInfo where -- Format as a hyperlink on modern terminals (older -- terminals should ignore the hyperlink part). - show info = T.unpack ("\ESC]8;;" <> overloadedMethodURL info - <> "\ESC\\" <> overloadedMethodName info + show info = T.unpack ("\ESC]8;;" <> resolvedSymbolURL info + <> "\ESC\\" <> resolvedSymbolName info <> "\ESC]8;;\ESC\\") -- | This is for debugging purposes, see `resolveMethod` below. class OverloadedMethodInfo i o where - overloadedMethodInfo :: MethodInfo + overloadedMethodInfo :: Maybe ResolvedSymbolInfo -- | A proxy for carrying the types `MethodInfoName` needs (this is used -- for `resolveMethod`, see below). @@ -215,7 +217,7 @@ -- | Return the fully qualified method name that a given overloaded -- method call resolves to (mostly useful for debugging). -- --- > resolveMethod #show widget +-- > resolveMethod widget #show resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) => - MethodProxy info obj -> obj -> MethodInfo -resolveMethod _p _o = overloadedMethodInfo @info @obj + obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo +resolveMethod _o _p = overloadedMethodInfo @info @obj diff --git a/Data/GI/Base/Overloading.hs-boot b/Data/GI/Base/Overloading.hs-boot --- a/Data/GI/Base/Overloading.hs-boot +++ b/Data/GI/Base/Overloading.hs-boot @@ -1,3 +1,3 @@ module Data.GI.Base.Overloading (HasParentTypes) where -class HasParentTypes o +class HasParentTypes a diff --git a/Data/GI/Base/Properties.hsc b/Data/GI/Base/Properties.hsc --- a/Data/GI/Base/Properties.hsc +++ b/Data/GI/Base/Properties.hsc @@ -29,6 +29,7 @@ , setObjectPropertyCallback , setObjectPropertyGError , setObjectPropertyGValue + , setObjectPropertyParamSpec , getObjectPropertyIsGValueInstance , getObjectPropertyString @@ -58,6 +59,7 @@ , getObjectPropertyCallback , getObjectPropertyGError , getObjectPropertyGValue + , getObjectPropertyParamSpec , constructObjectPropertyIsGValueInstance , constructObjectPropertyString @@ -87,6 +89,7 @@ , constructObjectPropertyCallback , constructObjectPropertyGError , constructObjectPropertyGValue + , constructObjectPropertyParamSpec ) where #if !MIN_VERSION_base(4,8,0) @@ -589,3 +592,17 @@ a -> String -> IO (Maybe GValue) getObjectPropertyGValue obj propName = getObjectPropertyBoxed obj propName GValue + +-- | Construct a property of type `GParamSpec`. +constructObjectPropertyParamSpec :: String -> Maybe GParamSpec -> + IO (GValueConstruct o) +constructObjectPropertyParamSpec = constructObjectPropertyIsGValueInstance + +-- | Get a property of type `GParamSpec`. +getObjectPropertyParamSpec :: GObject a => a -> String -> IO (Maybe GParamSpec) +getObjectPropertyParamSpec = getObjectPropertyIsGValueInstance + +-- | Set a property of type `GParamSpec`. +setObjectPropertyParamSpec :: GObject a => + a -> String -> Maybe GParamSpec -> IO () +setObjectPropertyParamSpec = setObjectPropertyIsGValueInstance diff --git a/Data/GI/Base/ShortPrelude.hs b/Data/GI/Base/ShortPrelude.hs --- a/Data/GI/Base/ShortPrelude.hs +++ b/Data/GI/Base/ShortPrelude.hs @@ -1,3 +1,6 @@ +#if MIN_VERSION_base(4,20,0) +{-# LANGUAGE ExplicitNamespaces #-} +#endif -- | The Haskell Prelude exports a number of symbols that can easily -- collide with functions appearing in bindings. The generated code -- requires just a small subset of the functions in the Prelude, @@ -57,6 +60,9 @@ , when , fromIntegral , realToFrac +#if MIN_VERSION_base(4,20,0) + , type (~) +#endif ) where import Control.Monad (when, (>=>)) 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 @@ -13,10 +13,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} -- | Routines for connecting `GObject`s to signals. There are two -- basic variants, 'on' and 'after', which correspond to --- and , respectively. +-- and , respectively. -- -- Basic usage is -- @@ -51,6 +53,8 @@ , SignalInfo(..) , GObjectNotifySignalInfo , SignalCodeGenError + , resolveSignal + , connectGObjectNotify ) where import Control.Monad.IO.Class (MonadIO, liftIO) @@ -71,12 +75,15 @@ import qualified Data.Text as T import Data.Text (Text) -import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel)) +import Data.GI.Base.Attributes (AttrLabelProxy(..), AttrInfo(AttrLabel), + AttrGetType, attrGet, + AttrBaseTypeConstraint) import Data.GI.Base.BasicConversions (withTextCString) import Data.GI.Base.BasicTypes import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) -import Data.GI.Base.ManagedPtr (withManagedPtr) -import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute) +import Data.GI.Base.ManagedPtr (withManagedPtr, withTransient) +import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute, + ResolvedSymbolInfo) import GHC.OverloadedLabels (IsLabel(..)) @@ -95,6 +102,16 @@ pl ~ AttrLabel info, KnownSymbol pl) => AttrLabelProxy propName -> SignalProxy o GObjectNotifySignalInfo + -- | A signal connector for the @notify@ signal on the given + -- property, similar to `PropertyNotify`, but it passes the new + -- value of the property to the callback for convenience. + PropertySet :: (info ~ ResolveAttribute propName o, + AttrInfo info, + AttrBaseTypeConstraint info o, + b ~ AttrGetType info, + pl ~ AttrLabel info, KnownSymbol pl) => + AttrLabelProxy propName -> + SignalProxy o (GObjectPropertySetSignalInfo b) -- | Support for overloaded labels. instance (info ~ ResolveSignal slot object) => @@ -107,18 +124,25 @@ -- | Information about an overloaded signal. class SignalInfo (info :: Type) where - -- | The type for the signal handler. - type HaskellCallbackType info :: Type - -- | Connect a Haskell function to a signal of the given - -- `GObject`, specifying whether the handler will be called before - -- or after the default handler. - connectSignal :: GObject o => - o -> - HaskellCallbackType info -> - SignalConnectMode -> - Maybe Text -> - IO SignalHandlerId + -- | The type for the signal handler. + type HaskellCallbackType info :: Type + -- | Connect a Haskell function to a signal of the given `GObject`, + -- specifying whether the handler will be called before or after the + -- default handler. Note that the callback being passed here admits + -- an extra initial parameter with respect to the usual Haskell + -- callback type. This will be passed as an /implicit/ @?self@ + -- argument to the Haskell callback. + connectSignal :: GObject o => + o -> + (o -> HaskellCallbackType info) -> + SignalConnectMode -> + Maybe Text -> + IO SignalHandlerId + -- | Optional extra debug information, for `resolveSignal` below. + dbgSignalInfo :: Maybe ResolvedSymbolInfo + dbgSignalInfo = Nothing + -- | Whether to connect a handler to a signal with `connectSignal` so -- that it runs before/after the default handler for the given signal. data SignalConnectMode = SignalConnectBefore -- ^ Run before the default handler. @@ -128,17 +152,43 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) + -> m SignalHandlerId +on o p@(PropertySet (_ :: AttrLabelProxy propName)) cb = liftIO $ do + let wrapped = wrapPropertySet (Proxy @propName) (Proxy @object) cb + cb' <- mkGObjectNotifyCallback wrapped + connectSignalFunPtr o "notify" cb' SignalConnectBefore (proxyDetail p) on o p c = - liftIO $ connectSignal @info o c SignalConnectBefore (proxyDetail p) + liftIO $ connectSignal @info o w SignalConnectBefore (proxyDetail p) + where w :: object -> HaskellCallbackType info + w parent = let ?self = parent in c +-- | Wrap a @b -> IO ()@ callback into a property notify callback on +-- the C side, by adding some code that reads the current value of the +-- property before invoking the callback. +wrapPropertySet :: forall info prop obj. + (info ~ ResolveAttribute prop obj, + AttrBaseTypeConstraint info obj, + AttrInfo info, + GObject obj) => + Proxy (prop :: Symbol) -> Proxy obj -> + ((?self :: obj) => AttrGetType info -> IO ()) -> + Ptr obj -> Ptr GParamSpec -> Ptr () -> IO () +wrapPropertySet _ _ cb objPtr _pspec _data = + withTransient objPtr $ \self -> do + val <- attrGet @(ResolveAttribute prop obj) self + let ?self = self in cb val + -- | Connect a signal to a handler, running the handler after the default one. after :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) + -> m SignalHandlerId after o p c = - liftIO $ connectSignal @info o c SignalConnectAfter (proxyDetail p) + liftIO $ connectSignal @info o w SignalConnectAfter (proxyDetail p) + where w :: object -> HaskellCallbackType info + w parent = let ?self = parent in c -- | Given a signal proxy, determine the corresponding detail. proxyDetail :: forall object info. SignalProxy object info -> Maybe Text @@ -147,6 +197,8 @@ (_ ::: detail) -> Just detail PropertyNotify (AttrLabelProxy :: AttrLabelProxy propName) -> Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object))) + PropertySet (AttrLabelProxy :: AttrLabelProxy propName) -> + Just . T.pack $ symbolVal (Proxy @(AttrLabel (ResolveAttribute propName object))) -- Connecting GObjects to signals foreign import ccall g_signal_connect_data :: @@ -196,20 +248,20 @@ -- | Type for a `GObject` "notify" callback. type GObjectNotifyCallback = GParamSpec -> IO () -gobjectNotifyCallbackWrapper :: - GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO () -gobjectNotifyCallbackWrapper _cb _ pspec _ = do +gobjectNotifyCallbackWrapper :: GObject o => + (o -> GObjectNotifyCallback) -> GObjectNotifyCallbackC o +gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do pspec' <- newGParamSpecFromPtr pspec - _cb pspec' + withTransient (castPtr selfPtr) $ \self -> cb self pspec' -type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO () +type GObjectNotifyCallbackC o = Ptr o -> Ptr GParamSpec -> Ptr () -> IO () foreign import ccall "wrapper" - mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC) + mkGObjectNotifyCallback :: GObjectNotifyCallbackC o -> IO (FunPtr (GObjectNotifyCallbackC o)) -- | Connect the given notify callback for a GObject. connectGObjectNotify :: GObject o => - o -> GObjectNotifyCallback -> + o -> (o -> GObjectNotifyCallback) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId @@ -217,6 +269,11 @@ cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb) connectSignalFunPtr obj "notify" cb' mode detail +data GObjectPropertySetSignalInfo (b :: Type) +instance SignalInfo (GObjectPropertySetSignalInfo b) where + type HaskellCallbackType (GObjectPropertySetSignalInfo b) = b -> IO () + connectSignal = undefined -- We connect these separately + -- | Generate an informative type error whenever one tries to use a -- signal for which code generation has failed. type family SignalCodeGenError (signalName :: Symbol) :: Type where @@ -225,3 +282,11 @@ ':<>: 'Text signalName ':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings." ':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.") + +-- | Return the fully qualified signal name that a given overloaded +-- signal resolves to (mostly useful for debugging). +-- +-- > resolveSignal #childNotify button +resolveSignal :: forall object info. (GObject object, SignalInfo info) => + object -> SignalProxy object info -> Maybe ResolvedSymbolInfo +resolveSignal _o _p = dbgSignalInfo @info 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 @@ -3,10 +3,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} -module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on) where +module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after, + connectGObjectNotify, SignalConnectMode(..)) where -import Data.GI.Base.BasicTypes (GObject) +import Data.GI.Base.Overloading (ResolvedSymbolInfo) +import Data.GI.Base.BasicTypes (GObject, GParamSpec) import Control.Monad.IO.Class (MonadIO) import Foreign.C (CULong) import Data.Text (Text) @@ -18,10 +22,12 @@ type HaskellCallbackType info connectSignal :: GObject o => o -> - HaskellCallbackType info -> + (o -> HaskellCallbackType info) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId + dbgSignalInfo :: Maybe ResolvedSymbolInfo + dbgSignalInfo = Nothing type role SignalProxy nominal nominal data SignalProxy object info where @@ -31,4 +37,17 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId + +after :: forall object info m. + (GObject object, MonadIO m, SignalInfo info) => + object -> SignalProxy object info + -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId + +type GObjectNotifyCallback = GParamSpec -> IO () + +connectGObjectNotify :: GObject o => + o -> (o -> GObjectNotifyCallback) -> + SignalConnectMode -> + Maybe Text -> + IO SignalHandlerId diff --git a/c/hsgclosure.c b/c/hsgclosure.c deleted file mode 100644 --- a/c/hsgclosure.c +++ /dev/null @@ -1,410 +0,0 @@ -#define _GNU_SOURCE - -/* GHC's semi-public Rts API */ -#include - -#include -#include -#include -#include - -#include -#include - -static int print_debug_info () -{ - static int __print_debug_info = -1; - - if (__print_debug_info == -1) { - __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL; - } - - return __print_debug_info; -} - -/* - A mutex protecting the log file handle. We make it recursive, - i.e. refcounted, so it is OK to lock repeatedly in the same thread. -*/ -static pthread_mutex_t log_mutex -#if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP) - = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP; -#elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER) - = PTHREAD_RECURSIVE_MUTEX_INITIALIZER; -#else - ; -__attribute__ ((constructor)) static void init_log_mutex() -{ - pthread_mutexattr_t attr; - pthread_mutexattr_init(&attr); - pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(&log_mutex, &attr); - pthread_mutexattr_destroy(&attr); -} -#endif - -/* Give the current thread exclusive access to the log */ -static void lock_log() -{ - pthread_mutex_lock(&log_mutex); -} - -/* Decrease the refcount of the mutex protecting access to the log - from other threads */ -static void unlock_log() -{ - pthread_mutex_unlock(&log_mutex); -} - -/* Print the given message to the log. The passed in string does not - need to be zero-terminated. The message is only printed if the - HASKELL_GI_DEBUG_MEM variable is set. */ -void dbg_log_with_len (const char *msg, int len) -{ - if (print_debug_info()) { - lock_log(); - fwrite(msg, len, 1, stderr); - unlock_log(); - } -} - -/* Print the given printf-style message to the log. The message is - only printed if the HASKELL_GI_DEBUG_MEM variable is set. */ -__attribute__ ((format (printf, 1, 2))) -static void dbg_log (const char *msg, ...) -{ - va_list args; - - va_start(args, msg); - - if (print_debug_info()) { - lock_log(); - vfprintf(stderr, msg, args); - unlock_log(); - } - - va_end(args); -} - -int check_object_type (void *instance, GType type) -{ - int result; - - if (instance != NULL) { - result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type); - } else { - result = 0; - dbg_log("Check failed: got a null pointer\n"); - } - - return result; -} - -GType _haskell_gi_g_value_get_type (GValue *gvalue) -{ - return G_VALUE_TYPE (gvalue); -} - -/* Information about a boxed type to free */ -typedef struct { - GType gtype; - gpointer boxed; -} BoxedFreeInfo; - -/* Auxiliary function for freeing boxed types in the main loop. See - the annotation in g_object_unref_in_main_loop() below. */ -static gboolean main_loop_boxed_free_helper (gpointer _info) -{ - BoxedFreeInfo *info = (BoxedFreeInfo*)_info; - - if (print_debug_info()) { - GThread *self = g_thread_self (); - lock_log(); - dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n", - info->boxed, self); - dbg_log("\tIt is of type %s\n", g_type_name(info->gtype)); - } - - g_boxed_free (info->gtype, info->boxed); - - if (print_debug_info()) { - dbg_log("\tdone freeing %p.\n", info->boxed); - unlock_log(); - } - - g_free(info); - - return FALSE; /* Do not invoke again */ -} - -void boxed_free_helper (GType gtype, void *boxed) -{ - BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo)); - - info->gtype = gtype; - info->boxed = boxed; - - g_idle_add (main_loop_boxed_free_helper, info); -} - -void dbg_g_object_disown (GObject *obj) -{ - GType gtype; - - if (print_debug_info()) { - lock_log(); - GThread *self = g_thread_self(); - dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self); - gtype = G_TYPE_FROM_INSTANCE (obj); - dbg_log("\tIt is of type %s\n", g_type_name(gtype)); - dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count); - unlock_log(); - } -} - -static void print_object_dbg_info (GObject *obj) -{ - GThread *self = g_thread_self(); - GType gtype; - - dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self); - gtype = G_TYPE_FROM_INSTANCE (obj); - dbg_log("\tIt is of type %s\n", g_type_name(gtype)); - dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count); -} - -/* - We schedule all GObject deletions to happen in the main loop. The - reason is that for some types the destructor is not thread safe, and - assumes that it is being run from the same thread as the main loop - that created the object. - */ -static gboolean -g_object_unref_in_main_loop (gpointer obj) -{ - if (print_debug_info()) { - lock_log(); - print_object_dbg_info ((GObject*)obj); - } - - g_object_unref (obj); - - if (print_debug_info()) { - fprintf(stderr, "\tUnref done\n"); - unlock_log(); - } - - return FALSE; /* Do not invoke again */ -} - -void dbg_g_object_unref (GObject *obj) -{ - g_idle_add(g_object_unref_in_main_loop, obj); -} - -/** - * dbg_g_object_new: - * @gtype: #GType for the object to construct. - * @n_props: Number of parameters for g_object_new_with_properties(). - * @names: Names of the properties to be set. - * @values: Parameters for g_object_new_with_properties(). - * - * Allocate a #GObject of #GType @gtype, with the given @params. The - * returned object is never floating, and we always own a reference to - * it. (It might not be the only existing to the object, but it is in - * any case safe to call g_object_unref() when we are not wrapping the - * object ourselves anymore.) - * - * Returns: A new #GObject. - */ -gpointer dbg_g_object_new (GType gtype, guint n_props, - const char *names[], const GValue values[]) -{ - gpointer result; - - if (print_debug_info()) { - GThread *self = g_thread_self(); - - lock_log(); - dbg_log("Creating a new GObject of type %s [thread: %p]\n", - g_type_name(gtype), self); - } - -#if GLIB_CHECK_VERSION(2,54,0) - result = g_object_new_with_properties (gtype, n_props, names, values); -#else - { GParameter params[n_props]; - int i; - - for (i=0; icallback); - - 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); diff --git a/csrc/hsgclosure.c b/csrc/hsgclosure.c new file mode 100644 --- /dev/null +++ b/csrc/hsgclosure.c @@ -0,0 +1,477 @@ +#define _GNU_SOURCE + +/* GHC's semi-public Rts API */ +#include + +#include +#include +#include +#include + +#include +#include + +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; idata; + g_type_add_interface_static (result, info->gtype, info->info); + interfaces = interfaces -> next; + } + } else { + /* Free the memory associated with the HsFunPtrs that we are + given, to avoid a (small) memory leak. */ + hs_free_fun_ptr ((HsFunPtr)class_init); + hs_free_fun_ptr ((HsFunPtr)instance_init); + + while (interfaces != NULL) { + CombinedInterfaceInfo *info = (CombinedInterfaceInfo*) interfaces->data; + hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_init); + if (info -> info -> interface_finalize) + hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_finalize); + interfaces = interfaces -> next; + } + } + pthread_mutex_unlock(>ypes_mutex); + + return result; +} + +static HsStablePtr duplicateStablePtr(HsStablePtr stable_ptr) +{ + return getStablePtr(deRefStablePtr(stable_ptr)); +} + +GType haskell_gi_StablePtr_get_type (void) +{ + static gsize g_define_type_id = 0; + + if (g_once_init_enter (&g_define_type_id)) + { + GType type_id = + g_boxed_type_register_static (g_intern_static_string ("HaskellGIStablePtr"), + duplicateStablePtr, + hs_free_stable_ptr); + + g_once_init_leave (&g_define_type_id, type_id); + } + + return g_define_type_id; +} + +/* This is identical to haskell_gi_StablePtr_get_type, other than the + type name. The reason for this is that we want two different types, + to distinguish between GValues wrapping generic StablePtrs, and + those wrapping specifically wrapping StablePtrs to Dynamic + values. */ +GType haskell_gi_HaskellValue_get_type (void) +{ + static gsize g_define_type_id = 0; + + if (g_once_init_enter (&g_define_type_id)) + { + GType type_id = + g_boxed_type_register_static (g_intern_static_string ("HaskellGIHaskellValue"), + duplicateStablePtr, + hs_free_stable_ptr); + + g_once_init_leave (&g_define_type_id, type_id); + } + + return g_define_type_id; +} + +/* A safer version of get_boxed, that checks that the GValue contains + the right boxed type. */ +gpointer haskell_gi_safe_get_boxed_haskell_value(const GValue *gv) +{ + if (G_VALUE_TYPE(gv) != haskell_gi_HaskellValue_get_type()) { + fprintf(stderr, "Unexpected type inside the GValue: ‘%s’\n.", + G_VALUE_TYPE_NAME(gv)); + + return NULL; + } + + return g_value_get_boxed(gv); +} + +/* Release the FunPtr allocated for a Haskell signal handler */ +void +haskell_gi_release_signal_closure (gpointer unused, + GCClosure *closure) +{ + lock_log(); + dbg_log("Releasing a signal closure %p\n", closure->callback); + + hs_free_fun_ptr (closure->callback); + + dbg_log("\tDone.\n"); + unlock_log(); +} + +/* Check whether the given closure is floating */ +gboolean +haskell_gi_g_closure_is_floating (GClosure *closure) +{ + return !!(closure->floating); +} + +/* GParamSpec* types are registered as GObjects, but they do not have + an exported type_init function. They only export CPP macros, so + we have to provide our own. */ +#define PARAM_TYPE(CamelCase, UPPERCASE) \ + GType haskell_gi_pspec_type_init_##CamelCase (void) { \ + return G_TYPE_##UPPERCASE; \ + } + +PARAM_TYPE(ParamSpec, PARAM); +PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN); +PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED); +PARAM_TYPE(ParamSpecChar, PARAM_CHAR); +PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE); +PARAM_TYPE(ParamSpecEnum, PARAM_ENUM); +PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS); +PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT); +PARAM_TYPE(ParamSpecGType, PARAM_GTYPE); +PARAM_TYPE(ParamSpecInt, PARAM_INT); +PARAM_TYPE(ParamSpecInt64, PARAM_INT64); +PARAM_TYPE(ParamSpecLong, PARAM_LONG); +PARAM_TYPE(ParamSpecObject, PARAM_OBJECT); +PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE); +PARAM_TYPE(ParamSpecParam, PARAM_PARAM); +PARAM_TYPE(ParamSpecPointer, PARAM_POINTER); +PARAM_TYPE(ParamSpecString, PARAM_STRING); +PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR); +PARAM_TYPE(ParamSpecUInt, PARAM_UINT); +PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64); +PARAM_TYPE(ParamSpecULong, PARAM_ULONG); +PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR); +PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT); +/* The following is deprecated, ignore the warning that GLib raises. */ +#undef GLIB_DEPRECATED_MACRO +#define GLIB_DEPRECATED_MACRO +PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY); 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.25.0 +version: 0.26.9 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi @@ -19,7 +19,7 @@ source-repository head type: git - location: git://github.com/haskell-gi/haskell-gi.git + location: https://github.com/haskell-gi/haskell-gi.git library exposed-modules: Data.GI.Base, @@ -44,19 +44,22 @@ Data.GI.Base.ShortPrelude, Data.GI.Base.Signals, Data.GI.Base.Utils, + Data.GI.Base.DynVal, Data.GI.Base.Internal.CTypes + Data.GI.Base.Internal.PathFieldAccess pkgconfig-depends: gobject-2.0 >= 2.42, glib-2.0 - build-depends: base >= 4.9 && < 5, + build-depends: base >= 4.11 && < 5, bytestring, containers, - text >= 1.0 + text >= 1.0, + optics-core >= 0.4 - ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns + ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat -Wno-unticked-promoted-constructors build-tool-depends: hsc2hs:hsc2hs cc-options: -fPIC default-language: Haskell2010 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds other-extensions: TypeApplications, ScopedTypeVariables - c-sources: c/hsgclosure.c + c-sources: csrc/hsgclosure.c