haskell-gi-base 0.20 → 0.20.1

raw patch · 9 files changed

+169/−86 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• Data/GI/Base/BasicTypes.hs +7/−6
• Data/GI/Base/CallStack.hs +58/−0
• Data/GI/Base/GError.hsc +20/−14
• Data/GI/Base/ManagedPtr.hs +25/−60
• Data/GI/Base/ShortPrelude.hs +2/−1
• Data/GI/Base/Utils.hsc +10/−4
• c/hsgclosure.c +30/−0
• haskell-gi-base.cabal +4/−1

@@ -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.

@@ -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 <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#GInitiallyUnowned GInitiallyUnowned>.-    gobjectIsInitiallyUnowned :: a -> Bool     -- | The `GType` for this object.     gobjectType :: a -> IO GType @@ -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

@@ -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 _ = "<CallStack only available with GHC >= 7.10.2>"+#endif+#endif

@@ -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 <glib.h>@@ -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

@@ -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 = "<CallStack only available with GHC 8.0>"-#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--- <https://developer.gnome.org/gobject/stable/gobject-The-Base-Object-Type.html#g-object-ref-sink g_object_ref_sink>.---- Notice that the--- semantics here are a little bit subtle: some objects (such as--- GtkWindow, see the code about "user_ref_count" in gtkwindow.c in--- the gtk+ distribution) are created /without/ the floating flag,--- since they own a reference to themselves. So, wrapping them is--- really about adding a ref. If we add the ref, when Haskell drops--- the last ref to the 'GObject' it will /g_object_unref/, and the--- window will /g_object_unref/ itself upon destruction, so by the end--- we don't leak memory. If we don't add the ref, there will be two--- /g_object_unrefs/ acting on the object (one from Haskell and one from--- the GtkWindow destroy) when the object is destroyed and the second--- one will give a segfault.------ This is the story for GInitiallyUnowned objects (e.g. anything that--- is a descendant from GtkWidget). For objects that are not initially--- floating (i.e. not descendents of GInitiallyUnowned) we simply take--- control of the reference.+-- | 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'

@@ -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)

@@ -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)                  })

@@ -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);

@@ -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,