diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,13 @@ +### 0.20.1 + ++ Add Data.GI.Base.CallStack, abstracting (and backporting to the +extent possible) the `HasCallStack` constraint present in newer +GHCs. Using this, we now include callstacks pervasively in the +generated code. + ++ Improve the `WrappedPtr` implementation. + ++ Deprecate `nulltoNothing`, it is better to simply fix the +overrides when necessary. + ++ Make the semantics of GObject ownership transfer closer to those used by the Python bindings. diff --git a/Data/GI/Base/BasicTypes.hs b/Data/GI/Base/BasicTypes.hs --- a/Data/GI/Base/BasicTypes.hs +++ b/Data/GI/Base/BasicTypes.hs @@ -99,8 +99,8 @@ 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) + -- | Make a copy of the given `WrappedPtr`. + wrappedPtrCopy :: a -> IO a -- | A pointer to a function for freeing the given pointer, or -- `Nothing` is the memory associated to the pointer does not need -- to be freed. @@ -108,8 +108,6 @@ -- | 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 @@ -125,7 +123,6 @@ (TypeError ('Text "Type ‘" ':<>: 'ShowType a ':<>: 'Text "’ does not descend from GObject."), ManagedPtrNewtype a) => GObject a where - gobjectIsInitiallyUnowned = undefined gobjectType = undefined #endif @@ -138,14 +135,18 @@ -- an unexpected `Foreign.Ptr.nullPtr`. data UnexpectedNullPointerReturn = UnexpectedNullPointerReturn { nullPtrErrorMsg :: T.Text } - deriving (Show, Typeable) + deriving (Typeable) +instance Show UnexpectedNullPointerReturn where + show r = T.unpack (nullPtrErrorMsg r) + instance Exception UnexpectedNullPointerReturn type family UnMaybe a :: * where UnMaybe (Maybe a) = a UnMaybe a = a +{-# DEPRECATED nullToNothing ["This will be removed in future versions of haskell-gi.", "If you know of wrong introspection data in a binding please report it as an issue at", "http://github.com/haskell-gi/haskell-gi", "so that it can be fixed."] #-} class NullToNothing a where -- | Some functions are not marked as having a nullable return type -- in the introspection data. The result is that they currently do diff --git a/Data/GI/Base/CallStack.hs b/Data/GI/Base/CallStack.hs new file mode 100644 --- /dev/null +++ b/Data/GI/Base/CallStack.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ImplicitParams, KindSignatures, ConstraintKinds #-} +-- | A compatibility layer for `CallStack`, so that we can have +-- uniform signatures even in old GHC versions (even if the +-- functionality itself does not work there). +module Data.GI.Base.CallStack + ( HasCallStack + , prettyCallStack + , callStack + ) where + +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (HasCallStack, prettyCallStack, callStack) +#elif MIN_VERSION_base(4,8,1) +import Data.List (intercalate) +import qualified GHC.Stack as S +import GHC.SrcLoc (SrcLoc(..)) +import GHC.Exts (Constraint) +type HasCallStack = ((?callStack :: S.CallStack) :: Constraint) +type CallStack = [(String, SrcLoc)] +#else +import GHC.Exts (Constraint) +type HasCallStack = (() :: Constraint) +type CallStack = () +#endif + +#if !MIN_VERSION_base(4,9,0) +-- | Return the current `CallStack`. +callStack :: HasCallStack => CallStack +#if MIN_VERSION_base(4,8,1) +callStack = drop 1 (S.getCallStack ?callStack) +#else +callStack = () +#endif +#endif + +#if !MIN_VERSION_base(4,9,0) +prettyCallStack :: CallStack -> String +#if MIN_VERSION_base(4,8,1) +-- | Give a text representation of the current `CallStack`. +prettyCallStack = intercalate "\n" . prettyCallStackLines + where prettySrcLoc :: SrcLoc -> String + prettySrcLoc l = foldr (++) "" [ srcLocFile l, ":" + , show (srcLocStartLine l), ":" + , show (srcLocStartCol l), " in " + , srcLocPackage l, ":", srcLocModule l + ] + + prettyCallStackLines :: CallStack -> [String] + prettyCallStackLines cs = case cs of + [] -> [] + stk -> "CallStack (from HasCallStack):" + : map ((" " ++) . prettyCallSite) stk + + prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc +#else +prettyCallStack _ = "= 7.10.2>" +#endif +#endif diff --git a/Data/GI/Base/GError.hsc b/Data/GI/Base/GError.hsc --- a/Data/GI/Base/GError.hsc +++ b/Data/GI/Base/GError.hsc @@ -11,15 +11,15 @@ -- -- 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 +-- example, for errors of type 'GI.GdkPixbuf.Enums.PixbufError' one could +-- invoke 'GI.GdkPixbuf.Enums.catchPixbufError' \/ +-- 'GI.GdkPixbuf.Enums.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. +-- errors of type 'GI.GdkPixbuf.Enums.PixbufError' will be caught. module Data.GI.Base.GError ( -- * Unpacking GError @@ -51,7 +51,7 @@ , propagateGError , checkGError - + , maybePokeGError ) where #if __GLASGOW_HASKELL__ < 710 @@ -72,7 +72,7 @@ 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.ManagedPtr (wrapBoxed, withManagedPtr, copyBoxed) import Data.GI.Base.Utils (allocMem, freeMem) #include @@ -181,10 +181,9 @@ -> (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 +catchGErrorJust code action handler = catch action handler' + where handler' gerror = do + quark <- gErrorQuarkFromDomain (gerrorClassDomain code) domain <- gerrorDomain gerror code' <- gerrorCode gerror if domain == quark && code' == (fromIntegral . fromEnum) code @@ -208,10 +207,9 @@ 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 +catchGErrorJustDomain action handler = catch action handler' + where handler' gerror = do + quark <- gErrorQuarkFromDomain (gerrorClassDomain (undefined :: err)) domain <- gerrorDomain gerror if domain == quark then do @@ -246,3 +244,11 @@ if gerror /= nullPtr then wrapBoxed GError gerror >>= handler else return result + +-- | If the passed in @`Maybe` `GError`@ is not `Nothing`, store a +-- copy in the passed in pointer, unless the pointer is `nullPtr`. +maybePokeGError :: Ptr (Ptr GError) -> Maybe GError -> IO () +maybePokeGError _ Nothing = return () +maybePokeGError ptrPtr (Just gerror) + | ptrPtr == nullPtr = return () + | otherwise = copyBoxed gerror >>= poke ptrPtr diff --git a/Data/GI/Base/ManagedPtr.hs b/Data/GI/Base/ManagedPtr.hs --- a/Data/GI/Base/ManagedPtr.hs +++ b/Data/GI/Base/ManagedPtr.hs @@ -33,12 +33,13 @@ , disownObject , newBoxed , wrapBoxed + , copyBoxed , copyBoxedPtr , freeBoxed , disownBoxed , wrapPtr , newPtr - , copyPtr + , copyBytes ) where #if !MIN_VERSION_base(4,8,0) @@ -56,21 +57,11 @@ import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Data.GI.Base.BasicTypes +import Data.GI.Base.CallStack (HasCallStack, prettyCallStack, callStack) 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 @@ -104,7 +95,7 @@ } -- | Do not run the finalizers upon garbage collection of the `ManagedPtr`. -disownManagedPtr :: forall a. ManagedPtrNewtype a => a -> IO (Ptr a) +disownManagedPtr :: forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a) disownManagedPtr managed = do ptr <- unsafeManagedPtrGetPtr managed writeIORef (managedPtrIsOwned c) False @@ -112,7 +103,7 @@ 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 :: (HasCallStack, ManagedPtrNewtype a) => a -> (Ptr a -> IO c) -> IO c withManagedPtr managed action = do ptr <- unsafeManagedPtrGetPtr managed result <- action ptr @@ -122,7 +113,7 @@ -- | 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 :: (HasCallStack, ManagedPtrNewtype a) => Maybe a -> (Ptr a -> IO c) -> IO c maybeWithManagedPtr Nothing action = action nullPtr maybeWithManagedPtr (Just managed) action = do ptr <- unsafeManagedPtrGetPtr managed @@ -132,7 +123,7 @@ -- | 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 :: (HasCallStack, ManagedPtrNewtype a) => [a] -> ([Ptr a] -> IO c) -> IO c withManagedPtrList managedList action = do ptrs <- mapM unsafeManagedPtrGetPtr managedList result <- action ptrs @@ -163,13 +154,7 @@ 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 + ++ prettyCallStack callStack) -- | 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 @@ -214,46 +199,22 @@ 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 :: +foreign import ccall "g_object_ref_sink" g_object_ref_sink :: Ptr a -> IO (Ptr a) -- | Construct a Haskell wrapper for a 'GObject', increasing its --- reference count. +-- reference count, or taking ownership of the floating reference if +-- there is one. newObject :: (GObject a, GObject b) => (ManagedPtr a -> a) -> Ptr b -> IO a newObject constructor ptr = do - void $ g_object_ref ptr + void $ g_object_ref_sink 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. +-- | Same as 'newObject', but we steal ownership of the object. 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 @@ -303,6 +264,12 @@ fPtr <- newManagedPtr 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 b = do + GType gtype <- boxedType b + withManagedPtr b (g_boxed_copy gtype) + -- | Like 'copyBoxed', but acting directly on a pointer, instead of a -- managed pointer. copyBoxedPtr :: forall a. BoxedObject a => Ptr a -> IO (Ptr a) @@ -314,7 +281,7 @@ CGType -> Ptr a -> IO () -- | Free the memory associated with a boxed object -freeBoxed :: forall a. BoxedObject a => a -> IO () +freeBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO () freeBoxed boxed = do GType gtype <- boxedType (undefined :: a) ptr <- unsafeManagedPtrGetPtr boxed @@ -338,16 +305,14 @@ -- | 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 + tmpWrap <- newManagedPtr_ ptr + ptr' <- wrappedPtrCopy (constructor tmpWrap) + return $! ptr' -- | 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 +copyBytes :: WrappedPtr a => Int -> Ptr a -> IO (Ptr a) +copyBytes size ptr = do ptr' <- wrappedPtrCalloc memcpy ptr' ptr size return ptr' diff --git a/Data/GI/Base/ShortPrelude.hs b/Data/GI/Base/ShortPrelude.hs --- a/Data/GI/Base/ShortPrelude.hs +++ b/Data/GI/Base/ShortPrelude.hs @@ -45,6 +45,7 @@ , ($) , (++) , (=<<) + , (>=>) , Bool(..) , Float , Double @@ -59,7 +60,7 @@ , realToFrac ) where -import Control.Monad (when) +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) diff --git a/Data/GI/Base/Utils.hsc b/Data/GI/Base/Utils.hsc --- a/Data/GI/Base/Utils.hsc +++ b/Data/GI/Base/Utils.hsc @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, TupleSections, OverloadedStrings, + FlexibleContexts, ConstraintKinds #-} {- | Assorted utility functions for bindings. -} module Data.GI.Base.Utils ( whenJust @@ -44,6 +45,7 @@ import Data.GI.Base.BasicTypes (GType(..), CGType, BoxedObject(..), UnexpectedNullPointerReturn(..)) +import Data.GI.Base.CallStack (HasCallStack, callStack, prettyCallStack) -- | When the given value is of "Just a" form, execute the given action, -- otherwise do nothing. @@ -178,12 +180,14 @@ -- | Check that the given pointer is not NULL. If it is, raise a -- `UnexpectedNullPointerReturn` exception. -checkUnexpectedReturnNULL :: T.Text -> Ptr a -> IO () +checkUnexpectedReturnNULL :: HasCallStack => T.Text -> Ptr a -> IO () checkUnexpectedReturnNULL fnName ptr | ptr == nullPtr = throwIO (UnexpectedNullPointerReturn { nullPtrErrorMsg = "Received unexpected nullPtr in \"" - <> fnName <> "\"." + <> fnName <> "\".\n" <> + "This is a bug in the introspection data, please report it at\nhttps://github.com/haskell-gi/haskell-gi/issues\n" <> + T.pack (prettyCallStack callStack) }) | otherwise = return () @@ -196,5 +200,7 @@ Just r -> return r Nothing -> throwIO (UnexpectedNullPointerReturn { nullPtrErrorMsg = "Received unexpected nullPtr in \"" - <> fnName <> "\"." + <> fnName <> "\".\n" <> + "This is a bug in the introspection data, please report it at\nhttps://github.com/haskell-gi/haskell-gi/issues\n" <> + T.pack (prettyCallStack callStack) }) diff --git a/c/hsgclosure.c b/c/hsgclosure.c --- a/c/hsgclosure.c +++ b/c/hsgclosure.c @@ -79,6 +79,20 @@ } } +/** + * dbg_g_object_new: + * @gtype: #GType for the object to construct. + * @n_params: Number of parameters for g_object_newv(). + * @params: (array length=n_params) Parameters for g_object_newv(). + * + * 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_newv (GType gtype, guint n_params, GParameter *params) { gpointer result; @@ -89,6 +103,22 @@ } result = g_object_newv (gtype, n_params, params); + + /* + Initially unowned GObjects can be either floating or not after + construction. They are generally floating, but GtkWindow for + instance is not floating after construction. + + In either case we want to call g_object_ref_sink(): if the object + is floating to take ownership of the reference, and otherwise to + add a reference that we own. + + If the object is not initially unowned we simply take control of + the initial reference (implicitly). + */ + if (G_IS_INITIALLY_UNOWNED (result)) { + g_object_ref_sink (result); + } if (print_debug_info()) { fprintf(stderr, "\tdone, got a pointer at %p\n", result); 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.20 +version: 0.20.1 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 @@ -15,6 +15,8 @@ build-type: Simple cabal-version: >=1.8 +extra-source-files: ChangeLog.md + source-repository head type: git location: git://github.com/haskell-gi/haskell-gi-base.git @@ -24,6 +26,7 @@ Data.GI.Base.Attributes, Data.GI.Base.BasicConversions, Data.GI.Base.BasicTypes, + Data.GI.Base.CallStack, Data.GI.Base.Closure, Data.GI.Base.Constructible, Data.GI.Base.GError,