haskell-gi-base 0.19 → 0.20

raw patch · 41 files changed

+4965/−4859 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/GI/Base.hs +33/−0
• Data/GI/Base/Attributes.hs +378/−0
• Data/GI/Base/BasicConversions.hsc +595/−0
• Data/GI/Base/BasicTypes.hs +215/−0
• Data/GI/Base/Closure.hs +41/−0
• Data/GI/Base/Constructible.hs +31/−0
• Data/GI/Base/GError.hsc +248/−0
• Data/GI/Base/GHashTable.hsc +68/−0
• Data/GI/Base/GObject.hsc +98/−0
• Data/GI/Base/GParamSpec.hsc +52/−0
• Data/GI/Base/GType.hsc +142/−0
• Data/GI/Base/GValue.hsc +378/−0
• Data/GI/Base/GVariant.hsc +977/−0
• Data/GI/Base/ManagedPtr.hs +353/−0
• Data/GI/Base/Overloading.hs +263/−0
• Data/GI/Base/Properties.hsc +521/−0
• Data/GI/Base/ShortPrelude.hs +93/−0
• Data/GI/Base/Signals.hsc +170/−0
• Data/GI/Base/Utils.hsc +200/−0
• c/hsgclosure.c +106/−0
• haskell-gi-base.cabal +3/−3
• src/Data/GI/Base.hs +0/−33
• src/Data/GI/Base/Attributes.hs +0/−364
• src/Data/GI/Base/BasicConversions.hsc +0/−595
• src/Data/GI/Base/BasicTypes.hs +0/−206
• src/Data/GI/Base/Closure.hs +0/−41
• src/Data/GI/Base/Constructible.hs +0/−32
• src/Data/GI/Base/GError.hsc +0/−240
• src/Data/GI/Base/GHashTable.hsc +0/−68
• src/Data/GI/Base/GObject.hsc +0/−98
• src/Data/GI/Base/GParamSpec.hsc +0/−51
• src/Data/GI/Base/GType.hsc +0/−142
• src/Data/GI/Base/GValue.hsc +0/−379
• src/Data/GI/Base/GVariant.hsc +0/−977
• src/Data/GI/Base/ManagedPtr.hs +0/−290
• src/Data/GI/Base/Overloading.hs +0/−263
• src/Data/GI/Base/Properties.hsc +0/−521
• src/Data/GI/Base/ShortPrelude.hs +0/−93
• src/Data/GI/Base/Signals.hsc +0/−170
• src/Data/GI/Base/Utils.hsc +0/−200
• src/c/hsgclosure.c +0/−93

@@ -0,0 +1,33 @@+{- |+   == 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.Closure+    , module Data.GI.Base.Constructible+    , module Data.GI.Base.GError+    , module Data.GI.Base.GHashTable+    , module Data.GI.Base.GObject+    , module Data.GI.Base.GValue+    , module Data.GI.Base.GVariant+    , module Data.GI.Base.ManagedPtr+    , module Data.GI.Base.Signals+    ) where++import Data.GI.Base.Attributes (get, set, AttrOp(..))+import Data.GI.Base.BasicConversions+import Data.GI.Base.BasicTypes+import Data.GI.Base.Closure+import Data.GI.Base.Constructible (new)+import Data.GI.Base.GError+import Data.GI.Base.GHashTable+import Data.GI.Base.GObject (new')+import Data.GI.Base.GValue (GValue(..), IsGValue(..))+import Data.GI.Base.GVariant+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Signals (on, after, SignalProxy(PropertyNotify))

@@ -0,0 +1,378 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,+  TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,+  UndecidableInstances, FlexibleInstances #-}++-- |+--+-- == 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`).+--+-- 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. There is also '::=' and '::~'+-- which take the object as an extra parameter.+--+-- Attributes can also be set during construction of a+-- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.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 atributes+--+-- 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 he empty list). This can be overriden 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(..)+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)++import Data.Proxy (Proxy(..))++import Data.GI.Base.GValue (GValueConstruct)+import Data.GI.Base.Overloading (HasAttributeList,+                                 ResolveAttribute, IsLabelProxy(..))++import GHC.TypeLits+import GHC.Exts (Constraint)++#if MIN_VERSION_base(4,9,0)+import GHC.OverloadedLabels (IsLabel(..))+#endif++infixr 0 :=,:~,:=>,:~>,::=,::~++-- | A proxy for attribute labels.+data AttrLabelProxy (a :: Symbol) = AttrLabelProxy++-- | Support for overloaded labels.+instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where+    fromLabelProxy _ = AttrLabelProxy++#if MIN_VERSION_base(4,9,0)+instance a ~ x => IsLabel x (AttrLabelProxy a) where+    fromLabel _ = AttrLabelProxy+#endif++-- | Info describing an attribute.+class AttrInfo (info :: *) where+    -- | The operations that are allowed on the attribute.+    type AttrAllowedOps info :: [AttrOpTag]+    -- | Constraint on the value being set.+    type AttrSetTypeConstraint info :: * -> Constraint+    -- | Constraint on the type for which we are allowed to+    -- create\/set\/get the attribute.+    type AttrBaseTypeConstraint info :: * -> Constraint+    -- | Type returned by `attrGet`.+    type AttrGetType info+    -- | Name of the attribute.+    type AttrLabel info :: Symbol+    -- | Type which introduces the attribute.+    type AttrOrigin info+    -- | Get the value of the given attribute.+    attrGet :: AttrBaseTypeConstraint info o =>+               Proxy info -> o -> IO (AttrGetType info)+    -- | Set the value of the given attribute, after the object having+    -- the attribute has already been created.+    attrSet :: (AttrBaseTypeConstraint info o,+                AttrSetTypeConstraint info b) =>+               Proxy info -> o -> b -> IO ()+    -- | Set the value of the given attribute to @NULL@ (for nullable+    -- attributes).+    attrClear :: AttrBaseTypeConstraint info o =>+                 Proxy info -> o -> IO ()+    -- | Build a `GValue` representing the attribute.+    attrConstruct :: (AttrBaseTypeConstraint info o,+                      AttrSetTypeConstraint info b) =>+                     Proxy info -> b -> IO (GValueConstruct o)++-- | Result of checking whether an op is allowed on an attribute.+data OpAllowed tag attrName definingType useType =+    OpIsAllowed+#if !MIN_VERSION_base(4,9,0)+        | AttrOpNotAllowed Symbol tag Symbol definingType Symbol attrName+#endif++#if MIN_VERSION_base(4,9,0)+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 "’)"+#endif++-- | Look in the given list to see if the given `AttrOp` is a member,+-- if not return an error type.+type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) (definingType :: *) (useType :: *) :: OpAllowed AttrOpTag Symbol * * where+    AttrOpIsAllowed tag '[] label definingType useType =+#if !MIN_VERSION_base(4,9,0)+        'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute " definingType "." label+#else+        TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>:+                   'Text "’ for type " ':<>:+                   TypeOriginInfo definingType useType ':<>:+                   'Text " is not " ':<>:+                   'Text (AttrOpText tag) ':<>: 'Text ".")+#endif+    AttrOpIsAllowed tag (tag ': ops) label definingType useType = 'OpIsAllowed+    AttrOpIsAllowed tag (other ': ops) label definingType useType = AttrOpIsAllowed tag ops label definingType useType++-- | Whether a given `AttrOpTag` is allowed on an attribute, given the+-- info type.+type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) (useType :: *) :: Constraint where+    AttrOpAllowed tag info useType =+        AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) (AttrOrigin info) useType ~ 'OpIsAllowed++-- | Possible operations on an attribute.+data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear++#if MIN_VERSION_base(4,9,0)+-- | A user friendly description of the `AttrOpTag`, useful when+-- printing type errors.+type family AttrOpText (tag :: AttrOpTag) :: Symbol where+    AttrOpText 'AttrGet = "gettable"+    AttrOpText 'AttrSet = "settable"+    AttrOpText 'AttrConstruct = "constructible"+    AttrOpText 'AttrClear = "nullable"+#endif++-- | 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 `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 with the object as an argument+    (::=) :: (HasAttributeList obj,+              info ~ ResolveAttribute attr obj,+              AttrInfo info,+              AttrBaseTypeConstraint info obj,+              tag ~ 'AttrSet,+              AttrOpAllowed tag info obj,+              (AttrSetTypeConstraint info) b) =>+             AttrLabelProxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag+    -- Apply an update function to an attribute with the object as an+    -- argument+    (::~) :: (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) -> (obj -> a -> b) -> 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+   resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)+   resolve _ = Proxy++   app :: AttrOp o 'AttrSet -> IO ()+   app (attr :=  x) = attrSet (resolve attr) obj x+   app (attr :=> x) = x >>= attrSet (resolve attr) obj+   app (attr :~  f) = attrGet (resolve attr) obj >>=+                      \v -> attrSet (resolve attr) obj (f v)+   app (attr :~> f) = attrGet (resolve attr) obj >>= f >>=+                      attrSet (resolve attr) obj+   app (attr ::= f) = attrSet (resolve attr) obj (f obj)+   app (attr ::~ f) = attrGet (resolve attr) obj >>=+                      \v -> attrSet (resolve attr) obj (f obj v)++-- | 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 (Proxy :: Proxy 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 (Proxy :: Proxy info) o

@@ -0,0 +1,595 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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.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.GHashTable (GEqualFunc, GHashFunc)+import Data.GI.Base.ManagedPtr (copyBoxedPtr)+import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem)++#include <glib-object.h>++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 -> Int -> 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) -> Int -> 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 :: 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 :: 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 :: 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 :: 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 :: CString -> IO String+cstringToString = peekCString++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 :: CString -> IO Text+cstringToText cstr = do+  len <- c_strlen cstr+  let cstrlen = (cstr, fromIntegral len)+  TF.peekCStringLen cstrlen++byteStringToCString :: ByteString -> IO CString+byteStringToCString bs = B.useAsCString bs g_strdup++cstringToByteString :: CString -> IO ByteString+cstringToByteString = B.packCString++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)++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, BoxedObject 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)

@@ -0,0 +1,215 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,+  DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-}+#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE OverlappingInstances #-}+#endif+#if MIN_VERSION_base(4,9,0)+{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}+#endif+-- | Basic types used in the bindings.+module Data.GI.Base.BasicTypes+    (+      -- * GType related+      module Data.GI.Base.GType         -- reexported for convenience++     -- * Memory management+    , ManagedPtr(..)+    , ManagedPtrNewtype+    , BoxedObject(..)+    , BoxedEnum(..)+    , BoxedFlags(..)+    , GObject(..)+    , WrappedPtr(..)+    , UnexpectedNullPointerReturn(..)+    , NullToNothing(..)++    -- * Basic GLib \/ GObject types+    , GVariant(..)+    , GParamSpec(..)++    , GArray(..)+    , GPtrArray(..)+    , GByteArray(..)+    , GHashTable(..)+    , GList(..)+    , g_list_free+    , GSList(..)+    , g_slist_free++    , IsGFlag++    , PtrWrapped(..)+    , GDestroyNotify+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Exception (Exception, catch)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Coerce (Coercible)+import Data.IORef (IORef)+import Data.Proxy (Proxy)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Foreign.Ptr (Ptr, FunPtr)+import Foreign.ForeignPtr (ForeignPtr)++#if MIN_VERSION_base(4,9,0)+import GHC.TypeLits+#endif++import Data.GI.Base.GType++-- | Thin wrapper over `ForeignPtr`, supporting the extra notion of+-- `disowning`, that is, not running the finalizers associated with+-- the foreign ptr.+data ManagedPtr a = ManagedPtr {+      managedForeignPtr :: ForeignPtr a+    , managedPtrIsOwned :: IORef Bool+    }++-- | A constraint ensuring that the given type is coercible to a+-- ManagedPtr. It will hold for newtypes of the form+--+-- > newtype Foo = Foo (ManagedPtr Foo)+--+-- which is the typical shape of wrapped 'GObject's.+type ManagedPtrNewtype a = Coercible a (ManagedPtr ())+-- Notice that the Coercible here is to ManagedPtr (), instead of+-- "ManagedPtr a", which would be the most natural thing. Both are+-- representationally equivalent, so this is not a big deal. This is+-- to work around a problem in ghc 7.10:+-- https://ghc.haskell.org/trac/ghc/ticket/10715++-- | Wrapped boxed structures, identified by their `GType`.+class ManagedPtrNewtype a => BoxedObject a where+    boxedType :: a -> IO GType -- This should not use the value of its+                               -- argument.++-- | Enums with an associated `GType`.+class BoxedEnum a where+    boxedEnumType :: a -> IO GType++-- | Flags with an associated `GType`.+class BoxedFlags a where+    boxedFlagsType :: Proxy a -> IO GType++-- | Pointers to structs/unions without an associated `GType`.+class ManagedPtrNewtype a => WrappedPtr a where+    -- | Allocate a zero-initialized block of memory for the given type.+    wrappedPtrCalloc :: IO (Ptr a)+    -- | Make a copy of the given pointer.+    wrappedPtrCopy   :: Ptr a -> IO (Ptr a)+    -- | A pointer to a function for freeing the given pointer, or+    -- `Nothing` is the memory associated to the pointer does not need+    -- to be freed.+    wrappedPtrFree   :: Maybe (FunPtr (Ptr a -> IO ()))++-- | A wrapped `GObject`.+class ManagedPtrNewtype a => GObject a where+    -- | Whether the `GObject` is a descendent of <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#GInitiallyUnowned GInitiallyUnowned>.+    gobjectIsInitiallyUnowned :: a -> Bool+    -- | The `GType` for this object.+    gobjectType :: a -> IO GType++-- Raise a more understandable type error whenever the `GObject a`+-- constraint is imposed on a type which has no such instance. This+-- helps in the common case where one passes a wrong type (such as+-- `Maybe Widget`) into a function with a `IsWidget a`+-- constraint. Without this type error, the resulting type error is+-- much less understandable, since GHC complains (at length) about a+-- missing type family instance for `ParentTypes`.+#if MIN_VERSION_base(4,9,0)+instance {-# OVERLAPPABLE #-}+    (TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:+                'Text "’ does not descend from GObject."), ManagedPtrNewtype a)+    => GObject a where+    gobjectIsInitiallyUnowned = undefined+    gobjectType = undefined+#endif++-- | 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 (Show, Typeable)++instance Exception UnexpectedNullPointerReturn++type family UnMaybe a :: * where+    UnMaybe (Maybe a) = a+    UnMaybe a         = a++class NullToNothing a where+    -- | Some functions are not marked as having a nullable return type+    -- in the introspection data.  The result is that they currently do+    -- not return a Maybe type.  This functions lets you work around this+    -- in a way that will not break when the introspection data is fixed.+    --+    -- When you want to call a `someHaskellGIFunction` that may return null+    -- wrap the call like this.+    --+    -- > nullToNothing (someHaskellGIFunction x y)+    --+    -- The result will be a Maybe type even if the introspection data has+    -- not been fixed for `someHaskellGIFunction` yet.+    nullToNothing :: MonadIO m => IO a -> m (Maybe (UnMaybe a))++instance+#if MIN_VERSION_base(4,8,0)+    {-# OVERLAPPABLE #-}+#endif+    a ~ UnMaybe a => NullToNothing a where+        nullToNothing f = liftIO $+            (Just <$> f) `catch` (\(_::UnexpectedNullPointerReturn) -> return Nothing)++instance NullToNothing (Maybe a) where+    nullToNothing = liftIO++-- | A <https://developer.gnome.org/glib/stable/glib-GVariant.html GVariant>. See "Data.GI.Base.GVariant" for further methods.+newtype GVariant = GVariant (ManagedPtr GVariant)++-- | A <https://developer.gnome.org/gobject/stable/gobject-GParamSpec.html GParamSpec>. See "Data.GI.Base.GParamSpec" for further methods.+newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec)++-- | An enum usable as a flag for a function.+class Enum a => IsGFlag a++-- | A <https://developer.gnome.org/glib/stable/glib-Arrays.html GArray>. 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 <https://developer.gnome.org/glib/stable/glib-Pointer-Arrays.html GPtrArray>. 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 <https://developer.gnome.org/glib/stable/glib-Byte-Arrays.html GByteArray>. 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 <https://developer.gnome.org/glib/stable/glib-Hash-Tables.html GHashTable>. It is mapped to a 'Data.Map.Map' on the Haskell side.+data GHashTable a b = GHashTable (Ptr (GHashTable a b))++-- | A <https://developer.gnome.org/glib/stable/glib-Doubly-Linked-Lists.html GList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+data GList a = GList (Ptr (GList a))++-- | A <https://developer.gnome.org/glib/stable/glib-Singly-Linked-Lists.html GSList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".+data GSList a = GSList (Ptr (GSList a))++-- | Some APIs, such as `GHashTable`, pass around scalar types+-- wrapped into a pointer. We encode such a type as follows.+newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a}++-- | Destroy the memory associated with a given pointer.+type GDestroyNotify a = FunPtr (Ptr a -> IO ())++-- | Free the given 'GList'.+foreign import ccall "g_list_free" g_list_free ::+    Ptr (GList a) -> IO ()++-- | Free the given 'GSList'.+foreign import ccall "g_slist_free" g_slist_free ::+    Ptr (GSList a) -> IO ()

@@ -0,0 +1,41 @@+-- Some helper functions to create closures.+module Data.GI.Base.Closure+    ( Closure(..)+    , newCClosure+    , noClosure+    ) where++import Foreign++import Data.GI.Base.BasicTypes+import Data.GI.Base.ManagedPtr (wrapBoxed)+import Data.GI.Base.Utils (safeFreeFunPtrPtr)++newtype Closure = Closure (ManagedPtr Closure)++noClosure :: Maybe Closure+noClosure = Nothing++foreign import ccall "g_closure_get_type" c_g_closure_get_type ::+    IO GType++instance BoxedObject Closure where+    boxedType _ = c_g_closure_get_type+++foreign import ccall "g_cclosure_new" g_cclosure_new+    :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure)++foreign import ccall "g_closure_ref" g_closure_ref+    :: Ptr Closure -> IO (Ptr Closure)++foreign import ccall "g_closure_sink" g_closure_sink+    :: Ptr Closure -> IO ()++newCClosure :: FunPtr a -> IO Closure+newCClosure ptr = do+  closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr+  -- The Haskell runtime will manage the memory associated to the+  -- closure, so ref and sink to let GLib know this.+  g_closure_ref closure >>= g_closure_sink+  wrapBoxed Closure closure

@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses,+  UndecidableInstances, KindSignatures, TypeFamilies #-}+#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+    new :: MonadIO m => (ManagedPtr a -> a) -> [AttrOp a tag] -> m a++-- | Default instance, assuming we have a `GObject`.+instance+#if MIN_VERSION_base(4,8,0)+    {-# OVERLAPPABLE #-}+#endif+    (GObject a, tag ~ 'AttrConstruct) => Constructible a tag where+        new = constructGObject

@@ -0,0 +1,248 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++-- | To catch GError exceptions use the+-- catchGError* or handleGError* functions. They work in a similar+-- way to the standard 'Control.Exception.catch' and+-- 'Control.Exception.handle' functions.+--+-- To catch just a single specific error use 'catchGErrorJust' \/+-- 'handleGErrorJust'. To catch any error in a particular error domain+-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'+--+-- For convenience, generated code also includes specialized variants+-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For+-- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could+-- invoke 'GI.GdkPixbuf.catchPixbufError' \/+-- 'GI.GdkPixbuf.handlePixbufError'. 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 'GI.GdkPixbuf.PixbufError' 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++    ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Foreign (poke, peek)+import Foreign.Ptr (Ptr, plusPtr, nullPtr)+import Foreign.C+import Control.Exception+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Int+import Data.Word++import System.IO.Unsafe (unsafePerformIO)++import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), ManagedPtr)+import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)+import Data.GI.Base.Utils (allocMem, freeMem)++#include <glib.h>++-- | A GError, consisting of a domain, code and a human readable+-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and+-- 'gerrorMessage' below.+newtype GError = GError (ManagedPtr GError)+    deriving (Typeable)++instance Show GError where+    show gerror = unsafePerformIO $ do+                       code <- gerrorCode gerror+                       message <- gerrorMessage gerror+                       return $ T.unpack message ++ " (" ++ show code ++ ")"++instance Exception GError++foreign import ccall "g_error_get_type" g_error_get_type :: IO GType++instance BoxedObject GError where+    boxedType _ = g_error_get_type++-- | A GQuark.+type GQuark = #type GQuark++-- | A code used to identify the "namespace" of the error. Within each error+--   domain all the error codes are defined in an enumeration. Each gtk\/gnome+--   module that uses GErrors has its own error domain. The rationale behind+--   using error domains is so that each module can organise its own error codes+--   without having to coordinate on a global error code list.+type GErrorDomain  = GQuark++-- | A code to identify a specific error within a given 'GErrorDomain'. Most of+--   time you will not need to deal with this raw code since there is an+--   enumeration type for each error domain. Of course which enumeration to use+--   depends on the error domain, but if you use 'catchGErrorJustDomain' or+--   'handleGErrorJustDomain', this is worked out for you automatically.+type GErrorCode = #type gint++-- | A human readable error message.+type GErrorMessage = Text++foreign import ccall "g_error_new_literal" g_error_new_literal ::+    GQuark -> GErrorCode -> CString -> IO (Ptr GError)++-- | Create a new 'GError'.+gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError+gerrorNew domain code message =+    withTextCString message $ \cstring ->+        g_error_new_literal domain code cstring >>= wrapBoxed GError++-- | Return the domain for the given `GError`. This is a GQuark, a+-- textual representation can be obtained with+-- `GI.GLib.quarkToString`.+gerrorDomain :: GError -> IO GQuark+gerrorDomain gerror =+    withManagedPtr gerror $ \ptr ->+      peek $ ptr `plusPtr` #{offset GError, domain}++-- | The numeric code for the given `GError`.+gerrorCode :: GError -> IO GErrorCode+gerrorCode gerror =+    withManagedPtr gerror $ \ptr ->+        peek $ ptr `plusPtr` #{offset GError, code}++-- | A text message describing the `GError`.+gerrorMessage :: GError -> IO GErrorMessage+gerrorMessage gerror =+    withManagedPtr gerror $ \ptr ->+      (peek $ ptr `plusPtr` #{offset GError, message}) >>= cstringToText++-- | Each error domain's error enumeration type should be an instance of this+--   class. This class helps to hide the raw error and domain codes from the+--   user.+--+-- Example for 'GI.GdkPixbuf.PixbufError':+--+-- > 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 = do+  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code+  catch action (handler' domainQuark)+  where handler' quark gerror = do+          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 = do+  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err)+  catch action (handler' domainQuark)+  where handler' quark gerror = do+          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

@@ -0,0 +1,68 @@+{- | 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+    ) where++import Data.Int+import Data.Word++import Foreign.C+import Foreign.Ptr (Ptr, castPtr, FunPtr)++import Data.GI.Base.BasicTypes (PtrWrapped(..))++#include <glib-object.h>++-- | A pointer to a hashing function on the C side.+type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})++-- | A pointer to an equality checking function on the C side.+type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})++-- | Compute the hash for a `Ptr`.+foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a)++-- | 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

@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-}++module Data.GI.Base.GObject+    ( constructGObject+    , new'+    ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy(..))++import Foreign.C (CUInt(..), CString, newCString)+import Foreign++import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy,+                                attrConstruct)+import Data.GI.Base.BasicTypes (GType(..), GObject(..), ManagedPtr)+import Data.GI.Base.GValue (GValue(..), GValueConstruct(..))+import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject)+import Data.GI.Base.Overloading (ResolveAttribute)++#include <glib-object.h>++foreign import ccall "dbg_g_object_newv" g_object_newv ::+    GType -> CUInt -> Ptr a -> IO (Ptr b)++-- | Construct a GObject given the constructor and a list of settable+-- attributes.+constructGObject :: forall o m. (GObject o, MonadIO m)+    => (ManagedPtr o -> o)+    -> [AttrOp o 'AttrConstruct]+    -> m o+constructGObject constructor attrs = liftIO $ do+  props <- mapM construct attrs+  doConstructGObject constructor props+  where+    resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)+    resolve _ = Proxy++    construct :: AttrOp o 'AttrConstruct ->+                 IO (GValueConstruct o)+    construct (attr := x) = attrConstruct (resolve attr) x+    construct (attr :=> x) = x >>= attrConstruct (resolve attr)++-- | Construct the `GObject` given the list of `GValueConstruct`s.+doConstructGObject :: forall o m. (GObject o, MonadIO m)+                      => (ManagedPtr o -> o) -> [GValueConstruct o] -> m o+doConstructGObject constructor props = liftIO $ do+  let nprops = length props+  params <- mallocBytes (nprops*gparameterSize)+  fill params props+  gtype <- gobjectType (undefined :: o)+  result <- g_object_newv gtype (fromIntegral nprops) params+  freeStrings nprops params+  free params+  -- Make sure that the GValues defining the GProperties are still+  -- alive at this point (so, in particular, they are still alive when+  -- g_object_newv is called). Without this the GHC garbage collector+  -- may free the GValues before g_object_newv is called, which will+  -- unref the referred to objects, which may drop the last reference+  -- to the contained objects. g_object_newv 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+    gparameterSize = #size GParameter++    -- Fill the given memory address with the contents of the array of+    -- GParameters.+    fill :: Ptr () -> [GValueConstruct o] -> IO ()+    fill _ [] = return ()+    fill dataPtr ((GValueConstruct str gvalue):xs) =+        do cstr <- newCString str+           poke (castPtr dataPtr) cstr+           withManagedPtr gvalue $ \gvalueptr ->+               copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize+           fill (dataPtr `plusPtr` gparameterSize) xs++    -- Free the strings in the GParameter array (the GValues will be+    -- freed separately).+    freeStrings :: Int -> Ptr () -> IO ()+    freeStrings 0 _ = return ()+    freeStrings n dataPtr =+        do cstr <- peek (castPtr dataPtr) :: IO CString+           free cstr+           freeStrings (n-1) (dataPtr `plusPtr` gparameterSize)++-- | Construct the given `GObject`, given a set of actions+-- constructing desired `GValue`s to set at construction time.+new' :: (MonadIO m, GObject o) =>+        (ManagedPtr o -> o) -> [IO (GValueConstruct o)] -> m o+new' constructor actions = do+  props <- liftIO $ sequence (actions)+  doConstructGObject constructor props

@@ -0,0 +1,52 @@+module Data.GI.Base.GParamSpec+    ( noGParamSpec++    , wrapGParamSpecPtr+    , newGParamSpecFromPtr+    , unrefGParamSpec+    , disownGParamSpec+    ) where++import Foreign.Ptr+import Control.Monad (void)++import Data.GI.Base.ManagedPtr (newManagedPtr', withManagedPtr, disownManagedPtr)+import Data.GI.Base.BasicTypes (GParamSpec(..))++#include <glib-object.h>++noGParamSpec :: Maybe GParamSpec+noGParamSpec = Nothing++foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink ::+    Ptr GParamSpec -> IO (Ptr GParamSpec)+foreign import ccall "g_param_spec_ref" g_param_spec_ref ::+    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

@@ -0,0 +1,142 @@+-- | Basic `GType`s.+module Data.GI.Base.GType+    ( GType(..)+    , CGType++    , gtypeName++    , gtypeString+    , gtypePointer+    , gtypeInt+    , gtypeUInt+    , gtypeLong+    , gtypeULong+    , gtypeInt64+    , gtypeUInt64+    , gtypeFloat+    , gtypeDouble+    , gtypeBoolean+    , gtypeGType+    , gtypeStrv+    , gtypeBoxed+    , gtypeObject+    , gtypeVariant+    , gtypeByteArray+    , gtypeInvalid+    ) where++import Data.Word+import Foreign.C.String (CString, peekCString)++#include <glib-object.h>++-- | A type identifier in the GLib type system. This is the low-level+-- type associated with the representation in memory, when using this+-- on the Haskell side use `GType` below.+type CGType = #type GType++-- | A newtype for use on the haskell side.+newtype GType = GType {gtypeToCGType :: CGType}++foreign import ccall "g_type_name" g_type_name :: GType -> IO CString++-- | Get the name assigned to the given `GType`.+gtypeName :: GType -> IO String+gtypeName gtype = g_type_name gtype >>= peekCString++{-| [Note: compile-time vs run-time GTypes]++Notice that there are two types of GType's: the fundamental ones,+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 `BoxedObject`.+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++{- 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

@@ -0,0 +1,378 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.GI.Base.GValue+    ( GValue(..)+    , IsGValue(..)++    , newGValue         -- Build a new, empty, GValue of the given type+    , buildGValue       -- Build a new GValue and initialize to the given value+    , noGValue++    , GValueConstruct(..)++    , set_string+    , get_string+    , set_pointer+    , get_pointer+    , set_int+    , get_int+    , set_uint+    , get_uint+    , set_long+    , get_long+    , set_ulong+    , get_ulong+    , set_int32+    , get_int32+    , set_uint32+    , get_uint32+    , set_int64+    , get_int64+    , set_uint64+    , get_uint64+    , set_float+    , get_float+    , set_double+    , get_double+    , set_boolean+    , get_boolean+    , set_gtype+    , get_gtype+    , set_object+    , get_object+    , set_boxed+    , get_boxed+    , set_variant+    , get_variant+    , set_enum+    , get_enum+    , set_flags+    , get_flags+    ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Data.Coerce (coerce)+import Data.Word+import Data.Int+import Data.Text (Text, pack, unpack)++import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),+                        CLong(..), CULong(..))+import Foreign.C.String (CString)+import Foreign.Ptr (Ptr, nullPtr)++import Data.GI.Base.BasicTypes+import Data.GI.Base.BasicConversions (cstringToText, textToCString)+import Data.GI.Base.ManagedPtr+import Data.GI.Base.Utils (callocBytes, freeMem)++newtype GValue = GValue (ManagedPtr GValue)++noGValue :: Maybe GValue+noGValue = Nothing++foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::+    IO CGType++instance BoxedObject GValue where+    boxedType _ = GType <$> c_g_value_get_type++foreign import ccall "g_value_init" g_value_init ::+    Ptr GValue -> CGType -> IO (Ptr GValue)++-- | A type holding a `GValue` with an associated label. It is+-- parameterized by a phantom type encoding the target type for the+-- `GValue` (useful when constructing properties).+data GValueConstruct o = GValueConstruct String GValue++newGValue :: GType -> IO GValue+newGValue (GType gtype) = do+  gvptr <- callocBytes #size GValue+  _ <- g_value_init gvptr gtype+  gv <- wrapBoxed GValue gvptr+  return $! gv++-- Build a new GValue and set the initial value, just for convenience+buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue+buildGValue gtype setter val = do+  gv <- newGValue gtype+  setter gv val+  return gv++class IsGValue a where+    toGValue :: a -> IO GValue+    fromGValue :: GValue -> IO a++instance IsGValue (Maybe String) where+    toGValue = buildGValue gtypeString set_string . fmap pack+    fromGValue v = (fmap unpack) <$> get_string v++instance IsGValue (Maybe Text) where+    toGValue = buildGValue gtypeString set_string+    fromGValue = get_string++instance IsGValue (Ptr a) where+    toGValue = buildGValue gtypePointer set_pointer+    fromGValue = get_pointer++instance IsGValue Int32 where+    toGValue = buildGValue gtypeInt set_int32+    fromGValue = get_int32++instance IsGValue Word32 where+    toGValue = buildGValue gtypeUInt set_uint32+    fromGValue = get_uint32++instance IsGValue CInt where+    toGValue = buildGValue gtypeInt set_int+    fromGValue = get_int++instance IsGValue CUInt where+    toGValue = buildGValue gtypeUInt set_uint+    fromGValue = get_uint++instance IsGValue CLong where+    toGValue = buildGValue gtypeLong set_long+    fromGValue = get_long++instance IsGValue CULong where+    toGValue = buildGValue gtypeULong set_ulong+    fromGValue = get_ulong++instance IsGValue Int64 where+    toGValue = buildGValue gtypeInt64 set_int64+    fromGValue = get_int64++instance IsGValue Word64 where+    toGValue = buildGValue gtypeUInt64 set_uint64+    fromGValue = get_uint64++instance IsGValue Float where+    toGValue = buildGValue gtypeFloat set_float+    fromGValue = get_float++instance IsGValue Double where+    toGValue = buildGValue gtypeDouble set_double+    fromGValue = get_double++instance IsGValue Bool where+    toGValue = buildGValue gtypeBoolean set_boolean+    fromGValue = get_boolean++instance IsGValue GType where+    toGValue = buildGValue gtypeGType set_gtype+    fromGValue = get_gtype++foreign import ccall "g_value_set_string" _set_string ::+    Ptr GValue -> CString -> IO ()+foreign import ccall "g_value_get_string" _get_string ::+    Ptr GValue -> IO CString++set_string :: GValue -> Maybe Text -> IO ()+set_string gv maybeStr =+    withManagedPtr gv $ \ptr -> do+      cstr <- case maybeStr of+                Just str -> textToCString str+                Nothing -> return nullPtr+      _set_string ptr cstr+      freeMem cstr++get_string :: GValue -> IO (Maybe Text)+get_string gv = withManagedPtr gv $ \gvptr -> do+                  cstr <- _get_string gvptr+                  if cstr /= nullPtr+                  then Just <$> cstringToText cstr+                  else return Nothing++foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::+    Ptr GValue -> IO (Ptr b)++set_pointer :: GValue -> Ptr a -> IO ()+set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr++get_pointer :: GValue -> IO (Ptr b)+get_pointer gv = withManagedPtr gv _get_pointer++foreign import ccall unsafe "g_value_set_int" _set_int ::+    Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_int" _get_int ::+    Ptr GValue -> IO CInt++set_int32 :: GValue -> Int32 -> IO ()+set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n)++get_int32 :: GValue -> IO Int32+get_int32 gv = coerce <$> withManagedPtr gv _get_int++set_int :: GValue -> CInt -> IO ()+set_int gv n = withManagedPtr gv $ flip _set_int n++get_int :: GValue -> IO CInt+get_int gv = withManagedPtr gv _get_int++foreign import ccall unsafe "g_value_set_uint" _set_uint ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_uint" _get_uint ::+    Ptr GValue -> IO CUInt++set_uint32 :: GValue -> Word32 -> IO ()+set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n)++get_uint32 :: GValue -> IO Word32+get_uint32 gv = coerce <$> withManagedPtr gv _get_uint++set_uint :: GValue -> CUInt -> IO ()+set_uint gv n = withManagedPtr gv $ flip _set_uint n++get_uint :: GValue -> IO CUInt+get_uint gv = withManagedPtr gv _get_uint++foreign import ccall unsafe "g_value_set_long" _set_long ::+    Ptr GValue -> CLong -> IO ()+foreign import ccall unsafe "g_value_get_long" _get_long ::+    Ptr GValue -> IO CLong++set_long :: GValue -> CLong -> IO ()+set_long gv n = withManagedPtr gv $ flip _set_long n++get_long :: GValue -> IO CLong+get_long gv = withManagedPtr gv _get_long++foreign import ccall unsafe "g_value_set_ulong" _set_ulong ::+    Ptr GValue -> CULong -> IO ()+foreign import ccall unsafe "g_value_get_ulong" _get_ulong ::+    Ptr GValue -> IO CULong++set_ulong :: GValue -> CULong -> IO ()+set_ulong gv n = withManagedPtr gv $ flip _set_ulong n++get_ulong :: GValue -> IO CULong+get_ulong gv = withManagedPtr gv _get_ulong++foreign import ccall unsafe "g_value_set_int64" _set_int64 ::+    Ptr GValue -> Int64 -> IO ()+foreign import ccall unsafe "g_value_get_int64" _get_int64 ::+    Ptr GValue -> IO Int64++set_int64 :: GValue -> Int64 -> IO ()+set_int64 gv n = withManagedPtr gv $ flip _set_int64 n++get_int64 :: GValue -> IO Int64+get_int64 gv = withManagedPtr gv _get_int64++foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::+    Ptr GValue -> Word64 -> IO ()+foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::+    Ptr GValue -> IO Word64++set_uint64 :: GValue -> Word64 -> IO ()+set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n++get_uint64 :: GValue -> IO Word64+get_uint64 gv = withManagedPtr gv _get_uint64++foreign import ccall unsafe "g_value_set_float" _set_float ::+    Ptr GValue -> CFloat -> IO ()+foreign import ccall unsafe "g_value_get_float" _get_float ::+    Ptr GValue -> IO CFloat++set_float :: GValue -> Float -> IO ()+set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)++get_float :: GValue -> IO Float+get_float gv = realToFrac <$> withManagedPtr gv _get_float++foreign import ccall unsafe "g_value_set_double" _set_double ::+    Ptr GValue -> CDouble -> IO ()+foreign import ccall unsafe "g_value_get_double" _get_double ::+    Ptr GValue -> IO CDouble++set_double :: GValue -> Double -> IO ()+set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)++get_double :: GValue -> IO Double+get_double gv = realToFrac <$> withManagedPtr gv _get_double++foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::+    Ptr GValue -> CInt -> IO ()+foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::+    Ptr GValue -> IO CInt++set_boolean :: GValue -> Bool -> IO ()+set_boolean gv b = withManagedPtr gv $ \ptr ->+                   _set_boolean ptr (fromIntegral $ fromEnum b)++get_boolean :: GValue -> IO Bool+get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr++foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::+    Ptr GValue -> CGType -> IO ()+foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::+    Ptr GValue -> IO CGType++set_gtype :: GValue -> GType -> IO ()+set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g++get_gtype :: GValue -> IO GType+get_gtype gv = GType <$> withManagedPtr gv _get_gtype++foreign import ccall "g_value_set_object" _set_object ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_object" _get_object ::+    Ptr GValue -> IO (Ptr a)++set_object :: GObject a => GValue -> Ptr a -> IO ()+set_object gv o = withManagedPtr gv $ flip _set_object o++get_object :: GObject b => GValue -> IO (Ptr b)+get_object gv = withManagedPtr gv _get_object++foreign import ccall "g_value_set_boxed" _set_boxed ::+    Ptr GValue -> Ptr a -> IO ()+foreign import ccall "g_value_get_boxed" _get_boxed ::+    Ptr GValue -> IO (Ptr b)++set_boxed :: GValue -> Ptr a -> IO ()+set_boxed gv b = withManagedPtr gv $ flip _set_boxed b++get_boxed :: GValue -> IO (Ptr b)+get_boxed gv = withManagedPtr gv _get_boxed++foreign import ccall "g_value_set_variant" _set_variant ::+    Ptr GValue -> Ptr GVariant -> IO ()+foreign import ccall "g_value_get_variant" _get_variant ::+    Ptr GValue -> IO (Ptr GVariant)++set_variant :: GValue -> Ptr GVariant -> IO ()+set_variant gv v = withManagedPtr gv $ flip _set_variant v++get_variant :: GValue -> IO (Ptr GVariant)+get_variant gv = withManagedPtr gv _get_variant++foreign import ccall unsafe "g_value_set_enum" _set_enum ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_enum" _get_enum ::+    Ptr GValue -> IO CUInt++set_enum :: GValue -> CUInt -> IO ()+set_enum gv e = withManagedPtr gv $ flip _set_enum e++get_enum :: GValue -> IO CUInt+get_enum gv = withManagedPtr gv _get_enum++foreign import ccall unsafe "g_value_set_flags" _set_flags ::+    Ptr GValue -> CUInt -> IO ()+foreign import ccall unsafe "g_value_get_flags" _get_flags ::+    Ptr GValue -> IO CUInt++set_flags :: GValue -> CUInt -> IO ()+set_flags gv f = withManagedPtr gv $ flip _set_flags f++get_flags :: GValue -> IO CUInt+get_flags gv = withManagedPtr gv _get_flags

@@ -0,0 +1,977 @@+{-# 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 <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+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+import Data.Monoid ((<>))+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+-- <https://developer.gnome.org/glib/stable/glib-GVariantType.html>+-- 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+      mapM ((g_variant_get_child_value vptr) >=> wrapGVariantPtr)+               [0..(n_children-1)]++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_children+                     >=> return . head+                     >=> 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+  if isJust maybeChildren+  then do+    let (Just [a1,a2]) = maybeChildren+    (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2+    return $ if isJust ma1 && isJust ma2+             then Just (fromJust ma1, fromJust ma2)+             else Nothing+  else return Nothing++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+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3]) = maybeChildren+    (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1+                            <*> fromGVariant a2+                            <*> fromGVariant a3+    return $ if isJust ma1 && isJust ma2 && isJust ma3+             then Just (fromJust ma1, fromJust ma2, fromJust ma3)+             else Nothing+  else return Nothing++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+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3,a4]) = maybeChildren+    (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1+                                 <*> fromGVariant a2+                                 <*> fromGVariant a3+                                 <*> fromGVariant a4+    return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4+             then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4)+             else Nothing+  else return Nothing++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+  if isJust maybeChildren+  then do+    let (Just [a1,a2,a3,a4,a5]) = maybeChildren+    (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1+                                        <*> fromGVariant a2+                                        <*> fromGVariant a3+                                        <*> fromGVariant a4+                                        <*> fromGVariant a5+    return $ if isJust ma1 && isJust ma2 && isJust ma3 &&+                              isJust ma4 && isJust ma5+             then Just (fromJust ma1, fromJust ma2, fromJust ma3,+                        fromJust ma4, fromJust ma5)+             else Nothing+  else return Nothing

@@ -0,0 +1,353 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+-- For HasCallStack compatibility+{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-}++-- | 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'+    , withManagedPtr+    , maybeWithManagedPtr+    , withManagedPtrList+    , unsafeManagedPtrGetPtr+    , unsafeManagedPtrCastPtr+    , touchManagedPtr+    , disownManagedPtr++    -- * Safe casting+    , castTo+    , unsafeCastTo++    -- * Wrappers+    , newObject+    , wrapObject+    , unrefObject+    , disownObject+    , newBoxed+    , wrapBoxed+    , copyBoxedPtr+    , freeBoxed+    , disownBoxed+    , wrapPtr+    , newPtr+    , copyPtr+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (when, void)++import Data.Coerce (coerce)+import Data.IORef (newIORef, readIORef, writeIORef, IORef)++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.Utils++import System.IO (hPutStrLn, stderr)++#if MIN_VERSION_base(4,9,0)+import GHC.Stack (HasCallStack, prettyCallStack, callStack)+#elif MIN_VERSION_base(4,8,1)+import GHC.Stack (CallStack)+import GHC.Exts (Constraint)+type HasCallStack = ((?callStack :: CallStack) :: Constraint)+#else+import GHC.Exts (Constraint)+type HasCallStack = (() :: Constraint)+#endif++-- | Thin wrapper over `Foreign.Concurrent.newForeignPtr`.+newManagedPtr :: Ptr a -> IO () -> IO (ManagedPtr a)+newManagedPtr ptr finalizer = do+  let ownedFinalizer :: IORef Bool -> IO ()+      ownedFinalizer boolRef = do+        owned <- readIORef boolRef+        when owned finalizer+  isOwnedRef <- newIORef True+  fPtr <- FC.newForeignPtr ptr (ownedFinalizer isOwnedRef)+  return $ ManagedPtr {+               managedForeignPtr = fPtr+             , managedPtrIsOwned = isOwnedRef+             }++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' :: 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+  isOwnedRef <- newIORef True+  fPtr <- newForeignPtr_ ptr+  return $ ManagedPtr {+               managedForeignPtr = fPtr+             , managedPtrIsOwned = isOwnedRef+             }++-- | Do not run the finalizers upon garbage collection of the `ManagedPtr`.+disownManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO (Ptr a)+disownManagedPtr managed = do+  ptr <- unsafeManagedPtrGetPtr managed+  writeIORef (managedPtrIsOwned c) False+  return ptr+    where c = coerce managed :: ManagedPtr ()++-- | Perform an IO action on the 'Ptr' inside a managed pointer.+withManagedPtr :: 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 :: ManagedPtrNewtype a => Maybe a -> (Ptr a -> IO c) -> IO c+maybeWithManagedPtr Nothing action = action nullPtr+maybeWithManagedPtr (Just managed) action = do+  ptr <- unsafeManagedPtrGetPtr managed+  result <- action ptr+  touchManagedPtr managed+  return result++-- | Perform an IO action taking a list of 'Ptr' on a list of managed+-- pointers.+withManagedPtrList :: 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++-- | 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 = coerce m :: ManagedPtr ()+        ptr = (castPtr . unsafeForeignPtrToPtr . managedForeignPtr) c+    owned <- readIORef (managedPtrIsOwned c)+    when (not owned) (notOwnedWarning ptr)+    return ptr++-- | Print a warning when we try to access a disowned foreign ptr.+notOwnedWarning :: HasCallStack => Ptr a -> IO ()+notOwnedWarning ptr = do+  hPutStrLn stderr ("Accessing a disowned pointer <" ++ show ptr+                     ++ ">, this may lead to crashes.\n"+                     ++ callstack)+  where+#if MIN_VERSION_base(4,9,0)+    callstack = prettyCallStack (callStack)+#else+    callstack = "<CallStack only available with GHC 8.0>"+#endif++-- | 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 = coerce m :: ManagedPtr ()+                    in (touchForeignPtr . managedForeignPtr) c++-- Safe casting machinery+foreign import ccall unsafe "check_object_type"+    c_check_object_type :: Ptr o -> CGType -> CInt++-- | Cast to the given type, checking that the cast is valid. If it is+-- not, we return `Nothing`. Usage:+--+-- > maybeWidget <- castTo Widget label+castTo :: forall o o'. (GObject o, GObject o') =>+          (ManagedPtr o' -> o') -> o -> IO (Maybe o')+castTo constructor obj =+    withManagedPtr obj $ \objPtr -> do+      GType t <- gobjectType (undefined :: o')+      if c_check_object_type objPtr t /= 1+        then return Nothing+        else Just <$> newObject constructor objPtr++-- | Cast to the given type, assuming that the cast will succeed. This+-- function will call `error` if the cast is illegal.+unsafeCastTo :: forall o o'. (HasCallStack, GObject o, GObject o') =>+                (ManagedPtr o' -> o') -> o -> IO o'+unsafeCastTo constructor obj =+  withManagedPtr obj $ \objPtr -> do+    GType t <- gobjectType (undefined :: o')+    if c_check_object_type objPtr t /= 1+      then do+      srcType <- gobjectType obj >>= gtypeName+      destType <- gobjectType (undefined :: o') >>= gtypeName+      error $ "unsafeCastTo :: invalid conversion from " ++ srcType ++ " to "+        ++ destType ++ " requested."+      else newObject constructor objPtr++-- 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" g_object_ref ::+    Ptr a -> IO (Ptr a)++-- | Construct a Haskell wrapper for a 'GObject', increasing its+-- reference count.+newObject :: (GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a+newObject constructor ptr = do+  void $ g_object_ref ptr+  fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr+  return $! constructor fPtr++foreign import ccall "g_object_ref_sink" g_object_ref_sink ::+    Ptr a -> IO (Ptr a)++-- | Same as 'newObject', but we take ownership of the object. Newly+-- created 'GObject's are typically floating, so we use+-- <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#g-object-ref-sink g_object_ref_sink>.++-- Notice that the+-- semantics here are a little bit subtle: some objects (such as+-- GtkWindow, see the code about "user_ref_count" in gtkwindow.c in+-- the gtk+ distribution) are created /without/ the floating flag,+-- since they own a reference to themselves. So, wrapping them is+-- really about adding a ref. If we add the ref, when Haskell drops+-- the last ref to the 'GObject' it will /g_object_unref/, and the+-- window will /g_object_unref/ itself upon destruction, so by the end+-- we don't leak memory. If we don't add the ref, there will be two+-- /g_object_unrefs/ acting on the object (one from Haskell and one from+-- the GtkWindow destroy) when the object is destroyed and the second+-- one will give a segfault.+--+-- This is the story for GInitiallyUnowned objects (e.g. anything that+-- is a descendant from GtkWidget). For objects that are not initially+-- floating (i.e. not descendents of GInitiallyUnowned) we simply take+-- control of the reference.+wrapObject :: forall a b. (GObject a, GObject b) =>+              (ManagedPtr a -> a) -> Ptr b -> IO a+wrapObject constructor ptr = do+  when (gobjectIsInitiallyUnowned (undefined :: a)) $+       void $ g_object_ref_sink ptr+  fPtr <- newManagedPtr' ptr_to_g_object_unref $ castPtr ptr+  return $! constructor fPtr+++foreign import ccall "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 :: GObject a => a -> IO ()+unrefObject obj = withManagedPtr obj dbg_g_object_unref++-- | 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 :: GObject a => a -> IO (Ptr b)+disownObject obj = withManagedPtr obj $ \ptr -> do+                     dbg_g_object_disown ptr+                     castPtr <$> disownManagedPtr obj++foreign import ccall "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. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a+newBoxed constructor ptr = do+  GType gtype <- boxedType (undefined :: 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. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapBoxed constructor ptr = do+  GType gtype <- boxedType (undefined :: a)+  fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr)+  return $! constructor fPtr++-- | Like 'copyBoxed', but acting directly on a pointer, instead of a+-- managed pointer.+copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a)+copyBoxedPtr ptr = do+  GType gtype <- boxedType (undefined :: 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+freeBoxed :: forall a. BoxedObject a => a -> IO ()+freeBoxed boxed = do+  GType gtype <- boxedType (undefined :: a)+  ptr <- unsafeManagedPtrGetPtr boxed+  g_boxed_free gtype ptr+  touchManagedPtr boxed++-- | Disown a boxed object, that is, do not free the associated+-- foreign GBoxed when the Haskell object gets garbage+-- collected. Returns the pointer to the underlying `BoxedObject`.+disownBoxed :: BoxedObject a => a -> IO (Ptr a)+disownBoxed = disownManagedPtr++-- | Wrap a pointer, taking ownership of it.+wrapPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapPtr constructor ptr = do+  fPtr <- case wrappedPtrFree of+            Nothing -> newManagedPtr_ ptr+            Just finalizer -> newManagedPtr' finalizer ptr+  return $! constructor fPtr++-- | Wrap a pointer, making a copy of the data.+newPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a+newPtr constructor ptr = do+  ptr' <- wrappedPtrCopy ptr+  fPtr <- case wrappedPtrFree of+            Nothing -> newManagedPtr_ ptr+            Just finalizer -> newManagedPtr' finalizer ptr'+  return $! constructor fPtr++-- | Make a copy of a wrapped pointer using @memcpy@ into a freshly+-- allocated memory region of the given size.+copyPtr :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a)+copyPtr size ptr = do+  ptr' <- wrappedPtrCalloc+  memcpy ptr' ptr size+  return ptr'

@@ -0,0 +1,263 @@+{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, PolyKinds,+             TypeFamilies, UndecidableInstances, EmptyDataDecls,+             MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}++-- | Helpers for dealing with `GObject`s.++module Data.GI.Base.Overloading+    ( -- * Type level inheritance+      ParentTypes+    , IsDescendantOf+#if MIN_VERSION_base(4,9,0)+    , UnknownAncestorError+#endif++    -- * 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+    , MethodInfo(..)+    , MethodProxy(..)+    , MethodResolutionFailed++    -- * Overloaded labels+    , IsLabelProxy(..)++#if MIN_VERSION_base(4,9,0)+    , module GHC.OverloadedLabels       -- Reexported for convenience+#endif+    ) where++import GHC.Exts (Constraint)+import GHC.TypeLits+import Data.Proxy (Proxy)++#if MIN_VERSION_base(4,9,0)+import GHC.OverloadedLabels (IsLabel(..))+#endif++-- | Support for overloaded labels in ghc < 8.0. This is like the+-- `IsLabel` class introduced in ghc 8.0 (for use with the+-- OverloadedLabels extension) with the difference that the `Proxy`+-- argument is lifted. (Using the unlifted Proxy# type in user code is+-- a bit of a pain, hence the choice.)+class IsLabelProxy (x :: Symbol) a where+  fromLabelProxy :: Proxy x -> a++-- | Join two lists.+type family JoinLists (as :: [a]) (bs :: [a]) :: [a] where+    JoinLists '[] bs = bs+    JoinLists (a ': as) bs = a ': JoinLists as bs++-- | Look in the given list of (symbol, tag) tuples for the tag+-- corresponding to the given symbol. If not found raise the given+-- type error.+type family FindElement (m :: Symbol) (ms :: [(Symbol, *)])+#if !MIN_VERSION_base(4,9,0)+    (typeError :: *)+#else+    (typeError :: ErrorMessage)+#endif+    :: * where+    FindElement m '[] typeError =+#if !MIN_VERSION_base(4,9,0)+        typeError+#else+        TypeError typeError+#endif+    FindElement m ('(m, o) ': ms) typeError = o+    FindElement m ('(m', o) ': ms) typeError = FindElement m ms typeError++-- | Result of a ancestor check. Basically a Bool type with a bit of+-- extra info in order to improve typechecker error messages.+data AncestorCheck t a = HasAncestor a t+#if !MIN_VERSION_base(4,9,0)+                       | DoesNotHaveRequiredAncestor Symbol t Symbol a+#endif++#if MIN_VERSION_base(4,9,0)+-- | Type error to be generated when an ancestor check fails.+type family UnknownAncestorError (a :: *) (t :: *) where+    UnknownAncestorError a t =+        TypeError ('Text "Required ancestor ‘" ':<>: 'ShowType a+                   ':<>: 'Text "’ not found for type ‘"+                   ':<>: 'ShowType t ':<>: 'Text "’.")+#endif++-- | Check whether a type appears in a list. We specialize the+-- names/types a bit so the error messages are more informative.+type family CheckForAncestorType t (a :: *) (as :: [*]) :: AncestorCheck * * where+    CheckForAncestorType t a '[] =+#if !MIN_VERSION_base(4,9,0)+        'DoesNotHaveRequiredAncestor "Error: Required ancestor" a "not found for type" t+#else+        UnknownAncestorError a t+#endif+    CheckForAncestorType t a (a ': as) = 'HasAncestor a t+    CheckForAncestorType t a (b ': as) = CheckForAncestorType t a as++-- | Check that a type is in the list of `GObjectParents` of another+-- `GObject`-derived type.+type family IsDescendantOf (parent :: *) (descendant :: *) :: Constraint where+    -- Every object is defined to be a descendant of itself.+    IsDescendantOf d d = () ~ ()+    IsDescendantOf p d = CheckForAncestorType d p (ParentTypes d) ~ 'HasAncestor p d++-- | The direct parents of this object: its direct parent type, if any,+-- and the interfaces it implements. The interfaces inherited from+-- parent types can be omitted.+type family ParentTypes a :: [*]++-- | The list of attributes defined for a given type. Each element of+-- the list is a tuple, with the first element of the tuple the name+-- of the attribute, and the second the type encoding the information+-- of the attribute. This type will be an instance of `AttrInfo`.+type family AttributeList a :: [(Symbol, *)]++-- | A constraint on a type, to be fulfilled whenever it has a type+-- instance for `AttributeList`. This is here for nicer error+-- reporting.+class HasAttributeList a++#if MIN_VERSION_base(4,9,0)+-- Default instance, which will give rise to an error for types+-- without an associated `AttributeList`.+instance {-# OVERLAPPABLE #-}+    TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:+               'Text "’ does not have any known attributes.")+    => HasAttributeList a+#endif++#if !MIN_VERSION_base(4,9,0)+-- | Datatype returned when the attribute is not found, hopefully making+-- the resulting error messages somewhat clearer.+data UnknownAttribute (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)+#endif++-- | Return the type encoding the attribute information for a given+-- type and attribute.+type family ResolveAttribute (s :: Symbol) (o :: *) :: * where+    ResolveAttribute s o = FindElement s (AttributeList o)+#if !MIN_VERSION_base(4,9,0)+                           (UnknownAttribute "Error: could not find attribute" s "for object" o)+#else+                           ('Text "Unknown attribute ‘" ':<>:+                            'Text s ':<>: 'Text "’ for object ‘" ':<>:+                            'ShowType o ':<>: 'Text "’.")+#endif++-- | Whether a given type is in the given list. If found, return+-- @success@, otherwise return @failure@.+type family IsElem (e :: Symbol) (es :: [(Symbol, *)]) (success :: k)+#if !MIN_VERSION_base(4,9,0)+    (failure :: k)+#else+    (failure :: ErrorMessage)+#endif+        :: k where+    IsElem e '[] success failure =+#if !MIN_VERSION_base(4,9,0)+        failure+#else+        TypeError failure+#endif+    IsElem e ( '(e, t) ': es) success failure = success+    IsElem e ( '(other, t) ': es) s f = IsElem e es s f++-- | Isomorphic to Bool, but having some extra debug information.+data AttributeCheck a t = HasAttribute+#if !MIN_VERSION_base(4,9,0)+                        | DoesNotHaveAttribute Symbol a Symbol t+#endif++-- | A constraint imposing that the given object has the given attribute.+type family HasAttribute (attr :: Symbol) (o :: *) where+    HasAttribute attr o = IsElem attr (AttributeList o)+                          'HasAttribute+#if !MIN_VERSION_base(4,9,0)+                          ('DoesNotHaveAttribute "Error: attribute" attr "not found for type" o)+#else+                          ('Text "Attribute ‘" ':<>: 'Text attr ':<>:+                           'Text "’ not found for type ‘" ':<>:+                           'ShowType o ':<>: 'Text "’.")+#endif+                          ~ 'HasAttribute++-- | A constraint that enforces that the given type has a given attribute.+class HasAttr (attr :: Symbol) (o :: *)+instance HasAttribute attr o => HasAttr attr o++-- | The list of signals defined for a given type. Each element of+-- the list is a tuple, with the first element of the tuple the name+-- of the signal, and the second the type encoding the information of+-- the signal. This type will be an instance of `SignalInfo`.+type family SignalList a :: [(Symbol, *)]++#if !MIN_VERSION_base(4,9,0)+-- | Datatype returned when the signal is not found, hopefully making+-- the resulting error messages somewhat clearer.+data UnknownSignal (msg1 :: Symbol) (s :: Symbol) (msg2 :: Symbol) (o :: *)+#endif++-- | Return the type encoding the signal information for a given+-- type and signal.+type family ResolveSignal (s :: Symbol) (o :: *) :: * where+    ResolveSignal s o = FindElement s (SignalList o)+#if !MIN_VERSION_base(4,9,0)+                        (UnknownSignal "Error: could not find signal" s "for object" o)+#else+                        ('Text "Unknown signal ‘" ':<>:+                         'Text s ':<>: 'Text "’ for object ‘" ':<>:+                         'ShowType o ':<>: 'Text "’.")+#endif++-- | Isomorphic to Bool, but having some extra debug information.+data SignalCheck s t = HasSignal+#if !MIN_VERSION_base(4,9,0)+                     | DoesNotHaveSignal Symbol s Symbol t+#endif++-- | A constraint enforcing that the signal exists for the given+-- object, or one of its ancestors.+type family HasSignal (s :: Symbol) (o :: *) where+    HasSignal s o = IsElem s (SignalList o)+                    'HasSignal+#if !MIN_VERSION_base(4,9,0)+                    ('DoesNotHaveSignal "Error: signal" s "not found for type" o)+#else+                    ('Text "Signal ‘" ':<>: 'Text s ':<>:+                     'Text "’ not found for type ‘" ':<>:+                     'ShowType o ':<>: 'Text "’.")+#endif+                    ~ 'HasSignal++-- | Class for types containing the information about an overloaded+-- method of type `o -> s`.+class MethodInfo i o s where+    overloadedMethod :: MethodProxy i -> o -> s++-- | Proxy for passing a type to `overloadedMethod`. We do not use+-- `Data.Proxy.Proxy` directly since it clashes with types defined in+-- the autogenerated bindings.+data MethodProxy a = MethodProxy++#if !MIN_VERSION_base(4,9,0)+-- | Datatype returned when the method is not found, hopefully making+-- the resulting error messages somewhat clearer.+data MethodResolutionFailed (label :: Symbol) (o :: *)+#else+type family MethodResolutionFailed (method :: Symbol) (o :: *) where+    MethodResolutionFailed m o =+        TypeError ('Text "Unknown method ‘" ':<>:+                   'Text m ':<>: 'Text "’ for type ‘" ':<>:+                   'ShowType o ':<>: 'Text "’.")+#endif

@@ -0,0 +1,521 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.GI.Base.Properties+    ( setObjectPropertyString+    , setObjectPropertyStringArray+    , setObjectPropertyPtr+    , setObjectPropertyInt+    , setObjectPropertyUInt+    , setObjectPropertyLong+    , setObjectPropertyULong+    , setObjectPropertyInt32+    , setObjectPropertyUInt32+    , setObjectPropertyInt64+    , setObjectPropertyUInt64+    , setObjectPropertyFloat+    , setObjectPropertyDouble+    , setObjectPropertyBool+    , setObjectPropertyGType+    , setObjectPropertyObject+    , setObjectPropertyBoxed+    , setObjectPropertyEnum+    , setObjectPropertyFlags+    , setObjectPropertyVariant+    , setObjectPropertyByteArray+    , setObjectPropertyPtrGList+    , setObjectPropertyHash++    , getObjectPropertyString+    , getObjectPropertyStringArray+    , getObjectPropertyPtr+    , getObjectPropertyInt+    , getObjectPropertyUInt+    , getObjectPropertyLong+    , getObjectPropertyULong+    , getObjectPropertyInt32+    , getObjectPropertyUInt32+    , getObjectPropertyInt64+    , getObjectPropertyUInt64+    , getObjectPropertyFloat+    , getObjectPropertyDouble+    , getObjectPropertyBool+    , getObjectPropertyGType+    , getObjectPropertyObject+    , getObjectPropertyBoxed+    , getObjectPropertyEnum+    , getObjectPropertyFlags+    , getObjectPropertyVariant+    , getObjectPropertyByteArray+    , getObjectPropertyPtrGList+    , getObjectPropertyHash++    , constructObjectPropertyString+    , constructObjectPropertyStringArray+    , constructObjectPropertyPtr+    , constructObjectPropertyInt+    , constructObjectPropertyUInt+    , constructObjectPropertyLong+    , constructObjectPropertyULong+    , constructObjectPropertyInt32+    , constructObjectPropertyUInt32+    , constructObjectPropertyInt64+    , constructObjectPropertyUInt64+    , constructObjectPropertyFloat+    , constructObjectPropertyDouble+    , constructObjectPropertyBool+    , constructObjectPropertyGType+    , constructObjectPropertyObject+    , constructObjectPropertyBoxed+    , constructObjectPropertyEnum+    , constructObjectPropertyFlags+    , constructObjectPropertyVariant+    , constructObjectPropertyByteArray+    , constructObjectPropertyPtrGList+    , constructObjectPropertyHash+    ) 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.Proxy (Proxy(..))++import Data.GI.Base.BasicTypes+import Data.GI.Base.BasicConversions+import Data.GI.Base.ManagedPtr+import Data.GI.Base.GValue+import Data.GI.Base.GVariant (newGVariantFromPtr)+import Data.GI.Base.Utils (freeMem, convertIfNonNull)++import Foreign (Ptr, Int32, Word32, Int64, Word64, nullPtr)+import Foreign.C (CString, withCString)+import Foreign.C.Types (CInt, CUInt, CLong, CULong)++#include <glib-object.h>++foreign import ccall "g_object_set_property" g_object_set_property ::+    Ptr a -> CString -> Ptr GValue -> IO ()++setObjectProperty :: GObject a => a -> String -> b ->+                     (GValue -> b -> IO ()) -> GType -> IO ()+setObjectProperty obj propName propValue setter (GType gtype) = do+  gvalue <- buildGValue (GType gtype) setter propValue+  withManagedPtr obj $ \objPtr ->+      withCString propName $ \cPropName ->+          withManagedPtr gvalue $ \gvalueptr ->+              g_object_set_property objPtr cPropName gvalueptr++foreign import ccall "g_object_get_property" g_object_get_property ::+    Ptr a -> CString -> Ptr GValue -> IO ()++getObjectProperty :: GObject a => a -> String ->+                     (GValue -> IO b) -> GType -> IO b+getObjectProperty obj propName getter gtype = do+  gvalue <- newGValue gtype+  withManagedPtr obj $ \objPtr ->+      withCString propName $ \cPropName ->+          withManagedPtr gvalue $ \gvalueptr ->+              g_object_get_property objPtr cPropName gvalueptr+  getter gvalue++constructObjectProperty :: String -> b -> (GValue -> b -> IO ()) ->+                           GType -> IO (GValueConstruct o)+constructObjectProperty propName propValue setter gtype = do+  gvalue <- buildGValue gtype setter propValue+  return (GValueConstruct propName gvalue)++setObjectPropertyString :: GObject a =>+                           a -> String -> Maybe Text -> IO ()+setObjectPropertyString obj propName str =+    setObjectProperty obj propName str set_string gtypeString++constructObjectPropertyString :: String -> Maybe Text ->+                                 IO (GValueConstruct o)+constructObjectPropertyString propName str =+    constructObjectProperty propName str set_string gtypeString++getObjectPropertyString :: GObject a =>+                           a -> String -> IO (Maybe Text)+getObjectPropertyString obj propName =+    getObjectProperty obj propName get_string gtypeString++setObjectPropertyPtr :: GObject a =>+                        a -> String -> Ptr b -> IO ()+setObjectPropertyPtr obj propName ptr =+    setObjectProperty obj propName ptr set_pointer gtypePointer++constructObjectPropertyPtr :: String -> Ptr b ->+                              IO (GValueConstruct o)+constructObjectPropertyPtr propName ptr =+    constructObjectProperty propName ptr set_pointer gtypePointer++getObjectPropertyPtr :: GObject a =>+                        a -> String -> IO (Ptr b)+getObjectPropertyPtr obj propName =+    getObjectProperty obj propName get_pointer gtypePointer++setObjectPropertyInt :: GObject a =>+                         a -> String -> CInt -> IO ()+setObjectPropertyInt obj propName int =+    setObjectProperty obj propName int set_int gtypeInt++constructObjectPropertyInt :: String -> CInt ->+                              IO (GValueConstruct o)+constructObjectPropertyInt propName int =+    constructObjectProperty propName int set_int gtypeInt++getObjectPropertyInt :: GObject a => a -> String -> IO CInt+getObjectPropertyInt obj propName =+    getObjectProperty obj propName get_int gtypeInt++setObjectPropertyUInt :: GObject a =>+                          a -> String -> CUInt -> IO ()+setObjectPropertyUInt obj propName uint =+    setObjectProperty obj propName uint set_uint gtypeUInt++constructObjectPropertyUInt :: String -> CUInt ->+                                IO (GValueConstruct o)+constructObjectPropertyUInt propName uint =+    constructObjectProperty propName uint set_uint gtypeUInt++getObjectPropertyUInt :: GObject a => a -> String -> IO CUInt+getObjectPropertyUInt obj propName =+    getObjectProperty obj propName get_uint gtypeUInt++setObjectPropertyLong :: GObject a =>+                         a -> String -> CLong -> IO ()+setObjectPropertyLong obj propName int =+    setObjectProperty obj propName int set_long gtypeLong++constructObjectPropertyLong :: String -> CLong ->+                               IO (GValueConstruct o)+constructObjectPropertyLong propName int =+    constructObjectProperty propName int set_long gtypeLong++getObjectPropertyLong :: GObject a => a -> String -> IO CLong+getObjectPropertyLong obj propName =+    getObjectProperty obj propName get_long gtypeLong++setObjectPropertyULong :: GObject a =>+                          a -> String -> CULong -> IO ()+setObjectPropertyULong obj propName uint =+    setObjectProperty obj propName uint set_ulong gtypeULong++constructObjectPropertyULong :: String -> CULong ->+                                IO (GValueConstruct o)+constructObjectPropertyULong propName uint =+    constructObjectProperty propName uint set_ulong gtypeULong++getObjectPropertyULong :: GObject a => a -> String -> IO CULong+getObjectPropertyULong obj propName =+    getObjectProperty obj propName get_ulong gtypeULong++setObjectPropertyInt32 :: GObject a =>+                          a -> String -> Int32 -> IO ()+setObjectPropertyInt32 obj propName int32 =+    setObjectProperty obj propName int32 set_int32 gtypeInt++constructObjectPropertyInt32 :: String -> Int32 ->+                                IO (GValueConstruct o)+constructObjectPropertyInt32 propName int32 =+    constructObjectProperty propName int32 set_int32 gtypeInt++getObjectPropertyInt32 :: GObject a => a -> String -> IO Int32+getObjectPropertyInt32 obj propName =+    getObjectProperty obj propName get_int32 gtypeInt++setObjectPropertyUInt32 :: GObject a =>+                          a -> String -> Word32 -> IO ()+setObjectPropertyUInt32 obj propName uint32 =+    setObjectProperty obj propName uint32 set_uint32 gtypeUInt++constructObjectPropertyUInt32 :: String -> Word32 ->+                                 IO (GValueConstruct o)+constructObjectPropertyUInt32 propName uint32 =+    constructObjectProperty propName uint32 set_uint32 gtypeUInt++getObjectPropertyUInt32 :: GObject a => a -> String -> IO Word32+getObjectPropertyUInt32 obj propName =+    getObjectProperty obj propName get_uint32 gtypeUInt++setObjectPropertyInt64 :: GObject a =>+                          a -> String -> Int64 -> IO ()+setObjectPropertyInt64 obj propName int64 =+    setObjectProperty obj propName int64 set_int64 gtypeInt64++constructObjectPropertyInt64 :: String -> Int64 ->+                                IO (GValueConstruct o)+constructObjectPropertyInt64 propName int64 =+    constructObjectProperty propName int64 set_int64 gtypeInt64++getObjectPropertyInt64 :: GObject a => a -> String -> IO Int64+getObjectPropertyInt64 obj propName =+    getObjectProperty obj propName get_int64 gtypeInt64++setObjectPropertyUInt64 :: GObject a =>+                          a -> String -> Word64 -> IO ()+setObjectPropertyUInt64 obj propName uint64 =+    setObjectProperty obj propName uint64 set_uint64 gtypeUInt64++constructObjectPropertyUInt64 :: String -> Word64 ->+                                 IO (GValueConstruct o)+constructObjectPropertyUInt64 propName uint64 =+    constructObjectProperty propName uint64 set_uint64 gtypeUInt64++getObjectPropertyUInt64 :: GObject a => a -> String -> IO Word64+getObjectPropertyUInt64 obj propName =+    getObjectProperty obj propName get_uint64 gtypeUInt64++setObjectPropertyFloat :: GObject a =>+                           a -> String -> Float -> IO ()+setObjectPropertyFloat obj propName float =+    setObjectProperty obj propName float set_float gtypeFloat++constructObjectPropertyFloat :: String -> Float ->+                                 IO (GValueConstruct o)+constructObjectPropertyFloat propName float =+    constructObjectProperty propName float set_float gtypeFloat++getObjectPropertyFloat :: GObject a =>+                           a -> String -> IO Float+getObjectPropertyFloat obj propName =+    getObjectProperty obj propName get_float gtypeFloat++setObjectPropertyDouble :: GObject a =>+                            a -> String -> Double -> IO ()+setObjectPropertyDouble obj propName double =+    setObjectProperty obj propName double set_double gtypeDouble++constructObjectPropertyDouble :: String -> Double ->+                                  IO (GValueConstruct o)+constructObjectPropertyDouble propName double =+    constructObjectProperty propName double set_double gtypeDouble++getObjectPropertyDouble :: GObject a =>+                            a -> String -> IO Double+getObjectPropertyDouble obj propName =+    getObjectProperty obj propName get_double gtypeDouble++setObjectPropertyBool :: GObject a =>+                         a -> String -> Bool -> IO ()+setObjectPropertyBool obj propName bool =+    setObjectProperty obj propName bool set_boolean gtypeBoolean++constructObjectPropertyBool :: String -> Bool -> IO (GValueConstruct o)+constructObjectPropertyBool propName bool =+    constructObjectProperty propName bool set_boolean gtypeBoolean++getObjectPropertyBool :: GObject a => a -> String -> IO Bool+getObjectPropertyBool obj propName =+    getObjectProperty obj propName get_boolean gtypeBoolean++setObjectPropertyGType :: GObject a =>+                         a -> String -> GType -> IO ()+setObjectPropertyGType obj propName gtype =+    setObjectProperty obj propName gtype set_gtype gtypeGType++constructObjectPropertyGType :: String -> GType -> IO (GValueConstruct o)+constructObjectPropertyGType propName bool =+    constructObjectProperty propName bool set_gtype gtypeGType++getObjectPropertyGType :: GObject a => a -> String -> IO GType+getObjectPropertyGType obj propName =+    getObjectProperty obj propName get_gtype gtypeGType++setObjectPropertyObject :: forall a b. (GObject a, GObject b) =>+                           a -> String -> Maybe b -> IO ()+setObjectPropertyObject obj propName maybeObject = do+  gtype <- gobjectType (undefined :: b)+  maybeWithManagedPtr maybeObject $ \objectPtr ->+      setObjectProperty obj propName objectPtr set_object gtype++constructObjectPropertyObject :: forall a o. GObject a =>+                                 String -> Maybe a -> IO (GValueConstruct o)+constructObjectPropertyObject propName maybeObject = do+  gtype <- gobjectType (undefined :: a)+  maybeWithManagedPtr maybeObject $ \objectPtr ->+      constructObjectProperty propName objectPtr set_object gtype++getObjectPropertyObject :: forall a b. (GObject a, GObject b) =>+                           a -> String -> (ManagedPtr b -> b) -> IO (Maybe b)+getObjectPropertyObject obj propName constructor = do+  gtype <- gobjectType (undefined :: b)+  getObjectProperty obj propName+                        (\val -> (get_object val :: IO (Ptr b))+                            >>= flip convertIfNonNull (newObject constructor))+                      gtype++setObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+                          a -> String -> Maybe b -> IO ()+setObjectPropertyBoxed obj propName maybeBoxed = do+  gtype <- boxedType (undefined :: b)+  maybeWithManagedPtr maybeBoxed $ \boxedPtr ->+        setObjectProperty obj propName boxedPtr set_boxed gtype++constructObjectPropertyBoxed :: forall a o. (BoxedObject a) =>+                                String -> Maybe a -> IO (GValueConstruct o)+constructObjectPropertyBoxed propName maybeBoxed = do+  gtype <- boxedType (undefined :: a)+  maybeWithManagedPtr maybeBoxed $ \boxedPtr ->+      constructObjectProperty propName boxedPtr set_boxed gtype++getObjectPropertyBoxed :: forall a b. (GObject a, BoxedObject b) =>+                          a -> String -> (ManagedPtr b -> b) -> IO (Maybe b)+getObjectPropertyBoxed obj propName constructor = do+  gtype <- boxedType (undefined :: 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 :: (GObject a, Enum b, BoxedEnum b) =>+                         a -> String -> b -> IO ()+setObjectPropertyEnum obj propName enum = do+  gtype <- boxedEnumType enum+  let cEnum = (fromIntegral . fromEnum) enum+  setObjectProperty obj propName cEnum set_enum gtype++constructObjectPropertyEnum :: (Enum a, BoxedEnum a) =>+                               String -> a -> IO (GValueConstruct o)+constructObjectPropertyEnum propName enum = do+  gtype <- boxedEnumType enum+  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 <- boxedEnumType (undefined :: 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 <- boxedFlagsType (Proxy :: Proxy b)+  setObjectProperty obj propName cFlags set_flags gtype++constructObjectPropertyFlags :: forall a o. (IsGFlag a, BoxedFlags a)+                                => String -> [a] -> IO (GValueConstruct o)+constructObjectPropertyFlags propName flags = do+  let cFlags = gflagsToWord flags+  gtype <- boxedFlagsType (Proxy :: Proxy a)+  constructObjectProperty propName cFlags set_flags gtype++getObjectPropertyFlags :: forall a b. (GObject a, IsGFlag b, BoxedFlags b) =>+                          a -> String -> IO [b]+getObjectPropertyFlags obj propName = do+  gtype <- boxedFlagsType (Proxy :: Proxy b)+  getObjectProperty obj propName+                        (\val -> wordToGFlags <$> get_flags val)+                        gtype++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 (get_pointer >=> 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."

@@ -0,0 +1,93 @@+-- | 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.Closure+    , 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.Properties+    , 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+    ) 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.Closure+import Data.GI.Base.Constructible+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.Properties+import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId, SignalInfo(..), GObjectNotifySignalInfo)+import Data.GI.Base.Utils++import GHC.TypeLits (Symbol)

@@ -0,0 +1,170 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Routines for connecting `GObject`s to signals.+module Data.GI.Base.Signals+    ( on+    , after+    , SignalProxy(..)+    , SignalConnectMode(..)+    , connectSignalFunPtr+    , SignalHandlerId+    , SignalInfo(..)+    , GObjectNotifySignalInfo+    ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy(..))++import Foreign+import Foreign.C++import GHC.TypeLits++import Data.GI.Base.Attributes (AttrLabelProxy, AttrInfo(AttrLabel))+import Data.GI.Base.BasicTypes+import Data.GI.Base.GParamSpec (newGParamSpecFromPtr)+import Data.GI.Base.ManagedPtr (withManagedPtr)+import Data.GI.Base.Overloading (ResolveSignal,+                                 IsLabelProxy(..), ResolveAttribute)+import Data.GI.Base.Utils (safeFreeFunPtrPtr)++#if MIN_VERSION_base(4,9,0)+import GHC.OverloadedLabels (IsLabel(..))+#else+import Data.GI.Base.Overloading (HasSignal)+#endif++-- | Type of a `GObject` signal handler id.+type SignalHandlerId = CULong++-- | A class that provides a constraint satisfied by every type.+class NoConstraint a+instance NoConstraint a++-- | Support for overloaded signal connectors.+data SignalProxy (object :: *) (info :: *) where+    SignalProxy :: SignalProxy o info+    PropertyNotify :: (info ~ ResolveAttribute propName o,+                       AttrInfo info,+                       pl ~ AttrLabel info) =>+                      AttrLabelProxy propName ->+                      SignalProxy o (GObjectNotifySignalInfo pl)++-- | Support for overloaded labels.+instance+#if !MIN_VERSION_base(4,9,0)+    -- This gives better error reporting in ghc < 8.0.+       (HasSignal slot object, info ~ ResolveSignal slot object)+#else+       info ~ ResolveSignal slot object+#endif+    => IsLabelProxy slot (SignalProxy object info) where+    fromLabelProxy _ = SignalProxy++#if MIN_VERSION_base(4,9,0)+instance info ~ ResolveSignal slot object =>+    IsLabel slot (SignalProxy object info) where+    fromLabel _ = SignalProxy+#endif++-- | Information about an overloaded signal.+class SignalInfo (info :: *) where+    type HaskellCallbackType info+    -- | Connect a Haskell function to a signal of the given `GObject`,+    -- specifying whether the handler will be called before or after+    -- the default handler.+    connectSignal :: GObject o =>+                     SignalProxy o info ->+                     o ->+                     HaskellCallbackType info ->+                     SignalConnectMode ->+                     IO SignalHandlerId++-- | Whether to connect a handler to a signal with `connectSignal` so+-- that it runs before/after the default handler for the given signal.+data SignalConnectMode = SignalConnectBefore  -- ^ Run before the default handler.+        | SignalConnectAfter -- ^ Run after the default handler.++-- | Same as `connectSignal`, specifying from the beginning that the+-- handler is to be run before the default handler.+--+-- > on = connectSignal SignalConnectBefore+on :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+      object -> SignalProxy object info+             -> HaskellCallbackType info -> m SignalHandlerId+on o p c = liftIO $ connectSignal p o c SignalConnectBefore++-- | Connect a signal to a handler, running the handler after the default one.+--+-- > after = connectSignal SignalConnectAfter+after :: forall object info m.+      (GObject object, MonadIO m, SignalInfo info) =>+      object -> SignalProxy object info+             -> HaskellCallbackType info -> m SignalHandlerId+after o p c = liftIO $ connectSignal p o c SignalConnectAfter++-- Connecting GObjects to signals+foreign import ccall "g_signal_connect_data" g_signal_connect_data ::+    Ptr a ->                            -- instance+    CString ->                          -- detailed_signal+    FunPtr b ->                         -- c_handler+    Ptr () ->                           -- data+    FunPtr c ->                         -- destroy_data+    CUInt ->                            -- connect_flags+    IO SignalHandlerId++-- | Connect a signal to a handler, given as a `FunPtr`.+connectSignalFunPtr :: GObject o =>+                  o -> String -> FunPtr a -> SignalConnectMode -> IO SignalHandlerId+connectSignalFunPtr object signal fn mode = do+  let flags = case mode of+                SignalConnectAfter -> 1+                SignalConnectBefore -> 0+  withCString signal $ \csignal ->+    withManagedPtr object $ \objPtr ->+        g_signal_connect_data objPtr csignal fn (castFunPtrToPtr fn) safeFreeFunPtrPtr flags++-- | Connection information for a "notify" signal indicating that a+-- specific property changed (see `PropertyNotify` for the relevant+-- constructor).+data GObjectNotifySignalInfo (propName :: Symbol)+instance KnownSymbol propName =>+    SignalInfo (GObjectNotifySignalInfo propName) where+  type HaskellCallbackType (GObjectNotifySignalInfo propName) = GObjectNotifyCallback+  connectSignal = connectGObjectNotify (symbolVal (Proxy :: Proxy propName))++-- | Type for a `GObject` `notify` callback.+type GObjectNotifyCallback = GParamSpec -> IO ()++gobjectNotifyCallbackWrapper ::+    GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()+gobjectNotifyCallbackWrapper _cb _ pspec _ = do+    pspec' <- newGParamSpecFromPtr pspec+    _cb  pspec'++type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO ()++foreign import ccall "wrapper"+    mkGObjectNotifyCallback :: GObjectNotifyCallbackC -> IO (FunPtr GObjectNotifyCallbackC)++-- | Connect the given notify callback for a GObject.+connectGObjectNotify :: forall o i. GObject o =>+                        String ->+                        SignalProxy o (i :: *) ->+                        o -> GObjectNotifyCallback ->+                        SignalConnectMode -> IO SignalHandlerId+connectGObjectNotify propName _ obj cb mode = do+  cb' <- mkGObjectNotifyCallback (gobjectNotifyCallbackWrapper cb)+  let signalName = "notify::" ++ propName+  connectSignalFunPtr obj signalName cb' mode

@@ -0,0 +1,200 @@+{-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings #-}+{- | 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+    , maybeReleaseFunPtr+    , checkUnexpectedReturnNULL+    , checkUnexpectedNothing+    ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative, pure, (<$>), (<*>))+#endif+import Control.Exception (throwIO)+import Control.Monad (void)++import qualified Data.Text as T+import Data.Monoid ((<>))+import Data.Word++import Foreign (peek)+import Foreign.C.Types (CSize(..))+import Foreign.Ptr (Ptr, nullPtr, FunPtr, nullFunPtr, freeHaskellFunPtr)+import Foreign.Storable (Storable(..))++import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..),+                                UnexpectedNullPointerReturn(..))++-- | 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. BoxedObject a => Int -> IO (Ptr a)+callocBoxedBytes n = do+  ptr <- callocBytes n+  GType cgtype <- boxedType (undefined :: 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 ())++-- | 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 :: T.Text -> Ptr a -> IO ()+checkUnexpectedReturnNULL fnName ptr+    | ptr == nullPtr =+        throwIO (UnexpectedNullPointerReturn {+                   nullPtrErrorMsg = "Received unexpected nullPtr in \""+                                     <> fnName <> "\"."+                 })+    | otherwise = return ()++-- | An annotated version of `fromJust`, which raises a+-- `UnexpectedNullPointerReturn` in case it encounters a `Nothing`.+checkUnexpectedNothing :: 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 nullPtr in \""+                                     <> fnName <> "\"."+                 })

@@ -0,0 +1,106 @@+#define _GNU_SOURCE++/* GHC's semi-public Rts API */+#include <Rts.h>++#include <stdlib.h>++#include <glib-object.h>++int check_object_type(void *instance, GType type)+{+  int result;++  if (instance != NULL) {+     result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);+  } else {+    result = 0;+    fprintf(stderr, "Check failed: got a null pointer\n");+  }++  return result;+}++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;+}++/* Auxiliary function for freeing boxed types */+void boxed_free_helper (GType gtype, void *boxed)+{+  if (print_debug_info()) {+    fprintf(stderr, "Freeing a boxed object at %p\n", boxed);+    fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));+  }++  g_boxed_free (gtype, boxed);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone\n");+  }+}++void dbg_g_object_disown (GObject *obj)+{+  GType gtype;++  if (print_debug_info()) {+    fprintf(stderr, "Disowning a GObject at %p\n", obj);+    gtype = G_TYPE_FROM_INSTANCE (obj);+    fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));+    fprintf(stderr, "\tIts refcount before disowning is %d\n",+            (int)obj->ref_count);+  }+}++void dbg_g_object_unref (GObject *obj)+{+  GType gtype;++  if (print_debug_info()) {+    fprintf(stderr, "Freeing a GObject at %p\n", obj);+    gtype = G_TYPE_FROM_INSTANCE (obj);+    fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));+    fprintf(stderr, "\tIts refcount before unref is %d\n",+            (int)obj->ref_count);+  }++  g_object_unref(obj);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone\n");+  }+}++gpointer dbg_g_object_newv (GType gtype, guint n_params, GParameter *params)+{+  gpointer result;++  if (print_debug_info()) {+    fprintf(stderr, "Creating a new GObject of type %s\n",+            g_type_name(gtype));+  }++  result = g_object_newv (gtype, n_params, params);++  if (print_debug_info()) {+    fprintf(stderr, "\tdone, got a pointer at %p\n", result);+  }++  return result;+}++/* Same as freeHaskellFunctionPtr, but it does nothing when given a+   null pointer, instead of crashing */+void safeFreeFunPtr(void *ptr)+{+  if (ptr != NULL)+    freeHaskellFunctionPtr(ptr);+}

@@ -1,5 +1,5 @@ name:                haskell-gi-base-version:             0.19+version:             0.20 synopsis:            Foundation for libraries generated by haskell-gi description:         Foundation for libraries generated by haskell-gi homepage:            https://github.com/haskell-gi/haskell-gi-base@@ -20,7 +20,6 @@   location: git://github.com/haskell-gi/haskell-gi-base.git  library-  hs-source-dirs:      src   exposed-modules:     Data.GI.Base,                        Data.GI.Base.Attributes,                        Data.GI.Base.BasicConversions,@@ -56,5 +55,6 @@     ghc-options: -Wall -fwarn-incomplete-patterns    build-tools:         hsc2hs+  cc-options:          -fPIC   extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse-  c-sources:           src/c/hsgclosure.c+  c-sources:           c/hsgclosure.c

@@ -1,33 +0,0 @@-{- |-   == 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.Closure-    , module Data.GI.Base.Constructible-    , module Data.GI.Base.GError-    , module Data.GI.Base.GHashTable-    , module Data.GI.Base.GObject-    , module Data.GI.Base.GValue-    , module Data.GI.Base.GVariant-    , module Data.GI.Base.ManagedPtr-    , module Data.GI.Base.Signals-    ) where--import Data.GI.Base.Attributes (get, set, AttrOp(..))-import Data.GI.Base.BasicConversions-import Data.GI.Base.BasicTypes-import Data.GI.Base.Closure-import Data.GI.Base.Constructible (new)-import Data.GI.Base.GError-import Data.GI.Base.GHashTable-import Data.GI.Base.GObject (new')-import Data.GI.Base.GValue (GValue(..), IsGValue(..))-import Data.GI.Base.GVariant-import Data.GI.Base.ManagedPtr-import Data.GI.Base.Signals (on, after, SignalProxy(PropertyNotify))

@@ -1,364 +0,0 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures,-  TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds,-  UndecidableInstances, FlexibleInstances #-}---- |------ == 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`).------ 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. There is also '::=' and '::~'--- which take the object as an extra parameter.------ Attributes can also be set during construction of a--- `Data.GI.Base.BasicTypes.GObject` using `Data.GI.Base.Properties.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 atributes------ 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 he empty list). This can be overriden 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(..)-  ) where--import Control.Monad.IO.Class (MonadIO, liftIO)--import Data.Proxy (Proxy(..))--import Data.GI.Base.GValue (GValueConstruct)-import Data.GI.Base.Overloading (HasAttributeList,-                                 ResolveAttribute, IsLabelProxy(..))--import GHC.TypeLits-import GHC.Exts (Constraint)--#if MIN_VERSION_base(4,9,0)-import GHC.OverloadedLabels (IsLabel(..))-#endif--infixr 0 :=,:~,:=>,:~>,::=,::~---- | A proxy for attribute labels.-data AttrLabelProxy (a :: Symbol) = AttrLabelProxy---- | Support for overloaded labels.-instance a ~ x => IsLabelProxy x (AttrLabelProxy a) where-    fromLabelProxy _ = AttrLabelProxy--#if MIN_VERSION_base(4,9,0)-instance a ~ x => IsLabel x (AttrLabelProxy a) where-    fromLabel _ = AttrLabelProxy-#endif---- | Info describing an attribute.-class AttrInfo (info :: *) where-    -- | The operations that are allowed on the attribute.-    type AttrAllowedOps info :: [AttrOpTag]-    -- | Constraint on the value being set.-    type AttrSetTypeConstraint info :: * -> Constraint-    -- | Constraint on the type for which we are allowed to-    -- create\/set\/get the attribute.-    type AttrBaseTypeConstraint info :: * -> Constraint-    -- | Type returned by `attrGet`.-    type AttrGetType info-    -- | A string describing the attribute (for error messages).-    type AttrLabel info :: Symbol-    -- | Get the value of the given attribute.-    attrGet :: AttrBaseTypeConstraint info o =>-               Proxy info -> o -> IO (AttrGetType info)-    -- | Set the value of the given attribute, after the object having-    -- the attribute has already been created.-    attrSet :: (AttrBaseTypeConstraint info o,-                AttrSetTypeConstraint info b) =>-               Proxy info -> o -> b -> IO ()-    -- | Set the value of the given attribute to @NULL@ (for nullable-    -- attributes).-    attrClear :: AttrBaseTypeConstraint info o =>-                 Proxy info -> o -> IO ()-    -- | Build a `GValue` representing the attribute.-    attrConstruct :: (AttrBaseTypeConstraint info o,-                      AttrSetTypeConstraint info b) =>-                     Proxy info -> b -> IO (GValueConstruct o)---- | Result of checking whether an op is allowed on an attribute.-data OpAllowed tag attrName =-    OpIsAllowed-#if !MIN_VERSION_base(4,9,0)-        | AttrOpNotAllowed Symbol tag Symbol attrName-#endif---- | Look in the given list to see if the given `AttrOp` is a member,--- if not return an error type.-type family AttrOpIsAllowed (tag :: AttrOpTag) (ops :: [AttrOpTag]) (label :: Symbol) :: OpAllowed AttrOpTag Symbol where-    AttrOpIsAllowed tag '[] label =-#if !MIN_VERSION_base(4,9,0)-        'AttrOpNotAllowed "Error: operation " tag " not allowed for attribute type " label-#else-        TypeError ('Text "Attribute ‘" ':<>: 'Text label ':<>:-                   'Text "’ is not " ':<>:-                   'Text (AttrOpText tag) ':<>: 'Text ".")-#endif-    AttrOpIsAllowed tag (tag ': ops) label = 'OpIsAllowed-    AttrOpIsAllowed tag (other ': ops) label = AttrOpIsAllowed tag ops label---- | Whether a given `AttrOpTag` is allowed on an attribute, given the--- info type.-type family AttrOpAllowed (tag :: AttrOpTag) (info :: *) :: Constraint where-    AttrOpAllowed tag info =-        AttrOpIsAllowed tag (AttrAllowedOps info) (AttrLabel info) ~ 'OpIsAllowed---- | Possible operations on an attribute.-data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear--#if MIN_VERSION_base(4,9,0)--- | A user friendly description of the `AttrOpTag`, useful when--- printing type errors.-type family AttrOpText (tag :: AttrOpTag) :: Symbol where-    AttrOpText 'AttrGet = "gettable"-    AttrOpText 'AttrSet = "settable"-    AttrOpText 'AttrConstruct = "constructible"-    AttrOpText 'AttrClear = "nullable"-#endif---- | 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,-                                     (AttrSetTypeConstraint info) value)---- | Constraint on a @obj@\/@value@ pair so that `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,-                                           (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,-              (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,-              (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,-              AttrOpAllowed 'AttrGet info,-              (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,-              AttrOpAllowed 'AttrGet info,-              (AttrSetTypeConstraint info) b,-              a ~ (AttrGetType info)) =>-             AttrLabelProxy (attr :: Symbol) -> (a -> IO b) -> AttrOp obj tag-    -- Assign a value to an attribute with the object as an argument-    (::=) :: (HasAttributeList obj,-              info ~ ResolveAttribute attr obj,-              AttrInfo info,-              AttrBaseTypeConstraint info obj,-              tag ~ 'AttrSet,-              AttrOpAllowed tag info,-              (AttrSetTypeConstraint info) b) =>-             AttrLabelProxy (attr :: Symbol) -> (obj -> b) -> AttrOp obj tag-    -- Apply an update function to an attribute with the object as an-    -- argument-    (::~) :: (HasAttributeList obj,-              info ~ ResolveAttribute attr obj,-              AttrInfo info,-              AttrBaseTypeConstraint info obj,-              tag ~ 'AttrSet,-              AttrOpAllowed 'AttrSet info,-              AttrOpAllowed 'AttrGet info,-              (AttrSetTypeConstraint info) b,-              a ~ (AttrGetType info)) =>-             AttrLabelProxy (attr :: Symbol) -> (obj -> a -> b) -> 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-   resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)-   resolve _ = Proxy--   app :: AttrOp o 'AttrSet -> IO ()-   app (attr :=  x) = attrSet (resolve attr) obj x-   app (attr :=> x) = x >>= attrSet (resolve attr) obj-   app (attr :~  f) = attrGet (resolve attr) obj >>=-                      \v -> attrSet (resolve attr) obj (f v)-   app (attr :~> f) = attrGet (resolve attr) obj >>= f >>=-                      attrSet (resolve attr) obj-   app (attr ::= f) = attrSet (resolve attr) obj (f obj)-   app (attr ::~ f) = attrGet (resolve attr) obj >>=-                      \v -> attrSet (resolve attr) obj (f obj v)---- | 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,-                                      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 (Proxy :: Proxy 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)---- | 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 (Proxy :: Proxy info) o

@@ -1,595 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# 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.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.GHashTable (GEqualFunc, GHashFunc)-import Data.GI.Base.ManagedPtr (copyBoxedPtr)-import Data.GI.Base.Utils (allocBytes, callocBytes, memcpy, freeMem)--#include <glib-object.h>--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 -> Int -> 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) -> Int -> 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 :: 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 :: 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 :: 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 :: 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 :: CString -> IO String-cstringToString = peekCString--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 :: CString -> IO Text-cstringToText cstr = do-  len <- c_strlen cstr-  let cstrlen = (cstr, fromIntegral len)-  TF.peekCStringLen cstrlen--byteStringToCString :: ByteString -> IO CString-byteStringToCString bs = B.useAsCString bs g_strdup--cstringToByteString :: CString -> IO ByteString-cstringToByteString = B.packCString--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)--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, BoxedObject 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)

@@ -1,206 +0,0 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances,-  DeriveDataTypeable, TypeFamilies, ScopedTypeVariables #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif-#if MIN_VERSION_base(4,9,0)-{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-}-#endif--- | Basic types used in the bindings.-module Data.GI.Base.BasicTypes-    (-      -- * GType related-      module Data.GI.Base.GType         -- reexported for convenience--     -- * Memory management--    , ForeignPtrNewtype-    , BoxedObject(..)-    , BoxedEnum(..)-    , BoxedFlags(..)-    , GObject(..)-    , WrappedPtr(..)-    , UnexpectedNullPointerReturn(..)-    , NullToNothing(..)--    -- * Basic GLib \/ GObject types-    , GVariant(..)-    , GParamSpec(..)--    , GArray(..)-    , GPtrArray(..)-    , GByteArray(..)-    , GHashTable(..)-    , GList(..)-    , g_list_free-    , GSList(..)-    , g_slist_free--    , IsGFlag--    , PtrWrapped(..)-    , GDestroyNotify-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Exception (Exception, catch)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Coerce (Coercible)-import Data.Proxy (Proxy)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Foreign.Ptr (Ptr, FunPtr)-import Foreign.ForeignPtr (ForeignPtr)--#if MIN_VERSION_base(4,9,0)-import GHC.TypeLits-#endif--import Data.GI.Base.GType---- | A constraint ensuring that the given type is coercible to a--- ForeignPtr. It will hold for newtypes of the form------ > newtype Foo = Foo (ForeignPtr Foo)------ which is the typical shape of wrapped 'GObject's.-type ForeignPtrNewtype a = Coercible a (ForeignPtr ())--- Notice that the Coercible here is to ForeignPtr (), instead of--- "ForeignPtr a", which would be the most natural thing. Both are--- representationally equivalent, so this is not a big deal. This is--- to work around a problem in ghc 7.10:--- https://ghc.haskell.org/trac/ghc/ticket/10715---- | Wrapped boxed structures, identified by their `GType`.-class ForeignPtrNewtype a => BoxedObject a where-    boxedType :: a -> IO GType -- This should not use the value of its-                               -- argument.---- | Enums with an associated `GType`.-class BoxedEnum a where-    boxedEnumType :: a -> IO GType---- | Flags with an associated `GType`.-class BoxedFlags a where-    boxedFlagsType :: Proxy a -> IO GType---- | Pointers to structs/unions without an associated `GType`.-class ForeignPtrNewtype a => WrappedPtr a where-    -- | Allocate a zero-initialized block of memory for the given type.-    wrappedPtrCalloc :: IO (Ptr a)-    -- | Make a copy of the given pointer.-    wrappedPtrCopy   :: Ptr a -> IO (Ptr a)-    -- | A pointer to a function for freeing the given pointer, or-    -- `Nothing` is the memory associated to the pointer does not need-    -- to be freed.-    wrappedPtrFree   :: Maybe (FunPtr (Ptr a -> IO ()))---- | A wrapped `GObject`.-class ForeignPtrNewtype a => GObject a where-    -- | Whether the `GObject` is a descendent of <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#GInitiallyUnowned GInitiallyUnowned>.-    gobjectIsInitiallyUnowned :: a -> Bool-    -- | The `GType` for this object.-    gobjectType :: a -> IO GType---- Raise a more understandable type error whenever the `GObject a`--- constraint is imposed on a type which has no such instance. This--- helps in the common case where one passes a wrong type (such as--- `Maybe Widget`) into a function with a `IsWidget a`--- constraint. Without this type error, the resulting type error is--- much less understandable, since GHC complains (at length) about a--- missing type family instance for `ParentTypes`.-#if MIN_VERSION_base(4,9,0)-instance {-# OVERLAPPABLE #-}-    (TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>:-                'Text "’ does not descend from GObject."), ForeignPtrNewtype a)-    => GObject a where-    gobjectIsInitiallyUnowned = undefined-    gobjectType = undefined-#endif---- | 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 (Show, Typeable)--instance Exception UnexpectedNullPointerReturn--type family UnMaybe a :: * where-    UnMaybe (Maybe a) = a-    UnMaybe a         = a--class NullToNothing a where-    -- | Some functions are not marked as having a nullable return type-    -- in the introspection data.  The result is that they currently do-    -- not return a Maybe type.  This functions lets you work around this-    -- in a way that will not break when the introspection data is fixed.-    ---    -- When you want to call a `someHaskellGIFunction` that may return null-    -- wrap the call like this.-    ---    -- > nullToNothing (someHaskellGIFunction x y)-    ---    -- The result will be a Maybe type even if the introspection data has-    -- not been fixed for `someHaskellGIFunction` yet.-    nullToNothing :: MonadIO m => IO a -> m (Maybe (UnMaybe a))--instance-#if MIN_VERSION_base(4,8,0)-    {-# OVERLAPPABLE #-}-#endif-    a ~ UnMaybe a => NullToNothing a where-        nullToNothing f = liftIO $-            (Just <$> f) `catch` (\(_::UnexpectedNullPointerReturn) -> return Nothing)--instance NullToNothing (Maybe a) where-    nullToNothing = liftIO---- | A <https://developer.gnome.org/glib/stable/glib-GVariant.html GVariant>. See "Data.GI.Base.GVariant" for further methods.-newtype GVariant = GVariant (ForeignPtr GVariant)---- | A <https://developer.gnome.org/gobject/stable/gobject-GParamSpec.html GParamSpec>. See "Data.GI.Base.GParamSpec" for further methods.-newtype GParamSpec = GParamSpec (ForeignPtr GParamSpec)---- | An enum usable as a flag for a function.-class Enum a => IsGFlag a---- | A <https://developer.gnome.org/glib/stable/glib-Arrays.html GArray>. 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 <https://developer.gnome.org/glib/stable/glib-Pointer-Arrays.html GPtrArray>. 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 <https://developer.gnome.org/glib/stable/glib-Byte-Arrays.html GByteArray>. 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 <https://developer.gnome.org/glib/stable/glib-Hash-Tables.html GHashTable>. It is mapped to a 'Data.Map.Map' on the Haskell side.-data GHashTable a b = GHashTable (Ptr (GHashTable a b))---- | A <https://developer.gnome.org/glib/stable/glib-Doubly-Linked-Lists.html GList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".-data GList a = GList (Ptr (GList a))---- | A <https://developer.gnome.org/glib/stable/glib-Singly-Linked-Lists.html GSList>, mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions".-data GSList a = GSList (Ptr (GSList a))---- | Some APIs, such as `GHashTable`, pass around scalar types--- wrapped into a pointer. We encode such a type as follows.-newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a}---- | Destroy the memory associated with a given pointer.-type GDestroyNotify a = FunPtr (Ptr a -> IO ())---- | Free the given 'GList'.-foreign import ccall "g_list_free" g_list_free ::-    Ptr (GList a) -> IO ()---- | Free the given 'GSList'.-foreign import ccall "g_slist_free" g_slist_free ::-    Ptr (GSList a) -> IO ()

@@ -1,41 +0,0 @@--- Some helper functions to create closures.-module Data.GI.Base.Closure-    ( Closure(..)-    , newCClosure-    , noClosure-    ) where--import Foreign--import Data.GI.Base.BasicTypes-import Data.GI.Base.ManagedPtr (wrapBoxed)-import Data.GI.Base.Utils (safeFreeFunPtrPtr)--newtype Closure = Closure (ForeignPtr Closure)--noClosure :: Maybe Closure-noClosure = Nothing--foreign import ccall "g_closure_get_type" c_g_closure_get_type ::-    IO GType--instance BoxedObject Closure where-    boxedType _ = c_g_closure_get_type---foreign import ccall "g_cclosure_new" g_cclosure_new-    :: FunPtr a -> Ptr () -> FunPtr c -> IO (Ptr Closure)--foreign import ccall "g_closure_ref" g_closure_ref-    :: Ptr Closure -> IO (Ptr Closure)--foreign import ccall "g_closure_sink" g_closure_sink-    :: Ptr Closure -> IO ()--newCClosure :: FunPtr a -> IO Closure-newCClosure ptr = do-  closure <- g_cclosure_new ptr nullPtr safeFreeFunPtrPtr-  -- The Haskell runtime will manage the memory associated to the-  -- closure, so ref and sink to let GLib know this.-  g_closure_ref closure >>= g_closure_sink-  wrapBoxed Closure closure

@@ -1,32 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses,-  UndecidableInstances, KindSignatures, TypeFamilies #-}-#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 Foreign (ForeignPtr)-import Control.Monad.IO.Class (MonadIO)--import Data.GI.Base.Attributes (AttrOp, AttrOpTag(..))-import Data.GI.Base.BasicTypes (GObject)-import Data.GI.Base.GObject (constructGObject)---- | Constructible types, i.e. those which can be allocated by `new`.-class Constructible a (tag :: AttrOpTag) where-    new :: MonadIO m => (ForeignPtr a -> a) -> [AttrOp a tag] -> m a---- | Default instance, assuming we have a `GObject`.-instance-#if MIN_VERSION_base(4,8,0)-    {-# OVERLAPPABLE #-}-#endif-    (GObject a, tag ~ 'AttrConstruct) => Constructible a tag where-        new = constructGObject

@@ -1,240 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}---- | To catch GError exceptions use the--- catchGError* or handleGError* functions. They work in a similar--- way to the standard 'Control.Exception.catch' and--- 'Control.Exception.handle' functions.------ To catch just a single specific error use 'catchGErrorJust' \/--- 'handleGErrorJust'. To catch any error in a particular error domain--- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'------ For convenience, generated code also includes specialized variants--- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For--- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could--- invoke 'GI.GdkPixbuf.catchPixbufError' \/--- 'GI.GdkPixbuf.handlePixbufError'. 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 'GI.GdkPixbuf.PixbufError' 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--    ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif--import Foreign (poke, peek)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr, nullPtr)-import Foreign.C-import Control.Exception-import Data.Text (Text)-import Data.Typeable (Typeable)-import Data.Int-import Data.Word--import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..))-import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.ManagedPtr (wrapBoxed)-import Data.GI.Base.Utils (allocMem, freeMem)--#include <glib.h>---- | 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 (ForeignPtr GError)-    deriving (Typeable, Show)--instance Exception GError--foreign import ccall "g_error_get_type" g_error_get_type :: IO GType--instance BoxedObject GError where-    boxedType _ = g_error_get_type---- | A GQuark.-type GQuark = #type GQuark---- | A code used to identify the "namespace" of the error. Within each error---   domain all the error codes are defined in an enumeration. Each gtk\/gnome---   module that uses GErrors has its own error domain. The rationale behind---   using error domains is so that each module can organise its own error codes---   without having to coordinate on a global error code list.-type GErrorDomain  = GQuark---- | A code to identify a specific error within a given 'GErrorDomain'. Most of---   time you will not need to deal with this raw code since there is an---   enumeration type for each error domain. Of course which enumeration to use---   depends on the error domain, but if you use 'catchGErrorJustDomain' or---   'handleGErrorJustDomain', this is worked out for you automatically.-type GErrorCode = #type gint---- | A human readable error message.-type GErrorMessage = Text--foreign import ccall "g_error_new_literal" g_error_new_literal ::-    GQuark -> GErrorCode -> CString -> IO (Ptr GError)---- | Create a new 'GError'.-gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError-gerrorNew domain code message =-    withTextCString message $ \cstring ->-        g_error_new_literal domain code cstring >>= wrapBoxed GError---- | Return the domain for the given `GError`. This is a GQuark, a--- textual representation can be obtained with--- `GI.GLib.quarkToString`.-gerrorDomain :: GError -> IO GQuark-gerrorDomain (GError fptr) =-    withForeignPtr fptr $ \ptr ->-      peek $ ptr `plusPtr` #{offset GError, domain}---- | The numeric code for the given `GError`.-gerrorCode :: GError -> IO GErrorCode-gerrorCode (GError fptr) =-    withForeignPtr fptr $ \ptr ->-        peek $ ptr `plusPtr` #{offset GError, code}---- | A text message describing the `GError`.-gerrorMessage :: GError -> IO GErrorMessage-gerrorMessage (GError fptr) =-    withForeignPtr fptr $ \ptr ->-      (peek $ ptr `plusPtr` #{offset GError, message}) >>= cstringToText---- | Each error domain's error enumeration type should be an instance of this---   class. This class helps to hide the raw error and domain codes from the---   user.------ Example for 'GI.GdkPixbuf.PixbufError':------ > 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 = do-  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code-  catch action (handler' domainQuark)-  where handler' quark gerror = do-          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 = do-  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err)-  catch action (handler' domainQuark)-  where handler' quark gerror = do-          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

@@ -1,68 +0,0 @@-{- | 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-    ) where--import Data.Int-import Data.Word--import Foreign.C-import Foreign.Ptr (Ptr, castPtr, FunPtr)--import Data.GI.Base.BasicTypes (PtrWrapped(..))--#include <glib-object.h>---- | A pointer to a hashing function on the C side.-type GHashFunc a = FunPtr (PtrWrapped a -> IO #{type guint})---- | A pointer to an equality checking function on the C side.-type GEqualFunc a = FunPtr (PtrWrapped a -> PtrWrapped a -> IO #{type gboolean})---- | Compute the hash for a `Ptr`.-foreign import ccall "&g_direct_hash" gDirectHash :: GHashFunc (Ptr a)---- | 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

@@ -1,98 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies #-}--module Data.GI.Base.GObject-    ( constructGObject-    , new'-    ) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Proxy (Proxy(..))--import Foreign.C (CUInt(..), CString, newCString)-import Foreign--import Data.GI.Base.Attributes (AttrOp(..), AttrOpTag(..), AttrLabelProxy,-                                attrConstruct)-import Data.GI.Base.BasicTypes (GType(..), GObject(..))-import Data.GI.Base.GValue (GValue(..), GValueConstruct(..))-import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject)-import Data.GI.Base.Overloading (ResolveAttribute)--#include <glib-object.h>--foreign import ccall "dbg_g_object_newv" g_object_newv ::-    GType -> CUInt -> Ptr a -> IO (Ptr b)---- | Construct a GObject given the constructor and a list of settable--- attributes.-constructGObject :: forall o m. (GObject o, MonadIO m)-    => (ForeignPtr o -> o)-    -> [AttrOp o 'AttrConstruct]-    -> m o-constructGObject constructor attrs = liftIO $ do-  props <- mapM construct attrs-  doConstructGObject constructor props-  where-    resolve :: AttrLabelProxy attr -> Proxy (ResolveAttribute attr o)-    resolve _ = Proxy--    construct :: AttrOp o 'AttrConstruct ->-                 IO (GValueConstruct o)-    construct (attr := x) = attrConstruct (resolve attr) x-    construct (attr :=> x) = x >>= attrConstruct (resolve attr)---- | Construct the `GObject` given the list of `GValueConstruct`s.-doConstructGObject :: forall o m. (GObject o, MonadIO m)-                      => (ForeignPtr o -> o) -> [GValueConstruct o] -> m o-doConstructGObject constructor props = liftIO $ do-  let nprops = length props-  params <- mallocBytes (nprops*gparameterSize)-  fill params props-  gtype <- gobjectType (undefined :: o)-  result <- g_object_newv gtype (fromIntegral nprops) params-  freeStrings nprops params-  free params-  -- Make sure that the GValues defining the GProperties are still-  -- alive at this point (so, in particular, they are still alive when-  -- g_object_newv is called). Without this the GHC garbage collector-  -- may free the GValues before g_object_newv is called, which will-  -- unref the referred to objects, which may drop the last reference-  -- to the contained objects. g_object_newv 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-    gparameterSize = #size GParameter--    -- Fill the given memory address with the contents of the array of-    -- GParameters.-    fill :: Ptr () -> [GValueConstruct o] -> IO ()-    fill _ [] = return ()-    fill dataPtr ((GValueConstruct str gvalue):xs) =-        do cstr <- newCString str-           poke (castPtr dataPtr) cstr-           withManagedPtr gvalue $ \gvalueptr ->-               copyBytes (dataPtr `plusPtr` sizeOf nullPtr) gvalueptr gvalueSize-           fill (dataPtr `plusPtr` gparameterSize) xs--    -- Free the strings in the GParameter array (the GValues will be-    -- freed separately).-    freeStrings :: Int -> Ptr () -> IO ()-    freeStrings 0 _ = return ()-    freeStrings n dataPtr =-        do cstr <- peek (castPtr dataPtr) :: IO CString-           free cstr-           freeStrings (n-1) (dataPtr `plusPtr` gparameterSize)---- | Construct the given `GObject`, given a set of actions--- constructing desired `GValue`s to set at construction time.-new' :: (MonadIO m, GObject o) =>-        (ForeignPtr o -> o) -> [IO (GValueConstruct o)] -> m o-new' constructor actions = do-  props <- liftIO $ sequence (actions)-  doConstructGObject constructor props

@@ -1,51 +0,0 @@-module Data.GI.Base.GParamSpec-    ( noGParamSpec--    , wrapGParamSpecPtr-    , newGParamSpecFromPtr-    , refGParamSpec-    , unrefGParamSpec-    ) where--import Foreign.Ptr-import Foreign.ForeignPtr (withForeignPtr)-import Control.Monad (void)--import Data.GI.Base.ManagedPtr (newManagedPtr)-import Data.GI.Base.BasicTypes (GParamSpec(..))--#include <glib-object.h>--noGParamSpec :: Maybe GParamSpec-noGParamSpec = Nothing--foreign import ccall "g_param_spec_ref_sink" g_param_spec_ref_sink ::-    Ptr GParamSpec -> IO (Ptr GParamSpec)-foreign import ccall "g_param_spec_ref" g_param_spec_ref ::-    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---- | Add a reference to the given 'GParamSpec'.-refGParamSpec :: GParamSpec -> IO (Ptr GParamSpec)-refGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_ref---- | Remove a reference to the given 'GParamSpec'.-unrefGParamSpec :: GParamSpec -> IO ()-unrefGParamSpec (GParamSpec fptr) = withForeignPtr fptr g_param_spec_unref

@@ -1,142 +0,0 @@--- | Basic `GType`s.-module Data.GI.Base.GType-    ( GType(..)-    , CGType--    , gtypeName--    , gtypeString-    , gtypePointer-    , gtypeInt-    , gtypeUInt-    , gtypeLong-    , gtypeULong-    , gtypeInt64-    , gtypeUInt64-    , gtypeFloat-    , gtypeDouble-    , gtypeBoolean-    , gtypeGType-    , gtypeStrv-    , gtypeBoxed-    , gtypeObject-    , gtypeVariant-    , gtypeByteArray-    , gtypeInvalid-    ) where--import Data.Word-import Foreign.C.String (CString, peekCString)--#include <glib-object.h>---- | A type identifier in the GLib type system. This is the low-level--- type associated with the representation in memory, when using this--- on the Haskell side use `GType` below.-type CGType = #type GType---- | A newtype for use on the haskell side.-newtype GType = GType {gtypeToCGType :: CGType}--foreign import ccall "g_type_name" g_type_name :: GType -> IO CString---- | Get the name assigned to the given `GType`.-gtypeName :: GType -> IO String-gtypeName gtype = g_type_name gtype >>= peekCString--{-| [Note: compile-time vs run-time GTypes]--Notice that there are two types of GType's: the fundamental ones,-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 `BoxedObject`.-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--{- 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

@@ -1,379 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Data.GI.Base.GValue-    ( GValue(..)-    , IsGValue(..)--    , newGValue         -- Build a new, empty, GValue of the given type-    , buildGValue       -- Build a new GValue and initialize to the given value-    , noGValue--    , GValueConstruct(..)--    , set_string-    , get_string-    , set_pointer-    , get_pointer-    , set_int-    , get_int-    , set_uint-    , get_uint-    , set_long-    , get_long-    , set_ulong-    , get_ulong-    , set_int32-    , get_int32-    , set_uint32-    , get_uint32-    , set_int64-    , get_int64-    , set_uint64-    , get_uint64-    , set_float-    , get_float-    , set_double-    , get_double-    , set_boolean-    , get_boolean-    , set_gtype-    , get_gtype-    , set_object-    , get_object-    , set_boxed-    , get_boxed-    , set_variant-    , get_variant-    , set_enum-    , get_enum-    , set_flags-    , get_flags-    ) where--#include <glib-object.h>--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Data.Coerce (coerce)-import Data.Word-import Data.Int-import Data.Text (Text, pack, unpack)--import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),-                        CLong(..), CULong(..))-import Foreign.C.String (CString)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.ForeignPtr (ForeignPtr)--import Data.GI.Base.BasicTypes-import Data.GI.Base.BasicConversions (cstringToText, textToCString)-import Data.GI.Base.ManagedPtr-import Data.GI.Base.Utils (callocBytes, freeMem)--newtype GValue = GValue (ForeignPtr GValue)--noGValue :: Maybe GValue-noGValue = Nothing--foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::-    IO CGType--instance BoxedObject GValue where-    boxedType _ = GType <$> c_g_value_get_type--foreign import ccall "g_value_init" g_value_init ::-    Ptr GValue -> CGType -> IO (Ptr GValue)---- | A type holding a `GValue` with an associated label. It is--- parameterized by a phantom type encoding the target type for the--- `GValue` (useful when constructing properties).-data GValueConstruct o = GValueConstruct String GValue--newGValue :: GType -> IO GValue-newGValue (GType gtype) = do-  gvptr <- callocBytes #size GValue-  _ <- g_value_init gvptr gtype-  gv <- wrapBoxed GValue gvptr-  return $! gv---- Build a new GValue and set the initial value, just for convenience-buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue-buildGValue gtype setter val = do-  gv <- newGValue gtype-  setter gv val-  return gv--class IsGValue a where-    toGValue :: a -> IO GValue-    fromGValue :: GValue -> IO a--instance IsGValue (Maybe String) where-    toGValue = buildGValue gtypeString set_string . fmap pack-    fromGValue v = (fmap unpack) <$> get_string v--instance IsGValue (Maybe Text) where-    toGValue = buildGValue gtypeString set_string-    fromGValue = get_string--instance IsGValue (Ptr a) where-    toGValue = buildGValue gtypePointer set_pointer-    fromGValue = get_pointer--instance IsGValue Int32 where-    toGValue = buildGValue gtypeInt set_int32-    fromGValue = get_int32--instance IsGValue Word32 where-    toGValue = buildGValue gtypeUInt set_uint32-    fromGValue = get_uint32--instance IsGValue CInt where-    toGValue = buildGValue gtypeInt set_int-    fromGValue = get_int--instance IsGValue CUInt where-    toGValue = buildGValue gtypeUInt set_uint-    fromGValue = get_uint--instance IsGValue CLong where-    toGValue = buildGValue gtypeLong set_long-    fromGValue = get_long--instance IsGValue CULong where-    toGValue = buildGValue gtypeULong set_ulong-    fromGValue = get_ulong--instance IsGValue Int64 where-    toGValue = buildGValue gtypeInt64 set_int64-    fromGValue = get_int64--instance IsGValue Word64 where-    toGValue = buildGValue gtypeUInt64 set_uint64-    fromGValue = get_uint64--instance IsGValue Float where-    toGValue = buildGValue gtypeFloat set_float-    fromGValue = get_float--instance IsGValue Double where-    toGValue = buildGValue gtypeDouble set_double-    fromGValue = get_double--instance IsGValue Bool where-    toGValue = buildGValue gtypeBoolean set_boolean-    fromGValue = get_boolean--instance IsGValue GType where-    toGValue = buildGValue gtypeGType set_gtype-    fromGValue = get_gtype--foreign import ccall "g_value_set_string" _set_string ::-    Ptr GValue -> CString -> IO ()-foreign import ccall "g_value_get_string" _get_string ::-    Ptr GValue -> IO CString--set_string :: GValue -> Maybe Text -> IO ()-set_string gv maybeStr =-    withManagedPtr gv $ \ptr -> do-      cstr <- case maybeStr of-                Just str -> textToCString str-                Nothing -> return nullPtr-      _set_string ptr cstr-      freeMem cstr--get_string :: GValue -> IO (Maybe Text)-get_string gv = withManagedPtr gv $ \gvptr -> do-                  cstr <- _get_string gvptr-                  if cstr /= nullPtr-                  then Just <$> cstringToText cstr-                  else return Nothing--foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::-    Ptr GValue -> IO (Ptr b)--set_pointer :: GValue -> Ptr a -> IO ()-set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr--get_pointer :: GValue -> IO (Ptr b)-get_pointer gv = withManagedPtr gv _get_pointer--foreign import ccall unsafe "g_value_set_int" _set_int ::-    Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_int" _get_int ::-    Ptr GValue -> IO CInt--set_int32 :: GValue -> Int32 -> IO ()-set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n)--get_int32 :: GValue -> IO Int32-get_int32 gv = coerce <$> withManagedPtr gv _get_int--set_int :: GValue -> CInt -> IO ()-set_int gv n = withManagedPtr gv $ flip _set_int n--get_int :: GValue -> IO CInt-get_int gv = withManagedPtr gv _get_int--foreign import ccall unsafe "g_value_set_uint" _set_uint ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_uint" _get_uint ::-    Ptr GValue -> IO CUInt--set_uint32 :: GValue -> Word32 -> IO ()-set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n)--get_uint32 :: GValue -> IO Word32-get_uint32 gv = coerce <$> withManagedPtr gv _get_uint--set_uint :: GValue -> CUInt -> IO ()-set_uint gv n = withManagedPtr gv $ flip _set_uint n--get_uint :: GValue -> IO CUInt-get_uint gv = withManagedPtr gv _get_uint--foreign import ccall unsafe "g_value_set_long" _set_long ::-    Ptr GValue -> CLong -> IO ()-foreign import ccall unsafe "g_value_get_long" _get_long ::-    Ptr GValue -> IO CLong--set_long :: GValue -> CLong -> IO ()-set_long gv n = withManagedPtr gv $ flip _set_long n--get_long :: GValue -> IO CLong-get_long gv = withManagedPtr gv _get_long--foreign import ccall unsafe "g_value_set_ulong" _set_ulong ::-    Ptr GValue -> CULong -> IO ()-foreign import ccall unsafe "g_value_get_ulong" _get_ulong ::-    Ptr GValue -> IO CULong--set_ulong :: GValue -> CULong -> IO ()-set_ulong gv n = withManagedPtr gv $ flip _set_ulong n--get_ulong :: GValue -> IO CULong-get_ulong gv = withManagedPtr gv _get_ulong--foreign import ccall unsafe "g_value_set_int64" _set_int64 ::-    Ptr GValue -> Int64 -> IO ()-foreign import ccall unsafe "g_value_get_int64" _get_int64 ::-    Ptr GValue -> IO Int64--set_int64 :: GValue -> Int64 -> IO ()-set_int64 gv n = withManagedPtr gv $ flip _set_int64 n--get_int64 :: GValue -> IO Int64-get_int64 gv = withManagedPtr gv _get_int64--foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::-    Ptr GValue -> Word64 -> IO ()-foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::-    Ptr GValue -> IO Word64--set_uint64 :: GValue -> Word64 -> IO ()-set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n--get_uint64 :: GValue -> IO Word64-get_uint64 gv = withManagedPtr gv _get_uint64--foreign import ccall unsafe "g_value_set_float" _set_float ::-    Ptr GValue -> CFloat -> IO ()-foreign import ccall unsafe "g_value_get_float" _get_float ::-    Ptr GValue -> IO CFloat--set_float :: GValue -> Float -> IO ()-set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)--get_float :: GValue -> IO Float-get_float gv = realToFrac <$> withManagedPtr gv _get_float--foreign import ccall unsafe "g_value_set_double" _set_double ::-    Ptr GValue -> CDouble -> IO ()-foreign import ccall unsafe "g_value_get_double" _get_double ::-    Ptr GValue -> IO CDouble--set_double :: GValue -> Double -> IO ()-set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)--get_double :: GValue -> IO Double-get_double gv = realToFrac <$> withManagedPtr gv _get_double--foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::-    Ptr GValue -> CInt -> IO ()-foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::-    Ptr GValue -> IO CInt--set_boolean :: GValue -> Bool -> IO ()-set_boolean gv b = withManagedPtr gv $ \ptr ->-                   _set_boolean ptr (fromIntegral $ fromEnum b)--get_boolean :: GValue -> IO Bool-get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr--foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::-    Ptr GValue -> CGType -> IO ()-foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::-    Ptr GValue -> IO CGType--set_gtype :: GValue -> GType -> IO ()-set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g--get_gtype :: GValue -> IO GType-get_gtype gv = GType <$> withManagedPtr gv _get_gtype--foreign import ccall "g_value_set_object" _set_object ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_object" _get_object ::-    Ptr GValue -> IO (Ptr a)--set_object :: GObject a => GValue -> Ptr a -> IO ()-set_object gv o = withManagedPtr gv $ flip _set_object o--get_object :: GObject b => GValue -> IO (Ptr b)-get_object gv = withManagedPtr gv _get_object--foreign import ccall "g_value_set_boxed" _set_boxed ::-    Ptr GValue -> Ptr a -> IO ()-foreign import ccall "g_value_get_boxed" _get_boxed ::-    Ptr GValue -> IO (Ptr b)--set_boxed :: GValue -> Ptr a -> IO ()-set_boxed gv b = withManagedPtr gv $ flip _set_boxed b--get_boxed :: GValue -> IO (Ptr b)-get_boxed gv = withManagedPtr gv _get_boxed--foreign import ccall "g_value_set_variant" _set_variant ::-    Ptr GValue -> Ptr GVariant -> IO ()-foreign import ccall "g_value_get_variant" _get_variant ::-    Ptr GValue -> IO (Ptr GVariant)--set_variant :: GValue -> Ptr GVariant -> IO ()-set_variant gv v = withManagedPtr gv $ flip _set_variant v--get_variant :: GValue -> IO (Ptr GVariant)-get_variant gv = withManagedPtr gv _get_variant--foreign import ccall unsafe "g_value_set_enum" _set_enum ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_enum" _get_enum ::-    Ptr GValue -> IO CUInt--set_enum :: GValue -> CUInt -> IO ()-set_enum gv e = withManagedPtr gv $ flip _set_enum e--get_enum :: GValue -> IO CUInt-get_enum gv = withManagedPtr gv _get_enum--foreign import ccall unsafe "g_value_set_flags" _set_flags ::-    Ptr GValue -> CUInt -> IO ()-foreign import ccall unsafe "g_value_get_flags" _get_flags ::-    Ptr GValue -> IO CUInt--set_flags :: GValue -> CUInt -> IO ()-set_flags gv f = withManagedPtr gv $ flip _set_flags f--get_flags :: GValue -> IO CUInt-get_flags gv = withManagedPtr gv _get_flags

@@ -1,977 +0,0 @@-{-# 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-    , refGVariant-    , unrefGVariant--    -- * 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 <glib-object.h>--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif-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-import Data.Monoid ((<>))-import Data.Maybe (isJust, fromJust)-import qualified Data.Map as M--import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import Foreign.Ptr-import Foreign.ForeignPtr (withForeignPtr)--import Data.GI.Base.BasicTypes (GVariant(..))-import Data.GI.Base.BasicConversions-import Data.GI.Base.ManagedPtr (withManagedPtr, withManagedPtrList,-                                newManagedPtr)-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--- <https://developer.gnome.org/glib/stable/glib-GVariantType.html>--- 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---- | Add a reference to the given 'GVariant'.-refGVariant :: GVariant -> IO (Ptr GVariant)-refGVariant (GVariant fptr) = withForeignPtr fptr g_variant_ref---- | Remove a reference to the given 'GVariant'.-unrefGVariant :: GVariant -> IO ()-unrefGVariant (GVariant fptr) = withForeignPtr fptr g_variant_unref--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-      mapM ((g_variant_get_child_value vptr) >=> wrapGVariantPtr)-               [0..(n_children-1)]--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_children-                     >=> return . head-                     >=> 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-  if isJust maybeChildren-  then do-    let (Just [a1,a2]) = maybeChildren-    (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2-    return $ if isJust ma1 && isJust ma2-             then Just (fromJust ma1, fromJust ma2)-             else Nothing-  else return Nothing--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-  if isJust maybeChildren-  then do-    let (Just [a1,a2,a3]) = maybeChildren-    (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1-                            <*> fromGVariant a2-                            <*> fromGVariant a3-    return $ if isJust ma1 && isJust ma2 && isJust ma3-             then Just (fromJust ma1, fromJust ma2, fromJust ma3)-             else Nothing-  else return Nothing--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-  if isJust maybeChildren-  then do-    let (Just [a1,a2,a3,a4]) = maybeChildren-    (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1-                                 <*> fromGVariant a2-                                 <*> fromGVariant a3-                                 <*> fromGVariant a4-    return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4-             then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4)-             else Nothing-  else return Nothing--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-  if isJust maybeChildren-  then do-    let (Just [a1,a2,a3,a4,a5]) = maybeChildren-    (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1-                                        <*> fromGVariant a2-                                        <*> fromGVariant a3-                                        <*> fromGVariant a4-                                        <*> fromGVariant a5-    return $ if isJust ma1 && isJust ma2 && isJust ma3 &&-                              isJust ma4 && isJust ma5-             then Just (fromJust ma1, fromJust ma2, fromJust ma3,-                        fromJust ma4, fromJust ma5)-             else Nothing-  else return Nothing