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