diff --git a/Data/GI/Base/Attributes.hs b/Data/GI/Base/Attributes.hs --- a/Data/GI/Base/Attributes.hs +++ b/Data/GI/Base/Attributes.hs @@ -1,7 +1,8 @@ {-# LANGUAGE GADTs, ScopedTypeVariables, DataKinds, KindSignatures, TypeFamilies, TypeOperators, MultiParamTypeClasses, ConstraintKinds, UndecidableInstances, FlexibleInstances, TypeApplications, - DefaultSignatures, PolyKinds, AllowAmbiguousTypes #-} + DefaultSignatures, PolyKinds, AllowAmbiguousTypes, + ImplicitParams, RankNTypes #-} -- | -- @@ -143,7 +144,9 @@ set, clear, - AttrLabelProxy(..) + AttrLabelProxy(..), + + resolveAttr ) where import Control.Monad (void) @@ -151,9 +154,11 @@ import Data.GI.Base.BasicTypes (GObject) import Data.GI.Base.GValue (GValueConstruct) -import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute) +import Data.GI.Base.Overloading (HasAttributeList, ResolveAttribute, + ResolvedSymbolInfo) -import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on) +import {-# SOURCE #-} Data.GI.Base.Signals (SignalInfo(..), SignalProxy, + on, after) import Data.Proxy (Proxy(..)) import Data.Kind (Type) @@ -269,6 +274,12 @@ Proxy o -> b -> IO (AttrTransferType info) attrTransfer _ = return + -- | Return some information about the overloaded attribute, + -- useful for debugging. See `resolveAttr` for how to access this + -- conveniently. + dbgAttrInfo :: Maybe ResolvedSymbolInfo + dbgAttrInfo = Nothing + -- | Pretty print a type, indicating the parent type that introduced -- the attribute, if different. type family TypeOriginInfo definingType useType :: ErrorMessage where @@ -441,7 +452,14 @@ AttrLabelProxy (attr :: Symbol) -> b -> AttrOp obj tag -- | Connect the given signal to a signal handler. On :: (GObject obj, SignalInfo info) => - SignalProxy obj info -> HaskellCallbackType info -> AttrOp obj tag + SignalProxy obj info + -> ((?self :: obj) => HaskellCallbackType info) + -> AttrOp obj tag + -- | Like 'On', but connect after the default signal. + After :: (GObject obj, SignalInfo info) => + SignalProxy obj info + -> ((?self :: obj) => HaskellCallbackType info) + -> AttrOp obj tag -- | Set a number of properties for some object. set :: forall o m. MonadIO m => o -> [AttrOp o 'AttrSet] -> m () @@ -467,6 +485,7 @@ attrSet @(ResolveAttribute label o) obj app (On signal callback) = void $ on obj signal callback + app (After signal callback) = void $ after obj signal callback -- | Constraints on a @obj@\/@attr@ pair so `get` is possible, -- producing a value of type @result@. @@ -495,3 +514,13 @@ (AttrClearC info obj attr, MonadIO m) => obj -> AttrLabelProxy (attr :: Symbol) -> m () clear o _ = liftIO $ attrClear @info o + +-- | Return the fully qualified attribute name that a given overloaded +-- attribute resolves to (mostly useful for debugging). +-- +-- > resolveAttr #sensitive button +resolveAttr :: forall info attr obj. + (HasAttributeList obj, info ~ ResolveAttribute attr obj, + AttrInfo info) => + obj -> AttrLabelProxy (attr :: Symbol) -> Maybe ResolvedSymbolInfo +resolveAttr _o _p = dbgAttrInfo @info diff --git a/Data/GI/Base/BasicConversions.hsc b/Data/GI/Base/BasicConversions.hsc --- a/Data/GI/Base/BasicConversions.hsc +++ b/Data/GI/Base/BasicConversions.hsc @@ -169,7 +169,7 @@ dataPtr <- peek (castPtr array :: Ptr (Ptr a)) nitems <- peek (array `plusPtr` sizeOf dataPtr) go dataPtr nitems - where go :: Ptr a -> Int -> IO [a] + where go :: Ptr a -> CUInt -> IO [a] go _ 0 = return [] go ptr n = do x <- peek ptr diff --git a/Data/GI/Base/GObject.hsc b/Data/GI/Base/GObject.hsc --- a/Data/GI/Base/GObject.hsc +++ b/Data/GI/Base/GObject.hsc @@ -77,7 +77,7 @@ import Data.GI.Base.ManagedPtr (withManagedPtr, touchManagedPtr, wrapObject, newObject) import Data.GI.Base.Overloading (ResolveAttribute) -import Data.GI.Base.Signals (on) +import Data.GI.Base.Signals (on, after) import Data.GI.Base.Utils (dbgLog) #include @@ -111,9 +111,11 @@ attrConstruct @(ResolveAttribute label o)) construct (On _ _) = return Nothing + construct (After _ _) = return Nothing setSignal :: GObject o => o -> AttrOp o 'AttrConstruct -> IO () setSignal obj (On signal callback) = void $ on obj signal callback + setSignal obj (After signal callback) = void $ after obj signal callback setSignal _ _ = return () -- | Construct the given `GObject`, given a set of actions diff --git a/Data/GI/Base/GParamSpec.hsc b/Data/GI/Base/GParamSpec.hsc --- a/Data/GI/Base/GParamSpec.hsc +++ b/Data/GI/Base/GParamSpec.hsc @@ -154,7 +154,7 @@ value <- objectFromPtr objPtr >>= getter gvalueSetter destPtr value , propSetter = \objPtr newGValuePtr -> - withTransient GValue newGValuePtr $ \newGValue -> do + withTransient newGValuePtr $ \newGValue -> do obj <- objectFromPtr objPtr value <- GV.fromGValue newGValue setter obj value @@ -215,7 +215,7 @@ take_stablePtr destPtr stablePtr setter' :: Ptr o -> (Ptr GValue) -> IO () - setter' objPtr gvPtr = withTransient GValue gvPtr $ \gv -> do + setter' objPtr gvPtr = withTransient gvPtr $ \gv -> do obj <- objectFromPtr objPtr val <- GV.fromGValue gv >>= deRefStablePtr setter obj val diff --git a/Data/GI/Base/GValue.hs b/Data/GI/Base/GValue.hs --- a/Data/GI/Base/GValue.hs +++ b/Data/GI/Base/GValue.hs @@ -45,6 +45,8 @@ ) where +import Control.Monad.IO.Class (MonadIO, liftIO) + import Data.Coerce (coerce) import Data.Word import Data.Int @@ -152,8 +154,8 @@ -- the `GValue`. -- | Create a `GValue` from the given Haskell value. -toGValue :: forall a. IsGValue a => a -> IO GValue -toGValue val = do +toGValue :: forall a m. (IsGValue a, MonadIO m) => a -> m GValue +toGValue val = liftIO $ do gvptr <- callocBytes cgvalueSize GType gtype <- gvalueGType_ @a _ <- g_value_init gvptr gtype @@ -162,8 +164,8 @@ return $! gv -- | Create a Haskell object out of the given `GValue`. -fromGValue :: IsGValue a => GValue -> IO a -fromGValue gv = withManagedPtr gv gvalueGet_ +fromGValue :: (IsGValue a, MonadIO m) => GValue -> m a +fromGValue gv = liftIO $ withManagedPtr gv gvalueGet_ instance IsGValue (Maybe String) where gvalueGType_ = return gtypeString diff --git a/Data/GI/Base/GVariant.hsc b/Data/GI/Base/GVariant.hsc --- a/Data/GI/Base/GVariant.hsc +++ b/Data/GI/Base/GVariant.hsc @@ -854,14 +854,14 @@ gvariantToTwoTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2]) = maybeChildren - (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2 - return $ if isJust ma1 && isJust ma2 - then Just (fromJust ma1, fromJust ma2) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2] -> do + (ma1, ma2) <- (,) <$> fromGVariant a1 <*> fromGVariant a2 + return $ if isJust ma1 && isJust ma2 + then Just (fromJust ma1, fromJust ma2) + else Nothing + Just _ -> error "gvariantToTwoTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c) => IsGVariant (a,b,c) where toGVariant = gvariantFromThreeTuple @@ -886,16 +886,16 @@ gvariantToThreeTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3]) = maybeChildren - (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - return $ if isJust ma1 && isJust ma2 && isJust ma3 - then Just (fromJust ma1, fromJust ma2, fromJust ma3) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3] -> do + (ma1, ma2, ma3) <- (,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + return $ if isJust ma1 && isJust ma2 && isJust ma3 + then Just (fromJust ma1, fromJust ma2, fromJust ma3) + else Nothing + Just _ -> error "gvariantToThreeTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d) => IsGVariant (a,b,c,d) where @@ -923,17 +923,17 @@ gvariantToFourTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3,a4]) = maybeChildren - (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - <*> fromGVariant a4 - return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4 - then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3,a4] -> do + (ma1, ma2, ma3,ma4) <- (,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && isJust ma4 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, fromJust ma4) + else Nothing + Just _ -> error "gvariantToFourTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing instance (IsGVariant a, IsGVariant b, IsGVariant c, IsGVariant d, IsGVariant e) => IsGVariant (a,b,c,d,e) where @@ -965,17 +965,17 @@ gvariantToFiveTuple variant = do let expectedType = toGVariantFormatString (undefined :: (a,b,c,d,e)) maybeChildren <- withExplicitType expectedType gvariant_get_children variant - if isJust maybeChildren - then do - let (Just [a1,a2,a3,a4,a5]) = maybeChildren - (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1 - <*> fromGVariant a2 - <*> fromGVariant a3 - <*> fromGVariant a4 - <*> fromGVariant a5 - return $ if isJust ma1 && isJust ma2 && isJust ma3 && - isJust ma4 && isJust ma5 - then Just (fromJust ma1, fromJust ma2, fromJust ma3, - fromJust ma4, fromJust ma5) - else Nothing - else return Nothing + case maybeChildren of + Just [a1,a2,a3,a4,a5] -> do + (ma1, ma2, ma3, ma4, ma5) <- (,,,,) <$> fromGVariant a1 + <*> fromGVariant a2 + <*> fromGVariant a3 + <*> fromGVariant a4 + <*> fromGVariant a5 + return $ if isJust ma1 && isJust ma2 && isJust ma3 && + isJust ma4 && isJust ma5 + then Just (fromJust ma1, fromJust ma2, fromJust ma3, + fromJust ma4, fromJust ma5) + else Nothing + Just _ -> error "gvariantToFiveTuple :: the impossible happened, this is a bug." + Nothing -> return Nothing diff --git a/Data/GI/Base/ManagedPtr.hs b/Data/GI/Base/ManagedPtr.hs --- a/Data/GI/Base/ManagedPtr.hs +++ b/Data/GI/Base/ManagedPtr.hs @@ -168,9 +168,9 @@ -- managed pointer will be valid while calling the action, but will be -- disowned as soon as the action finished. withTransient :: (HasCallStack, ManagedPtrNewtype a) - => (ManagedPtr a -> a) -> Ptr a -> (a -> IO b) -> IO b -withTransient constructor ptr action = do - managed <- constructor <$> newManagedPtr_ ptr + => Ptr a -> (a -> IO b) -> IO b +withTransient ptr action = do + managed <- coerce <$> newManagedPtr_ ptr r <- action managed _ <- disownManagedPtr managed return r diff --git a/Data/GI/Base/Overloading.hs b/Data/GI/Base/Overloading.hs --- a/Data/GI/Base/Overloading.hs +++ b/Data/GI/Base/Overloading.hs @@ -33,7 +33,8 @@ , OverloadedMethodInfo(..) , OverloadedMethod(..) , MethodProxy(..) - , MethodInfo(..) + + , ResolvedSymbolInfo(..) , resolveMethod ) where @@ -191,22 +192,23 @@ class OverloadedMethod i o s where overloadedMethod :: o -> s -- ^ The actual method being invoked. --- | Information about the method that will be invoked, for debugging +-- | Information about a fully resolved symbol, for debugging -- purposes. -data MethodInfo = MethodInfo { overloadedMethodName :: Text - , overloadedMethodURL :: Text - } +data ResolvedSymbolInfo = ResolvedSymbolInfo { + resolvedSymbolName :: Text + , resolvedSymbolURL :: Text + } -instance Show MethodInfo where +instance Show ResolvedSymbolInfo where -- Format as a hyperlink on modern terminals (older -- terminals should ignore the hyperlink part). - show info = T.unpack ("\ESC]8;;" <> overloadedMethodURL info - <> "\ESC\\" <> overloadedMethodName info + show info = T.unpack ("\ESC]8;;" <> resolvedSymbolURL info + <> "\ESC\\" <> resolvedSymbolName info <> "\ESC]8;;\ESC\\") -- | This is for debugging purposes, see `resolveMethod` below. class OverloadedMethodInfo i o where - overloadedMethodInfo :: MethodInfo + overloadedMethodInfo :: Maybe ResolvedSymbolInfo -- | A proxy for carrying the types `MethodInfoName` needs (this is used -- for `resolveMethod`, see below). @@ -215,7 +217,7 @@ -- | Return the fully qualified method name that a given overloaded -- method call resolves to (mostly useful for debugging). -- --- > resolveMethod #show widget +-- > resolveMethod widget #show resolveMethod :: forall info obj. (OverloadedMethodInfo info obj) => - MethodProxy info obj -> obj -> MethodInfo -resolveMethod _p _o = overloadedMethodInfo @info @obj + obj -> MethodProxy info obj -> Maybe ResolvedSymbolInfo +resolveMethod _o _p = overloadedMethodInfo @info @obj diff --git a/Data/GI/Base/Signals.hs b/Data/GI/Base/Signals.hs --- a/Data/GI/Base/Signals.hs +++ b/Data/GI/Base/Signals.hs @@ -13,6 +13,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} -- | Routines for connecting `GObject`s to signals. There are two -- basic variants, 'on' and 'after', which correspond to @@ -51,6 +53,7 @@ , SignalInfo(..) , GObjectNotifySignalInfo , SignalCodeGenError + , resolveSignal ) where import Control.Monad.IO.Class (MonadIO, liftIO) @@ -75,8 +78,9 @@ import Data.GI.Base.BasicConversions (withTextCString) import Data.GI.Base.BasicTypes import Data.GI.Base.GParamSpec (newGParamSpecFromPtr) -import Data.GI.Base.ManagedPtr (withManagedPtr) -import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute) +import Data.GI.Base.ManagedPtr (withManagedPtr, withTransient) +import Data.GI.Base.Overloading (ResolveSignal, ResolveAttribute, + ResolvedSymbolInfo) import GHC.OverloadedLabels (IsLabel(..)) @@ -107,18 +111,25 @@ -- | Information about an overloaded signal. class SignalInfo (info :: Type) where - -- | The type for the signal handler. - type HaskellCallbackType info :: Type - -- | Connect a Haskell function to a signal of the given - -- `GObject`, specifying whether the handler will be called before - -- or after the default handler. - connectSignal :: GObject o => - o -> - HaskellCallbackType info -> - SignalConnectMode -> - Maybe Text -> - IO SignalHandlerId + -- | The type for the signal handler. + type HaskellCallbackType info :: Type + -- | Connect a Haskell function to a signal of the given `GObject`, + -- specifying whether the handler will be called before or after the + -- default handler. Note that the callback being passed here admits + -- an extra initial parameter with respect to the usual Haskell + -- callback type. This will be passed as an /implicit/ @?self@ + -- argument to the Haskell callback. + connectSignal :: GObject o => + o -> + (o -> HaskellCallbackType info) -> + SignalConnectMode -> + Maybe Text -> + IO SignalHandlerId + -- | Optional extra debug information, for `resolveSignal` below. + dbgSignalInfo :: Maybe ResolvedSymbolInfo + dbgSignalInfo = Nothing + -- | Whether to connect a handler to a signal with `connectSignal` so -- that it runs before/after the default handler for the given signal. data SignalConnectMode = SignalConnectBefore -- ^ Run before the default handler. @@ -128,17 +139,23 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) + -> m SignalHandlerId on o p c = - liftIO $ connectSignal @info o c SignalConnectBefore (proxyDetail p) + liftIO $ connectSignal @info o w SignalConnectBefore (proxyDetail p) + where w :: object -> HaskellCallbackType info + w parent = let ?self = parent in c -- | Connect a signal to a handler, running the handler after the default one. after :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) + -> m SignalHandlerId after o p c = - liftIO $ connectSignal @info o c SignalConnectAfter (proxyDetail p) + liftIO $ connectSignal @info o w SignalConnectAfter (proxyDetail p) + where w :: object -> HaskellCallbackType info + w parent = let ?self = parent in c -- | Given a signal proxy, determine the corresponding detail. proxyDetail :: forall object info. SignalProxy object info -> Maybe Text @@ -196,11 +213,11 @@ -- | Type for a `GObject` "notify" callback. type GObjectNotifyCallback = GParamSpec -> IO () -gobjectNotifyCallbackWrapper :: - GObjectNotifyCallback -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO () -gobjectNotifyCallbackWrapper _cb _ pspec _ = do +gobjectNotifyCallbackWrapper :: GObject o => + (o -> GObjectNotifyCallback) -> Ptr () -> Ptr GParamSpec -> Ptr () -> IO () +gobjectNotifyCallbackWrapper cb selfPtr pspec _ = do pspec' <- newGParamSpecFromPtr pspec - _cb pspec' + withTransient (castPtr selfPtr) $ \self -> cb self pspec' type GObjectNotifyCallbackC = Ptr () -> Ptr GParamSpec -> Ptr () -> IO () @@ -209,7 +226,7 @@ -- | Connect the given notify callback for a GObject. connectGObjectNotify :: GObject o => - o -> GObjectNotifyCallback -> + o -> (o -> GObjectNotifyCallback) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId @@ -225,3 +242,11 @@ ':<>: 'Text signalName ':<>: 'Text "’ is not supported, because haskell-gi failed to generate appropriate bindings." ':$$: 'Text "Please file an issue at https://github.com/haskell-gi/haskell-gi/issues.") + +-- | Return the fully qualified signal name that a given overloaded +-- signal resolves to (mostly useful for debugging). +-- +-- > resolveSignal #childNotify button +resolveSignal :: forall object info. (GObject object, SignalInfo info) => + object -> SignalProxy object info -> Maybe ResolvedSymbolInfo +resolveSignal _o _p = dbgSignalInfo @info diff --git a/Data/GI/Base/Signals.hs-boot b/Data/GI/Base/Signals.hs-boot --- a/Data/GI/Base/Signals.hs-boot +++ b/Data/GI/Base/Signals.hs-boot @@ -3,9 +3,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} -module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on) where +module Data.GI.Base.Signals (SignalInfo(..), SignalProxy, on, after) where +import Data.GI.Base.Overloading (ResolvedSymbolInfo) import Data.GI.Base.BasicTypes (GObject) import Control.Monad.IO.Class (MonadIO) import Foreign.C (CULong) @@ -18,10 +21,12 @@ type HaskellCallbackType info connectSignal :: GObject o => o -> - HaskellCallbackType info -> + (o -> HaskellCallbackType info) -> SignalConnectMode -> Maybe Text -> IO SignalHandlerId + dbgSignalInfo :: Maybe ResolvedSymbolInfo + dbgSignalInfo = Nothing type role SignalProxy nominal nominal data SignalProxy object info where @@ -31,4 +36,9 @@ on :: forall object info m. (GObject object, MonadIO m, SignalInfo info) => object -> SignalProxy object info - -> HaskellCallbackType info -> m SignalHandlerId + -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId + +after :: forall object info m. + (GObject object, MonadIO m, SignalInfo info) => + object -> SignalProxy object info + -> ((?self :: object) => HaskellCallbackType info) -> m SignalHandlerId diff --git a/c/hsgclosure.c b/c/hsgclosure.c deleted file mode 100644 --- a/c/hsgclosure.c +++ /dev/null @@ -1,410 +0,0 @@ -#define _GNU_SOURCE - -/* GHC's semi-public Rts API */ -#include - -#include -#include -#include -#include - -#include -#include - -static int print_debug_info () -{ - static int __print_debug_info = -1; - - if (__print_debug_info == -1) { - __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL; - } - - return __print_debug_info; -} - -/* - A mutex protecting the log file handle. We make it recursive, - i.e. refcounted, so it is OK to lock repeatedly in the same thread. -*/ -static pthread_mutex_t log_mutex -#if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP) - = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP; -#elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER) - = PTHREAD_RECURSIVE_MUTEX_INITIALIZER; -#else - ; -__attribute__ ((constructor)) static void init_log_mutex() -{ - pthread_mutexattr_t attr; - pthread_mutexattr_init(&attr); - pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(&log_mutex, &attr); - pthread_mutexattr_destroy(&attr); -} -#endif - -/* Give the current thread exclusive access to the log */ -static void lock_log() -{ - pthread_mutex_lock(&log_mutex); -} - -/* Decrease the refcount of the mutex protecting access to the log - from other threads */ -static void unlock_log() -{ - pthread_mutex_unlock(&log_mutex); -} - -/* Print the given message to the log. The passed in string does not - need to be zero-terminated. The message is only printed if the - HASKELL_GI_DEBUG_MEM variable is set. */ -void dbg_log_with_len (const char *msg, int len) -{ - if (print_debug_info()) { - lock_log(); - fwrite(msg, len, 1, stderr); - unlock_log(); - } -} - -/* Print the given printf-style message to the log. The message is - only printed if the HASKELL_GI_DEBUG_MEM variable is set. */ -__attribute__ ((format (printf, 1, 2))) -static void dbg_log (const char *msg, ...) -{ - va_list args; - - va_start(args, msg); - - if (print_debug_info()) { - lock_log(); - vfprintf(stderr, msg, args); - unlock_log(); - } - - va_end(args); -} - -int check_object_type (void *instance, GType type) -{ - int result; - - if (instance != NULL) { - result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type); - } else { - result = 0; - dbg_log("Check failed: got a null pointer\n"); - } - - return result; -} - -GType _haskell_gi_g_value_get_type (GValue *gvalue) -{ - return G_VALUE_TYPE (gvalue); -} - -/* Information about a boxed type to free */ -typedef struct { - GType gtype; - gpointer boxed; -} BoxedFreeInfo; - -/* Auxiliary function for freeing boxed types in the main loop. See - the annotation in g_object_unref_in_main_loop() below. */ -static gboolean main_loop_boxed_free_helper (gpointer _info) -{ - BoxedFreeInfo *info = (BoxedFreeInfo*)_info; - - if (print_debug_info()) { - GThread *self = g_thread_self (); - lock_log(); - dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n", - info->boxed, self); - dbg_log("\tIt is of type %s\n", g_type_name(info->gtype)); - } - - g_boxed_free (info->gtype, info->boxed); - - if (print_debug_info()) { - dbg_log("\tdone freeing %p.\n", info->boxed); - unlock_log(); - } - - g_free(info); - - return FALSE; /* Do not invoke again */ -} - -void boxed_free_helper (GType gtype, void *boxed) -{ - BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo)); - - info->gtype = gtype; - info->boxed = boxed; - - g_idle_add (main_loop_boxed_free_helper, info); -} - -void dbg_g_object_disown (GObject *obj) -{ - GType gtype; - - if (print_debug_info()) { - lock_log(); - GThread *self = g_thread_self(); - dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self); - gtype = G_TYPE_FROM_INSTANCE (obj); - dbg_log("\tIt is of type %s\n", g_type_name(gtype)); - dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count); - unlock_log(); - } -} - -static void print_object_dbg_info (GObject *obj) -{ - GThread *self = g_thread_self(); - GType gtype; - - dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self); - gtype = G_TYPE_FROM_INSTANCE (obj); - dbg_log("\tIt is of type %s\n", g_type_name(gtype)); - dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count); -} - -/* - We schedule all GObject deletions to happen in the main loop. The - reason is that for some types the destructor is not thread safe, and - assumes that it is being run from the same thread as the main loop - that created the object. - */ -static gboolean -g_object_unref_in_main_loop (gpointer obj) -{ - if (print_debug_info()) { - lock_log(); - print_object_dbg_info ((GObject*)obj); - } - - g_object_unref (obj); - - if (print_debug_info()) { - fprintf(stderr, "\tUnref done\n"); - unlock_log(); - } - - return FALSE; /* Do not invoke again */ -} - -void dbg_g_object_unref (GObject *obj) -{ - g_idle_add(g_object_unref_in_main_loop, obj); -} - -/** - * dbg_g_object_new: - * @gtype: #GType for the object to construct. - * @n_props: Number of parameters for g_object_new_with_properties(). - * @names: Names of the properties to be set. - * @values: Parameters for g_object_new_with_properties(). - * - * Allocate a #GObject of #GType @gtype, with the given @params. The - * returned object is never floating, and we always own a reference to - * it. (It might not be the only existing to the object, but it is in - * any case safe to call g_object_unref() when we are not wrapping the - * object ourselves anymore.) - * - * Returns: A new #GObject. - */ -gpointer dbg_g_object_new (GType gtype, guint n_props, - const char *names[], const GValue values[]) -{ - gpointer result; - - if (print_debug_info()) { - GThread *self = g_thread_self(); - - lock_log(); - dbg_log("Creating a new GObject of type %s [thread: %p]\n", - g_type_name(gtype), self); - } - -#if GLIB_CHECK_VERSION(2,54,0) - result = g_object_new_with_properties (gtype, n_props, names, values); -#else - { GParameter params[n_props]; - int i; - - for (i=0; icallback); - - hs_free_fun_ptr (closure->callback); - - dbg_log("\tDone.\n"); - unlock_log(); -} - -/* Check whether the given closure is floating */ -gboolean -haskell_gi_g_closure_is_floating (GClosure *closure) -{ - return !!(closure->floating); -} - -/* GParamSpec* types are registered as GObjects, but they do not have - an exported type_init function. They only export CPP macros, so - we have to provide our own. */ -#define PARAM_TYPE(CamelCase, UPPERCASE) \ - GType haskell_gi_pspec_type_init_##CamelCase (void) { \ - return G_TYPE_##UPPERCASE; \ - } - -PARAM_TYPE(ParamSpec, PARAM); -PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN); -PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED); -PARAM_TYPE(ParamSpecChar, PARAM_CHAR); -PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE); -PARAM_TYPE(ParamSpecEnum, PARAM_ENUM); -PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS); -PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT); -PARAM_TYPE(ParamSpecGType, PARAM_GTYPE); -PARAM_TYPE(ParamSpecInt, PARAM_INT); -PARAM_TYPE(ParamSpecInt64, PARAM_INT64); -PARAM_TYPE(ParamSpecLong, PARAM_LONG); -PARAM_TYPE(ParamSpecObject, PARAM_OBJECT); -PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE); -PARAM_TYPE(ParamSpecParam, PARAM_PARAM); -PARAM_TYPE(ParamSpecPointer, PARAM_POINTER); -PARAM_TYPE(ParamSpecString, PARAM_STRING); -PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR); -PARAM_TYPE(ParamSpecUInt, PARAM_UINT); -PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64); -PARAM_TYPE(ParamSpecULong, PARAM_ULONG); -PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR); -PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT); -/* The following is deprecated, ignore the warning that GLib raises. */ -#undef GLIB_DEPRECATED_MACRO -#define GLIB_DEPRECATED_MACRO -PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY); diff --git a/csrc/hsgclosure.c b/csrc/hsgclosure.c new file mode 100644 --- /dev/null +++ b/csrc/hsgclosure.c @@ -0,0 +1,410 @@ +#define _GNU_SOURCE + +/* GHC's semi-public Rts API */ +#include + +#include +#include +#include +#include + +#include +#include + +static int print_debug_info () +{ + static int __print_debug_info = -1; + + if (__print_debug_info == -1) { + __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL; + } + + return __print_debug_info; +} + +/* + A mutex protecting the log file handle. We make it recursive, + i.e. refcounted, so it is OK to lock repeatedly in the same thread. +*/ +static pthread_mutex_t log_mutex +#if defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP) + = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP; +#elif defined(PTHREAD_RECURSIVE_MUTEX_INITIALIZER) + = PTHREAD_RECURSIVE_MUTEX_INITIALIZER; +#else + ; +__attribute__ ((constructor)) static void init_log_mutex() +{ + pthread_mutexattr_t attr; + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); + pthread_mutex_init(&log_mutex, &attr); + pthread_mutexattr_destroy(&attr); +} +#endif + +/* Give the current thread exclusive access to the log */ +static void lock_log() +{ + pthread_mutex_lock(&log_mutex); +} + +/* Decrease the refcount of the mutex protecting access to the log + from other threads */ +static void unlock_log() +{ + pthread_mutex_unlock(&log_mutex); +} + +/* Print the given message to the log. The passed in string does not + need to be zero-terminated. The message is only printed if the + HASKELL_GI_DEBUG_MEM variable is set. */ +void dbg_log_with_len (const char *msg, int len) +{ + if (print_debug_info()) { + lock_log(); + fwrite(msg, len, 1, stderr); + unlock_log(); + } +} + +/* Print the given printf-style message to the log. The message is + only printed if the HASKELL_GI_DEBUG_MEM variable is set. */ +__attribute__ ((format (printf, 1, 2))) +static void dbg_log (const char *msg, ...) +{ + va_list args; + + va_start(args, msg); + + if (print_debug_info()) { + lock_log(); + vfprintf(stderr, msg, args); + unlock_log(); + } + + va_end(args); +} + +int check_object_type (void *instance, GType type) +{ + int result; + + if (instance != NULL) { + result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type); + } else { + result = 0; + dbg_log("Check failed: got a null pointer\n"); + } + + return result; +} + +GType _haskell_gi_g_value_get_type (GValue *gvalue) +{ + return G_VALUE_TYPE (gvalue); +} + +/* Information about a boxed type to free */ +typedef struct { + GType gtype; + gpointer boxed; +} BoxedFreeInfo; + +/* Auxiliary function for freeing boxed types in the main loop. See + the annotation in g_object_unref_in_main_loop() below. */ +static gboolean main_loop_boxed_free_helper (gpointer _info) +{ + BoxedFreeInfo *info = (BoxedFreeInfo*)_info; + + if (print_debug_info()) { + GThread *self = g_thread_self (); + lock_log(); + dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n", + info->boxed, self); + dbg_log("\tIt is of type %s\n", g_type_name(info->gtype)); + } + + g_boxed_free (info->gtype, info->boxed); + + if (print_debug_info()) { + dbg_log("\tdone freeing %p.\n", info->boxed); + unlock_log(); + } + + g_free(info); + + return FALSE; /* Do not invoke again */ +} + +void boxed_free_helper (GType gtype, void *boxed) +{ + BoxedFreeInfo *info = g_malloc(sizeof(BoxedFreeInfo)); + + info->gtype = gtype; + info->boxed = boxed; + + g_idle_add (main_loop_boxed_free_helper, info); +} + +void dbg_g_object_disown (GObject *obj) +{ + GType gtype; + + if (print_debug_info()) { + lock_log(); + GThread *self = g_thread_self(); + dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self); + gtype = G_TYPE_FROM_INSTANCE (obj); + dbg_log("\tIt is of type %s\n", g_type_name(gtype)); + dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count); + unlock_log(); + } +} + +static void print_object_dbg_info (GObject *obj) +{ + GThread *self = g_thread_self(); + GType gtype; + + dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self); + gtype = G_TYPE_FROM_INSTANCE (obj); + dbg_log("\tIt is of type %s\n", g_type_name(gtype)); + dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count); +} + +/* + We schedule all GObject deletions to happen in the main loop. The + reason is that for some types the destructor is not thread safe, and + assumes that it is being run from the same thread as the main loop + that created the object. + */ +static gboolean +g_object_unref_in_main_loop (gpointer obj) +{ + if (print_debug_info()) { + lock_log(); + print_object_dbg_info ((GObject*)obj); + } + + g_object_unref (obj); + + if (print_debug_info()) { + fprintf(stderr, "\tUnref done\n"); + unlock_log(); + } + + return FALSE; /* Do not invoke again */ +} + +void dbg_g_object_unref (GObject *obj) +{ + g_idle_add(g_object_unref_in_main_loop, obj); +} + +/** + * dbg_g_object_new: + * @gtype: #GType for the object to construct. + * @n_props: Number of parameters for g_object_new_with_properties(). + * @names: Names of the properties to be set. + * @values: Parameters for g_object_new_with_properties(). + * + * Allocate a #GObject of #GType @gtype, with the given @params. The + * returned object is never floating, and we always own a reference to + * it. (It might not be the only existing to the object, but it is in + * any case safe to call g_object_unref() when we are not wrapping the + * object ourselves anymore.) + * + * Returns: A new #GObject. + */ +gpointer dbg_g_object_new (GType gtype, guint n_props, + const char *names[], const GValue values[]) +{ + gpointer result; + + if (print_debug_info()) { + GThread *self = g_thread_self(); + + lock_log(); + dbg_log("Creating a new GObject of type %s [thread: %p]\n", + g_type_name(gtype), self); + } + +#if GLIB_CHECK_VERSION(2,54,0) + result = g_object_new_with_properties (gtype, n_props, names, values); +#else + { GParameter params[n_props]; + int i; + + for (i=0; icallback); + + hs_free_fun_ptr (closure->callback); + + dbg_log("\tDone.\n"); + unlock_log(); +} + +/* Check whether the given closure is floating */ +gboolean +haskell_gi_g_closure_is_floating (GClosure *closure) +{ + return !!(closure->floating); +} + +/* GParamSpec* types are registered as GObjects, but they do not have + an exported type_init function. They only export CPP macros, so + we have to provide our own. */ +#define PARAM_TYPE(CamelCase, UPPERCASE) \ + GType haskell_gi_pspec_type_init_##CamelCase (void) { \ + return G_TYPE_##UPPERCASE; \ + } + +PARAM_TYPE(ParamSpec, PARAM); +PARAM_TYPE(ParamSpecBoolean, PARAM_BOOLEAN); +PARAM_TYPE(ParamSpecBoxed, PARAM_BOXED); +PARAM_TYPE(ParamSpecChar, PARAM_CHAR); +PARAM_TYPE(ParamSpecDouble, PARAM_DOUBLE); +PARAM_TYPE(ParamSpecEnum, PARAM_ENUM); +PARAM_TYPE(ParamSpecFlags, PARAM_FLAGS); +PARAM_TYPE(ParamSpecFloat, PARAM_FLOAT); +PARAM_TYPE(ParamSpecGType, PARAM_GTYPE); +PARAM_TYPE(ParamSpecInt, PARAM_INT); +PARAM_TYPE(ParamSpecInt64, PARAM_INT64); +PARAM_TYPE(ParamSpecLong, PARAM_LONG); +PARAM_TYPE(ParamSpecObject, PARAM_OBJECT); +PARAM_TYPE(ParamSpecOverride, PARAM_OVERRIDE); +PARAM_TYPE(ParamSpecParam, PARAM_PARAM); +PARAM_TYPE(ParamSpecPointer, PARAM_POINTER); +PARAM_TYPE(ParamSpecString, PARAM_STRING); +PARAM_TYPE(ParamSpecUChar, PARAM_UCHAR); +PARAM_TYPE(ParamSpecUInt, PARAM_UINT); +PARAM_TYPE(ParamSpecUInt64, PARAM_UINT64); +PARAM_TYPE(ParamSpecULong, PARAM_ULONG); +PARAM_TYPE(ParamSpecUnichar, PARAM_UNICHAR); +PARAM_TYPE(ParamSpecVariant, PARAM_VARIANT); +/* The following is deprecated, ignore the warning that GLib raises. */ +#undef GLIB_DEPRECATED_MACRO +#define GLIB_DEPRECATED_MACRO +PARAM_TYPE(ParamSpecValueArray, PARAM_VALUE_ARRAY); diff --git a/haskell-gi-base.cabal b/haskell-gi-base.cabal --- a/haskell-gi-base.cabal +++ b/haskell-gi-base.cabal @@ -1,5 +1,5 @@ name: haskell-gi-base -version: 0.25.0 +version: 0.26.0 synopsis: Foundation for libraries generated by haskell-gi description: Foundation for libraries generated by haskell-gi homepage: https://github.com/haskell-gi/haskell-gi @@ -47,16 +47,16 @@ Data.GI.Base.Internal.CTypes pkgconfig-depends: gobject-2.0 >= 2.42, glib-2.0 - build-depends: base >= 4.9 && < 5, + build-depends: base >= 4.11 && < 5, bytestring, containers, text >= 1.0 - ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns + ghc-options: -Wall -Wno-redundant-constraints -fwarn-incomplete-patterns -Wcompat build-tool-depends: hsc2hs:hsc2hs cc-options: -fPIC default-language: Haskell2010 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, MonoLocalBinds other-extensions: TypeApplications, ScopedTypeVariables - c-sources: c/hsgclosure.c + c-sources: csrc/hsgclosure.c