haskell-gi 0.26.19 → 0.27.0

raw patch · 6 files changed

+230/−21 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• haskell-gi.cabal +1/−1
• lib/Data/GI/CodeGen/API.hs +13/−2
• lib/Data/GI/CodeGen/CabalHooks.hs +43/−16
• lib/Data/GI/CodeGen/PkgConfig.hs +136/−1
• lib/Data/GI/GIR/Repository.hs +19/−1

@@ -1,3 +1,21 @@+### 0.27.0+++ Record in the generated `GI.<Name>.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).

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

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

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

@@ -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.<Name>.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 "*"

@@ -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\/\<multiarch triplet\>\/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