haskell-gi-base-0.26.8/0000755000000000000000000000000007346545000012730 5ustar0000000000000000haskell-gi-base-0.26.8/ChangeLog.md0000644000000000000000000000721207346545000015103 0ustar0000000000000000### 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. ### 0.21.4 + Add support for callback-valued properties. ### 0.21.3 + Fix a compilation error on Windows, see [issue 193](https://github.com/haskell-gi/haskell-gi/issues/193). ### 0.21.2 + Export [newManagedPtr_](https://hackage.haskell.org/package/haskell-gi-base-0.21.2/docs/Data-GI-Base-ManagedPtr.html#v:newManagedPtr_). ### 0.21.1 + Remove the `::=` and `::~` constructors in `AttrOp`, since they cannot really be used for anything, as they are pure functions. ### 0.21.0 + New release to keep major version parity with the `haskell-gi` package, no changes otherwise. ### 0.20.8 + Fix a bug which could lead to crashes when releasing boxed objects, see [issue #130](https://github.com/haskell-gi/haskell-gi/issues/130). ### 0.20.7 + Fix a memory leak in doConstructGObject. ### 0.20.6 + Use g_object_new_with_properties instead of g_object_newv in GLib versions 2.54 or later, to avoid a deprecation warning. ### 0.20.5 + Run object finalizers 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 thread that created the object, which can lead to crashes when using the threaded runtime. ### 0.20.4 + Better error diagnostics for [wrapObject](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-ManagedPtr.html#v:wrapObject) and [newObject](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-ManagedPtr.html#v:newObject). ### 0.20.3 + Fixes for GHC 8.2.1 (and the corresponding `base-4.10.0`). ### 0.20.2 + Fix fromGVariant for empty arrays, see [#91](https://github.com/haskell-gi/haskell-gi/issues/91) for details. ### 0.20.1 + Add Data.GI.Base.CallStack, abstracting (and backporting to the extent possible) the `HasCallStack` constraint present in newer GHCs. Using this, we now include callstacks pervasively in the generated code. + Improve the `WrappedPtr` implementation. + Deprecate `nulltoNothing`, it is better to simply fix the overrides when necessary. + Make the semantics of GObject ownership transfer closer to those used by the Python bindings. haskell-gi-base-0.26.8/Data/GI/0000755000000000000000000000000007346545000014100 5ustar0000000000000000haskell-gi-base-0.26.8/Data/GI/Base.hs0000644000000000000000000000216307346545000015310 0ustar0000000000000000{- | == Convenience header for basic GObject-Introspection modules See the documentation for each individual module for a description and usage help. -} module Data.GI.Base ( module Data.GI.Base.Attributes , module Data.GI.Base.BasicConversions , module Data.GI.Base.BasicTypes , module Data.GI.Base.GClosure , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable , 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.GClosure (GClosure) import Data.GI.Base.Constructible (new) import Data.GI.Base.GError import Data.GI.Base.GHashTable 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.Overloading (asA) haskell-gi-base-0.26.8/Data/GI/Base/0000755000000000000000000000000007346545000014752 5ustar0000000000000000haskell-gi-base-0.26.8/Data/GI/Base/Attributes.hs0000644000000000000000000005320307346545000017437 0ustar0000000000000000{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures, TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds, UndecidableInstances, FlexibleInstances, TypeApplications, DefaultSignatures, PolyKinds, AllowAmbiguousTypes, ImplicitParams, RankNTypes #-} -- | -- -- == Basic attributes interface -- -- Attributes of an object can be get, set and constructed. For types -- descending from 'Data.GI.Base.BasicTypes.GObject', properties are -- encoded in attributes, although attributes are slightly more -- general (every property of a `Data.GI.Base.BasicTypes.GObject` is an -- attribute, but we can also have attributes for types not descending -- from `Data.GI.Base.BasicTypes.GObject`). -- -- If you're wondering what the possible attributes of a GObject are, -- look at the list of properties in the documentation, e.g. the -- Properties heading of the docs for 'GI.Gtk.Objects.Button' lists -- properties such as @image@ and @relief@. Parent classes may also -- introduce properties, so since a Button is an instance of -- @IsActionable@, it inherits properties like @actionName@ from -- 'GI.Gtk.Interfaces.Actionable' too. -- -- As an example consider a @button@ widget and a property (of the -- Button class, or any of its parent classes or implemented -- interfaces) called "label". The simplest way of getting the value -- of the button is to do -- -- > value <- getButtonLabel button -- -- And for setting: -- -- > setButtonLabel button label -- -- This mechanism quickly becomes rather cumbersome, for example for -- setting the "window" property in a DOMDOMWindow in WebKit: -- -- > win <- getDOMDOMWindowWindow dom -- -- and perhaps more importantly, one needs to chase down the type -- which introduces the property: -- -- > setWidgetSensitive button False -- -- There is no @setButtonSensitive@, since it is the @Widget@ type -- that introduces the "sensitive" property. -- -- == Overloaded attributes -- -- A much more convenient overloaded attribute resolution API is -- provided by this module. Getting the value of an object's attribute -- is straightforward: -- -- > value <- get button _label -- -- The definition of @_label@ is basically a 'Proxy' encoding the name -- of the attribute to get: -- -- > _label = fromLabelProxy (Proxy :: Proxy "label") -- -- These proxies can be automatically generated by invoking the code -- generator with the @-l@ option. The leading underscore is simply so -- the autogenerated identifiers do not pollute the namespace, but if -- this is not a concern the autogenerated names (in the autogenerated -- @GI/Properties.hs@) can be edited as one wishes. -- -- In addition, for ghc >= 8.0, one can directly use the overloaded -- labels provided by GHC itself. Using the "OverloadedLabels" -- extension, the code above can also be written as -- -- > value <- get button #label -- -- The syntax for setting or updating an attribute is only slightly more -- complex. At the simplest level it is just: -- -- > set button [ _label := value ] -- -- or for the WebKit example above -- -- > set dom [_window := win] -- -- However as the list notation would indicate, you can set or update multiple -- attributes of the same object in one go: -- -- > set button [ _label := value, _sensitive := False ] -- -- You are not limited to setting the value of an attribute, you can also -- apply an update function to an attribute's value. That is the function -- receives the current value of the attribute and returns the new value. -- -- > set spinButton [ _value :~ (+1) ] -- -- There are other variants of these operators, see 'AttrOp' -- below. ':=>' and ':~>' are like ':=' and ':~' but operate in the -- 'IO' monad rather than being pure. -- -- Attributes can also be set during construction of a -- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Constructible.new` -- -- > button <- new Button [_label := "Can't touch this!", _sensitive := False] -- -- In addition for value being set/get having to have the right type, -- there can be attributes that are read-only, or that can only be set -- during construction with `Data.GI.Base.Properties.new`, but cannot be -- `set` afterwards. That these invariants hold is also checked during -- compile time. -- -- == 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 -- returns @NULL@ as a valid value for the property. In these cases -- the `get` operation may return a `Maybe` value, with `Nothing` -- 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 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@. -- -- For convenience, in nullable cases the `set` operation will by -- default /not/ take a `Maybe` value, but rather assume that the -- caller wants to set a non-@NULL@ value. If setting a @NULL@ value -- is desired, use `clear` as follows -- -- > clear object _propName -- module Data.GI.Base.Attributes ( AttrInfo(..), AttrOpTag(..), AttrOp(..), AttrOpAllowed, AttrGetC, AttrSetC, AttrConstructC, AttrClearC, get, set, clear, AttrLabelProxy(..), resolveAttr ) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.GI.Base.BasicTypes (GObject) import Data.GI.Base.GValue (GValueConstruct) import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute, ResolvedSymbolInfo) import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after) import Data.Proxy (Proxy(..)) import Data.Kind (Type) import GHC.TypeLits import GHC.Exts (Constraint) import GHC.OverloadedLabels (IsLabel(..)) infixr 0 :=,:~,:=>,:~> -- | A proxy for attribute labels. data AttrLabelProxy (a :: Symbol) = AttrLabelProxy #if MIN_VERSION_base(4,10,0) instance a ~ x => IsLabel x (AttrLabelProxy a) where fromLabel = AttrLabelProxy #else instance a ~ x => IsLabel x (AttrLabelProxy a) where fromLabel _ = AttrLabelProxy #endif -- | Info describing an attribute. class AttrInfo (info :: Type) where -- | The operations that are allowed on the attribute. type AttrAllowedOps info :: [AttrOpTag] -- | Constraint on the type for which we are allowed to -- create\/set\/get the attribute. 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 => 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) => 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 => 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) => 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 -- | 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 -- | 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 "’" TypeOriginInfo definingType useType = 'Text "‘" ':<>: 'ShowType useType ':<>: 'Text "’ (inherited from parent type ‘" ':<>: 'ShowType definingType ':<>: 'Text "’)" -- | 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 :: Type) (useType :: Type) :: Constraint where AttrOpIsAllowed tag '[] label definingType useType = TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>: 'Text "’ for type " ':<>: TypeOriginInfo definingType useType ':<>: 'Text " is not " ':<>: 'Text (AttrOpText tag) ':<>: 'Text ".") 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 :: Type) (useType :: Type) :: Constraint where AttrOpAllowed tag info useType = 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 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 -- ^ 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`. deriving (Eq, Ord, Enum, Bounded, Show) -- | A user friendly description of the `AttrOpTag`, useful when -- printing type errors. type family AttrOpText (tag :: AttrOpTag) :: Symbol where AttrOpText 'AttrGet = "gettable" AttrOpText 'AttrSet = "settable" AttrOpText 'AttrConstruct = "constructible" AttrOpText 'AttrClear = "nullable" -- | Constraint on a @obj@\/@attr@ pair so that `set` works on values -- of type @value@. type AttrSetC info obj attr value = (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, AttrOpAllowed 'AttrSet info obj, (AttrSetTypeConstraint info) 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, AttrBaseTypeConstraint info obj, AttrOpAllowed 'AttrConstruct info obj, (AttrSetTypeConstraint info) value) -- | Constructors for the different operations allowed on an attribute. data AttrOp obj (tag :: AttrOpTag) where -- | Assign a value to an attribute (:=) :: (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, AttrOpAllowed tag info obj, (AttrSetTypeConstraint info) b) => AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag -- | Assign the result of an IO action to an attribute (:=>) :: (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, AttrOpAllowed tag info obj, (AttrSetTypeConstraint info) b) => AttrLabelProxy (attr :: Symbol) -> IO b -> AttrOp obj tag -- | Apply an update function to an attribute (:~) :: (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, tag ~ 'AttrSet, AttrOpAllowed 'AttrSet info obj, AttrOpAllowed 'AttrGet info obj, (AttrSetTypeConstraint info) b, a ~ (AttrGetType info)) => AttrLabelProxy (attr :: Symbol) -> (a -> b) -> AttrOp obj tag -- | Apply an IO update function to an attribute (:~>) :: (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, AttrBaseTypeConstraint info obj, tag ~ 'AttrSet, AttrOpAllowed 'AttrSet info obj, AttrOpAllowed 'AttrGet info obj, (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 -- | 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 -- | 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 app :: AttrOp o 'AttrSet -> IO () 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 (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, info ~ ResolveAttribute attr obj, AttrInfo info, (AttrBaseTypeConstraint info) obj, AttrOpAllowed 'AttrGet info obj, result ~ AttrGetType info) -- | Get the value of an attribute for an object. get :: forall info attr obj result m. (AttrGetC info obj attr result, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m result get o _ = liftIO $ attrGet @info o -- | Constraint on a @obj@\/@attr@ pair so that `clear` is allowed. type AttrClearC info obj attr = (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info, (AttrBaseTypeConstraint info) obj, AttrOpAllowed 'AttrClear info obj) -- | Set a nullable attribute to @NULL@. clear :: forall info attr obj m. (AttrClearC info obj attr, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m () clear o _ = liftIO $ attrClear @info o -- | Return the fully qualified attribute name that a given overloaded -- attribute resolves to (mostly useful for debugging). -- -- > resolveAttr #sensitive button resolveAttr :: forall info attr obj. (HasAttributeList obj, info ~ ResolveAttribute attr obj, AttrInfo info) => obj -> AttrLabelProxy (attr :: Symbol) -> Maybe ResolvedSymbolInfo resolveAttr _o _p = dbgAttrInfo @info haskell-gi-base-0.26.8/Data/GI/Base/BasicConversions.hsc0000644000000000000000000005371207346545000020733 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.GI.Base.BasicConversions ( gflagsToWord , wordToGFlags , packGList , unpackGList , packGSList , unpackGSList , packGArray , unpackGArray , unrefGArray , packGPtrArray , unpackGPtrArray , unrefPtrArray , packGByteArray , unpackGByteArray , unrefGByteArray , packGHashTable , unpackGHashTable , unrefGHashTable , packByteString , packZeroTerminatedByteString , unpackByteStringWithLength , unpackZeroTerminatedByteString , packFileNameArray , packZeroTerminatedFileNameArray , unpackZeroTerminatedFileNameArray , unpackFileNameArrayWithLength , packUTF8CArray , packZeroTerminatedUTF8CArray , unpackUTF8CArrayWithLength , unpackZeroTerminatedUTF8CArray , packStorableArray , packZeroTerminatedStorableArray , unpackStorableArrayWithLength , unpackZeroTerminatedStorableArray , packMapStorableArray , packMapZeroTerminatedStorableArray , unpackMapStorableArrayWithLength , unpackMapZeroTerminatedStorableArray , packPtrArray , packZeroTerminatedPtrArray , unpackPtrArrayWithLength , unpackZeroTerminatedPtrArray , packBlockArray , unpackBlockArrayWithLength , unpackBoxedArrayWithLength , stringToCString , cstringToString , textToCString , withTextCString , cstringToText , byteStringToCString , cstringToByteString , mapZeroTerminatedCArray , mapCArrayWithLength , mapGArray , mapPtrArray , mapGList , mapGSList ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception.Base (bracket) import Control.Monad (foldM) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BI import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Foreign as TF import Foreign.Ptr (Ptr, plusPtr, nullPtr, nullFunPtr, castPtr) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable (Storable, peek, poke, sizeOf) import Foreign.C.Types (CInt(..), CUInt(..), CSize(..), CChar(..)) import Foreign.C.String (CString, withCString, peekCString) import Data.Word import Data.Int (Int32) import Data.Bits (Bits, (.|.), (.&.), shift) import Data.GI.Base.BasicTypes import Data.GI.Base.CallStack (HasCallStack) import Data.GI.Base.ManagedPtr (copyBoxedPtr) import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem, checkUnexpectedReturnNULL) #include gflagsToWord :: (Num b, IsGFlag a) => [a] -> b gflagsToWord flags = fromIntegral (go flags) where go (f:fs) = fromEnum f .|. go fs go [] = 0 wordToGFlags :: (Storable a, Integral a, Bits a, IsGFlag b) => a -> [b] wordToGFlags w = go 0 where nbits = (sizeOf w)*8 go k | k == nbits = [] | otherwise = if mask .&. w /= 0 then toEnum (fromIntegral mask) : go (k+1) else go (k+1) where mask = shift 1 k 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. 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. unpackGList :: Ptr (GList (Ptr a)) -> IO [Ptr a] unpackGList gsl | gsl == nullPtr = return [] | otherwise = do x <- peek (castPtr gsl) next <- peek (gsl `plusPtr` sizeOf x) xs <- unpackGList next return $ x : xs -- Same thing for singly linked lists 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. 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. unpackGSList :: Ptr (GSList (Ptr a)) -> IO [Ptr a] unpackGSList gsl = unpackGList (castPtr gsl) foreign import ccall "g_array_new" g_array_new :: CInt -> CInt -> CUInt -> IO (Ptr (GArray ())) foreign import ccall "g_array_set_size" g_array_set_size :: Ptr (GArray ()) -> CUInt -> IO (Ptr (GArray ())) foreign import ccall "g_array_unref" unrefGArray :: Ptr (GArray a) -> IO () packGArray :: forall a. Storable a => [a] -> IO (Ptr (GArray a)) packGArray elems = do let elemsize = sizeOf (elems!!0) array <- g_array_new 0 0 (fromIntegral elemsize) _ <- g_array_set_size array (fromIntegral $ length elems) dataPtr <- peek (castPtr array :: Ptr (Ptr a)) fill dataPtr elems return $ castPtr array where fill :: Ptr a -> [a] -> IO () fill _ [] = return () fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` (sizeOf x)) xs unpackGArray :: forall a. Storable a => Ptr (GArray a) -> IO [a] unpackGArray array = do dataPtr <- peek (castPtr array :: Ptr (Ptr a)) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems where go :: Ptr a -> CUInt -> IO [a] go _ 0 = return [] go ptr n = do x <- peek ptr (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1) foreign import ccall "g_ptr_array_new" g_ptr_array_new :: IO (Ptr (GPtrArray ())) foreign import ccall "g_ptr_array_set_size" g_ptr_array_set_size :: Ptr (GPtrArray ()) -> CUInt -> IO (Ptr (GPtrArray ())) foreign import ccall "g_ptr_array_unref" unrefPtrArray :: Ptr (GPtrArray a) -> IO () packGPtrArray :: [Ptr a] -> IO (Ptr (GPtrArray (Ptr a))) packGPtrArray elems = do array <- g_ptr_array_new _ <- g_ptr_array_set_size array (fromIntegral $ length elems) dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a))) fill dataPtr elems return $ castPtr array where fill :: Ptr (Ptr a) -> [Ptr a] -> IO () fill _ [] = return () fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` (sizeOf x)) xs unpackGPtrArray :: Ptr (GPtrArray (Ptr a)) -> IO [Ptr a] unpackGPtrArray array = do dataPtr <- peek (castPtr array :: Ptr (Ptr (Ptr a))) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems where go :: Ptr (Ptr a) -> CUInt -> IO [Ptr a] go _ 0 = return [] go ptr n = do x <- peek ptr (x:) <$> go (ptr `plusPtr` sizeOf x) (n-1) foreign import ccall "g_byte_array_new" g_byte_array_new :: IO (Ptr GByteArray) foreign import ccall "g_byte_array_append" g_byte_array_append :: Ptr GByteArray -> Ptr a -> CUInt -> IO (Ptr GByteArray) foreign import ccall "g_byte_array_unref" unrefGByteArray :: Ptr GByteArray -> IO () packGByteArray :: ByteString -> IO (Ptr GByteArray) packGByteArray bs = do array <- g_byte_array_new let (ptr, offset, length) = BI.toForeignPtr bs _ <- withForeignPtr ptr $ \dataPtr -> g_byte_array_append array (dataPtr `plusPtr` offset) (fromIntegral length) return array unpackGByteArray :: Ptr GByteArray -> IO ByteString unpackGByteArray array = do dataPtr <- peek (castPtr array :: Ptr (Ptr CChar)) length <- peek (array `plusPtr` (sizeOf dataPtr)) :: IO CUInt B.packCStringLen (dataPtr, fromIntegral length) foreign import ccall "g_hash_table_new_full" g_hash_table_new_full :: GHashFunc a -> GEqualFunc a -> GDestroyNotify a -> GDestroyNotify b -> IO (Ptr (GHashTable a b)) foreign import ccall "g_hash_table_insert" g_hash_table_insert :: Ptr (GHashTable a b) -> PtrWrapped a -> PtrWrapped b -> IO #{type gboolean} packGHashTable :: GHashFunc a -> GEqualFunc a -> Maybe (GDestroyNotify a) -> Maybe (GDestroyNotify b) -> [(PtrWrapped a, PtrWrapped b)] -> IO (Ptr (GHashTable a b)) packGHashTable keyHash keyEqual keyDestroy elemDestroy pairs = do let keyDPtr = fromMaybe nullFunPtr keyDestroy elemDPtr = fromMaybe nullFunPtr elemDestroy ht <- g_hash_table_new_full keyHash keyEqual keyDPtr elemDPtr mapM_ (uncurry (g_hash_table_insert ht)) pairs return ht foreign import ccall "g_hash_table_get_keys" g_hash_table_get_keys :: Ptr (GHashTable a b) -> IO (Ptr (GList (Ptr a))) foreign import ccall "g_hash_table_lookup" g_hash_table_lookup :: Ptr (GHashTable a b) -> PtrWrapped a -> IO (PtrWrapped b) unpackGHashTable :: Ptr (GHashTable a b) -> IO [(PtrWrapped a, PtrWrapped b)] unpackGHashTable ht = do keysGList <- g_hash_table_get_keys ht keys <- (map (PtrWrapped . castPtr)) <$> unpackGList keysGList g_list_free keysGList -- At this point we could use g_hash_table_get_values, since the -- current implementation in GLib returns elements in the same order -- as g_hash_table_get_keys. But to be on the safe side, since the -- ordering is not specified in the documentation, we do the -- following, which is (quite) slower but manifestly safe. elems <- mapM (g_hash_table_lookup ht) keys return (zip keys elems) foreign import ccall "g_hash_table_unref" unrefGHashTable :: Ptr (GHashTable a b) -> IO () packByteString :: ByteString -> IO (Ptr Word8) packByteString bs = do let (ptr, offset, length) = BI.toForeignPtr bs mem <- allocBytes length withForeignPtr ptr $ \dataPtr -> memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length) return mem packZeroTerminatedByteString :: ByteString -> IO (Ptr Word8) packZeroTerminatedByteString bs = do let (ptr, offset, length) = BI.toForeignPtr bs mem <- allocBytes (length+1) withForeignPtr ptr $ \dataPtr -> memcpy mem (dataPtr `plusPtr` offset) (fromIntegral length) poke (mem `plusPtr` (offset+length)) (0 :: Word8) return mem unpackByteStringWithLength :: Integral a => a -> Ptr Word8 -> IO ByteString unpackByteStringWithLength length ptr = B.packCStringLen (castPtr ptr, fromIntegral length) unpackZeroTerminatedByteString :: Ptr Word8 -> IO ByteString unpackZeroTerminatedByteString ptr = B.packCString (castPtr ptr) packStorableArray :: Storable a => [a] -> IO (Ptr a) packStorableArray = packMapStorableArray id packZeroTerminatedStorableArray :: (Num a, Storable a) => [a] -> IO (Ptr a) packZeroTerminatedStorableArray = packMapZeroTerminatedStorableArray id unpackStorableArrayWithLength :: (Integral a, Storable b) => a -> Ptr b -> IO [b] unpackStorableArrayWithLength = unpackMapStorableArrayWithLength id unpackZeroTerminatedStorableArray :: (Eq a, Num a, Storable a) => Ptr a -> IO [a] unpackZeroTerminatedStorableArray = unpackMapZeroTerminatedStorableArray id packMapStorableArray :: forall a b. Storable b => (a -> b) -> [a] -> IO (Ptr b) packMapStorableArray fn items = do let nitems = length items mem <- allocBytes $ (sizeOf (undefined::b)) * nitems fill mem (map fn items) return mem where fill :: Ptr b -> [b] -> IO () fill _ [] = return () fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` sizeOf x) xs packMapZeroTerminatedStorableArray :: forall a b. (Num b, Storable b) => (a -> b) -> [a] -> IO (Ptr b) packMapZeroTerminatedStorableArray fn items = do let nitems = length items mem <- allocBytes $ (sizeOf (undefined::b)) * (nitems+1) fill mem (map fn items) return mem where fill :: Ptr b -> [b] -> IO () fill ptr [] = poke ptr 0 fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` sizeOf x) xs unpackMapStorableArrayWithLength :: forall a b c. (Integral a, Storable b) => (b -> c) -> a -> Ptr b -> IO [c] unpackMapStorableArrayWithLength fn n ptr = map fn <$> go (fromIntegral n) ptr where go :: Int -> Ptr b -> IO [b] go 0 _ = return [] go n ptr = do x <- peek ptr (x:) <$> go (n-1) (ptr `plusPtr` sizeOf x) unpackMapZeroTerminatedStorableArray :: forall a b. (Eq a, Num a, Storable a) => (a -> b) -> Ptr a -> IO [b] unpackMapZeroTerminatedStorableArray fn ptr = map fn <$> go ptr where go :: Ptr a -> IO [a] go ptr = do x <- peek ptr if x == 0 then return [] else (x:) <$> go (ptr `plusPtr` sizeOf x) packUTF8CArray :: [Text] -> IO (Ptr CString) packUTF8CArray items = do let nitems = length items mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString)) fill mem items return mem where fill :: Ptr CString -> [Text] -> IO () fill _ [] = return () fill ptr (x:xs) = do cstring <- textToCString x poke ptr cstring fill (ptr `plusPtr` sizeOf cstring) xs packZeroTerminatedUTF8CArray :: [Text] -> IO (Ptr CString) packZeroTerminatedUTF8CArray items = do let nitems = length items mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1) fill mem items return mem where fill :: Ptr CString -> [Text] -> IO () fill ptr [] = poke ptr nullPtr fill ptr (x:xs) = do cstring <- textToCString x poke ptr cstring fill (ptr `plusPtr` sizeOf cstring) xs unpackZeroTerminatedUTF8CArray :: HasCallStack => Ptr CString -> IO [Text] unpackZeroTerminatedUTF8CArray listPtr = go listPtr where go :: Ptr CString -> IO [Text] go ptr = do cstring <- peek ptr if cstring == nullPtr then return [] else (:) <$> cstringToText cstring <*> go (ptr `plusPtr` sizeOf cstring) unpackUTF8CArrayWithLength :: (HasCallStack, Integral a) => a -> Ptr CString -> IO [Text] unpackUTF8CArrayWithLength n ptr = go (fromIntegral n) ptr where go :: Int -> Ptr CString -> IO [Text] go 0 _ = return [] go n ptr = do cstring <- peek ptr (:) <$> cstringToText cstring <*> go (n-1) (ptr `plusPtr` sizeOf cstring) packFileNameArray :: [String] -> IO (Ptr CString) packFileNameArray items = do let nitems = length items mem <- allocBytes $ nitems * (sizeOf (nullPtr :: CString)) fill mem items return mem where fill :: Ptr CString -> [String] -> IO () fill _ [] = return () fill ptr (x:xs) = do cstring <- stringToCString x poke ptr cstring fill (ptr `plusPtr` sizeOf cstring) xs packZeroTerminatedFileNameArray :: [String] -> IO (Ptr CString) packZeroTerminatedFileNameArray items = do let nitems = length items mem <- allocBytes $ (sizeOf (nullPtr :: CString)) * (nitems+1) fill mem items return mem where fill :: Ptr CString -> [String] -> IO () fill ptr [] = poke ptr nullPtr fill ptr (x:xs) = do cstring <- stringToCString x poke ptr cstring fill (ptr `plusPtr` sizeOf cstring) xs unpackZeroTerminatedFileNameArray :: HasCallStack => Ptr CString -> IO [String] unpackZeroTerminatedFileNameArray listPtr = go listPtr where go :: Ptr CString -> IO [String] go ptr = do cstring <- peek ptr if cstring == nullPtr then return [] else (:) <$> cstringToString cstring <*> go (ptr `plusPtr` sizeOf cstring) unpackFileNameArrayWithLength :: (HasCallStack, Integral a) => a -> Ptr CString -> IO [String] unpackFileNameArrayWithLength n ptr = go (fromIntegral n) ptr where go :: Int -> Ptr CString -> IO [String] go 0 _ = return [] go n ptr = do cstring <- peek ptr (:) <$> cstringToString cstring <*> go (n-1) (ptr `plusPtr` sizeOf cstring) foreign import ccall "g_strdup" g_strdup :: CString -> IO CString -- We need to use the GLib allocator for constructing CStrings, since -- the ownership of the string may be transferred to the GLib side, -- which will free it with g_free. stringToCString :: String -> IO CString stringToCString str = withCString str g_strdup cstringToString :: HasCallStack => CString -> IO String cstringToString cstr = do checkUnexpectedReturnNULL (T.pack "cstringToString") cstr peekCString cstr foreign import ccall "g_strndup" g_strndup :: CString -> #{type gsize} -> IO CString -- | Convert `Text` into a `CString`, using the GLib allocator. textToCString :: Text -> IO CString textToCString str = TF.withCStringLen str $ \(cstr, len) -> -- Because withCStringLen returns NULL for a zero-length Text, and -- g_strndup returns NULL for NULL, even if n==0. if cstr /= nullPtr then g_strndup cstr (fromIntegral len) else callocBytes 1 withTextCString :: Text -> (CString -> IO a) -> IO a withTextCString text action = bracket (textToCString text) freeMem action foreign import ccall "strlen" c_strlen :: CString -> IO (CSize) cstringToText :: HasCallStack => CString -> IO Text cstringToText cstr = do checkUnexpectedReturnNULL (T.pack "cstringToText") cstr len <- c_strlen cstr let cstrlen = (cstr, fromIntegral len) TF.peekCStringLen cstrlen byteStringToCString :: ByteString -> IO CString byteStringToCString bs = B.useAsCString bs g_strdup cstringToByteString :: HasCallStack => CString -> IO ByteString cstringToByteString cstr = do checkUnexpectedReturnNULL (T.pack "cstringToByteString") cstr B.packCString cstr packPtrArray :: [Ptr a] -> IO (Ptr (Ptr a)) packPtrArray items = do let nitems = length items mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * nitems fill mem items return mem where fill :: Ptr (Ptr a) -> [Ptr a] -> IO () fill _ [] = return () fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` sizeOf x) xs packZeroTerminatedPtrArray :: [Ptr a] -> IO (Ptr (Ptr a)) packZeroTerminatedPtrArray items = do let nitems = length items mem <- allocBytes $ (sizeOf (nullPtr :: Ptr a)) * (nitems+1) fill mem items return mem where fill :: Ptr (Ptr a) -> [Ptr a] -> IO () fill ptr [] = poke ptr nullPtr fill ptr (x:xs) = do poke ptr x fill (ptr `plusPtr` sizeOf x) xs unpackPtrArrayWithLength :: Integral a => a -> Ptr (Ptr b) -> IO [Ptr b] unpackPtrArrayWithLength n ptr = go (fromIntegral n) ptr where go :: Int -> Ptr (Ptr a) -> IO [Ptr a] go 0 _ = return [] go n ptr = (:) <$> peek ptr <*> go (n-1) (ptr `plusPtr` sizeOf (nullPtr :: Ptr a)) unpackZeroTerminatedPtrArray :: Ptr (Ptr a) -> IO [Ptr a] unpackZeroTerminatedPtrArray ptr = go ptr where go :: Ptr (Ptr a) -> IO [Ptr a] go ptr = do p <- peek ptr if p == nullPtr then return [] else (p:) <$> go (ptr `plusPtr` sizeOf p) mapZeroTerminatedCArray :: (Ptr a -> IO b) -> Ptr (Ptr a) -> IO () mapZeroTerminatedCArray f dataPtr | (dataPtr == nullPtr) = return () | otherwise = do ptr <- peek dataPtr if ptr == nullPtr then return () else do _ <- f ptr mapZeroTerminatedCArray f (dataPtr `plusPtr` sizeOf ptr) -- | Given a set of pointers to blocks of memory of the specified -- size, copy the contents of these blocks to a freshly-allocated -- (with `allocBytes`) continuous area of memory. packBlockArray :: Int -> [Ptr a] -> IO (Ptr a) packBlockArray size items = do let nitems = length items mem <- allocBytes $ size * nitems fill mem items return mem where fill :: Ptr a -> [Ptr a] -> IO () fill _ [] = return () fill ptr (x:xs) = do memcpy ptr x size fill (ptr `plusPtr` size) xs foreign import ccall "g_memdup" g_memdup :: Ptr a -> CUInt -> IO (Ptr a) unpackBlockArrayWithLength :: Integral a => Int -> a -> Ptr b -> IO [Ptr b] unpackBlockArrayWithLength size n ptr = go size (fromIntegral n) ptr where go :: Int -> Int -> Ptr b -> IO [Ptr b] go _ 0 _ = return [] go size n ptr = do buf <- g_memdup ptr (fromIntegral size) (buf :) <$> go size (n-1) (ptr `plusPtr` size) 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] go _ 0 _ = return [] go size n ptr = do buf <- copyBoxedPtr ptr (buf :) <$> go size (n-1) (ptr `plusPtr` size) mapCArrayWithLength :: (Storable a, Integral b) => b -> (a -> IO c) -> Ptr a -> IO () mapCArrayWithLength n f dataPtr | (dataPtr == nullPtr) = return () | (n <= 0) = return () | otherwise = do ptr <- peek dataPtr _ <- f ptr mapCArrayWithLength (n-1) f (dataPtr `plusPtr` sizeOf ptr) mapGArray :: forall a b. Storable a => (a -> IO b) -> Ptr (GArray a) -> IO () mapGArray f array | (array == nullPtr) = return () | otherwise = do dataPtr <- peek (castPtr array :: Ptr (Ptr a)) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems where go :: Ptr a -> Int -> IO () go _ 0 = return () go ptr n = do x <- peek ptr _ <- f x go (ptr `plusPtr` sizeOf x) (n-1) mapPtrArray :: (Ptr a -> IO b) -> Ptr (GPtrArray (Ptr a)) -> IO () mapPtrArray f array = mapGArray f (castPtr array) mapGList :: (Ptr a -> IO b) -> Ptr (GList (Ptr a)) -> IO () mapGList f glist | (glist == nullPtr) = return () | otherwise = do ptr <- peek (castPtr glist) next <- peek (glist `plusPtr` sizeOf ptr) _ <- f ptr mapGList f next mapGSList :: (Ptr a -> IO b) -> Ptr (GSList (Ptr a)) -> IO () mapGSList f gslist = mapGList f (castPtr gslist) haskell-gi-base-0.26.8/Data/GI/Base/BasicTypes.hsc0000644000000000000000000002002107346545000017512 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, DeriveDataTypeable, 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.Typeable (Typeable) 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 } deriving (Typeable) 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}) haskell-gi-base-0.26.8/Data/GI/Base/CallStack.hs0000644000000000000000000000367107346545000017156 0ustar0000000000000000{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-} -- | A compatibility layer for `CallStack`, so that we can have -- uniform signatures even in old GHC versions (even if the -- functionality itself does not work there). module Data.GI.Base.CallStack ( HasCallStack , CallStack , prettyCallStack , callStack ) where #if MIN_VERSION_base(4,9,0) import GHC.Stack (HasCallStack, prettyCallStack, callStack, CallStack) #elif MIN_VERSION_base(4,8,1) import Data.List (intercalate) import qualified GHC.Stack as S import GHC.SrcLoc (SrcLoc(..)) import GHC.Exts (Constraint) type HasCallStack = ((?callStack :: S.CallStack) :: Constraint) type CallStack = [(String, SrcLoc)] #else import GHC.Exts (Constraint) type HasCallStack = (() :: Constraint) type CallStack = () #endif #if !MIN_VERSION_base(4,9,0) -- | Return the current `CallStack`. callStack :: HasCallStack => CallStack #if MIN_VERSION_base(4,8,1) callStack = drop 1 (S.getCallStack ?callStack) #else callStack = () #endif #endif #if !MIN_VERSION_base(4,9,0) prettyCallStack :: CallStack -> String #if MIN_VERSION_base(4,8,1) -- | Give a text representation of the current `CallStack`. prettyCallStack = intercalate "\n" . prettyCallStackLines where prettySrcLoc :: SrcLoc -> String prettySrcLoc l = foldr (++) "" [ srcLocFile l, ":" , show (srcLocStartLine l), ":" , show (srcLocStartCol l), " in " , srcLocPackage l, ":", srcLocModule l ] prettyCallStackLines :: CallStack -> [String] prettyCallStackLines cs = case cs of [] -> [] stk -> "CallStack (from HasCallStack):" : map ((" " ++) . prettyCallSite) stk prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc #else prettyCallStack _ = "= 7.10.2>" #endif #endif haskell-gi-base-0.26.8/Data/GI/Base/Constructible.hs0000644000000000000000000000212207346545000020123 0ustar0000000000000000{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, KindSignatures, TypeFamilies, TypeOperators #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif -- | `Constructible` types are those for which `new` is -- defined. Often these are `GObject`s, but it is possible to -- construct new (zero-initialized) structures and unions too. module Data.GI.Base.Constructible ( Constructible(..) ) where import Control.Monad.IO.Class (MonadIO) import Data.GI.Base.Attributes (AttrOp, AttrOpTag(..)) import Data.GI.Base.BasicTypes (GObject, ManagedPtr) import Data.GI.Base.GObject (constructGObject) -- | Constructible types, i.e. those which can be allocated by `new`. class Constructible a (tag :: AttrOpTag) where -- | 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 {-# OVERLAPPABLE #-} (GObject a, tag ~ 'AttrConstruct) => Constructible a tag where new = constructGObject haskell-gi-base-0.26.8/Data/GI/Base/GArray.hs0000644000000000000000000000075007346545000016475 0ustar0000000000000000-- | 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 haskell-gi-base-0.26.8/Data/GI/Base/GClosure.hs0000644000000000000000000000703707346545000017040 0ustar0000000000000000{-# 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 haskell-gi-base-0.26.8/Data/GI/Base/GError.hs0000644000000000000000000002423207346545000016511 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, 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 Data.Typeable (Typeable) 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) 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 -- | 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 haskell-gi-base-0.26.8/Data/GI/Base/GHashTable.hsc0000644000000000000000000000415607346545000017421 0ustar0000000000000000{- | Machinery for some basic support of `GHashTable`. The GLib `GHashTable` implementation requires two things: we need to "pack" a datatype into a pointer (for datatypes that are represented by pointers this is the trivial operation, for integers it is not, and GLib has some helper macros). We also need to be able to hash and check for equality different datatypes. -} module Data.GI.Base.GHashTable ( GHashFunc , GEqualFunc , gDirectHash , gDirectEqual , ptrPackPtr , ptrUnpackPtr , gStrHash , gStrEqual , cstringPackPtr , cstringUnpackPtr , gvaluePackPtr , gvalueUnpackPtr ) where import Foreign.C import Foreign.Ptr (Ptr, castPtr) import Data.GI.Base.BasicTypes (PtrWrapped(..), GHashFunc, GEqualFunc) import Data.GI.Base.GValue (GValue) #include -- | Compute the hash for a `Ptr`. foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a) -- | Check whether two pointers are equal. foreign import ccall "&g_direct_equal" gDirectEqual :: GEqualFunc (Ptr a) -- | Pack a `Ptr` into a `PtrWrapped` `Ptr`. ptrPackPtr :: Ptr a -> PtrWrapped (Ptr a) ptrPackPtr = PtrWrapped . castPtr -- | Extract a `Ptr` from a `PtrWrapped` `Ptr`. ptrUnpackPtr :: PtrWrapped (Ptr a) -> Ptr a ptrUnpackPtr = castPtr . unwrapPtr -- | Compute the hash for a `CString`. foreign import ccall "&g_str_hash" gStrHash :: GHashFunc CString -- | Check whether two `CString`s are equal. foreign import ccall "&g_str_equal" gStrEqual :: GEqualFunc CString -- | Pack a `CString` into a `Ptr` than can go into a `GHashTable`. cstringPackPtr :: CString -> PtrWrapped CString cstringPackPtr = ptrPackPtr -- | 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 haskell-gi-base-0.26.8/Data/GI/Base/GObject.hsc0000644000000000000000000004720107346545000016772 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -- | This module constains helpers for dealing with `GObject`-derived -- types. module Data.GI.Base.GObject ( -- * 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) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Proxy (Proxy(..)) import Data.Coerce (coerce) import Foreign.C (CUInt(..), CString, newCString) import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, plusPtr, 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 Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy, attrConstruct, attrTransfer, AttrInfo(..)) 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.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, newObject) import Data.GI.Base.Overloading (ResolveAttribute) import Data.GI.Base.Signals (on, after) import Data.GI.Base.Utils (dbgLog, callocBytes, freeMem) #include foreign import ccall "dbg_g_object_new" g_object_new :: GType -> CUInt -> Ptr CString -> Ptr a -> IO (Ptr b) -- | Construct a GObject given the constructor and a list of settable -- 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 <- catMaybes <$> mapM construct attrs obj <- doConstructGObject constructor props mapM_ (setSignal obj) attrs return obj where construct :: AttrOp o 'AttrConstruct -> 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 (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 () -- | 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. (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 <- glibType @o result <- g_object_new gtype (fromIntegral nprops) names values freeStrings nprops names free values free names -- Make sure that the GValues defining the GProperties are still -- alive at this point (so, in particular, they are still alive when -- g_object_new is called). Without this the GHC garbage collector -- may free the GValues before g_object_new is called, which will -- unref the referred to objects, which may drop the last reference -- to the contained objects. g_object_new then tries to access the -- (now invalid) contents of the GValue, and mayhem ensues. mapM_ (touchManagedPtr . deconstructGValue) props wrapObject constructor (result :: Ptr o) where deconstructGValue :: GValueConstruct o -> GValue deconstructGValue (GValueConstruct _ v) = v gvalueSize = #size GValue -- Fill in the memory associated with the parameters. fill :: Ptr CString -> Ptr GValue -> [GValueConstruct o] -> IO () fill _ _ [] = return () fill namePtr dataPtr ((GValueConstruct str gvalue):xs) = do cstr <- newCString str poke namePtr cstr withManagedPtr gvalue $ \gvalueptr -> copyBytes dataPtr gvalueptr gvalueSize fill (namePtr `plusPtr` sizeOf nullPtr) (dataPtr `plusPtr` gvalueSize) xs -- Free the strings in the GParameter array (the GValues will be -- freed separately). freeStrings :: Int -> Ptr CString -> IO () freeStrings 0 _ = return () freeStrings n namePtr = do peek namePtr >>= free freeStrings (n-1) (namePtr `plusPtr` sizeOf nullPtr) -- | 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 haskell-gi-base-0.26.8/Data/GI/Base/GParamSpec.hsc0000644000000000000000000004171707346545000017445 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Management of `GParamSpec`s. module Data.GI.Base.GParamSpec ( -- * Memory management wrapGParamSpecPtr , newGParamSpecFromPtr , unrefGParamSpec , disownGParamSpec -- * GParamSpec building , PropertyInfo(..) , gParamSpecValue , CStringPropertyInfo(..) , gParamSpecCString , CIntPropertyInfo(..) , gParamSpecCInt , GBooleanPropertyInfo(..) , gParamSpecGBoolean , GParamFlag(..) -- * 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, 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 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 :: Ptr GParamSpec -> IO (Ptr GParamSpec) foreign import ccall "g_param_spec_unref" g_param_spec_unref :: Ptr GParamSpec -> IO () foreign import ccall "&g_param_spec_unref" ptr_to_g_param_spec_unref :: FunPtr (Ptr GParamSpec -> IO ()) -- | Take ownership of a ParamSpec passed in 'Ptr'. wrapGParamSpecPtr :: Ptr GParamSpec -> IO GParamSpec wrapGParamSpecPtr ptr = do void $ g_param_spec_ref_sink ptr fPtr <- newManagedPtr' ptr_to_g_param_spec_unref ptr return $! GParamSpec fPtr -- | Construct a Haskell wrapper for the given 'GParamSpec', without -- assuming ownership. newGParamSpecFromPtr :: Ptr GParamSpec -> IO GParamSpec newGParamSpecFromPtr ptr = do fPtr <- g_param_spec_ref ptr >>= newManagedPtr' ptr_to_g_param_spec_unref return $! GParamSpec fPtr -- | Remove a reference to the given 'GParamSpec'. unrefGParamSpec :: GParamSpec -> IO () unrefGParamSpec ps = withManagedPtr ps g_param_spec_unref -- | Disown a `GParamSpec`, i.e. do not longer unref the associated -- foreign `GParamSpec` when the Haskell `GParamSpec` gets garbage -- 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 haskell-gi-base-0.26.8/Data/GI/Base/GQuark.hsc0000644000000000000000000000107207346545000016643 0ustar0000000000000000-- | 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 haskell-gi-base-0.26.8/Data/GI/Base/GType.hsc0000644000000000000000000000772307346545000016512 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Basic `GType`s. module Data.GI.Base.GType ( gtypeString , gtypePointer , gtypeInt , gtypeUInt , gtypeLong , gtypeULong , gtypeInt64 , gtypeUInt64 , gtypeFloat , gtypeDouble , gtypeBoolean , gtypeError , gtypeGType , gtypeStrv , gtypeBoxed , gtypeObject , gtypeVariant , gtypeByteArray , gtypeInvalid , gtypeParam , gtypeStablePtr , gtypeHValue ) where import Data.GI.Base.BasicTypes (GType(..), CGType) #include {-| [Note: compile-time vs run-time GTypes] Notice that there are two types of GType's: the fundamental ones, which are created with G_TYPE_MAKE_FUNDAMENTAL(n) and always have the same runtime representation, and the ones that are registered in the GObject type system at runtime, and whose `CGType` may change for each program run (and generally does). For the first type it is safe to use hsc to read the numerical values of the CGType at compile type, but for the second type it is essential to call the corresponding _get_type() function at runtime, and not use the value of the corresponding "constant" at compile time via hsc. -} {- Fundamental types -} -- | `GType` of strings. gtypeString :: GType gtypeString = GType #const G_TYPE_STRING -- | `GType` of pointers. gtypePointer :: GType gtypePointer = GType #const G_TYPE_POINTER -- | `GType` for signed integers (@gint@ or @gint32@). gtypeInt :: GType gtypeInt = GType #const G_TYPE_INT -- | `GType` for unsigned integers (@guint@ or @guint32@). gtypeUInt :: GType gtypeUInt = GType #const G_TYPE_UINT -- | `GType` for @glong@. gtypeLong :: GType gtypeLong = GType #const G_TYPE_LONG -- | `GType` for @gulong@. gtypeULong :: GType gtypeULong = GType #const G_TYPE_ULONG -- | `GType` for signed 64 bit integers. gtypeInt64 :: GType gtypeInt64 = GType #const G_TYPE_INT64 -- | `GType` for unsigned 64 bit integers. gtypeUInt64 :: GType gtypeUInt64 = GType #const G_TYPE_UINT64 -- | `GType` for floating point values. gtypeFloat :: GType gtypeFloat = GType #const G_TYPE_FLOAT -- | `GType` for gdouble. gtypeDouble :: GType gtypeDouble = GType #const G_TYPE_DOUBLE -- | `GType` corresponding to gboolean. gtypeBoolean :: GType gtypeBoolean = GType #const G_TYPE_BOOLEAN -- | `GType` corresponding to a boxed object. gtypeBoxed :: GType gtypeBoxed = GType #const G_TYPE_BOXED -- | `GType` corresponding to a @GObject@. gtypeObject :: GType gtypeObject = GType #const G_TYPE_OBJECT -- | An invalid `GType` used as error return value in some functions -- which return a `GType`. gtypeInvalid :: GType gtypeInvalid = GType #const G_TYPE_INVALID -- | 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 -- | `GType` corresponding to a `GType` itself. gtypeGType :: GType gtypeGType = GType g_gtype_get_type foreign import ccall "g_strv_get_type" g_strv_get_type :: CGType -- | `GType` for a NULL terminated array of strings. gtypeStrv :: GType gtypeStrv = GType g_strv_get_type foreign import ccall "g_byte_array_get_type" g_byte_array_get_type :: CGType -- | `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 haskell-gi-base-0.26.8/Data/GI/Base/GValue.hs0000644000000000000000000004262107346545000016476 0ustar0000000000000000{-# 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) haskell-gi-base-0.26.8/Data/GI/Base/GVariant.hsc0000644000000000000000000011246707346545000017177 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE EmptyDataDecls #-} {-| This module contains some helper functions for dealing with GVariant values. The simplest way of dealing with them is by using the 'IsGVariant' typeclass: > str <- fromGVariant variant :: IO (Maybe Text) assuming that the variant is expected to contain a string in UTF8 encoding. The code becomes even shorter if the type checker can determine the return type for you: > readStringVariant :: GVariant -> IO Text > readStringVariant variant = > fromGVariant variant >>= \case > Nothing -> error "Variant was not a string" > Just str -> return str Alternatively, you can use manually the gvariantFrom* and gvariantTo* family of functions. -} module Data.GI.Base.GVariant ( IsGVariant(..) , IsGVariantBasicType , noGVariant , gvariantGetTypeString -- * Type wrappers -- | Some 'GVariant' types are isomorphic to Haskell types, but they -- carry some extra information. For example, there is a tuple -- singlet type, which is isomorphic to a single Haskell value -- with the added bit of information that it is wrapped in a tuple -- container. In order to use these values you can use the -- following wrappers, which allow the 'IsGVariant' instance to -- disambiguate the requested type properly. , GVariantSinglet(GVariantSinglet) , GVariantDictEntry(GVariantDictEntry) , GVariantHandle(GVariantHandle) , GVariantObjectPath , newGVariantObjectPath , gvariantObjectPathToText , GVariantSignature , newGVariantSignature , gvariantSignatureToText -- * Manual memory management , wrapGVariantPtr , newGVariantFromPtr , unrefGVariant , disownGVariant -- * Manual conversions -- ** Basic types -- -- | The use of these should be fairly self-explanatory. If you -- want to convert a Haskell type into a 'GVariant', use -- gvariantTo*. If you want to convert a 'GVariant' into a Haskell -- type, use gvariantFrom*. The conversion can fail if the -- 'GVariant' is not of the expected type (if you want to convert -- a 'GVariant' containing a 'Int16' into a 'Text' value, say), in -- which case 'Nothing' will be returned. , gvariantToBool , gvariantFromBool , gvariantToWord8 , gvariantFromWord8 , gvariantToInt16 , gvariantFromInt16 , gvariantToWord16 , gvariantFromWord16 , gvariantToInt32 , gvariantFromInt32 , gvariantToWord32 , gvariantFromWord32 , gvariantToInt64 , gvariantFromInt64 , gvariantToWord64 , gvariantFromWord64 , gvariantToHandle , gvariantFromHandle , gvariantToDouble , gvariantFromDouble , gvariantToText , gvariantFromText , gvariantToObjectPath , gvariantFromObjectPath , gvariantToSignature , gvariantFromSignature -- ** Container type conversions , gvariantToGVariant , gvariantFromGVariant , gvariantToBytestring , gvariantFromBytestring , gvariantFromMaybe , gvariantToMaybe , gvariantFromDictEntry , gvariantToDictEntry , gvariantFromMap , gvariantToMap , gvariantFromList , gvariantToList , gvariantFromTuple , gvariantToTuple ) where #include import Control.Monad (when, void, (>=>)) import Control.Exception.Base (bracket) import Data.Text (Text) import Data.ByteString (ByteString) 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 import System.IO.Unsafe (unsafePerformIO) import Foreign.C import Foreign.Ptr import Data.GI.Base.BasicTypes (GVariant(..)) import Data.GI.Base.BasicConversions import Data.GI.Base.ManagedPtr (withManagedPtr, withManagedPtrList, newManagedPtr', disownManagedPtr) import Data.GI.Base.Utils (freeMem) -- | An alias for @Nothing :: Maybe GVariant@ to save some typing. noGVariant :: Maybe GVariant noGVariant = Nothing -- | The typeclass for types that can be automatically marshalled into -- 'GVariant' using 'toGVariant' and 'fromGVariant'. class IsGVariant a where -- | Convert a value of the given type into a GVariant. toGVariant :: a -> IO GVariant -- | Try to decode a 'GVariant' into a target type. If the -- conversion fails we return 'Nothing'. The type that was -- expected can be obtained by calling 'toGVariantFormatString', -- and the actual type as understood by the 'GVariant' code can be -- obtained by calling 'gvariantToTypeString'. fromGVariant :: GVariant -> IO (Maybe a) -- | The expected format string for this type (the argument is -- ignored). toGVariantFormatString :: a -> Text -- Same as fromGVariant, for cases where we have checked that things -- have the right type in advance. unsafeFromGVariant :: IsGVariant a => GVariant -> IO a unsafeFromGVariant gv = fromGVariant gv >>= \case Nothing -> error "Error decoding GVariant. This is a bug in haskell-gi, please report it." Just value -> return value -- | The typeclass for basic type 'GVariant' types, i.e. those that -- are not containers. class Ord a => IsGVariantBasicType a -- | Haskell has no notion of one element tuples, but GVariants do, so -- the following allows for marshalling one element tuples properly -- using 'fromGVariant' and 'toGVariant'. For instance, to construct a -- single element tuple containing a string, you could do -- -- > toGVariant (GVariantSinglet "Test") newtype GVariantSinglet a = GVariantSinglet a deriving (Eq, Show) data GVariantType foreign import ccall "g_variant_type_new" g_variant_type_new :: CString -> IO (Ptr GVariantType) foreign import ccall "g_variant_type_free" g_variant_type_free :: Ptr GVariantType -> IO () foreign import ccall "g_variant_is_of_type" g_variant_is_of_type :: Ptr GVariant -> Ptr GVariantType -> IO #{type gboolean} withGVariantType :: Text -> (Ptr GVariantType -> IO a) -> IO a withGVariantType text action = withTextCString text $ \textPtr -> bracket (g_variant_type_new textPtr) g_variant_type_free action gvariantIsOfType :: Text -> GVariant -> IO Bool gvariantIsOfType typeString variant = withGVariantType typeString $ \typePtr -> (toEnum . fromIntegral) <$> withManagedPtr variant (\vptr -> g_variant_is_of_type vptr typePtr) withExplicitType :: Text -> (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a) withExplicitType format action variant = do check <- gvariantIsOfType format variant if check then Just <$> withManagedPtr variant action else return Nothing withTypeCheck :: forall a. (IsGVariant a) => (Ptr GVariant -> IO a) -> GVariant -> IO (Maybe a) withTypeCheck = withExplicitType $ toGVariantFormatString (undefined :: a) foreign import ccall "g_variant_get_type_string" g_variant_get_type_string :: Ptr GVariant -> IO CString -- | 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 = withManagedPtr variant (g_variant_get_type_string >=> cstringToText) foreign import ccall "g_variant_is_floating" g_variant_is_floating :: Ptr GVariant -> IO CInt foreign import ccall "g_variant_ref_sink" g_variant_ref_sink :: Ptr GVariant -> IO (Ptr GVariant) foreign import ccall "g_variant_ref" g_variant_ref :: Ptr GVariant -> IO (Ptr GVariant) foreign import ccall "g_variant_unref" g_variant_unref :: Ptr GVariant -> IO () foreign import ccall "&g_variant_unref" ptr_to_g_variant_unref :: FunPtr (Ptr GVariant -> IO ()) -- | Take ownership of a passed in 'Ptr' (typically created just for -- us, so if it is floating we sink it). wrapGVariantPtr :: Ptr GVariant -> IO GVariant wrapGVariantPtr ptr = do floating <- g_variant_is_floating ptr when (floating /= 0) $ void $ g_variant_ref_sink ptr fPtr <- newManagedPtr' ptr_to_g_variant_unref ptr return $! GVariant fPtr -- | Construct a Haskell wrapper for the given 'GVariant', without -- assuming ownership. newGVariantFromPtr :: Ptr GVariant -> IO GVariant newGVariantFromPtr ptr = do fPtr <- g_variant_ref ptr >>= newManagedPtr' ptr_to_g_variant_unref return $! GVariant fPtr -- | Remove a reference to the given 'GVariant'. unrefGVariant :: GVariant -> IO () unrefGVariant gv = withManagedPtr gv g_variant_unref -- | Disown a `GVariant`, i.e. do not unref the underlying object when -- the Haskell object is garbage collected. disownGVariant :: GVariant -> IO (Ptr GVariant) disownGVariant = disownManagedPtr instance IsGVariant Bool where toGVariant = gvariantFromBool fromGVariant = gvariantToBool toGVariantFormatString _ = "b" instance IsGVariantBasicType Bool foreign import ccall "g_variant_new_boolean" new_bool :: #{type gboolean} -> IO (Ptr GVariant) gvariantFromBool :: Bool -> IO GVariant gvariantFromBool = (new_bool . fromIntegral . fromEnum) >=> wrapGVariantPtr foreign import ccall "g_variant_get_boolean" get_bool :: Ptr GVariant -> IO #{type gboolean} gvariantToBool :: GVariant -> IO (Maybe Bool) gvariantToBool = withTypeCheck $ get_bool >=> (return . toEnum . fromIntegral) instance IsGVariant Word8 where toGVariant = gvariantFromWord8 fromGVariant = gvariantToWord8 toGVariantFormatString _ = "y" instance IsGVariantBasicType Word8 foreign import ccall "g_variant_new_byte" new_byte :: #{type guchar} -> IO (Ptr GVariant) gvariantFromWord8 :: Word8 -> IO GVariant gvariantFromWord8 = (new_byte . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_byte" get_byte :: Ptr GVariant -> IO #{type guchar} gvariantToWord8 :: GVariant -> IO (Maybe Word8) gvariantToWord8 = withTypeCheck $ get_byte >=> (return . fromIntegral) instance IsGVariant Int16 where toGVariant = gvariantFromInt16 fromGVariant = gvariantToInt16 toGVariantFormatString _ = "n" instance IsGVariantBasicType Int16 foreign import ccall "g_variant_new_int16" new_int16 :: #{type gint16} -> IO (Ptr GVariant) gvariantFromInt16 :: Int16 -> IO GVariant gvariantFromInt16 = (new_int16 . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_int16" get_int16 :: Ptr GVariant -> IO #{type gint16} gvariantToInt16 :: GVariant -> IO (Maybe Int16) gvariantToInt16 = withTypeCheck $ get_int16 >=> (return . fromIntegral) instance IsGVariant Word16 where toGVariant = gvariantFromWord16 fromGVariant = gvariantToWord16 toGVariantFormatString _ = "q" instance IsGVariantBasicType Word16 foreign import ccall "g_variant_new_uint16" new_uint16 :: #{type guint16} -> IO (Ptr GVariant) gvariantFromWord16 :: Word16 -> IO GVariant gvariantFromWord16 = new_uint16 . fromIntegral >=> wrapGVariantPtr foreign import ccall "g_variant_get_uint16" get_uint16 :: Ptr GVariant -> IO #{type guint16} gvariantToWord16 :: GVariant -> IO (Maybe Word16) gvariantToWord16 = withTypeCheck $ get_uint16 >=> (return . fromIntegral) instance IsGVariant Int32 where toGVariant = gvariantFromInt32 fromGVariant = gvariantToInt32 toGVariantFormatString _ = "i" instance IsGVariantBasicType Int32 foreign import ccall "g_variant_new_int32" new_int32 :: #{type gint16} -> IO (Ptr GVariant) gvariantFromInt32 :: Int32 -> IO GVariant gvariantFromInt32 = (new_int32 . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_int32" get_int32 :: Ptr GVariant -> IO #{type gint32} gvariantToInt32 :: GVariant -> IO (Maybe Int32) gvariantToInt32 = withTypeCheck $ get_int32 >=> (return . fromIntegral) instance IsGVariant Word32 where toGVariant = gvariantFromWord32 fromGVariant = gvariantToWord32 toGVariantFormatString _ = "u" instance IsGVariantBasicType Word32 foreign import ccall "g_variant_new_uint32" new_uint32 :: #{type guint32} -> IO (Ptr GVariant) gvariantFromWord32 :: Word32 -> IO GVariant gvariantFromWord32 = (new_uint32 . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_uint32" get_uint32 :: Ptr GVariant -> IO #{type guint32} gvariantToWord32 :: GVariant -> IO (Maybe Word32) gvariantToWord32 = withTypeCheck $ get_uint32 >=> (return . fromIntegral) instance IsGVariant Int64 where toGVariant = gvariantFromInt64 fromGVariant = gvariantToInt64 toGVariantFormatString _ = "x" instance IsGVariantBasicType Int64 foreign import ccall "g_variant_new_int64" new_int64 :: #{type gint64} -> IO (Ptr GVariant) gvariantFromInt64 :: Int64 -> IO GVariant gvariantFromInt64 = (new_int64 . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_int64" get_int64 :: Ptr GVariant -> IO #{type gint64} gvariantToInt64 :: GVariant -> IO (Maybe Int64) gvariantToInt64 = withTypeCheck $ get_int64 >=> (return . fromIntegral) instance IsGVariant Word64 where toGVariant = gvariantFromWord64 fromGVariant = gvariantToWord64 toGVariantFormatString _ = "t" instance IsGVariantBasicType Word64 foreign import ccall "g_variant_new_uint64" new_uint64 :: #{type guint64} -> IO (Ptr GVariant) gvariantFromWord64 :: Word64 -> IO GVariant gvariantFromWord64 = (new_uint64 . fromIntegral) >=> wrapGVariantPtr foreign import ccall "g_variant_get_uint64" get_uint64 :: Ptr GVariant -> IO #{type guint64} gvariantToWord64 :: GVariant -> IO (Maybe Word64) gvariantToWord64 = withTypeCheck $ get_uint64 >=> (return . fromIntegral) newtype GVariantHandle = GVariantHandle Int32 deriving (Eq, Ord, Show) instance IsGVariant GVariantHandle where toGVariant (GVariantHandle h) = gvariantFromHandle h fromGVariant = gvariantToHandle >=> (return . (GVariantHandle <$>)) toGVariantFormatString _ = "h" instance IsGVariantBasicType GVariantHandle foreign import ccall "g_variant_new_handle" new_handle :: #{type gint32} -> IO (Ptr GVariant) -- | Convert a DBus handle (an 'Int32') into a 'GVariant'. gvariantFromHandle :: Int32 -> IO GVariant gvariantFromHandle h = (new_handle . fromIntegral) h >>= wrapGVariantPtr foreign import ccall "g_variant_get_handle" get_handle :: Ptr GVariant -> IO #{type gint32} -- | Extract the DBus handle (an 'Int32') inside a 'GVariant'. gvariantToHandle :: GVariant -> IO (Maybe Int32) gvariantToHandle = withExplicitType (toGVariantFormatString (undefined :: GVariantHandle)) $ get_handle >=> (return . fromIntegral) instance IsGVariant Double where toGVariant = gvariantFromDouble fromGVariant = gvariantToDouble toGVariantFormatString _ = "d" instance IsGVariantBasicType Double foreign import ccall "g_variant_new_double" new_double :: #{type gdouble} -> IO (Ptr GVariant) gvariantFromDouble :: Double -> IO GVariant gvariantFromDouble = (new_double . realToFrac) >=> wrapGVariantPtr foreign import ccall "g_variant_get_double" get_double :: Ptr GVariant -> IO #{type gdouble} gvariantToDouble :: GVariant -> IO (Maybe Double) gvariantToDouble = withTypeCheck $ get_double >=> (return . realToFrac) instance IsGVariant Text where toGVariant = gvariantFromText fromGVariant = gvariantToText toGVariantFormatString _ = "s" instance IsGVariantBasicType Text foreign import ccall "g_variant_get_string" _get_string :: Ptr GVariant -> Ptr #{type gsize} -> IO CString get_string :: Ptr GVariant -> IO CString get_string v = _get_string v nullPtr -- | Decode an UTF-8 encoded string 'GVariant' into 'Text'. gvariantToText :: GVariant -> IO (Maybe Text) gvariantToText = withTypeCheck $ get_string >=> cstringToText foreign import ccall "g_variant_new_take_string" take_string :: CString -> IO (Ptr GVariant) -- | Encode a 'Text' into an UTF-8 encoded string 'GVariant'. gvariantFromText :: Text -> IO GVariant gvariantFromText = textToCString >=> take_string >=> wrapGVariantPtr foreign import ccall "g_variant_is_object_path" g_variant_is_object_path :: CString -> IO #{type gboolean} -- | An object representing a DBus object path, which is a particular -- type of 'GVariant' too. (Just a string with some specific -- requirements.) In order to construct/deconstruct a -- 'GVariantObjectPath' one can use 'newGVariantObjectPath' -- and 'gvariantObjectPathToText'. newtype GVariantObjectPath = GVariantObjectPath Text deriving (Ord, Eq, Show) -- | Try to construct a DBus object path. If the passed string is not -- a valid object path 'Nothing' will be returned. newGVariantObjectPath :: Text -> Maybe GVariantObjectPath newGVariantObjectPath p = unsafePerformIO $ withTextCString p $ \cstr -> do isObjectPath <- toEnum . fromIntegral <$> g_variant_is_object_path cstr if isObjectPath then return $ Just (GVariantObjectPath p) else return Nothing -- | Return the 'Text' representation of a 'GVariantObjectPath'. gvariantObjectPathToText :: GVariantObjectPath -> Text gvariantObjectPathToText (GVariantObjectPath p) = p instance IsGVariant GVariantObjectPath where toGVariant = gvariantFromObjectPath fromGVariant = gvariantToObjectPath >=> return . (GVariantObjectPath <$>) toGVariantFormatString _ = "o" instance IsGVariantBasicType GVariantObjectPath foreign import ccall "g_variant_new_object_path" new_object_path :: CString -> IO (Ptr GVariant) -- | Construct a 'GVariant' containing an object path. In order to -- build a 'GVariantObjectPath' value see 'newGVariantObjectPath'. gvariantFromObjectPath :: GVariantObjectPath -> IO GVariant gvariantFromObjectPath (GVariantObjectPath p) = withTextCString p $ new_object_path >=> wrapGVariantPtr -- | Extract a 'GVariantObjectPath' from a 'GVariant', represented as -- its underlying 'Text' representation. gvariantToObjectPath :: GVariant -> IO (Maybe Text) gvariantToObjectPath = withExplicitType (toGVariantFormatString (undefined :: GVariantObjectPath)) (get_string >=> cstringToText) foreign import ccall "g_variant_is_signature" g_variant_is_signature :: CString -> IO #{type gboolean} -- | An object representing a DBus signature, which is a particular -- type of 'GVariant' too. (Just a string with some specific -- requirements.) In order to construct/deconstruct a -- 'GVariantSignature' one can use 'newGVariantSignature' and -- 'gvariantSignatureToText'. newtype GVariantSignature = GVariantSignature Text deriving (Ord, Eq, Show) -- | Try to construct a DBus object path. If the passed string is not -- a valid DBus signature 'Nothing' will be returned. newGVariantSignature :: Text -> Maybe GVariantSignature newGVariantSignature p = unsafePerformIO $ withTextCString p $ \cstr -> do isSignature <- toEnum . fromIntegral <$> g_variant_is_signature cstr if isSignature then return $ Just (GVariantSignature p) else return Nothing -- | Return the 'Text' representation of a 'GVariantSignature'. gvariantSignatureToText :: GVariantSignature -> Text gvariantSignatureToText (GVariantSignature p) = p instance IsGVariant GVariantSignature where toGVariant = gvariantFromSignature fromGVariant = gvariantToSignature >=> return . (GVariantSignature <$>) toGVariantFormatString _ = "g" instance IsGVariantBasicType GVariantSignature foreign import ccall "g_variant_new_signature" new_signature :: CString -> IO (Ptr GVariant) -- | Construct a 'GVariant' containing an DBus signature. In order to -- build a 'GVariantSignature' value see 'newGVariantSignature'. gvariantFromSignature :: GVariantSignature -> IO GVariant gvariantFromSignature (GVariantSignature p) = withTextCString p $ new_signature >=> wrapGVariantPtr -- | Extract a 'GVariantSignature' from a 'GVariant', represented as -- 'Text'. gvariantToSignature :: GVariant -> IO (Maybe Text) gvariantToSignature = withExplicitType (toGVariantFormatString (undefined :: GVariantSignature)) $ get_string >=> cstringToText instance IsGVariant GVariant where toGVariant = gvariantFromGVariant fromGVariant = gvariantToGVariant toGVariantFormatString _ = "v" foreign import ccall "g_variant_new_variant" new_variant :: Ptr GVariant -> IO (Ptr GVariant) -- | Box a 'GVariant' inside another 'GVariant'. gvariantFromGVariant :: GVariant -> IO GVariant gvariantFromGVariant v = withManagedPtr v $ new_variant >=> wrapGVariantPtr foreign import ccall "g_variant_get_variant" get_variant :: Ptr GVariant -> IO (Ptr GVariant) -- | Unbox a 'GVariant' contained inside another 'GVariant'. gvariantToGVariant :: GVariant -> IO (Maybe GVariant) gvariantToGVariant = withTypeCheck $ get_variant >=> wrapGVariantPtr instance IsGVariant ByteString where toGVariant = gvariantFromBytestring fromGVariant = gvariantToBytestring toGVariantFormatString _ = "ay" foreign import ccall "g_variant_get_bytestring" get_bytestring :: Ptr GVariant -> IO CString -- | Extract a zero terminated list of bytes into a 'ByteString'. gvariantToBytestring :: GVariant -> IO (Maybe ByteString) gvariantToBytestring = withTypeCheck (get_bytestring >=> cstringToByteString) foreign import ccall "g_variant_new_bytestring" new_bytestring :: CString -> IO (Ptr GVariant) -- | Encode a 'ByteString' into a list of bytes 'GVariant'. gvariantFromBytestring :: ByteString -> IO GVariant gvariantFromBytestring bs = wrapGVariantPtr =<< B.useAsCString bs new_bytestring foreign import ccall "g_variant_n_children" g_variant_n_children :: Ptr GVariant -> IO #{type gsize} foreign import ccall "g_variant_get_child_value" g_variant_get_child_value :: Ptr GVariant -> #{type gsize} -> IO (Ptr GVariant) -- No type checking is done here, it is assumed that the caller knows -- that the passed variant is indeed of a container type. gvariant_get_children :: (Ptr GVariant) -> IO [GVariant] gvariant_get_children vptr = do n_children <- g_variant_n_children vptr -- n_children is an unsigned type (Word64 in 64 bit -- architectures), so if it is 0 and we substract one we would -- wrap around to 2^64-1. if n_children /= 0 then mapM ((g_variant_get_child_value vptr) >=> wrapGVariantPtr) [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 toGVariantFormatString _ = "m" <> toGVariantFormatString (undefined :: a) foreign import ccall "g_variant_new_maybe" g_variant_new_maybe :: Ptr GVariantType -> Ptr GVariant -> IO (Ptr GVariant) -- | Convert a 'Maybe' value into a corresponding 'GVariant' of maybe -- type. gvariantFromMaybe :: forall a. IsGVariant a => Maybe a -> IO GVariant gvariantFromMaybe m = do let fmt = toGVariantFormatString (undefined :: a) withGVariantType fmt $ \tPtr -> case m of Just child -> do childVariant <- toGVariant child withManagedPtr childVariant (g_variant_new_maybe tPtr >=> wrapGVariantPtr) Nothing -> g_variant_new_maybe tPtr nullPtr >>= wrapGVariantPtr -- | Try to decode a maybe 'GVariant' into the corresponding 'Maybe' -- type. If the conversion is successful this returns @Just x@, where -- @x@ itself is of 'Maybe' type. So, in particular, @Just Nothing@ -- indicates a successful call, and means that the GVariant of maybe -- type was empty. gvariantToMaybe :: forall a. IsGVariant a => GVariant -> IO (Maybe (Maybe a)) gvariantToMaybe v = do let fmt = toGVariantFormatString (undefined :: Maybe a) withExplicitType fmt gvariant_get_children v >>= \case Just [] -> return (Just Nothing) Just [child] -> fromGVariant child >>= \case Nothing -> return Nothing Just result -> return (Just (Just result)) Just _ -> error "gvariantToMaybe :: the impossible happened, this is a bug." Nothing -> return Nothing -- | A DictEntry 'GVariant' is isomorphic to a two-tuple. Wrapping the -- values into a 'GVariantDictentry' allows the 'IsGVariant' instance -- to do the right thing. data GVariantDictEntry key value = GVariantDictEntry key value deriving (Eq, Show) instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) => IsGVariant (GVariantDictEntry a b) where toGVariant (GVariantDictEntry key value) = gvariantFromDictEntry key value fromGVariant gv = ((uncurry GVariantDictEntry) <$>) <$> gvariantToDictEntry gv toGVariantFormatString _ = "{" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> "}" foreign import ccall "g_variant_new_dict_entry" g_variant_new_dict_entry :: Ptr GVariant -> Ptr GVariant -> IO (Ptr GVariant) -- | Construct a 'GVariant' of type DictEntry from the given 'key' and -- 'value'. The key must be a basic 'GVariant' type, i.e. not a -- container. This is determined by whether it belongs to the -- 'IsGVariantBasicType' typeclass. On the other hand 'value' is an -- arbitrary 'GVariant', and in particular it can be a container type. gvariantFromDictEntry :: (IsGVariant key, IsGVariantBasicType key, IsGVariant value) => key -> value -> IO GVariant gvariantFromDictEntry key value = do keyVar <- toGVariant key valueVar <- toGVariant value withManagedPtr keyVar $ \keyPtr -> withManagedPtr valueVar $ \valuePtr -> g_variant_new_dict_entry keyPtr valuePtr >>= wrapGVariantPtr -- | Unpack a DictEntry variant into 'key' and 'value', which are -- returned as a two element tuple in case of success. gvariantToDictEntry :: forall key value. (IsGVariant key, IsGVariantBasicType key, IsGVariant value) => GVariant -> IO (Maybe (key, value)) gvariantToDictEntry = withExplicitType fmt $ \varPtr -> do [key, value] <- gvariant_get_children varPtr (,) <$> unsafeFromGVariant key <*> unsafeFromGVariant value where fmt = toGVariantFormatString (undefined :: GVariantDictEntry key value) instance (IsGVariant a, IsGVariantBasicType a, IsGVariant b) => IsGVariant (M.Map a b) where toGVariant = gvariantFromMap fromGVariant = gvariantToMap toGVariantFormatString _ = "a{" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> "}" -- | Pack a 'Map' into a 'GVariant' for dictionary type, which is just -- an array of 'GVariantDictEntry'. gvariantFromMap :: (IsGVariant key, IsGVariantBasicType key, IsGVariant value) => M.Map key value -> IO GVariant gvariantFromMap m = gvariantFromList $ map (uncurry GVariantDictEntry) (M.toList m) -- | Unpack a 'GVariant' into a 'M.Map'. Notice that this assumes that -- all the elements in the 'GVariant' array of 'GVariantDictEntry' are -- of the same type, which is not necessary for a generic 'GVariant', -- so this is somewhat restrictive. For the general case it is -- necessary to use 'gvariantToList' plus 'gvariantToDictEntry' -- directly. gvariantToMap :: forall key value. (IsGVariant key, IsGVariantBasicType key, IsGVariant value) => GVariant -> IO (Maybe (M.Map key value)) gvariantToMap = gvariantToList >=> (return . (fromDictEntryList <$>)) where fromDictEntryList :: [GVariantDictEntry key value] -> M.Map key value fromDictEntryList = M.fromList . (map tuplefy) tuplefy :: GVariantDictEntry key value -> (key, value) tuplefy (GVariantDictEntry key value) = (key, value) instance IsGVariant a => IsGVariant [a] where toGVariant = gvariantFromList fromGVariant = gvariantToList toGVariantFormatString _ = "a" <> toGVariantFormatString (undefined :: a) foreign import ccall "g_variant_new_array" g_variant_new_array :: Ptr GVariantType -> Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant) -- | Given a list of elements construct a 'GVariant' array containing -- them. gvariantFromList :: forall a. IsGVariant a => [a] -> IO GVariant gvariantFromList children = do let fmt = toGVariantFormatString (undefined :: a) mapM toGVariant children >>= \childVariants -> withManagedPtrList childVariants $ \childrenPtrs -> do withGVariantType fmt $ \childType -> do packed <- packPtrArray childrenPtrs result <- g_variant_new_array childType packed (fromIntegral $ length children) freeMem packed wrapGVariantPtr result -- | Unpack a 'GVariant' array into its elements. gvariantToList :: forall a. IsGVariant a => GVariant -> IO (Maybe [a]) gvariantToList = withExplicitType (toGVariantFormatString (undefined :: [a])) (gvariant_get_children >=> mapM unsafeFromGVariant) foreign import ccall "g_variant_new_tuple" g_variant_new_tuple :: Ptr (Ptr GVariant) -> #{type gsize} -> IO (Ptr GVariant) -- | Given a list of 'GVariant', construct a 'GVariant' tuple -- containing the elements in the list. gvariantFromTuple :: [GVariant] -> IO GVariant gvariantFromTuple children = withManagedPtrList children $ \childrenPtrs -> do packed <- packPtrArray childrenPtrs result <- g_variant_new_tuple packed (fromIntegral $ length children) freeMem packed wrapGVariantPtr result -- | Extract the children of a 'GVariant' tuple into a list. gvariantToTuple :: GVariant -> IO (Maybe [GVariant]) gvariantToTuple = withExplicitType "r" gvariant_get_children -- | The empty tuple GVariant, mostly useful for type checking. instance IsGVariant () where toGVariant _ = gvariantFromTuple [] fromGVariant = withTypeCheck (const $ return ()) toGVariantFormatString _ = "()" -- | One element tuples. instance IsGVariant a => IsGVariant (GVariantSinglet a) where toGVariant (GVariantSinglet s) = gvariantFromSinglet s fromGVariant = gvariantToSinglet >=> return . (GVariantSinglet <$>) toGVariantFormatString _ = "(" <> toGVariantFormatString (undefined :: a) <> ")" gvariantFromSinglet :: IsGVariant a => a -> IO GVariant gvariantFromSinglet s = do sv <- toGVariant s gvariantFromTuple [sv] gvariantToSinglet :: forall a. IsGVariant a => GVariant -> IO (Maybe a) gvariantToSinglet = withExplicitType fmt (gvariant_get_child >=> unsafeFromGVariant) where fmt = toGVariantFormatString (undefined :: GVariantSinglet a) instance (IsGVariant a, IsGVariant b) => IsGVariant (a,b) where toGVariant = gvariantFromTwoTuple fromGVariant = gvariantToTwoTuple toGVariantFormatString _ = "(" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> ")" gvariantFromTwoTuple :: (IsGVariant a, IsGVariant b) => (a,b) -> IO GVariant gvariantFromTwoTuple (a, b) = do va <- toGVariant a vb <- toGVariant b gvariantFromTuple [va, vb] gvariantToTwoTuple :: forall a b. (IsGVariant a, IsGVariant b) => GVariant -> IO (Maybe (a,b)) gvariantToTwoTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant 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 fromGVariant = gvariantToThreeTuple toGVariantFormatString _ = "(" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> toGVariantFormatString (undefined :: c) <> ")" gvariantFromThreeTuple :: (IsGVariant a, IsGVariant b, IsGVariant c) => (a,b,c) -> IO GVariant gvariantFromThreeTuple (a, b, c) = do va <- toGVariant a vb <- toGVariant b vc <- toGVariant c gvariantFromTuple [va, vb, vc] gvariantToThreeTuple :: forall a b c. (IsGVariant a, IsGVariant b, IsGVariant c) => GVariant -> IO (Maybe (a,b,c)) gvariantToThreeTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant 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 toGVariant = gvariantFromFourTuple fromGVariant = gvariantToFourTuple toGVariantFormatString _ = "(" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> toGVariantFormatString (undefined :: c) <> toGVariantFormatString (undefined :: d) <> ")" gvariantFromFourTuple :: (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => (a,b,c,d) -> IO GVariant gvariantFromFourTuple (a, b, c, d) = do va <- toGVariant a vb <- toGVariant b vc <- toGVariant c vd <- toGVariant d gvariantFromTuple [va, vb, vc, vd] gvariantToFourTuple :: forall a b c d. (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => GVariant -> IO (Maybe (a,b,c,d)) gvariantToFourTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant 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 toGVariant = gvariantFromFiveTuple fromGVariant = gvariantToFiveTuple toGVariantFormatString _ = "(" <> toGVariantFormatString (undefined :: a) <> toGVariantFormatString (undefined :: b) <> toGVariantFormatString (undefined :: c) <> toGVariantFormatString (undefined :: d) <> toGVariantFormatString (undefined :: e) <> ")" gvariantFromFiveTuple :: (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) => (a,b,c,d,e) -> IO GVariant gvariantFromFiveTuple (a, b, c, d, e) = do va <- toGVariant a vb <- toGVariant b vc <- toGVariant c vd <- toGVariant d ve <- toGVariant e gvariantFromTuple [va, vb, vc, vd, ve] gvariantToFiveTuple :: forall a b c d e. (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) => GVariant -> IO (Maybe (a,b,c,d,e)) gvariantToFiveTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant 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 haskell-gi-base-0.26.8/Data/GI/Base/Internal/0000755000000000000000000000000007346545000016526 5ustar0000000000000000haskell-gi-base-0.26.8/Data/GI/Base/Internal/CTypes.hsc0000644000000000000000000000217307346545000020437 0ustar0000000000000000-- | 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} haskell-gi-base-0.26.8/Data/GI/Base/ManagedPtr.hs0000644000000000000000000004235707346545000017343 0ustar0000000000000000{-# 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 -- "disowning", which means not running the finalizers passed upon -- construction of the object upon garbage collection. The routines in -- this module deal with the memory management of such managed -- pointers. module Data.GI.Base.ManagedPtr ( -- * Managed pointers newManagedPtr , newManagedPtr' , newManagedPtr_ , withManagedPtr , maybeWithManagedPtr , withManagedPtrList , withTransient , unsafeManagedPtrGetPtr , unsafeManagedPtrCastPtr , touchManagedPtr , disownManagedPtr -- * Safe casting , castTo , unsafeCastTo , checkInstanceType -- * Wrappers , newObject , withNewObject , wrapObject , releaseObject , unrefObject , disownObject , newBoxed , wrapBoxed , copyBoxed , copyBoxedPtr , freeBoxed , disownBoxed , wrapPtr , newPtr , copyBytes ) where #if !MIN_VERSION_base(4,8,0) 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) import Data.Maybe (isNothing, isJust) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Foreign.C (CInt(..)) import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr) import Foreign.ForeignPtr (FinalizerPtr, touchForeignPtr, newForeignPtr_) import qualified Foreign.Concurrent as FC import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Data.GI.Base.BasicTypes import Data.GI.Base.CallStack (CallStack, HasCallStack, prettyCallStack, callStack) import Data.GI.Base.Utils import qualified Data.Text as T import System.IO (hPutStrLn, stderr) import System.Environment (lookupEnv) -- | Thin wrapper over `Foreign.Concurrent.newForeignPtr`. newManagedPtr :: HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a) newManagedPtr ptr finalizer = do isDisownedRef <- newIORef Nothing dbgMode <- isJust <$> lookupEnv "HASKELL_GI_DEBUG_MEM" let dbgCallStack = if dbgMode then Just callStack else Nothing fPtr <- FC.newForeignPtr ptr (ownedFinalizer finalizer ptr dbgCallStack isDisownedRef) return $ ManagedPtr { managedForeignPtr = fPtr , managedPtrAllocCallStack = dbgCallStack , managedPtrIsDisowned = isDisownedRef } -- | Run the finalizer for an owned pointer, assuming it has now been -- disowned. ownedFinalizer :: IO () -> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack) -> IO () ownedFinalizer finalizer ptr allocCallStack callStackRef = do cs <- readIORef callStackRef -- cs will be @Just cs@ whenever the pointer has been disowned. 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 () printAllocDebug ptr allocCS = (dbgLog . T.pack) ("Releasing <" <> show ptr <> ">. " <> "Callstack for allocation was:\n" <> prettyCallStack allocCS <> "\n\n") foreign import ccall "dynamic" mkFinalizer :: FinalizerPtr a -> Ptr a -> IO () -- | Version of `newManagedPtr` taking a `FinalizerPtr` and a -- corresponding `Ptr`, as in `Foreign.ForeignPtr.newForeignPtr`. newManagedPtr' :: HasCallStack => FinalizerPtr a -> Ptr a -> IO (ManagedPtr a) newManagedPtr' finalizer ptr = newManagedPtr ptr (mkFinalizer finalizer ptr) -- | Thin wrapper over `Foreign.Concurrent.newForeignPtr_`. newManagedPtr_ :: Ptr a -> IO (ManagedPtr a) newManagedPtr_ ptr = do isDisownedRef <- newIORef Nothing fPtr <- newForeignPtr_ ptr return $ ManagedPtr { managedForeignPtr = fPtr , managedPtrAllocCallStack = Nothing , managedPtrIsDisowned = isDisownedRef } -- | Do not run the finalizers upon garbage collection of the -- `ManagedPtr`. disownManagedPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b) disownManagedPtr managed = do ptr <- unsafeManagedPtrGetPtr managed writeIORef (managedPtrIsDisowned c) (Just callStack) 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 withManagedPtr managed action = do ptr <- unsafeManagedPtrGetPtr managed result <- action ptr touchManagedPtr managed return result -- | Like `withManagedPtr`, but accepts a `Maybe` type. If the passed -- value is `Nothing` the inner action will be executed with a -- `nullPtr` argument. maybeWithManagedPtr :: (HasCallStack, ManagedPtrNewtype a) => Maybe a -> (Ptr a -> IO c) -> IO c maybeWithManagedPtr Nothing action = action nullPtr maybeWithManagedPtr (Just managed) action = withManagedPtr managed action -- | Perform an IO action taking a list of 'Ptr' on a list of managed -- pointers. withManagedPtrList :: (HasCallStack, ManagedPtrNewtype a) => [a] -> ([Ptr a] -> IO c) -> IO c withManagedPtrList managedList action = do ptrs <- mapM unsafeManagedPtrGetPtr managedList result <- action ptrs mapM_ touchManagedPtr managedList return result -- | 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 finishes. withTransient :: (HasCallStack, ManagedPtrNewtype a) => Ptr a -> (a -> IO b) -> IO b withTransient ptr action = do managed <- coerce <$> newManagedPtr_ ptr r <- action managed _ <- disownManagedPtr managed return r -- | Return the 'Ptr' in a given managed pointer. As the name says, -- this is potentially unsafe: the given 'Ptr' may only be used -- /before/ a call to 'touchManagedPtr'. This function is of most -- interest to the autogenerated bindings, for hand-written code -- 'withManagedPtr' is almost always a better choice. unsafeManagedPtrGetPtr :: (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a) unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr -- | Same as 'unsafeManagedPtrGetPtr', but is polymorphic on the -- return type. unsafeManagedPtrCastPtr :: forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b) unsafeManagedPtrCastPtr m = do let c = toManagedPtr m ptr = (castPtr . unsafeForeignPtrToPtr . managedForeignPtr) c disowned <- readIORef (managedPtrIsDisowned c) maybe (return ptr) (notOwnedWarning ptr) disowned -- | Print a warning when we try to access a disowned foreign ptr. notOwnedWarning :: HasCallStack => Ptr a -> CallStack -> IO (Ptr a) notOwnedWarning ptr cs = do hPutStrLn stderr ("WARNING: Accessing a disowned pointer <" ++ show ptr ++ ">, this may lead to crashes.\n\n" ++ "• Callstack for the unsafe access to the pointer:\n" ++ prettyCallStack callStack ++ "\n\n" ++ "• The pointer was disowned at:\n" ++ prettyCallStack cs ++ "\n") return ptr -- | Ensure that the 'Ptr' in the given managed pointer is still alive -- (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 = toManagedPtr m in (touchForeignPtr . managedForeignPtr) c -- Safe casting machinery foreign import ccall unsafe "check_object_type" c_check_object_type :: Ptr o -> CGType -> IO CInt -- | 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'. (HasCallStack, ManagedPtrNewtype o, TypedObject o, ManagedPtrNewtype o', TypedObject o', GObject o') => (ManagedPtr o' -> o') -> o -> IO (Maybe o') castTo constructor obj = do gtype <- glibType @o' isInstance <- checkInstanceType obj gtype if isInstance then return . Just . constructor . coerce $ toManagedPtr obj else return Nothing -- | 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 = do gtype <- glibType @o' isInstance <- checkInstanceType obj gtype if not isInstance then do srcType <- glibType @o >>= gtypeName destType <- glibType @o' >>= gtypeName error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to " ++ destType ++ " requested." else return (constructor $ coerce $ toManagedPtr obj) -- Reference counting for constructors foreign import ccall "&dbg_g_object_unref" ptr_to_g_object_unref :: FunPtr (Ptr a -> IO ()) foreign import ccall "g_object_ref_sink" g_object_ref_sink :: Ptr a -> IO (Ptr a) -- | Print a warning when receiving a null pointer in a function that -- did not expect one, for easier debugging. nullPtrWarning :: String -> CallStack -> IO () nullPtrWarning fn cs = hPutStrLn stderr ("WARNING: Trying to wrap a null pointer in " ++ quotedFn ++ ", this may lead to crashes.\n\n" ++ "• Callstack for the unsafe call to " ++ quotedFn ++ ":\n" ++ prettyCallStack cs ++ "\n\n" ++ "This is probably a bug in the introspection data,\n" ++ "please report it at https://github.com/haskell-gi/haskell-gi/issues") where quotedFn = "‘" ++ fn ++ "’" -- | Construct a Haskell wrapper for a 'GObject', increasing its -- reference count, or taking ownership of the floating reference if -- there is one. newObject :: (HasCallStack, GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a newObject constructor ptr = do when (ptr == nullPtr) (nullPtrWarning "newObject" callStack) void $ g_object_ref_sink ptr fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr return $! constructor fPtr -- | Perform the given IO action with a wrapped copy of the given ptr -- to a GObject. Note that this increases the reference count of the -- wrapped GObject, similarly to 'newObject'. withNewObject :: (HasCallStack, GObject o) => Ptr o -> (o -> IO b) -> IO b withNewObject ptr action = do void $ g_object_ref_sink ptr managed <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr action (coerce managed) -- | Same as 'newObject', but we steal ownership of the object. wrapObject :: forall a b. (HasCallStack, GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a wrapObject constructor ptr = do when (ptr == nullPtr) (nullPtrWarning "wrapObject" callStack) fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr return $! constructor fPtr -- | Unref the given `GObject` and disown it. Use this if you want to -- manually release the memory associated to a given `GObject` -- (assuming that no other reference to the underlying C object exists) -- before the garbage collector does it. It is typically not safe to -- access the `GObject` after calling this function. releaseObject :: (HasCallStack, GObject a) => a -> IO () releaseObject obj = do ptr <- disownObject obj dbgDealloc obj dbg_g_object_unref ptr -- It is fine to use unsafe here, since all this does is schedule an -- idle callback. The scheduling itself will never block for a long -- time, or call back into Haskell. foreign import ccall unsafe "dbg_g_object_unref" dbg_g_object_unref :: Ptr a -> IO () -- | Decrease the reference count of the given 'GObject'. The memory -- associated with the object may be released if the reference count -- reaches 0. unrefObject :: (HasCallStack, GObject a) => a -> IO () unrefObject obj = withManagedPtr obj $ \ptr -> do dbgDealloc obj dbg_g_object_unref ptr -- | Print some debug info (if the right environment valiable is set) -- about the object being disowned. foreign import ccall "dbg_g_object_disown" dbg_g_object_disown :: Ptr a -> IO () -- | Disown a GObject, that is, do not unref the associated foreign -- GObject when the Haskell object gets garbage collected. Returns the -- pointer to the underlying GObject. disownObject :: (HasCallStack, GObject a) => a -> IO (Ptr b) disownObject obj = withManagedPtr obj $ \ptr -> do dbgDealloc obj dbg_g_object_disown ptr castPtr <$> disownManagedPtr obj -- It is fine to use unsafe here, since all this does is schedule an -- idle callback. The scheduling itself will never block for a long -- time, or call back into Haskell. foreign import ccall unsafe "boxed_free_helper" boxed_free_helper :: CGType -> Ptr a -> IO () foreign import ccall "g_boxed_copy" g_boxed_copy :: CGType -> Ptr a -> IO (Ptr a) -- | Construct a Haskell wrapper for the given boxed object. We make a -- copy of the object. newBoxed :: forall a. (HasCallStack, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a newBoxed constructor ptr = do 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, GBoxed a) => (ManagedPtr a -> a) -> Ptr a -> IO a wrapBoxed constructor ptr = do 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, GBoxed a) => a -> IO (Ptr a) copyBoxed b = do 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. GBoxed a => Ptr a -> IO (Ptr a) copyBoxedPtr ptr = do GType gtype <- glibType @a g_boxed_copy gtype ptr foreign import ccall "g_boxed_free" g_boxed_free :: CGType -> Ptr a -> IO () -- | Free the memory associated with a boxed object. Note that this -- disowns the associated `ManagedPtr` via `disownManagedPtr`. freeBoxed :: forall a. (HasCallStack, GBoxed a) => a -> IO () freeBoxed boxed = do 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 `GBoxed`. disownBoxed :: (HasCallStack, GBoxed a) => a -> IO (Ptr a) disownBoxed = disownManagedPtr -- | Wrap a pointer, taking ownership of it. 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, BoxedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a newPtr constructor ptr = do tmpWrap <- newManagedPtr_ ptr 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 :: (HasCallStack, CallocPtr a) => Int -> Ptr a -> IO (Ptr a) copyBytes size ptr = do ptr' <- boxedPtrCalloc memcpy ptr' ptr size return ptr' foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ()) -- | 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 = toManagedPtr m ptr = (unsafeForeignPtrToPtr . managedForeignPtr) mPtr threadPtr <- g_thread_self hPutStrLn stderr ("Releasing <" ++ show ptr ++ "> from thread [" ++ show threadPtr ++ "].\n" ++ (case managedPtrAllocCallStack mPtr of Just allocCS -> "• Callstack for allocation:\n" ++ prettyCallStack allocCS ++ "\n\n" Nothing -> "") ++ "• CallStack for deallocation:\n" ++ prettyCallStack callStack ++ "\n") haskell-gi-base-0.26.8/Data/GI/Base/Overloading.hs0000644000000000000000000002155607346545000017570 0ustar0000000000000000{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds, TypeFamilies, UndecidableInstances, EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, ConstraintKinds, AllowAmbiguousTypes, FlexibleContexts, ScopedTypeVariables, TypeApplications, OverloadedStrings #-} -- | Helpers for dealing with overladed properties, signals and -- methods. module Data.GI.Base.Overloading ( -- * Type level inheritance ParentTypes , HasParentTypes , IsDescendantOf , asA -- * Looking up attributes in parent types , AttributeList , HasAttributeList , ResolveAttribute , HasAttribute , HasAttr -- * Looking up signals in parent types , SignalList , ResolveSignal , HasSignal -- * Looking up methods in parent types , MethodResolutionFailed , UnsupportedMethodError , OverloadedMethodInfo(..) , OverloadedMethod(..) , MethodProxy(..) , ResolvedSymbolInfo(..) , resolveMethod ) where import Data.Coerce (coerce) import Data.Kind (Type) import GHC.Exts (Constraint) import GHC.TypeLits import Data.GI.Base.BasicTypes (ManagedPtrNewtype, ManagedPtr(..)) 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, 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 -- | All the types that are ascendants of this type, including -- interfaces that the type implements. type family ParentTypes a :: [Type] -- | A constraint on a type, to be fulfilled whenever it has a type -- instance for `ParentTypes`. This leads to nicer errors, thanks to -- the overlappable instance below. class HasParentTypes (o :: Type) -- | Default instance, which will give rise to an error for types -- without an associated `ParentTypes` instance. instance {-# OVERLAPPABLE #-} TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: 'Text "’ does not have any known parent types.") => HasParentTypes a -- | Check whether a type appears in a list. We specialize the -- names/types a bit so the error messages are more informative. type family CheckForAncestorType t (a :: Type) (as :: [Type]) :: Constraint where 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 `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) -- | 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 -- `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 -- | 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 -- | Return the type encoding the attribute information for a given -- type and attribute. type family ResolveAttribute (s :: Symbol) (o :: Type) :: Type where ResolveAttribute s o = FindElement s (AttributeList o) ('Text "Unknown attribute ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -- | Whether a given type is in the given list. If found, return -- @success@, otherwise return @failure@. 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 -- | A constraint imposing that the given object has the given attribute. type family HasAttribute (attr :: Symbol) (o :: Type) :: Constraint where HasAttribute attr o = IsElem attr (AttributeList o) (() :: Constraint) -- success ('Text "Attribute ‘" ':<>: 'Text attr ':<>: 'Text "’ not found for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -- | A constraint that enforces that the given type has a given attribute. 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 -- `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 :: Type) :: Type where ResolveSignal s o = FindElement s (SignalList o) ('Text "Unknown signal ‘" ':<>: 'Text s ':<>: 'Text "’ for object ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -- | A constraint enforcing that the signal exists for the given -- object, or one of its ancestors. type family HasSignal (s :: Symbol) (o :: Type) :: Constraint where HasSignal s o = IsElem s (SignalList o) (() :: Constraint) -- success ('Text "Signal ‘" ':<>: 'Text s ':<>: 'Text "’ not found for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -- | 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 "’.") -- | Returned when the method is not found, hopefully making -- the resulting error messages somewhat clearer. type family MethodResolutionFailed (method :: Symbol) (o :: Type) where MethodResolutionFailed m o = TypeError ('Text "Unknown method ‘" ':<>: 'Text m ':<>: 'Text "’ for type ‘" ':<>: 'ShowType o ':<>: 'Text "’.") -- | 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 haskell-gi-base-0.26.8/Data/GI/Base/Overloading.hs-boot0000644000000000000000000000011607346545000020516 0ustar0000000000000000module Data.GI.Base.Overloading (HasParentTypes) where class HasParentTypes ahaskell-gi-base-0.26.8/Data/GI/Base/Properties.hsc0000644000000000000000000006025607346545000017616 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} module Data.GI.Base.Properties ( setObjectPropertyIsGValueInstance , setObjectPropertyString , setObjectPropertyStringArray , setObjectPropertyPtr , setObjectPropertyInt , setObjectPropertyUInt , setObjectPropertyLong , setObjectPropertyULong , setObjectPropertyInt32 , setObjectPropertyUInt32 , setObjectPropertyInt64 , setObjectPropertyUInt64 , setObjectPropertyFloat , setObjectPropertyDouble , setObjectPropertyBool , setObjectPropertyGType , setObjectPropertyObject , setObjectPropertyBoxed , setObjectPropertyEnum , setObjectPropertyFlags , setObjectPropertyClosure , setObjectPropertyVariant , setObjectPropertyByteArray , setObjectPropertyPtrGList , setObjectPropertyHash , setObjectPropertyCallback , setObjectPropertyGError , setObjectPropertyGValue , setObjectPropertyParamSpec , getObjectPropertyIsGValueInstance , getObjectPropertyString , getObjectPropertyStringArray , getObjectPropertyPtr , getObjectPropertyInt , getObjectPropertyUInt , getObjectPropertyLong , getObjectPropertyULong , getObjectPropertyInt32 , getObjectPropertyUInt32 , getObjectPropertyInt64 , getObjectPropertyUInt64 , getObjectPropertyFloat , getObjectPropertyDouble , getObjectPropertyBool , getObjectPropertyGType , getObjectPropertyObject , getObjectPropertyBoxed , getObjectPropertyEnum , getObjectPropertyFlags , getObjectPropertyClosure , getObjectPropertyVariant , getObjectPropertyByteArray , getObjectPropertyPtrGList , getObjectPropertyHash , getObjectPropertyCallback , getObjectPropertyGError , getObjectPropertyGValue , getObjectPropertyParamSpec , constructObjectPropertyIsGValueInstance , constructObjectPropertyString , constructObjectPropertyStringArray , constructObjectPropertyPtr , constructObjectPropertyInt , constructObjectPropertyUInt , constructObjectPropertyLong , constructObjectPropertyULong , constructObjectPropertyInt32 , constructObjectPropertyUInt32 , constructObjectPropertyInt64 , constructObjectPropertyUInt64 , constructObjectPropertyFloat , constructObjectPropertyDouble , constructObjectPropertyBool , constructObjectPropertyGType , constructObjectPropertyObject , constructObjectPropertyBoxed , constructObjectPropertyEnum , constructObjectPropertyFlags , constructObjectPropertyClosure , constructObjectPropertyVariant , constructObjectPropertyByteArray , constructObjectPropertyPtrGList , constructObjectPropertyHash , constructObjectPropertyCallback , constructObjectPropertyGError , constructObjectPropertyGValue , constructObjectPropertyParamSpec ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Monad ((>=>)) import qualified Data.ByteString.Char8 as B import Data.Text (Text) 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) import Foreign (Ptr, FunPtr, Int32, Word32, Int64, Word64, nullPtr, castFunPtrToPtr, castPtrToFunPtr) import Foreign.C (CString, withCString) import Foreign.C.Types (CInt, CUInt, CLong, CULong) #include foreign import ccall "g_object_set_property" g_object_set_property :: Ptr a -> CString -> Ptr GValue -> IO () -- | 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 () -- | 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 return gvalue -- | 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 = setObjectPropertyIsGValueInstance constructObjectPropertyString :: String -> Maybe Text -> IO (GValueConstruct o) constructObjectPropertyString = constructObjectPropertyIsGValueInstance getObjectPropertyString :: GObject a => a -> String -> IO (Maybe Text) getObjectPropertyString = getObjectPropertyIsGValueInstance setObjectPropertyPtr :: GObject a => a -> String -> Ptr b -> IO () setObjectPropertyPtr = setObjectPropertyIsGValueInstance constructObjectPropertyPtr :: String -> Ptr b -> IO (GValueConstruct o) constructObjectPropertyPtr = constructObjectPropertyIsGValueInstance getObjectPropertyPtr :: GObject a => a -> String -> IO (Ptr b) getObjectPropertyPtr = getObjectPropertyIsGValueInstance setObjectPropertyInt :: GObject a => a -> String -> CInt -> IO () setObjectPropertyInt = setObjectPropertyIsGValueInstance constructObjectPropertyInt :: String -> CInt -> IO (GValueConstruct o) constructObjectPropertyInt = constructObjectPropertyIsGValueInstance getObjectPropertyInt :: GObject a => a -> String -> IO CInt getObjectPropertyInt = getObjectPropertyIsGValueInstance setObjectPropertyUInt :: GObject a => a -> String -> CUInt -> IO () setObjectPropertyUInt = setObjectPropertyIsGValueInstance constructObjectPropertyUInt :: String -> CUInt -> IO (GValueConstruct o) constructObjectPropertyUInt = constructObjectPropertyIsGValueInstance getObjectPropertyUInt :: GObject a => a -> String -> IO CUInt getObjectPropertyUInt = getObjectPropertyIsGValueInstance setObjectPropertyLong :: GObject a => a -> String -> CLong -> IO () setObjectPropertyLong = setObjectPropertyIsGValueInstance constructObjectPropertyLong :: String -> CLong -> IO (GValueConstruct o) constructObjectPropertyLong = constructObjectPropertyIsGValueInstance getObjectPropertyLong :: GObject a => a -> String -> IO CLong getObjectPropertyLong = getObjectPropertyIsGValueInstance setObjectPropertyULong :: GObject a => a -> String -> CULong -> IO () setObjectPropertyULong = setObjectPropertyIsGValueInstance constructObjectPropertyULong :: String -> CULong -> IO (GValueConstruct o) constructObjectPropertyULong = constructObjectPropertyIsGValueInstance getObjectPropertyULong :: GObject a => a -> String -> IO CULong getObjectPropertyULong = getObjectPropertyIsGValueInstance setObjectPropertyInt32 :: GObject a => a -> String -> Int32 -> IO () setObjectPropertyInt32 = setObjectPropertyIsGValueInstance constructObjectPropertyInt32 :: String -> Int32 -> IO (GValueConstruct o) constructObjectPropertyInt32 = constructObjectPropertyIsGValueInstance getObjectPropertyInt32 :: GObject a => a -> String -> IO Int32 getObjectPropertyInt32 = getObjectPropertyIsGValueInstance setObjectPropertyUInt32 :: GObject a => a -> String -> Word32 -> IO () setObjectPropertyUInt32 = setObjectPropertyIsGValueInstance constructObjectPropertyUInt32 :: String -> Word32 -> IO (GValueConstruct o) constructObjectPropertyUInt32 = constructObjectPropertyIsGValueInstance getObjectPropertyUInt32 :: GObject a => a -> String -> IO Word32 getObjectPropertyUInt32 = getObjectPropertyIsGValueInstance setObjectPropertyInt64 :: GObject a => a -> String -> Int64 -> IO () setObjectPropertyInt64 = setObjectPropertyIsGValueInstance constructObjectPropertyInt64 :: String -> Int64 -> IO (GValueConstruct o) constructObjectPropertyInt64 = constructObjectPropertyIsGValueInstance getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64 getObjectPropertyInt64 = getObjectPropertyIsGValueInstance setObjectPropertyUInt64 :: GObject a => a -> String -> Word64 -> IO () setObjectPropertyUInt64 = setObjectPropertyIsGValueInstance constructObjectPropertyUInt64 :: String -> Word64 -> IO (GValueConstruct o) constructObjectPropertyUInt64 = constructObjectPropertyIsGValueInstance getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64 getObjectPropertyUInt64 = getObjectPropertyIsGValueInstance setObjectPropertyFloat :: GObject a => a -> String -> Float -> IO () setObjectPropertyFloat = setObjectPropertyIsGValueInstance constructObjectPropertyFloat :: String -> Float -> IO (GValueConstruct o) constructObjectPropertyFloat = constructObjectPropertyIsGValueInstance getObjectPropertyFloat :: GObject a => a -> String -> IO Float getObjectPropertyFloat = getObjectPropertyIsGValueInstance setObjectPropertyDouble :: GObject a => a -> String -> Double -> IO () setObjectPropertyDouble = setObjectPropertyIsGValueInstance constructObjectPropertyDouble :: String -> Double -> IO (GValueConstruct o) constructObjectPropertyDouble = constructObjectPropertyIsGValueInstance getObjectPropertyDouble :: GObject a => a -> String -> IO Double getObjectPropertyDouble = getObjectPropertyIsGValueInstance setObjectPropertyBool :: GObject a => a -> String -> Bool -> IO () setObjectPropertyBool = setObjectPropertyIsGValueInstance constructObjectPropertyBool :: String -> Bool -> IO (GValueConstruct o) constructObjectPropertyBool = constructObjectPropertyIsGValueInstance getObjectPropertyBool :: GObject a => a -> String -> IO Bool getObjectPropertyBool = getObjectPropertyIsGValueInstance setObjectPropertyGType :: GObject a => a -> String -> GType -> IO () setObjectPropertyGType = setObjectPropertyIsGValueInstance constructObjectPropertyGType :: String -> GType -> IO (GValueConstruct o) constructObjectPropertyGType = constructObjectPropertyIsGValueInstance getObjectPropertyGType :: GObject a => a -> String -> IO GType getObjectPropertyGType = getObjectPropertyIsGValueInstance setObjectPropertyObject :: forall a b. (GObject a, GObject b) => a -> String -> Maybe b -> IO () setObjectPropertyObject obj propName maybeObject = do 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 <- 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 <- glibType @b getObjectProperty obj propName (\val -> (get_object val :: IO (Ptr b)) >>= flip convertIfNonNull (newObject constructor)) gtype setObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) => a -> String -> Maybe b -> IO () setObjectPropertyBoxed obj propName maybeBoxed = do gtype <- glibType @b maybeWithManagedPtr maybeBoxed $ \boxedPtr -> setObjectProperty obj propName boxedPtr set_boxed gtype constructObjectPropertyBoxed :: forall a o. (GBoxed a) => String -> Maybe a -> IO (GValueConstruct o) constructObjectPropertyBoxed propName maybeBoxed = do gtype <- glibType @a maybeWithManagedPtr maybeBoxed $ \boxedPtr -> constructObjectProperty propName boxedPtr set_boxed gtype getObjectPropertyBoxed :: forall a b. (GObject a, GBoxed b) => a -> String -> (ManagedPtr b -> b) -> IO (Maybe b) getObjectPropertyBoxed obj propName constructor = do gtype <- glibType @b getObjectProperty obj propName (get_boxed >=> flip convertIfNonNull (newBoxed constructor)) gtype setObjectPropertyStringArray :: GObject a => a -> String -> Maybe [Text] -> IO () setObjectPropertyStringArray obj propName Nothing = setObjectProperty obj propName nullPtr set_boxed gtypeStrv setObjectPropertyStringArray obj propName (Just strv) = do cStrv <- packZeroTerminatedUTF8CArray strv setObjectProperty obj propName cStrv set_boxed gtypeStrv mapZeroTerminatedCArray freeMem cStrv freeMem cStrv constructObjectPropertyStringArray :: String -> Maybe [Text] -> IO (GValueConstruct o) constructObjectPropertyStringArray propName Nothing = constructObjectProperty propName nullPtr set_boxed gtypeStrv constructObjectPropertyStringArray propName (Just strv) = do cStrv <- packZeroTerminatedUTF8CArray strv result <- constructObjectProperty propName cStrv set_boxed gtypeStrv mapZeroTerminatedCArray freeMem cStrv freeMem cStrv return result getObjectPropertyStringArray :: GObject a => a -> String -> IO (Maybe [Text]) getObjectPropertyStringArray obj propName = getObjectProperty obj propName (get_boxed >=> flip convertIfNonNull unpackZeroTerminatedUTF8CArray) gtypeStrv setObjectPropertyEnum :: forall a b. (GObject a, Enum b, BoxedEnum b) => a -> String -> b -> IO () setObjectPropertyEnum obj propName enum = do gtype <- glibType @b let cEnum = (fromIntegral . fromEnum) enum setObjectProperty obj propName cEnum set_enum gtype constructObjectPropertyEnum :: forall a o. (Enum a, BoxedEnum a) => String -> a -> IO (GValueConstruct o) constructObjectPropertyEnum propName enum = do gtype <- glibType @a let cEnum = (fromIntegral . fromEnum) enum constructObjectProperty propName cEnum set_enum gtype getObjectPropertyEnum :: forall a b. (GObject a, Enum b, BoxedEnum b) => a -> String -> IO b getObjectPropertyEnum obj propName = do gtype <- glibType @b getObjectProperty obj propName (\val -> toEnum . fromIntegral <$> get_enum val) gtype setObjectPropertyFlags :: forall a b. (IsGFlag b, BoxedFlags b, GObject a) => a -> String -> [b] -> IO () setObjectPropertyFlags obj propName flags = do let cFlags = gflagsToWord flags 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 <- 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 <- 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 = maybeWithManagedPtr maybeVariant $ \variantPtr -> setObjectProperty obj propName variantPtr set_variant gtypeVariant constructObjectPropertyVariant :: String -> Maybe GVariant -> IO (GValueConstruct o) constructObjectPropertyVariant propName maybeVariant = maybeWithManagedPtr maybeVariant $ \objPtr -> constructObjectProperty propName objPtr set_variant gtypeVariant getObjectPropertyVariant :: GObject a => a -> String -> IO (Maybe GVariant) getObjectPropertyVariant obj propName = getObjectProperty obj propName (get_variant >=> flip convertIfNonNull newGVariantFromPtr) gtypeVariant setObjectPropertyByteArray :: GObject a => a -> String -> Maybe B.ByteString -> IO () setObjectPropertyByteArray obj propName Nothing = setObjectProperty obj propName nullPtr set_boxed gtypeByteArray setObjectPropertyByteArray obj propName (Just bytes) = do packed <- packGByteArray bytes setObjectProperty obj propName packed set_boxed gtypeByteArray unrefGByteArray packed constructObjectPropertyByteArray :: String -> Maybe B.ByteString -> IO (GValueConstruct o) constructObjectPropertyByteArray propName Nothing = constructObjectProperty propName nullPtr set_boxed gtypeByteArray constructObjectPropertyByteArray propName (Just bytes) = do packed <- packGByteArray bytes result <- constructObjectProperty propName packed set_boxed gtypeByteArray unrefGByteArray packed return result getObjectPropertyByteArray :: GObject a => a -> String -> IO (Maybe B.ByteString) getObjectPropertyByteArray obj propName = getObjectProperty obj propName (get_boxed >=> flip convertIfNonNull unpackGByteArray) gtypeByteArray setObjectPropertyPtrGList :: GObject a => a -> String -> [Ptr b] -> IO () setObjectPropertyPtrGList obj propName ptrs = do packed <- packGList ptrs setObjectProperty obj propName packed set_boxed gtypePointer g_list_free packed constructObjectPropertyPtrGList :: String -> [Ptr a] -> IO (GValueConstruct o) constructObjectPropertyPtrGList propName ptrs = do packed <- packGList ptrs result <- constructObjectProperty propName packed set_boxed gtypePointer g_list_free packed return result getObjectPropertyPtrGList :: GObject a => a -> String -> IO [Ptr b] getObjectPropertyPtrGList obj propName = getObjectProperty obj propName (gvalueGet_ >=> unpackGList) gtypePointer setObjectPropertyHash :: GObject a => a -> String -> b -> IO () setObjectPropertyHash = error $ "Setting GHashTable properties not supported yet." constructObjectPropertyHash :: String -> b -> IO (GValueConstruct o) constructObjectPropertyHash = error $ "Constructing GHashTable properties not supported yet." getObjectPropertyHash :: GObject a => a -> String -> IO b getObjectPropertyHash = error $ "Getting GHashTable properties not supported yet." setObjectPropertyCallback :: GObject a => a -> String -> FunPtr b -> IO () setObjectPropertyCallback obj propName funPtr = setObjectProperty obj propName (castFunPtrToPtr funPtr) gvalueSet_ gtypePointer constructObjectPropertyCallback :: String -> FunPtr b -> IO (GValueConstruct o) constructObjectPropertyCallback propName funPtr = 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 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 haskell-gi-base-0.26.8/Data/GI/Base/ShortPrelude.hs0000644000000000000000000000560407346545000017733 0ustar0000000000000000#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, -- together with some of the functionality in Data.GI.Base, we -- reexport this explicitly here. module Data.GI.Base.ShortPrelude ( module Data.Char , module Data.Int , module Data.Word , module Data.ByteString.Char8 , module Foreign.C , module Foreign.Ptr , module Foreign.ForeignPtr , module Foreign.ForeignPtr.Unsafe , module Foreign.Storable , module Control.Applicative , module Control.Exception , module Control.Monad.IO.Class , module Data.GI.Base.Attributes , module Data.GI.Base.BasicTypes , module Data.GI.Base.BasicConversions , module Data.GI.Base.GClosure , module Data.GI.Base.Constructible , module Data.GI.Base.GError , module Data.GI.Base.GHashTable , module Data.GI.Base.GParamSpec , module Data.GI.Base.GObject , module Data.GI.Base.GVariant , module Data.GI.Base.GValue , module Data.GI.Base.ManagedPtr , module Data.GI.Base.Signals , module Data.GI.Base.Utils , module GHC.TypeLits , Enum(fromEnum, toEnum) , Show(..) , Eq(..) , IO , Monad(..) , Maybe(..) , (.) , ($) , (++) , (=<<) , (>=>) , Bool() , Float , Double , undefined , error , map , length , mapM , mapM_ , when , fromIntegral , realToFrac #if MIN_VERSION_base(4,20,0) , type (~) #endif ) where import Control.Monad (when, (>=>)) import Data.Char (Char, ord, chr) import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Data.ByteString.Char8 (ByteString) import Foreign.C (CInt(..), CUInt(..), CFloat(..), CDouble(..), CString, CIntPtr(..), CUIntPtr(..), CLong(..), CULong(..)) import Foreign.Ptr (Ptr, plusPtr, FunPtr, nullPtr, castFunPtrToPtr, castPtrToFunPtr) import Foreign.ForeignPtr (ForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Storable (peek, poke, sizeOf) import Control.Applicative ((<$>)) import Control.Exception (onException) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.GI.Base.Attributes hiding (get, set) import Data.GI.Base.BasicTypes import Data.GI.Base.BasicConversions 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 import Data.GI.Base.GParamSpec import Data.GI.Base.GVariant import Data.GI.Base.GValue import Data.GI.Base.ManagedPtr import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo) import Data.GI.Base.Utils import GHC.TypeLits (Symbol) haskell-gi-base-0.26.8/Data/GI/Base/Signals.hs0000644000000000000000000002415407346545000016714 0ustar0000000000000000{-# 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 ) 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)) 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 -- | 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 c = liftIO $ connectSignal @info o w SignalConnectBefore (proxyDetail p) where w :: object -> HaskellCallbackType info w parent = let ?self = parent in c -- | 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))) -- 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) -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO () gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do pspec' <- newGParamSpecFromPtr pspec withTransient (castPtr selfPtr) $ \self -> cb self 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 :: 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 -- | 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 haskell-gi-base-0.26.8/Data/GI/Base/Signals.hs-boot0000644000000000000000000000264407346545000017655 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RankNTypes #-} module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after) where import Data.GI.Base.Overloading (ResolvedSymbolInfo) import Data.GI.Base.BasicTypes (GObject) 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 haskell-gi-base-0.26.8/Data/GI/Base/Utils.hsc0000644000000000000000000002061507346545000016555 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings, FlexibleContexts, ConstraintKinds, TypeApplications #-} {- | Assorted utility functions for bindings. -} module Data.GI.Base.Utils ( whenJust , maybeM , maybeFromPtr , mapFirst , mapFirstA , mapSecond , mapSecondA , convertIfNonNull , convertFunPtrIfNonNull , callocBytes , callocBoxedBytes , callocMem , allocBytes , allocMem , freeMem , ptr_to_g_free , memcpy , safeFreeFunPtr , safeFreeFunPtrPtr , safeFreeFunPtrPtr' , maybeReleaseFunPtr , checkUnexpectedReturnNULL , checkUnexpectedNothing , dbgLog ) where #include 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, GBoxed, TypedObject(glibType), UnexpectedNullPointerReturn(..)) import Data.GI.Base.CallStack (HasCallStack, callStack, prettyCallStack) -- | When the given value is of "Just a" form, execute the given action, -- otherwise do nothing. whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust (Just v) f = f v whenJust Nothing _ = return () -- | Like `Control.Monad.maybe`, but for actions on a monad, and with -- slightly different argument order. maybeM :: Monad m => b -> Maybe a -> (a -> m b) -> m b maybeM d Nothing _ = return d maybeM _ (Just v) action = action v -- | Check if the pointer is `nullPtr`, and wrap it on a `Maybe` -- accordingly. maybeFromPtr :: Ptr a -> Maybe (Ptr a) maybeFromPtr ptr = if ptr == nullPtr then Nothing else Just ptr -- | Given a function and a list of two-tuples, apply the function to -- every first element of the tuples. mapFirst :: (a -> c) -> [(a,b)] -> [(c,b)] mapFirst _ [] = [] mapFirst f ((x,y) : rest) = (f x, y) : mapFirst f rest -- | Same for the second element. mapSecond :: (b -> c) -> [(a,b)] -> [(a,c)] mapSecond _ [] = [] mapSecond f ((x,y) : rest) = (x, f y) : mapSecond f rest -- | Applicative version of `mapFirst`. mapFirstA :: Applicative f => (a -> f c) -> [(a,b)] -> f [(c,b)] mapFirstA _ [] = pure [] mapFirstA f ((x,y) : rest) = (:) <$> ((,y) <$> f x) <*> mapFirstA f rest -- | Applicative version of `mapSecond`. mapSecondA :: Applicative f => (b -> f c) -> [(a,b)] -> f [(a,c)] mapSecondA _ [] = pure [] mapSecondA f ((x,y) : rest) = (:) <$> ((x,) <$> f y) <*> mapSecondA f rest -- | Apply the given conversion action to the given pointer if it is -- non-NULL, otherwise return `Nothing`. convertIfNonNull :: Ptr a -> (Ptr a -> IO b) -> IO (Maybe b) convertIfNonNull ptr convert = if ptr == nullPtr then return Nothing else Just <$> convert ptr -- | Apply the given conversion action to the given function pointer -- if it is non-NULL, otherwise return `Nothing`. convertFunPtrIfNonNull :: FunPtr a -> (FunPtr a -> IO b) -> IO (Maybe b) convertFunPtrIfNonNull ptr convert = if ptr == nullFunPtr then return Nothing else Just <$> convert ptr foreign import ccall "g_malloc0" g_malloc0 :: #{type gsize} -> IO (Ptr a) -- | Make a zero-filled allocation using the GLib allocator. {-# INLINE callocBytes #-} callocBytes :: Int -> IO (Ptr a) callocBytes n = g_malloc0 (fromIntegral n) -- | Make a zero-filled allocation of enough size to hold the given -- `Storable` type, using the GLib allocator. {-# INLINE callocMem #-} callocMem :: forall a. Storable a => IO (Ptr a) callocMem = g_malloc0 $ (fromIntegral . sizeOf) (undefined :: a) foreign import ccall "g_boxed_copy" g_boxed_copy :: CGType -> Ptr a -> IO (Ptr a) -- | Make a zero filled allocation of n bytes for a boxed object. The -- difference with a normal callocBytes is that the returned memory is -- allocated using whatever memory allocator g_boxed_copy uses, which -- 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. GBoxed a => Int -> IO (Ptr a) callocBoxedBytes n = do ptr <- callocBytes n GType cgtype <- glibType @a result <- g_boxed_copy cgtype ptr freeMem ptr return result foreign import ccall "g_malloc" g_malloc :: #{type gsize} -> IO (Ptr a) -- | Allocate the given number of bytes using the GLib allocator. {-# INLINE allocBytes #-} allocBytes :: Integral a => a -> IO (Ptr b) allocBytes n = g_malloc (fromIntegral n) -- | Allocate space for the given `Storable` using the GLib allocator. {-# INLINE allocMem #-} allocMem :: forall a. Storable a => IO (Ptr a) allocMem = g_malloc $ (fromIntegral . sizeOf) (undefined :: a) -- | A wrapper for `g_free`. foreign import ccall "g_free" freeMem :: Ptr a -> IO () -- | Pointer to `g_free`. foreign import ccall "&g_free" ptr_to_g_free :: FunPtr (Ptr a -> IO ()) foreign import ccall unsafe "string.h memcpy" _memcpy :: Ptr a -> Ptr b -> CSize -> IO (Ptr ()) -- | Copy memory into a destination (in the first argument) from a -- source (in the second argument). {-# INLINE memcpy #-} memcpy :: Ptr a -> Ptr b -> Int -> IO () memcpy dest src n = void $ _memcpy dest src (fromIntegral n) -- | Same as freeHaskellFunPtr, but it does nothing when given a -- nullPtr. foreign import ccall "safeFreeFunPtr" safeFreeFunPtr :: Ptr a -> IO () -- | A pointer to `safeFreeFunPtr`. 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 -- destroy notification. maybeReleaseFunPtr :: Maybe (Ptr (FunPtr a)) -> IO () maybeReleaseFunPtr Nothing = return () maybeReleaseFunPtr (Just f) = do peek f >>= freeHaskellFunPtr freeMem f -- | Check that the given pointer is not NULL. If it is, raise a -- `UnexpectedNullPointerReturn` exception. checkUnexpectedReturnNULL :: HasCallStack => T.Text -> Ptr a -> IO () checkUnexpectedReturnNULL fnName ptr | ptr == nullPtr = throwIO (UnexpectedNullPointerReturn { nullPtrErrorMsg = "Received unexpected nullPtr in \"" <> fnName <> "\".\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 () -- | An annotated version of `fromJust`, which raises a -- `UnexpectedNullPointerReturn` in case it encounters a `Nothing`. checkUnexpectedNothing :: HasCallStack => T.Text -> IO (Maybe a) -> IO a checkUnexpectedNothing fnName action = do result <- action case result of Just r -> return r Nothing -> throwIO (UnexpectedNullPointerReturn { nullPtrErrorMsg = "Received unexpected Nothing in \"" <> fnName <> "\".\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) }) foreign import ccall unsafe "dbg_log_with_len" dbg_log_with_len :: Ptr CChar -> Int -> IO () -- | Print a string to the debug log in an atomic way (so the output -- of different threads does not get intermingled). dbgLog :: T.Text -> IO () dbgLog msg = TF.withCStringLen msg $ \(ptr, len) -> dbg_log_with_len ptr len haskell-gi-base-0.26.8/LICENSE0000644000000000000000000006120707346545000013743 0ustar0000000000000000The haskell-gi-base library and included works are provided under the terms of the GNU Library General Public License (LGPL) version 2.1 with the following exception: Static linking of applications or any other source to the haskell-gi-base library does not constitute a modified or derivative work and does not require the author(s) to provide source code for said work, to link against the shared haskell-gi-base libraries, or to link their applications against a user-supplied version of haskell-gi-base. If you link applications to a modified version of haskell-gi-base, then the changes to haskell-gi-base must be provided under the terms of the LGPL. ---------------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS haskell-gi-base-0.26.8/Setup.hs0000644000000000000000000000011007346545000014354 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain haskell-gi-base-0.26.8/csrc/0000755000000000000000000000000007346545000013662 5ustar0000000000000000haskell-gi-base-0.26.8/csrc/hsgclosure.c0000644000000000000000000003176507346545000016220 0ustar0000000000000000#define _GNU_SOURCE /* GHC's semi-public Rts API */ #include #include #include #include #include #include #include static int print_debug_info () { static int __print_debug_info = -1; if (__print_debug_info == -1) { __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL; } return __print_debug_info; } /* A mutex protecting the log file handle. We make it recursive, i.e. refcounted, so it is OK to lock repeatedly in the same thread. */ static pthread_mutex_t log_mutex #if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP) = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP; #elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER) = PTHREAD_RECURSIVE_MUTEX_INITIALIZER; #else ; __attribute__ ((constructor)) static void init_log_mutex() { pthread_mutexattr_t attr; pthread_mutexattr_init(&attr); pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); pthread_mutex_init(&log_mutex, &attr); pthread_mutexattr_destroy(&attr); } #endif /* Give the current thread exclusive access to the log */ static void lock_log() { pthread_mutex_lock(&log_mutex); } /* Decrease the refcount of the mutex protecting access to the log from other threads */ static void unlock_log() { pthread_mutex_unlock(&log_mutex); } /* Print the given message to the log. The passed in string does not need to be zero-terminated. The message is only printed if the HASKELL_GI_DEBUG_MEM variable is set. */ void dbg_log_with_len (const char *msg, int len) { if (print_debug_info()) { lock_log(); fwrite(msg, len, 1, stderr); unlock_log(); } } /* Print the given printf-style message to the log. The message is only printed if the HASKELL_GI_DEBUG_MEM variable is set. */ __attribute__ ((format (printf, 1, 2))) static void dbg_log (const char *msg, ...) { va_list args; va_start(args, msg); if (print_debug_info()) { lock_log(); vfprintf(stderr, msg, args); unlock_log(); } va_end(args); } int check_object_type (void *instance, GType type) { int result; if (instance != NULL) { result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type); } else { result = 0; dbg_log("Check failed: got a null pointer\n"); } return result; } GType _haskell_gi_g_value_get_type (GValue *gvalue) { return G_VALUE_TYPE (gvalue); } /* Information about a boxed type to free */ typedef struct { GType gtype; gpointer boxed; } BoxedFreeInfo; /* Auxiliary function for freeing boxed types in the main loop. See the annotation in g_object_unref_in_main_loop() below. */ static gboolean main_loop_boxed_free_helper (gpointer _info) { BoxedFreeInfo *info = (BoxedFreeInfo*)_info; if (print_debug_info()) { GThread *self = g_thread_self (); lock_log(); dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n", info->boxed, self); dbg_log("\tIt is of type %s\n", g_type_name(info->gtype)); } g_boxed_free (info->gtype, info->boxed); if (print_debug_info()) { dbg_log("\tdone freeing %p.\n", info->boxed); unlock_log(); } g_free(info); return FALSE; /* Do not invoke again */ } void boxed_free_helper (GType gtype, void *boxed) { BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo)); info->gtype = gtype; info->boxed = boxed; g_idle_add (main_loop_boxed_free_helper, info); } void dbg_g_object_disown (GObject *obj) { GType gtype; if (print_debug_info()) { lock_log(); GThread *self = g_thread_self(); dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self); gtype = G_TYPE_FROM_INSTANCE (obj); dbg_log("\tIt is of type %s\n", g_type_name(gtype)); dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count); unlock_log(); } } static void print_object_dbg_info (GObject *obj) { GThread *self = g_thread_self(); GType gtype; dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self); gtype = G_TYPE_FROM_INSTANCE (obj); dbg_log("\tIt is of type %s\n", g_type_name(gtype)); dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count); } /* We schedule all GObject deletions to happen in the main loop. The reason is that for some types the destructor is not thread safe, and assumes that it is being run from the same thread as the main loop that created the object. */ static gboolean g_object_unref_in_main_loop (gpointer obj) { if (print_debug_info()) { lock_log(); print_object_dbg_info ((GObject*)obj); } g_object_unref (obj); if (print_debug_info()) { fprintf(stderr, "\tUnref done\n"); unlock_log(); } return FALSE; /* Do not invoke again */ } void dbg_g_object_unref (GObject *obj) { g_idle_add(g_object_unref_in_main_loop, obj); } static gboolean gvalue_unref_in_main_loop(void *gv) { g_boxed_free(G_TYPE_VALUE, gv); return FALSE; /* Do not invoke again */ } void haskell_gi_gvalue_free(GValue *gv) { g_idle_add(gvalue_unref_in_main_loop, gv); } /** * dbg_g_object_new: * @gtype: #GType for the object to construct. * @n_props: Number of parameters for g_object_new_with_properties(). * @names: Names of the properties to be set. * @values: Parameters for g_object_new_with_properties(). * * Allocate a #GObject of #GType @gtype, with the given @params. The * returned object is never floating, and we always own a reference to * it. (It might not be the only existing to the object, but it is in * any case safe to call g_object_unref() when we are not wrapping the * object ourselves anymore.) * * Returns: A new #GObject. */ gpointer dbg_g_object_new (GType gtype, guint n_props, const char *names[], const GValue values[]) { gpointer result; if (print_debug_info()) { GThread *self = g_thread_self(); lock_log(); dbg_log("Creating a new GObject of type %s [thread: %p]\n", g_type_name(gtype), self); } #if GLIB_CHECK_VERSION(2,54,0) result = g_object_new_with_properties (gtype, n_props, names, values); #else { GParameter params[n_props]; int i; for (i=0; idata; g_type_add_interface_static (result, info->gtype, info->info); interfaces = interfaces -> next; } } else { /* Free the memory associated with the HsFunPtrs that we are given, to avoid a (small) memory leak. */ hs_free_fun_ptr ((HsFunPtr)class_init); hs_free_fun_ptr ((HsFunPtr)instance_init); while (interfaces != NULL) { CombinedInterfaceInfo *info = (CombinedInterfaceInfo*) interfaces->data; hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_init); if (info -> info -> interface_finalize) hs_free_fun_ptr ((HsFunPtr) info -> info -> interface_finalize); interfaces = interfaces -> next; } } pthread_mutex_unlock(>ypes_mutex); return result; } static HsStablePtr duplicateStablePtr(HsStablePtr stable_ptr) { return getStablePtr(deRefStablePtr(stable_ptr)); } GType haskell_gi_StablePtr_get_type (void) { static gsize g_define_type_id = 0; if (g_once_init_enter (&g_define_type_id)) { GType type_id = g_boxed_type_register_static (g_intern_static_string ("HaskellGIStablePtr"), duplicateStablePtr, hs_free_stable_ptr); g_once_init_leave (&g_define_type_id, type_id); } return g_define_type_id; } /* This is identical to haskell_gi_StablePtr_get_type, other than the type name. The reason for this is that we want two different types, to distinguish between GValues wrapping generic StablePtrs, and those wrapping specifically wrapping StablePtrs to Dynamic values. */ GType haskell_gi_HaskellValue_get_type (void) { static gsize g_define_type_id = 0; if (g_once_init_enter (&g_define_type_id)) { GType type_id = g_boxed_type_register_static (g_intern_static_string ("HaskellGIHaskellValue"), duplicateStablePtr, hs_free_stable_ptr); g_once_init_leave (&g_define_type_id, type_id); } return g_define_type_id; } /* A safer version of get_boxed, that checks that the GValue contains the right boxed type. */ gpointer haskell_gi_safe_get_boxed_haskell_value(const GValue *gv) { if (G_VALUE_TYPE(gv) != haskell_gi_HaskellValue_get_type()) { fprintf(stderr, "Unexpected type inside the GValue: ‘%s’\n.", G_VALUE_TYPE_NAME(gv)); return NULL; } return g_value_get_boxed(gv); } /* Release the FunPtr allocated for a Haskell signal handler */ void haskell_gi_release_signal_closure (gpointer unused, GCClosure *closure) { lock_log(); dbg_log("Releasing a signal closure %p\n", closure->callback); hs_free_fun_ptr (closure->callback); dbg_log("\tDone.\n"); unlock_log(); } /* Check whether the given closure is floating */ gboolean haskell_gi_g_closure_is_floating (GClosure *closure) { return !!(closure->floating); } /* GParamSpec* types are registered as GObjects, but they do not have an exported type_init function. They only export CPP macros, so we have to provide our own. */ #define PARAM_TYPE(CamelCase, UPPERCASE) \ GType haskell_gi_pspec_type_init_##CamelCase (void) { \ return G_TYPE_##UPPERCASE; \ } PARAM_TYPE(ParamSpec, PARAM); PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN); PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED); PARAM_TYPE(ParamSpecChar, PARAM_CHAR); PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE); PARAM_TYPE(ParamSpecEnum, PARAM_ENUM); PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS); PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT); PARAM_TYPE(ParamSpecGType, PARAM_GTYPE); PARAM_TYPE(ParamSpecInt, PARAM_INT); PARAM_TYPE(ParamSpecInt64, PARAM_INT64); PARAM_TYPE(ParamSpecLong, PARAM_LONG); PARAM_TYPE(ParamSpecObject, PARAM_OBJECT); PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE); PARAM_TYPE(ParamSpecParam, PARAM_PARAM); PARAM_TYPE(ParamSpecPointer, PARAM_POINTER); PARAM_TYPE(ParamSpecString, PARAM_STRING); PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR); PARAM_TYPE(ParamSpecUInt, PARAM_UINT); PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64); PARAM_TYPE(ParamSpecULong, PARAM_ULONG); PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR); PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT); /* The following is deprecated, ignore the warning that GLib raises. */ #undef GLIB_DEPRECATED_MACRO #define GLIB_DEPRECATED_MACRO PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY); haskell-gi-base-0.26.8/haskell-gi-base.cabal0000644000000000000000000000462007346545000016646 0ustar0000000000000000name: haskell-gi-base version: 0.26.8 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi license: LGPL-2.1 -- or above license-file: LICENSE author: Will Thompson, Iñaki García Etxebarria, Jonas Platte maintainer: Iñaki García Etxebarria (inaki@blueleaf.cc) stability: Experimental category: Development build-type: Simple cabal-version: 2.0 extra-source-files: ChangeLog.md source-repository head type: git location: git://github.com/haskell-gi/haskell-gi.git library exposed-modules: Data.GI.Base, Data.GI.Base.Attributes, Data.GI.Base.BasicConversions, Data.GI.Base.BasicTypes, Data.GI.Base.CallStack, 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, Data.GI.Base.ManagedPtr, Data.GI.Base.GParamSpec, Data.GI.Base.Overloading, Data.GI.Base.Properties, Data.GI.Base.ShortPrelude, Data.GI.Base.Signals, Data.GI.Base.Utils, Data.GI.Base.Internal.CTypes pkgconfig-depends: gobject-2.0 >= 2.42, glib-2.0 build-depends: base >= 4.11 && < 5, bytestring, containers, text >= 1.0 ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat build-tool-depends: hsc2hs:hsc2hs cc-options: -fPIC default-language: Haskell2010 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds other-extensions: TypeApplications, ScopedTypeVariables c-sources: csrc/hsgclosure.c