diff --git a/Data/GI/Base.hs b/Data/GI/Base.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base.hs @@ -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)) diff --git a/Data/GI/Base/Attributes.hs b/Data/GI/Base/Attributes.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Attributes.hs @@ -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 diff --git a/Data/GI/Base/BasicConversions.hsc b/Data/GI/Base/BasicConversions.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/BasicConversions.hsc @@ -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 + +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) diff --git a/Data/GI/Base/BasicTypes.hs b/Data/GI/Base/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/BasicTypes.hs @@ -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 . + 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 . See "Data.GI.Base.GVariant" for further methods. +newtype GVariant = GVariant (ManagedPtr GVariant) + +-- | A . See "Data.GI.Base.GParamSpec" for further methods. +newtype GParamSpec = GParamSpec (ManagedPtr GParamSpec) + +-- | An enum usable as a flag for a function. +class Enum a => IsGFlag a + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GArray a = GArray (Ptr (GArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. +data GPtrArray a = GPtrArray (Ptr (GPtrArray a)) + +-- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. +data GByteArray = GByteArray (Ptr GByteArray) + +-- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. +data GHashTable a b = GHashTable (Ptr (GHashTable a b)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GList a = GList (Ptr (GList a)) + +-- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". +data GSList a = GSList (Ptr (GSList a)) + +-- | Some APIs, such as `GHashTable`, pass around scalar types +-- wrapped into a pointer. We encode such a type as follows. +newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} + +-- | Destroy the memory associated with a given pointer. +type GDestroyNotify a = FunPtr (Ptr a -> IO ()) + +-- | Free the given 'GList'. +foreign import ccall "g_list_free" g_list_free :: + Ptr (GList a) -> IO () + +-- | Free the given 'GSList'. +foreign import ccall "g_slist_free" g_slist_free :: + Ptr (GSList a) -> IO () diff --git a/Data/GI/Base/Closure.hs b/Data/GI/Base/Closure.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Closure.hs @@ -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 diff --git a/Data/GI/Base/Constructible.hs b/Data/GI/Base/Constructible.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Constructible.hs @@ -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 diff --git a/Data/GI/Base/GError.hsc b/Data/GI/Base/GError.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GError.hsc @@ -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 + +-- | 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 diff --git a/Data/GI/Base/GHashTable.hsc b/Data/GI/Base/GHashTable.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GHashTable.hsc @@ -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 + +-- | 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 diff --git a/Data/GI/Base/GObject.hsc b/Data/GI/Base/GObject.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GObject.hsc @@ -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 + +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 diff --git a/Data/GI/Base/GParamSpec.hsc b/Data/GI/Base/GParamSpec.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GParamSpec.hsc @@ -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 + +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 diff --git a/Data/GI/Base/GType.hsc b/Data/GI/Base/GType.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GType.hsc @@ -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 + +-- | 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 diff --git a/Data/GI/Base/GValue.hsc b/Data/GI/Base/GValue.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GValue.hsc @@ -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 + +#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 diff --git a/Data/GI/Base/GVariant.hsc b/Data/GI/Base/GVariant.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/GVariant.hsc @@ -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 + +#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 +-- +-- 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 diff --git a/Data/GI/Base/ManagedPtr.hs b/Data/GI/Base/ManagedPtr.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/ManagedPtr.hs @@ -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 = "" +#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 +-- . + +-- 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' diff --git a/Data/GI/Base/Overloading.hs b/Data/GI/Base/Overloading.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Overloading.hs @@ -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 diff --git a/Data/GI/Base/Properties.hsc b/Data/GI/Base/Properties.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Properties.hsc @@ -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 + +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." diff --git a/Data/GI/Base/ShortPrelude.hs b/Data/GI/Base/ShortPrelude.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/ShortPrelude.hs @@ -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) diff --git a/Data/GI/Base/Signals.hsc b/Data/GI/Base/Signals.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Signals.hsc @@ -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 diff --git a/Data/GI/Base/Utils.hsc b/Data/GI/Base/Utils.hsc new file mode 100644 --- /dev/null +++ b/Data/GI/Base/Utils.hsc @@ -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 + +#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 <> "\"." + }) diff --git a/c/hsgclosure.c b/c/hsgclosure.c new file mode 100644 --- /dev/null +++ b/c/hsgclosure.c @@ -0,0 +1,106 @@ +#define _GNU_SOURCE + +/* GHC's semi-public Rts API */ +#include + +#include + +#include + +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); +} diff --git a/haskell-gi-base.cabal b/haskell-gi-base.cabal --- a/haskell-gi-base.cabal +++ b/haskell-gi-base.cabal @@ -1,5 +1,5 @@ name: haskell-gi-base -version: 0.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 diff --git a/src/Data/GI/Base.hs b/src/Data/GI/Base.hs deleted file mode 100644 --- a/src/Data/GI/Base.hs +++ /dev/null @@ -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)) diff --git a/src/Data/GI/Base/Attributes.hs b/src/Data/GI/Base/Attributes.hs deleted file mode 100644 --- a/src/Data/GI/Base/Attributes.hs +++ /dev/null @@ -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 diff --git a/src/Data/GI/Base/BasicConversions.hsc b/src/Data/GI/Base/BasicConversions.hsc deleted file mode 100644 --- a/src/Data/GI/Base/BasicConversions.hsc +++ /dev/null @@ -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 - -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) diff --git a/src/Data/GI/Base/BasicTypes.hs b/src/Data/GI/Base/BasicTypes.hs deleted file mode 100644 --- a/src/Data/GI/Base/BasicTypes.hs +++ /dev/null @@ -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 . - 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 . See "Data.GI.Base.GVariant" for further methods. -newtype GVariant = GVariant (ForeignPtr GVariant) - --- | A . 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 . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. -data GArray a = GArray (Ptr (GArray a)) - --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is mapped to a list on the Haskell side. -data GPtrArray a = GPtrArray (Ptr (GPtrArray a)) - --- | A . Marshalling for this type is done in "Data.GI.Base.BasicConversions", it is packed to a 'Data.ByteString.ByteString' on the Haskell side. -data GByteArray = GByteArray (Ptr GByteArray) - --- | A . It is mapped to a 'Data.Map.Map' on the Haskell side. -data GHashTable a b = GHashTable (Ptr (GHashTable a b)) - --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". -data GList a = GList (Ptr (GList a)) - --- | A , mapped to a list on the Haskell side. Marshalling is done in "Data.GI.Base.BasicConversions". -data GSList a = GSList (Ptr (GSList a)) - --- | Some APIs, such as `GHashTable`, pass around scalar types --- wrapped into a pointer. We encode such a type as follows. -newtype PtrWrapped a = PtrWrapped {unwrapPtr :: Ptr a} - --- | Destroy the memory associated with a given pointer. -type GDestroyNotify a = FunPtr (Ptr a -> IO ()) - --- | Free the given 'GList'. -foreign import ccall "g_list_free" g_list_free :: - Ptr (GList a) -> IO () - --- | Free the given 'GSList'. -foreign import ccall "g_slist_free" g_slist_free :: - Ptr (GSList a) -> IO () diff --git a/src/Data/GI/Base/Closure.hs b/src/Data/GI/Base/Closure.hs deleted file mode 100644 --- a/src/Data/GI/Base/Closure.hs +++ /dev/null @@ -1,41 +0,0 @@ --- Some helper functions to create closures. -module Data.GI.Base.Closure - ( Closure(..) - , newCClosure - , noClosure - ) where - -import Foreign - -import Data.GI.Base.BasicTypes -import Data.GI.Base.ManagedPtr (wrapBoxed) -import Data.GI.Base.Utils (safeFreeFunPtrPtr) - -newtype Closure = Closure (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 diff --git a/src/Data/GI/Base/Constructible.hs b/src/Data/GI/Base/Constructible.hs deleted file mode 100644 --- a/src/Data/GI/Base/Constructible.hs +++ /dev/null @@ -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 diff --git a/src/Data/GI/Base/GError.hsc b/src/Data/GI/Base/GError.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GError.hsc +++ /dev/null @@ -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 - --- | 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 diff --git a/src/Data/GI/Base/GHashTable.hsc b/src/Data/GI/Base/GHashTable.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GHashTable.hsc +++ /dev/null @@ -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 - --- | 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 diff --git a/src/Data/GI/Base/GObject.hsc b/src/Data/GI/Base/GObject.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GObject.hsc +++ /dev/null @@ -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 - -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 diff --git a/src/Data/GI/Base/GParamSpec.hsc b/src/Data/GI/Base/GParamSpec.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GParamSpec.hsc +++ /dev/null @@ -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 - -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 diff --git a/src/Data/GI/Base/GType.hsc b/src/Data/GI/Base/GType.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GType.hsc +++ /dev/null @@ -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 - --- | 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 diff --git a/src/Data/GI/Base/GValue.hsc b/src/Data/GI/Base/GValue.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GValue.hsc +++ /dev/null @@ -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 - -#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 diff --git a/src/Data/GI/Base/GVariant.hsc b/src/Data/GI/Base/GVariant.hsc deleted file mode 100644 --- a/src/Data/GI/Base/GVariant.hsc +++ /dev/null @@ -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 - -#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 --- --- 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 diff --git a/src/Data/GI/Base/ManagedPtr.hs b/src/Data/GI/Base/ManagedPtr.hs deleted file mode 100644 --- a/src/Data/GI/Base/ManagedPtr.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} --- For HasCallStack compatibility -{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-} - --- | We wrap most objects in a "managed pointer", which is simply a --- newtype for a 'ForeignPtr' of the appropriate type: --- --- > newtype Foo = Foo (ForeignPtr Foo) --- --- Notice that types of this form are instances of --- 'ForeignPtrNewtype'. The newtype is useful in order to make the --- newtype an instance of different typeclasses. The routines in this --- module deal with the memory management of such managed pointers. - -module Data.GI.Base.ManagedPtr - ( - -- * Managed pointers - newManagedPtr - , withManagedPtr - , maybeWithManagedPtr - , withManagedPtrList - , unsafeManagedPtrGetPtr - , unsafeManagedPtrCastPtr - , touchManagedPtr - - -- * Safe casting - , castTo - , unsafeCastTo - - -- * Wrappers - , newObject - , wrapObject - , refObject - , unrefObject - , newBoxed - , wrapBoxed - , copyBoxed - , copyBoxedPtr - , freeBoxed - , 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 Foreign.C (CInt(..)) -import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr) -import Foreign.ForeignPtr (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 - -#if MIN_VERSION_base(4,9,0) -import GHC.Stack (HasCallStack) -#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 - -foreign import ccall "dynamic" - mkFinalizer :: FinalizerPtr a -> Ptr a -> IO () - --- | A thin wrapper over `Foreign.Concurrent.newForeignPtr`. -newManagedPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a) -newManagedPtr finalizer ptr = do - FC.newForeignPtr ptr (mkFinalizer finalizer ptr) - --- | Perform an IO action on the 'Ptr' inside a managed pointer. -withManagedPtr :: ForeignPtrNewtype a => a -> (Ptr a -> IO c) -> IO c -withManagedPtr managed action = do - let 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 :: ForeignPtrNewtype a => Maybe a -> (Ptr a -> IO c) -> IO c -maybeWithManagedPtr Nothing action = action nullPtr -maybeWithManagedPtr (Just managed) action = do - let 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 :: ForeignPtrNewtype a => [a] -> ([Ptr a] -> IO c) -> IO c -withManagedPtrList managedList action = do - let ptrs = map 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 :: ForeignPtrNewtype a => a -> Ptr a -unsafeManagedPtrGetPtr = unsafeManagedPtrCastPtr - --- | Same as 'unsafeManagedPtrGetPtr', but is polymorphic on the --- return type. -unsafeManagedPtrCastPtr :: forall a b. ForeignPtrNewtype a => a -> Ptr b -unsafeManagedPtrCastPtr x = let p = coerce x :: ForeignPtr () - in castPtr (unsafeForeignPtrToPtr p) - --- | 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. ForeignPtrNewtype a => a -> IO () -touchManagedPtr x = let p = coerce x :: ForeignPtr () - in touchForeignPtr p - --- 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') => - (ForeignPtr 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') => - (ForeignPtr 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) => (ForeignPtr 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 --- . - --- 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) => - (ForeignPtr 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 - --- | Increase the reference count of the given 'GObject'. -refObject :: (GObject a, GObject b) => a -> IO (Ptr b) -refObject obj = castPtr <$> withManagedPtr obj g_object_ref - -foreign import ccall "g_object_unref" 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 g_object_unref - -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 => (ForeignPtr a -> a) -> Ptr a -> IO a -newBoxed constructor ptr = do - GType gtype <- boxedType (undefined :: a) - ptr' <- g_boxed_copy gtype ptr - fPtr <- FC.newForeignPtr 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 => (ForeignPtr a -> a) -> Ptr a -> IO a -wrapBoxed constructor ptr = do - GType gtype <- boxedType (undefined :: a) - fPtr <- FC.newForeignPtr ptr (boxed_free_helper gtype ptr) - return $! constructor fPtr - --- | Make a copy of the given boxed object. -copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a) -copyBoxed boxed = withManagedPtr boxed copyBoxedPtr - --- | 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) - let ptr = unsafeManagedPtrGetPtr boxed - g_boxed_free gtype ptr - touchManagedPtr boxed - --- | Wrap a pointer, taking ownership of it. -wrapPtr :: WrappedPtr a => (ForeignPtr a -> a) -> Ptr a -> IO a -wrapPtr constructor ptr = do - fPtr <- case wrappedPtrFree of - Nothing -> newForeignPtr_ ptr - Just finalizer -> newManagedPtr finalizer ptr - return $! constructor fPtr - --- | Wrap a pointer, making a copy of the data. -newPtr :: WrappedPtr a => (ForeignPtr a -> a) -> Ptr a -> IO a -newPtr constructor ptr = do - ptr' <- wrappedPtrCopy ptr - fPtr <- case wrappedPtrFree of - Nothing -> newForeignPtr_ 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' diff --git a/src/Data/GI/Base/Overloading.hs b/src/Data/GI/Base/Overloading.hs deleted file mode 100644 --- a/src/Data/GI/Base/Overloading.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# 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 diff --git a/src/Data/GI/Base/Properties.hsc b/src/Data/GI/Base/Properties.hsc deleted file mode 100644 --- a/src/Data/GI/Base/Properties.hsc +++ /dev/null @@ -1,521 +0,0 @@ -{-# 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, ForeignPtr, Int32, Word32, Int64, Word64, nullPtr) -import Foreign.C (CString, withCString) -import Foreign.C.Types (CInt, CUInt, CLong, CULong) - -#include - -foreign import ccall "g_object_set_property" g_object_set_property :: - Ptr a -> CString -> Ptr GValue -> IO () - -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 -> (ForeignPtr 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 -> (ForeignPtr 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." diff --git a/src/Data/GI/Base/ShortPrelude.hs b/src/Data/GI/Base/ShortPrelude.hs deleted file mode 100644 --- a/src/Data/GI/Base/ShortPrelude.hs +++ /dev/null @@ -1,93 +0,0 @@ --- | 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) diff --git a/src/Data/GI/Base/Signals.hsc b/src/Data/GI/Base/Signals.hsc deleted file mode 100644 --- a/src/Data/GI/Base/Signals.hsc +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Routines for connecting `GObject`s to signals. -module Data.GI.Base.Signals - ( on - , after - , SignalProxy(..) - , SignalConnectMode(..) - , connectSignalFunPtr - , SignalHandlerId - , SignalInfo(..) - , GObjectNotifySignalInfo - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Proxy (Proxy(..)) - -import Foreign -import Foreign.C - -import GHC.TypeLits - -import Data.GI.Base.Attributes (AttrLabelProxy, AttrInfo(AttrLabel)) -import Data.GI.Base.BasicTypes -import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) -import Data.GI.Base.ManagedPtr (withManagedPtr) -import Data.GI.Base.Overloading (ResolveSignal, - IsLabelProxy(..), ResolveAttribute) -import Data.GI.Base.Utils (safeFreeFunPtrPtr) - -#if MIN_VERSION_base(4,9,0) -import GHC.OverloadedLabels (IsLabel(..)) -#else -import Data.GI.Base.Overloading (HasSignal) -#endif - --- | Type of a `GObject` signal handler id. -type SignalHandlerId = CULong - --- | A class that provides a constraint satisfied by every type. -class NoConstraint a -instance NoConstraint a - --- | Support for overloaded signal connectors. -data SignalProxy (object :: *) (info :: *) where - SignalProxy :: SignalProxy o info - PropertyNotify :: (info ~ ResolveAttribute propName o, - AttrInfo info, - pl ~ AttrLabel info) => - AttrLabelProxy propName -> - SignalProxy o (GObjectNotifySignalInfo pl) - --- | Support for overloaded labels. -instance -#if !MIN_VERSION_base(4,9,0) - -- This gives better error reporting in ghc < 8.0. - (HasSignal slot object, info ~ ResolveSignal slot object) -#else - info ~ ResolveSignal slot object -#endif - => IsLabelProxy slot (SignalProxy object info) where - fromLabelProxy _ = SignalProxy - -#if MIN_VERSION_base(4,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 diff --git a/src/Data/GI/Base/Utils.hsc b/src/Data/GI/Base/Utils.hsc deleted file mode 100644 --- a/src/Data/GI/Base/Utils.hsc +++ /dev/null @@ -1,200 +0,0 @@ -{-# 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 - -#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 <> "\"." - }) diff --git a/src/c/hsgclosure.c b/src/c/hsgclosure.c deleted file mode 100644 --- a/src/c/hsgclosure.c +++ /dev/null @@ -1,93 +0,0 @@ -#define _GNU_SOURCE - -/* GHC's semi-public Rts API */ -#include - -#include - -#include - -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_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); -}