diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +### 0.26.9 + ++ Add a workaround for a [GHC issue](https://gitlab.haskell.org/ghc/ghc/-/issues/23392) stopping parallel compilation in GHC >= 9.6. ++ Fix compilation issues regarding `time_t` and similar types in + introspection data. + ### 0.26.8 + Add support for scope type "forever": see [this issue](https://github.com/haskell-gi/haskell-gi/issues/425). diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.26.9 +version: 0.26.10 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too. @@ -81,7 +81,6 @@ Data.GI.GIR.Union, Data.GI.GIR.XMLUtils, Data.GI.CodeGen.API, - Data.GI.CodeGen.Cabal, Data.GI.CodeGen.CabalHooks, Data.GI.CodeGen.Callable, Data.GI.CodeGen.Code, @@ -124,4 +123,4 @@ build-depends: base , process , doctest >= 0.8 - , haskell-gi + , haskell-gi >= 0.26.10 diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Cabal.hs +++ /dev/null @@ -1,182 +0,0 @@ -module Data.GI.CodeGen.Cabal - ( genCabalProject - , cabalConfig - , setupHs - , tryPkgConfig - ) where - -import Control.Monad (forM_) -import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import Data.Version (Version(..)) -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Text (Text) -import Text.Read - -import Data.GI.CodeGen.API (GIRInfo(..)) -import Data.GI.CodeGen.Code -import Data.GI.CodeGen.Config (Config(..)) -import Data.GI.CodeGen.Overrides (cabalPkgVersion) -import Data.GI.CodeGen.PkgConfig (pkgConfigGetVersion) -import qualified Data.GI.CodeGen.ProjectInfo as PI -import Data.GI.CodeGen.Util (padTo, tshow) - -import Paths_haskell_gi (version) - -cabalConfig :: Text -cabalConfig = T.unlines ["optimization: False"] - -setupHs :: Text -setupHs = T.unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main = defaultMain"] - -haskellGIAPIVersion :: Int -haskellGIAPIVersion = (head . versionBranch) version - --- | Obtain the minor version. That is, if the given version numbers --- are x.y.z, so branch is [x,y,z], we return y. -minorVersion :: [Int] -> Int -minorVersion (_:y:_) = y -minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." - --- | Obtain the haskell-gi minor version. Notice that we only append --- the minor version here, ignoring revisions. (So if the version is --- x.y.z, we drop the "z" part.) This gives us a mechanism for --- releasing bug-fix releases of haskell-gi without increasing the --- necessary dependency on haskell-gi-base, which only depends on x.y. -haskellGIMinor :: Int -haskellGIMinor = minorVersion (versionBranch version) - -{- | - -If the haskell-gi version is of the form x.y[.z] and the pkgconfig -version of the package being wrapped is a.b.c, this gives something of -the form x.a.b.y. - -This strange seeming-rule is so that the packages that we produce -follow the PVP, assuming that the package being wrapped follows the -usual semantic versioning convention (http://semver.org) that -increases in "a" indicate non-backwards compatible changes, increases -in "b" backwards compatible additions to the API, and increases in "c" -denote API compatible changes (so we do not need to regenerate -bindings for these, at least in principle, so we do not encode them in -the cabal version). - -In order to follow the PVP, then everything we need to do in the -haskell-gi side is to increase x everytime the generated API changes -(for a fixed a.b.c version). - -In any case, if such "strange" package numbers are undesired, or the -wrapped package does not follow semver, it is possible to add an -explicit cabal-pkg-version override. This needs to be maintained by -hand (including in the list of dependencies of packages depending on -this one), so think carefully before using this override! - --} -giModuleVersion :: Int -> Int -> Text -giModuleVersion major minor = - (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor, - haskellGIMinor] - --- | Determine the next version for which the minor of the package has --- been bumped. -giNextMinor :: Int -> Int -> Text -giNextMinor major minor = (T.intercalate "." . map tshow) - [haskellGIAPIVersion, major, minor+1] - --- | Info for a given package. -data PkgInfo = PkgInfo { pkgName :: Text - , pkgMajor :: Int - , pkgMinor :: Int - } deriving Show - --- | Determine the pkg-config name and installed version (major.minor --- only) for a given module, or throw an exception if that fails. -tryPkgConfig :: GIRInfo -> Bool -> M.Map Text Text -> IO (Either Text PkgInfo) -tryPkgConfig gir verbose overridenNames = do - let name = girNSName gir - version = girNSVersion gir - packages = girPCPackages gir - - pkgConfigGetVersion name version packages verbose overridenNames >>= \case - Just (n,v) -> - case readMajorMinor v of - Just (major, minor) -> - return $ Right (PkgInfo { pkgName = n - , pkgMajor = major - , pkgMinor = minor}) - Nothing -> return $ Left $ "Cannot parse version \"" <> v <> - "\" for module " <> name - Nothing -> return $ Left $ - "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <> - "Try adding an override with the proper package name:\n" - <> "pkg-config-name " <> name <> " [matching pkg-config name here]" - --- | Given a string a.b.c..., representing a version number, determine --- the major and minor versions, i.e. "a" and "b". If successful, --- return (a,b). -readMajorMinor :: Text -> Maybe (Int, Int) -readMajorMinor version = - case T.splitOn "." version of - (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b) - _ -> Nothing - --- | Generate the cabal project. -genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] -> - [Text] -> BaseVersion -> CodeGen e () -genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major, - pkgMinor = minor}) - deps exposedModules minBaseVersion = do - cfg <- config - let name = girNSName gir - - line $ "-- Autogenerated, do not edit." - line $ padTo 20 "name:" <> "gi-" <> T.toLower name - - let cabalVersion = fromMaybe (giModuleVersion major minor) - (cabalPkgVersion $ overrides cfg) - line $ padTo 20 "version:" <> cabalVersion - line $ padTo 20 "synopsis:" <> name - <> " bindings" - line $ padTo 20 "description:" <> "Bindings for " <> name - <> ", autogenerated by haskell-gi." - line $ padTo 20 "homepage:" <> PI.homepage - line $ padTo 20 "license:" <> PI.license - line $ padTo 20 "license-file:" <> "LICENSE" - line $ padTo 20 "author:" <> PI.authors - line $ padTo 20 "maintainer:" <> PI.maintainers - line $ padTo 20 "category:" <> PI.category - line $ padTo 20 "build-type:" <> "Simple" - line $ padTo 20 "cabal-version:" <> ">=1.10" - blank - line $ "library" - indent $ do - line $ padTo 20 "default-language:" <> PI.defaultLanguage - line $ padTo 20 "default-extensions:" <> - T.intercalate ", " PI.defaultExtensions - line $ padTo 20 "other-extensions:" <> - T.intercalate ", " PI.otherExtensions - line $ padTo 20 "ghc-options:" <> T.intercalate " " PI.ghcOptions - line $ padTo 20 "exposed-modules:" <> head exposedModules - forM_ (tail exposedModules) $ \mod -> - line $ padTo 20 "" <> mod - line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <> - tshow major <> "." <> tshow minor - line $ "build-depends:" - indent $ do - line $ "haskell-gi-base >= " - <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor - <> " && < " <> tshow (haskellGIAPIVersion + 1) <> "," - forM_ deps $ \(dep, PkgInfo _ depMajor depMinor) -> do - let depName = girNSName dep - line $ "gi-" <> T.toLower depName <> " >= " - <> giModuleVersion depMajor depMinor - <> " && < " - <> giNextMinor depMajor depMinor - <> "," - forM_ PI.standardDeps (line . (<> ",")) - line $ "base >= " <> showBaseVersion minBaseVersion <> " && <5" diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -298,9 +298,12 @@ (convert name $ hToF (argType arg) (transfer arg)) (do let maybeName = "maybe" <> ucFirst name + nullPtr <- nullPtrForType (argType arg) >>= \case + Nothing -> terror $ "Unexpected non-pointer type " <> tshow (argType arg) + Just null -> pure null line $ maybeName <> " <- case " <> name <> " of" indent $ do - line $ "Nothing -> return nullPtr" + line $ "Nothing -> return " <> nullPtr let jName = "j" <> ucFirst name line $ "Just " <> jName <> " -> do" indent $ do @@ -360,7 +363,7 @@ let maybeName = "maybe" <> ucFirst name line $ maybeName <> " <- case " <> name <> " of" indent $ do - line $ "Nothing -> return (castPtrToFunPtr nullPtr)" + line $ "Nothing -> return FP.nullFunPtr" let jName = "j" <> ucFirst name jName' = prime jName line $ "Just " <> jName <> " -> do" diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -154,7 +154,9 @@ where returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c) args' = map (fixDestroyers . fixClosures . fixLengthArg) (args c) - args'' = fixInstance (head args') : tail args' + args'' = case args' of + inst:rest -> fixInstanceDirection inst : rest + [] -> [] fixLengthArg :: Arg -> Arg fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)} @@ -179,12 +181,12 @@ then arg {argClosure = closure + 1} else arg - -- We always treat the instance argument of a method as non-null - -- and "in", even if sometimes the introspection data may say - -- otherwise. - fixInstance :: Arg -> Arg - fixInstance arg = arg { mayBeNull = False - , direction = DirectionIn} + -- We always treat the instance argument of a method as "in", + -- even if the introspection data says otherwise (this is + -- generally an erroneous annotation, meaning that the structure + -- is modified). + fixInstanceDirection :: Arg -> Arg + fixInstanceDirection arg = arg { direction = DirectionIn} -- For constructors we want to return the actual type of the object, -- rather than a generic superclass (so Gtk.labelNew returns a @@ -220,7 +222,7 @@ export (NamedSubsection MethodSection $ lowerName mn) (lowerName mn') cppIf CPPOverloading $ - genMethodInfo cn (m {methodCallable = c''}) + genMethodInfo cn (m {methodCallable = c''}) -- | Generate an import for the gvalue getter for the given type. It -- returns the name of the function on the Haskell side. diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -126,6 +126,15 @@ <> "#g:method:" <> mn <> "\")" return $ T.intercalate ", " qualifiedMethods <> ".\n" +-- | Treat the instance argument of a method as non-null, even if the +-- introspection data may say otherwise. Returns the modified +-- callable, together with a boolean value indicating where the +-- nullability annotation has been erased. +nonNullableInstanceArg :: Callable -> (Callable, Bool) +nonNullableInstanceArg c = case args c of + inst:rest -> (c {args = inst {mayBeNull = False} : rest}, mayBeNull inst) + [] -> (c, False) + -- | Generate the `MethodInfo` type and instance for the given method. genMethodInfo :: Name -> Method -> ExcCodeGen () genMethodInfo n m = @@ -133,7 +142,8 @@ group $ do api <- findAPIByName n infoName <- methodInfoName n m - let callable = fixupCallerAllocates (methodCallable m) + let (callable, nullableInstance) = + nonNullableInstanceArg . fixupCallerAllocates $ methodCallable m sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures bline $ "data " <> infoName let (obj, otherTypes) = case map snd (signatureArgTypes sig) of @@ -154,7 +164,9 @@ <> T.intercalate ", " (sigConstraint : signatureConstraints sig) <> ") => O.OverloadedMethod " <> infoName <> " " <> obj <> " signature where" - indent $ line $ "overloadedMethod = " <> mangled + if nullableInstance + then indent $ line $ "overloadedMethod i = " <> mangled <> " (Just i)" + else indent $ line $ "overloadedMethod = " <> mangled group $ do line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -167,13 +167,16 @@ closureDoc :: Text closureDoc = "Wrap the callback into a `GClosure`." --- Wrap a conversion of a nullable object into "Maybe" object, by +-- | Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL. -convertNullable :: Text -> CodeGen e Text -> CodeGen e Text -convertNullable aname c = do +convertNullable :: Text -> CodeGen e Text -> Type -> CodeGen e Text +convertNullable aname c t = do + nullPtr <- nullPtrForType t >>= \case + Nothing -> terror $ "Unexpected non-pointer type " <> tshow t + Just null -> pure null line $ "maybe" <> ucFirst aname <> " <-" indent $ do - line $ "if " <> aname <> " == nullPtr" + line $ "if " <> aname <> " == " <> nullPtr line "then return Nothing" line "else do" indent $ do @@ -187,7 +190,7 @@ convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = if length > -1 then wrapMaybe arg >>= bool convertAndFree - (convertNullable aname convertAndFree) + (convertNullable aname convertAndFree t) else -- Not much we can do, we just pass the pointer along, and let -- the callback deal with it. @@ -220,7 +223,7 @@ t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name _ -> do let c = convert name $ transientToH (argType arg) (transfer arg) - wrapMaybe arg >>= bool c (convertNullable name c) + wrapMaybe arg >>= bool c (convertNullable name c (argType arg)) prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs --- a/lib/Data/GI/GIR/Field.hs +++ b/lib/Data/GI/GIR/Field.hs @@ -51,7 +51,7 @@ -- Sometimes fields marked as not introspectable contain invalid -- introspection info. We are lenient in these cases with parsing -- errors, and simply ignore the fields. - flip catchError (\e -> if (not introspectable) && private + flip catchError (\e -> if not introspectable then return Nothing else throwError e) $ do (t, isPtr, callback) <-