diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +### 0.22.5 + ++ Add support for inheriting overloading info. + ### 0.22.4 + Do not generate bindings for struct/union fields pointing to private/class structs, which we do not bind. 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.22.4 +version: 0.22.5 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. @@ -42,8 +42,6 @@ xml-conduit >= 1.3.0, regex-tdfa >= 1.2, text >= 1.0 - - build-depends: semigroups == 0.18.* extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing 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 @@ -2,7 +2,9 @@ -- bindings. module Data.GI.CodeGen.CabalHooks ( setupHaskellGIBinding + , setupBinding , configureDryRun + , TaggedOverride(..) ) where import qualified Distribution.ModuleName as MN @@ -14,40 +16,55 @@ import Data.GI.CodeGen.API (loadGIRInfo) import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree, - ModuleInfo) + ModuleInfo, transitiveModuleDeps) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath) import Data.GI.CodeGen.ModulePath (toModulePath) -import Data.GI.CodeGen.Overrides (parseOverridesFile, girFixups, +import Data.GI.CodeGen.Overrides (parseOverrides, girFixups, filterAPIsAndDeps) +import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst) -import Control.Monad (void) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (joinPath, takeDirectory) -import Data.Maybe (fromJust) +import Control.Monad (void, forM) + +import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M +import Data.Monoid ((<>)) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +-- | Included overrides file. +data TaggedOverride = + TaggedOverride { overrideTag :: Text + -- ^ Tag for the override, for error reporting purposes. + , overrideText :: Text + } + -- | Generate the code for the given module. genModuleCode :: Text -- ^ name -> Text -- ^ version -> Bool -- ^ verbose - -> Maybe FilePath -- ^ overrides file + -> [TaggedOverride] -- ^ Explicit overrides -> IO ModuleInfo genModuleCode name version verbosity overrides = do setupTypelibSearchPath [] - ovs <- case overrides of - Nothing -> return mempty - Just fname -> parseOverridesFile fname >>= \case - Left err -> error $ "Error when parsing overrides file: " - ++ T.unpack err - Right ovs -> return ovs + parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do + parseOverrides ovText >>= \case + Left err -> error $ "Error when parsing overrides file \"" + <> T.unpack tag <> "\":" + <> T.unpack err + Right ovs -> return ovs + let ovs = mconcat parsed + (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs) let (apis, deps) = filterAPIsAndDeps ovs gir girDeps allAPIs = M.union apis deps @@ -57,20 +74,55 @@ return $ genCode cfg allAPIs (toModulePath name) (genModule apis) +-- | Write a module containing information about the configuration for +-- the package. +genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO () +genConfigModule outputDir modName maybeGiven = do + let fname = joinPath [ fromMaybe "" outputDir + , "GI" + , T.unpack (ucFirst modName) + , "Config.hs" ] + dirname = takeDirectory fname + + createDirectoryIfMissing True dirname + + utf8WriteFile fname $ T.unlines + [ "{-# LANGUAGE OverloadedStrings #-}" + , "module GI." <> ucFirst modName <> ".Config ( overrides ) where" + , "" + , "import qualified Data.Text as T" + , "import Data.Text (Text)" + , "" + , "overrides :: Text" + , "overrides = T.unlines" + , " [ " <> T.intercalate "\n , " (quoteOverrides maybeGiven) <> "]" + ] + + where quoteOverrides :: Maybe TaggedOverride -> [Text] + quoteOverrides Nothing = [] + quoteOverrides (Just (TaggedOverride _ ovText)) = + map (T.pack . show) (T.lines ovText) + -- | A convenience helper for `confHook`, such that bindings for the -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name -> Text -- ^ version -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file + -> [TaggedOverride] -- ^ other overrides -> Maybe FilePath -- ^ output dir -> ConfHook -- ^ previous `confHook` -> ConfHook -confCodeGenHook name version verbosity overrides outputDir +confCodeGenHook name version verbosity overridesFile inheritedOverrides outputDir defaultConfHook (gpd, hbi) flags = do - m <- genModuleCode name version verbosity overrides - let em' = map (MN.fromString . T.unpack) (listModuleTree m) + givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile + + let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs + m <- genModuleCode name version verbosity ovs + + let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config" + em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m) lib = ((condTreeData . fromJust . condLibrary) gpd) bi = libBuildInfo lib #if MIN_VERSION_base(4,11,0) @@ -84,6 +136,8 @@ void $ writeModuleTree verbosity outputDir m + genConfigModule outputDir name givenOvs + lbi <- defaultConfHook (gpd', hbi) flags return (lbi {withOptimization = NoOptimisation}) @@ -96,18 +150,35 @@ -> Maybe FilePath -- ^ output dir -> IO () setupHaskellGIBinding name version verbose overridesFile outputDir = + setupBinding name version verbose overridesFile [] outputDir + +-- | The entry point for @Setup.hs@ files in bindings. +setupBinding :: Text -- ^ name + -> Text -- ^ version + -> Bool -- ^ verbose + -> Maybe FilePath -- ^ overrides file + -> [TaggedOverride] -- ^ Explicit overrides + -> Maybe FilePath -- ^ output dir + -> IO () +setupBinding name version verbose overridesFile overrides outputDir = defaultMainWithHooks (simpleUserHooks { confHook = confCodeGenHook name version verbose - overridesFile outputDir + overridesFile overrides outputDir (confHook simpleUserHooks) }) --- | Return the list of modules that `setupHaskellGIBinding` would create. +-- | Return the list of modules that `setupHaskellGIBinding` would +-- create, together with the set of dependencies loaded while +-- generating the code. configureDryRun :: Text -- ^ name -> Text -- ^ version - -> Maybe FilePath - -> IO [Text] -configureDryRun name version overrides = do - m <- genModuleCode name version False overrides + -> Maybe FilePath -- ^ Overrides file + -> [TaggedOverride] -- ^ Other overrides to load + -> IO ([Text], S.Set Text) +configureDryRun name version overridesFile inheritedOverrides = do + givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile - return (listModuleTree m) + let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs + m <- genModuleCode name version False ovs + + return (listModuleTree m, transitiveModuleDeps m) diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs --- a/lib/Data/GI/CodeGen/Overrides.hs +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -2,7 +2,7 @@ module Data.GI.CodeGen.Overrides ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups, onlineDocsMap) - , parseOverridesFile + , parseOverrides , filterAPIsAndDeps ) where @@ -132,12 +132,11 @@ -- encode this in a monad. type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a --- | Parse the given overrides file, filling in the configuration as +-- | Parse the given overrides, filling in the configuration as -- needed. In case the parsing fails we return a description of the -- error instead. -parseOverridesFile :: FilePath -> IO (Either Text Overrides) -parseOverridesFile fname = do - overrides <- utf8ReadFile fname +parseOverrides :: Text -> IO (Either Text Overrides) +parseOverrides overrides = do runExceptT $ flip evalStateT emptyParserState $ execWriterT $ mapM (parseOneLine . T.strip) (T.lines overrides) @@ -394,10 +393,12 @@ -- | Parse the given overrides file, and merge into the given context. parseInclude :: Text -> Parser () -parseInclude fname = liftIO (parseOverridesFile $ T.unpack fname) >>= \case - Left err -> throwError ("Error when parsing included '" - <> fname <> "': " <> err) - Right ovs -> tell ovs +parseInclude fname = do + includeText <- liftIO $ utf8ReadFile (T.unpack fname) + liftIO (parseOverrides includeText) >>= \case + Left err -> throwError ("Error when parsing included '" + <> fname <> "': " <> err) + Right ovs -> tell ovs -- | Filter a set of named objects based on a lookup list of names to -- ignore.