diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,21 @@ +### 0.27.0 + ++ Record in the generated `GI..Config` module the versions of the + pkg-config packages that the bindings were generated against + (`pkgConfigVersions`). `setupBinding` now takes an additional + argument with the versions recorded by the dependencies, and prints + a loud warning at configure time if they differ from the ones + currently installed. The behaviour on a mismatch can be controlled + with the `HASKELL_GI_ON_VERSION_MISMATCH` environment variable: + `ignore`, `warn` (the default) or `abort`. This helps diagnose + build failures caused by stale dependency bindings, as in + [issue 487](https://github.com/haskell-gi/haskell-gi/issues/487) and + [issue 488](https://github.com/haskell-gi/haskell-gi/issues/488). + +### 0.26.19 + ++ Broader and more robust support for struct fields. + ### 0.26.17 + More robust support for inout arguments, motivated by [issue 472](https://github.com/haskell-gi/haskell-gi/issues/472). 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.19 +version: 0.27.0 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. diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs --- a/lib/Data/GI/CodeGen/API.hs +++ b/lib/Data/GI/CodeGen/API.hs @@ -79,6 +79,8 @@ import Text.Regex.TDFA ((=~)) +import Data.GI.CodeGen.PkgConfig (TaggedPkgConfigVersions, + checkDepVersions) import Data.GI.GIR.Alias (documentListAliases) import Data.GI.GIR.Allocation (AllocationInfo(..), AllocationOp(..), unknownAllocationInfo) import Data.GI.GIR.Arg (Arg(..), Direction(..), Scope(..)) @@ -543,15 +545,22 @@ let callable' = (fnCallable f){callableResolvable = Just resolvable} return (n, APIFunction (f {fnCallable = callable'})) --- | Load and parse a GIR file, including its dependencies. +-- | Load and parse a GIR file, including its dependencies. The +-- pkg-config packages listed in the GIR files for the dependencies +-- are checked against the given versions recorded by the dependency +-- bindings, see `checkDepVersions`. loadGIRInfo :: Bool -- ^ verbose -> Text -- ^ name -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search -> [GIRRule] -- ^ fixups + -> Text -- ^ name of the package being + -- generated, for error reporting + -> [TaggedPkgConfigVersions] -- ^ versions recorded by + -- the dependency bindings -> IO (GIRInfo, [GIRInfo]) -- ^ (parsed doc, parsed deps) -loadGIRInfo verbose name version extraPaths rules = do +loadGIRInfo verbose name version extraPaths rules pkgName depVersions = do (doc, deps) <- loadGIRFile verbose name version extraPaths rules let aliases = M.unions (map documentListAliases (doc : M.elems deps)) parsedDoc = toGIRInfo (parseGIRDocument aliases doc) @@ -561,6 +570,8 @@ Right (docGIR, depsGIR) -> do if girNSName docGIR == name then do + checkDepVersions pkgName verbose (concatMap girPCPackages depsGIR) + depVersions typelibMap <- M.fromList <$> (forM (docGIR : depsGIR) $ \info -> do typelib <- girRequire (girNSName info) (girNSVersion info) return (girNSName info, typelib)) diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -5,6 +5,7 @@ , setupCompatWrapper , configureDryRun , TaggedOverride(..) + , TaggedPkgConfigVersions(..) ) where import qualified Distribution.ModuleName as MN @@ -14,7 +15,7 @@ defaultMainWithHooks, OptimisationLevel(..)) import Distribution.PackageDescription -import Data.GI.CodeGen.API (loadGIRInfo) +import Data.GI.CodeGen.API (loadGIRInfo, GIRInfo(girPCPackages)) import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree, ModuleInfo, transitiveModuleDeps) import Data.GI.CodeGen.CodeGen (genModule) @@ -23,6 +24,8 @@ import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.Overrides (parseOverrides, girFixups, filterAPIsAndDeps) +import Data.GI.CodeGen.PkgConfig (pkgConfigModVersions, + TaggedPkgConfigVersions(..)) import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst, splitOn) import System.Directory (createDirectoryIfMissing) @@ -49,15 +52,18 @@ , overrideText :: Text } --- | Generate the code for the given module. +-- | Generate the code for the given module. We also return the +-- pkg-config packages listed in the GIR file for the module. genModuleCode :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> [TaggedOverride] -- ^ Explicit overrides - -> IO ModuleInfo -genModuleCode name version pkgName pkgVersion verbosity overrides = do + -> [TaggedPkgConfigVersions] -- ^ Versions recorded + -- by the dependencies + -> IO (ModuleInfo, [Text]) +genModuleCode name version pkgName pkgVersion verbosity overrides depVersions = do setupTypelibSearchPath [] parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do @@ -70,6 +76,7 @@ let ovs = mconcat parsed (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs) + pkgName depVersions let (apis, deps) = filterAPIsAndDeps ovs gir girDeps allAPIs = M.union apis deps cfg = Config {modName = name, @@ -79,13 +86,14 @@ verbose = verbosity, overrides = ovs} - return $ genCode cfg allAPIs (toModulePath name) (genModule apis) + return (genCode cfg allAPIs (toModulePath name) (genModule apis), + girPCPackages gir) -- | Write a module containing information about the configuration for -- the package. genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> - [Text] -> IO () -genConfigModule outputDir modName maybeGiven modules = do + M.Map Text Text -> [Text] -> IO () +genConfigModule outputDir modName maybeGiven pcVersions modules = do let fname = joinPath [ fromMaybe "" outputDir , "GI" , T.unpack (ucFirst modName) @@ -97,8 +105,9 @@ utf8WriteFile fname $ T.unlines [ "{-# LANGUAGE OverloadedStrings #-}" , "-- | Build time configuration used during code generation." - , "module GI." <> ucFirst modName <> ".Config ( overrides, modules ) where" + , "module GI." <> ucFirst modName <> ".Config ( overrides, modules, pkgConfigVersions ) where" , "" + , "import qualified Data.Map as M" , "import qualified Data.Text as T" , "import Data.Text (Text)" , "" @@ -111,13 +120,19 @@ , "modules :: [Text]" , "modules = " <> formatList (("GI." <> ucFirst modName <> ".Config") : modules) + , "" + , "-- | Versions of the pkg-config packages (as listed in the" + , "-- introspection data) at the time the bindings were generated." + , "pkgConfigVersions :: M.Map Text Text" + , "pkgConfigVersions = M.fromList" + , formatList (M.toList pcVersions) ] where overrides :: Maybe TaggedOverride -> [Text] overrides Nothing = [] overrides (Just (TaggedOverride _ ovText)) = T.lines ovText - formatList :: [Text] -> Text + formatList :: Show a => [a] -> Text formatList l = " [ " <> T.intercalate "\n , " (map (T.pack . show) l) <> "]" @@ -131,18 +146,22 @@ -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ other overrides + -> [TaggedPkgConfigVersions] -- ^ dependency versions -> Maybe FilePath -- ^ output dir -> ConfHook -- ^ previous `confHook` -> ConfHook confCodeGenHook name version pkgName pkgVersion verbosity - overridesFile inheritedOverrides outputDir + overridesFile inheritedOverrides depVersions outputDir defaultConfHook (gpd, hbi) flags = do givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs - m <- genModuleCode name version pkgName pkgVersion verbosity ovs + (m, pcPackages) <- genModuleCode name version pkgName pkgVersion + verbosity ovs depVersions + pcVersions <- pkgConfigModVersions pcPackages + let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config" em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m) lib = ((condTreeData . fromJust . condLibrary) gpd) @@ -158,13 +177,18 @@ modules <- writeModuleTree verbosity outputDir m - genConfigModule outputDir name givenOvs modules + genConfigModule outputDir name givenOvs pcVersions modules lbi <- defaultConfHook (gpd', hbi) flags return (lbi {withOptimization = NoOptimisation}) --- | The entry point for @Setup.hs@ files in bindings. +-- | The entry point for @Setup.hs@ files in bindings. The +-- `TaggedPkgConfigVersions` should be taken from the +-- @pkgConfigVersions@ entries of the @GI..Config@ modules of the +-- dependencies: if they do not agree with the versions currently +-- reported by pkg-config a warning will be printed, since this +-- typically leads to compilation errors. setupBinding :: Text -- ^ name -> Text -- ^ version -> Text -- ^ pkgName @@ -172,14 +196,17 @@ -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ Explicit overrides + -> [TaggedPkgConfigVersions] -- ^ Dependency versions -> Maybe FilePath -- ^ output dir -> IO () -setupBinding name version pkgName pkgVersion verbose overridesFile overrides outputDir = +setupBinding name version pkgName pkgVersion verbose + overridesFile overrides depVersions outputDir = defaultMainWithHooks (simpleUserHooks { confHook = confCodeGenHook name version pkgName pkgVersion verbose - overridesFile overrides outputDir + overridesFile overrides + depVersions outputDir (confHook simpleUserHooks) }) @@ -266,7 +293,7 @@ givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs - m <- genModuleCode name version pkgName pkgVersion False ovs + (m, _) <- genModuleCode name version pkgName pkgVersion False ovs [] return (("GI." <> ucFirst name <> ".Config") : listModuleTree m, transitiveModuleDeps m) diff --git a/lib/Data/GI/CodeGen/PkgConfig.hs b/lib/Data/GI/CodeGen/PkgConfig.hs --- a/lib/Data/GI/CodeGen/PkgConfig.hs +++ b/lib/Data/GI/CodeGen/PkgConfig.hs @@ -1,9 +1,14 @@ module Data.GI.CodeGen.PkgConfig ( pkgConfigGetVersion , tryPkgConfig + , pkgConfigModVersions + , TaggedPkgConfigVersions(..) + , checkDepVersions ) where import Control.Monad (when) +import qualified Data.List as L +import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid (First(..), (<>)) #else @@ -12,9 +17,24 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Text (Text) -import System.Exit (ExitCode(..)) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..), exitFailure) +import System.IO (hPutStr, hPutStrLn, stderr) import System.Process (readProcessWithExitCode) +-- | The versions of the pkg-config packages that the bindings for a +-- dependency were generated against, as recorded in the +-- @pkgConfigVersions@ entry of its @GI..Config@ module. +data TaggedPkgConfigVersions = + TaggedPkgConfigVersions { pkgConfigTag :: Text + -- ^ Tag for the dependency, for error + -- reporting purposes. + , pkgConfigVersionMap :: M.Map Text Text + -- ^ Map from pkg-config package names to + -- the version of the package at the time + -- the dependency bindings were generated. + } + -- | Try asking pkg-config for the version of a given module, and -- return the package name together with its version. tryPkgConfig :: Text -> IO (Maybe (Text, Text)) @@ -27,6 +47,13 @@ _ -> return Nothing ExitFailure _ -> return Nothing +-- | Ask pkg-config for the installed version of each of the given +-- packages. Packages unknown to pkg-config are omitted from the +-- result. +pkgConfigModVersions :: [Text] -> IO (M.Map Text Text) +pkgConfigModVersions pkgs = + M.fromList . catMaybes <$> mapM tryPkgConfig pkgs + -- | Get the pkg-config name and associated installed version of a given -- gobject-introspection namespace. Since the mapping is not -- one-to-one some guessing is involved, although in most cases the @@ -48,3 +75,111 @@ Just n -> [n <> "-" <> version, n] firstJust = getFirst . mconcat . map First mapM tryPkgConfig alternatives >>= return . firstJust + +-- | What to do when the versions of the pkg-config packages that the +-- dependencies were generated against do not agree with the +-- currently installed ones. +data OnVersionMismatch = IgnoreMismatch -- ^ Do nothing. + | WarnOnMismatch -- ^ Print a warning and continue. + | AbortOnMismatch -- ^ Print a warning and abort. + +-- | Name of the environment variable controlling what to do on a +-- version mismatch. +onVersionMismatchEnvVar :: String +onVersionMismatchEnvVar = "HASKELL_GI_ON_VERSION_MISMATCH" + +-- | Read the desired behaviour on version mismatches from the +-- environment, defaulting to `WarnOnMismatch`. +getOnVersionMismatch :: IO OnVersionMismatch +getOnVersionMismatch = + lookupEnv onVersionMismatchEnvVar >>= \case + Nothing -> return WarnOnMismatch + Just v -> case T.toLower (T.strip (T.pack v)) of + "" -> return WarnOnMismatch + "ignore" -> return IgnoreMismatch + "warn" -> return WarnOnMismatch + "abort" -> return AbortOnMismatch + _ -> do + hPutStrLn stderr $ "Error: unknown value \"" <> v <> "\" for " + <> onVersionMismatchEnvVar + <> ". Valid values are \"ignore\", \"warn\" (the default) and \"abort\"." + exitFailure + +-- | Check that the versions of the pkg-config packages that the +-- bindings for the dependencies were generated against agree with +-- the versions currently reported by pkg-config for the given +-- packages (typically, those listed in the loaded GIR files for the +-- dependencies). What happens if they do not is controlled by the +-- @HASKELL_GI_ON_VERSION_MISMATCH@ environment variable, see +-- `getOnVersionMismatch`. +checkDepVersions :: Text -- ^ Name of the package being generated + -> Bool -- ^ verbose + -> [Text] -- ^ pkg-config packages to check + -> [TaggedPkgConfigVersions] -- ^ Dependency versions + -> IO () +checkDepVersions pkgName verbosity packages deps = + getOnVersionMismatch >>= \case + IgnoreMismatch -> return () + WarnOnMismatch -> findMismatches >>= \case + [] -> return () + mismatches -> printWarning mismatches + [ "Continuing anyway. Set " <> envVar <> "=abort to make this" + , "an error, or " <> envVar <> "=ignore to silence this warning." ] + AbortOnMismatch -> findMismatches >>= \case + [] -> return () + mismatches -> do + printWarning mismatches + [ "Aborting, since " <> envVar <> "=abort."] + exitFailure + + where + envVar :: Text + envVar = T.pack onVersionMismatchEnvVar + + findMismatches :: IO [(Text, Text, Text, Text)] + findMismatches = do + let recorded = M.unions (map pkgConfigVersionMap deps) + pcPkgs = filter (`M.member` recorded) (L.nub packages) + current <- pkgConfigModVersions pcPkgs + + when verbosity $ + putStrLn $ "Checking dependency versions against pkg-config: " + <> show (M.toList current) + + return [ (tag, pkg, recorded, installed) + | TaggedPkgConfigVersions tag versions <- deps + , (pkg, recorded) <- M.toList versions + , Just installed <- [M.lookup pkg current] + , installed /= recorded ] + + printWarning :: [(Text, Text, Text, Text)] -> [Text] -> IO () + printWarning mismatches outcome = + hPutStr stderr . T.unpack $ T.unlines $ + [ banner + , "WARNING: VERSION MISMATCH WHILE GENERATING BINDINGS FOR " <> T.toUpper pkgName + , banner + , "" + , "The Haskell bindings for the following dependencies were generated" + , "against a different version of the underlying library than the one" + , "currently reported by pkg-config:" + , "" + ] <> + [ " * " <> tag <> ": generated against " <> pkg <> " " <> recorded + <> ", but pkg-config reports " <> pkg <> " " <> installed + | (tag, pkg, recorded, installed) <- mismatches ] <> + [ "" + , "The bindings for " <> pkgName <> " are generated from the currently" + , "installed introspection data, so they may refer to types, methods" + , "or functions that are missing from the dependency bindings listed" + , "above. This typically shows up later as compilation errors of the" + , "form \"Not in scope: type constructor or class ...\" or \"module ..." + , "does not export ...\"." + , "" + , "If this happens, rebuild the dependency bindings listed above" + , "against the currently installed libraries." + , "" + ] <> outcome <> + [ banner ] + + banner :: Text + banner = T.replicate 72 "*" diff --git a/lib/Data/GI/GIR/Repository.hs b/lib/Data/GI/GIR/Repository.hs --- a/lib/Data/GI/GIR/Repository.hs +++ b/lib/Data/GI/GIR/Repository.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Data.GI.GIR.Repository (readGiRepository) where import Prelude hiding (readFile) @@ -6,6 +7,7 @@ import Control.Applicative ((<$>)) #endif +import Control.Exception (SomeException, try) import Control.Monad (when) import Data.Maybe import qualified Data.List as List @@ -18,6 +20,7 @@ import System.Environment (lookupEnv) import System.Environment.XDG.BaseDir (getSystemDataDirs) import System.FilePath (searchPathSeparator, takeBaseName, (), (<.>)) +import System.Process (readProcess) girFilePath :: String -> String -> FilePath -> FilePath girFilePath name version path = path name ++ "-" ++ version <.> "gir" @@ -53,9 +56,24 @@ girDataDirs :: IO [FilePath] girDataDirs = do sys <- getSystemDataDirs "gir-1.0" + arch <- archGirDirs -- See https://github.com/haskell-gi/haskell-gi/issues/390 let macOS = ["/opt/homebrew/share/gir-1.0"] - return (sys ++ macOS) + return (sys ++ arch ++ macOS) + +-- | Some distributions (Debian and Ubuntu, for instance) install the +-- gir files whose contents depend on the architecture (such as +-- Gst-1.0.gir) in an architecture-specific directory, +-- @\/usr\/lib\/\\/gir-1.0@, which we find +-- by asking pkg-config for the library directory. +archGirDirs :: IO [FilePath] +archGirDirs = do + result <- try (readProcess "pkg-config" ["--variable=libdir", "glib-2.0"] "") + return $ case result of + Left (_ :: SomeException) -> [] + Right out -> case lines out of + (libdir : _) | not (null libdir) -> [libdir "gir-1.0"] + _ -> [] -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit