haskell-gi 0.20.2 → 0.20.3

raw patch · 13 files changed

+379/−312 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• cmdline/haskell-gi.hs +38/−41
• haskell-gi.cabal +1/−1
• lib/Data/GI/CodeGen/Cabal.hs +27/−50
• lib/Data/GI/CodeGen/CabalHooks.hs +14/−34
• lib/Data/GI/CodeGen/Code.hs +215/−131
• lib/Data/GI/CodeGen/CodeGen.hs +11/−18
• lib/Data/GI/CodeGen/Config.hs +1/−14
• lib/Data/GI/CodeGen/Conversions.hs +55/−0
• lib/Data/GI/CodeGen/Haddock.hs +3/−3
• lib/Data/GI/CodeGen/Properties.hs +4/−11
• lib/Data/GI/CodeGen/Signal.hs +2/−2
• lib/Data/GI/CodeGen/Struct.hs +2/−7

@@ -1,3 +1,9 @@+### 0.20.3+++ Make the overloading code protected by a CPP conditional, depending on ENABLE_OVERLOADING being defined. See [issue 107](https://github.com/haskell-gi/haskell-gi/issues/107).+++ Wrap boxed structs/unions as transient [ManagedPtr](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-BasicTypes.html#t:ManagedPtr)s in callbacks. This is needed to fix a number of issues, including [issue 96](https://github.com/haskell-gi/haskell-gi/issues/96) and [issue 97](https://github.com/haskell-gi/haskell-gi/issues/97).+ ### 0.20.2  + Fixes for GHC 8.2.1.

@@ -3,7 +3,7 @@ #if !MIN_VERSION_base(4,8,0) import Data.Traversable (traverse) #endif-import Control.Monad (forM_, when, (>=>))+import Control.Monad (forM_, forM, when, (>=>)) import Control.Exception (handle) import Control.Applicative ((<|>)) @@ -28,17 +28,17 @@ import Text.Show.Pretty (ppShow)  import Data.GI.CodeGen.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API)-import Data.GI.CodeGen.Cabal (cabalConfig, setupHs, genCabalProject)-import Data.GI.CodeGen.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, moduleCode, codeToText, minBaseVersion)-import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..))+import Data.GI.CodeGen.Cabal (cabalConfig, setupHs, genCabalProject, tryPkgConfig)+import Data.GI.CodeGen.Code (genCode, transitiveModuleDeps, writeModuleTree, moduleCode, codeToText, minBaseVersion)+import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath) import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.OverloadedLabels (genOverloadedLabels) import Data.GI.CodeGen.OverloadedSignals (genOverloadedSignalConnectors)-import Data.GI.CodeGen.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps, girFixups)+import Data.GI.CodeGen.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps, girFixups, pkgConfigMap) import Data.GI.CodeGen.ProjectInfo (licenseText)-import Data.GI.CodeGen.Util (ucFirst, utf8ReadFile, utf8WriteFile)+import Data.GI.CodeGen.Util (ucFirst, utf8ReadFile, utf8WriteFile, terror)  data Mode = GenerateCode | Dump | Labels | Signals | Help @@ -134,14 +134,6 @@   gir <- loadRawGIRInfo verbose nameWithoutVersion version extraPaths   return (girAPIs gir) --- | Set up the flags for the code generator.-genFlags :: Options -> CodeGenFlags-genFlags opts = CodeGenFlags {-                  cgOverloadedProperties = optOvProperties opts-                , cgOverloadedSignals = optOvSignals opts-                , cgOverloadedMethods = optOvMethods opts-                }- -- | Generate overloaded labels ("_label", for example). genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO () genLabels options ovs modules extraPaths = do@@ -149,12 +141,11 @@   let allAPIs = M.unions (map M.fromList apis)       cfg = Config {modName = "<<GI autogenerated labels>>",                     verbose = optVerbose options,-                    overrides = ovs,-                    cgFlags = genFlags options+                    overrides = ovs                    }   putStrLn $ "\t* Generating GI.OverloadedLabels"-  m <- genCode cfg allAPIs  "OverloadedLabels"-       (genOverloadedLabels (M.toList allAPIs))+  let m = genCode cfg allAPIs  "OverloadedLabels"+        (genOverloadedLabels (M.toList allAPIs))   _ <- writeModuleTree (optVerbose options) (optOutputDir options) m   return () @@ -165,11 +156,9 @@   let allAPIs = M.unions (map M.fromList apis)       cfg = Config {modName = "<<GI autogenerated connectors>>",                     verbose = optVerbose options,-                    overrides = ovs,-                    cgFlags = genFlags options-                   }+                    overrides = ovs}   putStrLn $ "\t* Generating GI.Signals"-  m <- genCode cfg allAPIs "Signals" (genOverloadedSignalConnectors (M.toList allAPIs))+  let m = genCode cfg allAPIs "Signals" (genOverloadedSignalConnectors (M.toList allAPIs))   _ <- writeModuleTree (optVerbose options) (optOutputDir options) m   return () @@ -180,9 +169,7 @@   let (nameWithoutVersion, version) = solveNameVersion ovs name       cfg = Config {modName = nameWithoutVersion,                     verbose = optVerbose options,-                    overrides = ovs,-                    cgFlags = genFlags options-                   }+                    overrides = ovs}       nm = ucFirst nameWithoutVersion       mp = T.unpack . ("GI." <>) @@ -192,9 +179,9 @@                     (girFixups ovs)   let (apis, deps) = filterAPIsAndDeps ovs gir girDeps       allAPIs = M.union apis deps+      m = genCode cfg allAPIs (toModulePath nm) (genModule apis)+      modDeps = transitiveModuleDeps m -  m <- genCode cfg allAPIs (toModulePath nm) (genModule apis)-  let modDeps = transitiveModuleDeps m   moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m    when (optCabal options) $ do@@ -204,6 +191,13 @@                   (putStrLn (cabal ++ " exists, writing "                              ++ cabal ++ ".new instead") >>                    return (cabal ++ ".new"))++    let pkMap = pkgConfigMap (overrides cfg)++    pkgInfo <- tryPkgConfig gir (verbose cfg) pkMap >>= \case+        Left err -> terror err+        Right info -> return info+     -- The module is not a dep of itself     let usedDeps = S.delete nameWithoutVersion modDeps         -- We only list as dependencies in the cabal file the@@ -211,20 +205,23 @@         actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps         baseVersion = minBaseVersion m         p = \n -> joinPath [fromMaybe "" (optOutputDir options), n]-    (err, m) <- evalCodeGen cfg allAPIs (error "undefined module path")-                (genCabalProject gir actualDeps moduleList baseVersion)-    case err of-      Nothing -> do-               putStrLn $ "\t\t+ " ++ fname-               utf8WriteFile (p fname) (codeToText (moduleCode m))-               putStrLn "\t\t+ cabal.config"-               utf8WriteFile (p "cabal.config") cabalConfig-               putStrLn "\t\t+ Setup.hs"-               utf8WriteFile (p "Setup.hs") setupHs-               putStrLn "\t\t+ LICENSE"-               utf8WriteFile (p "LICENSE") licenseText-      Just msg -> putStrLn $ "ERROR: could not generate " ++ fname-                  ++ "\nError was: " ++ T.unpack msg++    resolvedDeps <- forM actualDeps $ \dep -> do+      tryPkgConfig dep (verbose cfg) pkMap >>= \case+        Left err -> terror err+        Right info -> return (dep, info)++    let m = genCode cfg allAPIs (error "undefined module path")+            (genCabalProject (gir, pkgInfo) resolvedDeps moduleList baseVersion)++    putStrLn $ "\t\t+ " ++ fname+    utf8WriteFile (p fname) (codeToText (moduleCode m))+    putStrLn "\t\t+ cabal.config"+    utf8WriteFile (p "cabal.config") cabalConfig+    putStrLn "\t\t+ Setup.hs"+    utf8WriteFile (p "Setup.hs") setupHs+    putStrLn "\t\t+ LICENSE"+    utf8WriteFile (p "LICENSE") licenseText  dump :: Options -> Overrides -> Text -> IO () dump options ovs name = do

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.20.2+version:             0.20.3 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.

@@ -2,27 +2,25 @@     ( genCabalProject     , cabalConfig     , setupHs+    , tryPkgConfig     ) where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Monad (forM_)-import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T-import qualified Data.Text.IO as TIO import Data.Text (Text) import Text.Read-import System.IO (stderr)  import Data.GI.CodeGen.API (GIRInfo(..)) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Config (Config(..))-import Data.GI.CodeGen.Overrides (pkgConfigMap, cabalPkgVersion)+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)@@ -99,11 +97,13 @@  -- | Determine the pkg-config name and installed version (major.minor -- only) for a given module, or throw an exception if that fails.-tryPkgConfig :: Text -> Text -> [Text] -> Bool-             -> M.Map Text Text-             -> CodeGen (Either Text PkgInfo)-tryPkgConfig name version packages verbose overridenNames =-    liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case+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) ->@@ -126,27 +126,20 @@       (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b)       _ -> Nothing --- | Try to generate the cabal project. In case of error return the--- corresponding error string.-genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion ->-                   CodeGen (Maybe Text)-genCabalProject gir deps exposedModules minBaseVersion = do+-- | Generate the cabal project.+genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] ->+                   [Text] -> BaseVersion -> CodeGen ()+genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major,+                               pkgMinor = minor})+  deps exposedModules minBaseVersion = do       cfg <- config-      let pkMap = pkgConfigMap (overrides cfg)-          name = girNSName gir-          pkgVersion = girNSVersion gir-          packages = girPCPackages gir+      let name = girNSName gir        line $ "-- Autogenerated, do not edit."       line $ padTo 20 "name:" <> "gi-" <> T.toLower name-      eitherPkgInfo <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap-      cabalVersion <- case eitherPkgInfo of-                        Left err -> do-                          liftIO $ TIO.hPutStrLn stderr $ "Warning: " <> err-                          return "0.0.1"-                        Right (PkgInfo _ major minor) ->-                          return $ fromMaybe (giModuleVersion major minor)-                                             (cabalPkgVersion $ overrides cfg)++      let cabalVersion = fromMaybe (giModuleVersion major minor)+                                    (cabalPkgVersion $ overrides cfg)       line $ padTo 20 "version:" <> cabalVersion       line $ padTo 20 "synopsis:" <> name                <> " bindings"@@ -172,35 +165,19 @@         line $ padTo 20 "exposed-modules:" <> head exposedModules         forM_ (tail exposedModules) $ \mod ->               line $ padTo 20 "" <> mod-        case eitherPkgInfo of-          Left _ -> do-            line $ padTo 20 "-- pkg-config info for the module not found:"-            line $ padTo 20 "-- pkgconfig-depends: XXX"-          Right (PkgInfo pcName major minor) ->-            line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <>-                   tshow major <> "." <> tshow minor+        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 -> do+          forM_ deps $ \(dep, PkgInfo _ depMajor depMinor) -> do               let depName = girNSName dep-                  depVersion = girNSVersion dep-                  depPackages = girPCPackages dep-              eitherDepInfo <- tryPkgConfig depName depVersion-                                         depPackages (verbose cfg) pkMap-              case eitherDepInfo of-                Left err -> do-                  liftIO $ TIO.hPutStrLn stderr $ "Warning: " <> err-                  line $ "-- gi-" <> T.toLower depName <> " >= XXX & < YYY"-                Right (PkgInfo _ depMajor depMinor) ->-                  line $ "gi-" <> T.toLower depName <> " >= "-                       <> giModuleVersion depMajor depMinor-                       <> " && < "-                       <> giNextMinor depMajor depMinor-                       <> ","+              line $ "gi-" <> T.toLower depName <> " >= "+                <> giModuleVersion depMajor depMinor+                <> " && < "+                <> giNextMinor depMajor depMinor+                <> ","           forM_ PI.standardDeps (line . (<> ","))           line $ "base >= " <> showBaseVersion minBaseVersion <> " && <5"--      return Nothing -- successful generation, no error

@@ -20,7 +20,7 @@ import Data.GI.CodeGen.API (loadGIRInfo) import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree) import Data.GI.CodeGen.CodeGen (genModule)-import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..))+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,@@ -28,7 +28,7 @@ import Data.GI.CodeGen.PkgConfig (tryPkgConfig) import Data.GI.CodeGen.Util (ucFirst, tshow, utf8ReadFile, utf8WriteFile) -import Control.Monad (when)+import Control.Monad (when, void)  import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M@@ -79,23 +79,6 @@           flags' :: [(String, Bool)]           flags' = map (\(f, v) -> (unFlagName f, v)) flags --- | Parse the set of flags given to configure into flags for the code--- generator.-parseFlags :: [(FlagName, Bool)] -> CodeGenFlags-parseFlags fs = parsed-    where parsed :: CodeGenFlags-          parsed = CodeGenFlags {-                    cgOverloadedProperties = check "overloaded-properties"-                  , cgOverloadedSignals = check "overloaded-signals"-                  , cgOverloadedMethods = check "overloaded-methods"-                  }--          check :: String -> Bool-          check s = fromMaybe True (M.lookup s flags)--          flags :: M.Map String Bool-          flags = M.fromList (map (\(f, v) -> (unFlagName f, v)) fs)- -- | A convenience helper for `confHook`, such that bindings for the -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name@@ -122,29 +105,26 @@       allAPIs = M.union apis deps       cfg = Config {modName = name,                     verbose = verbosity,-                    overrides = ovs,-                    cgFlags = parseFlags (configConfigurationsFlags flags)}+                    overrides = ovs} -  m <- genCode cfg allAPIs (toModulePath name) (genModule apis)-  alreadyDone <- doesFileExist (fromMaybe "" outputDir-                                </> "GI" </> T.unpack (ucFirst name) <.> "hs")-  moduleList <- if not alreadyDone-                then writeModuleTree verbosity outputDir m-                else return (listModuleTree m)+  let m = genCode cfg allAPIs (toModulePath name) (genModule apis)    let pkgInfoMod = "GI." <> ucFirst name <> ".PkgInfo"-      em' = map (MN.fromString . T.unpack) (pkgInfoMod : moduleList)+      em' = map (MN.fromString . T.unpack) (pkgInfoMod : listModuleTree m)       ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'}       cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'}       gpd' = gpd {condLibrary = Just cL'} -  when (not alreadyDone) $-       genPkgInfo ((pkgconfigDepends . libBuildInfo . condTreeData .-                    fromJust . condLibrary) gpd)-                  (configConfigurationsFlags flags)-                  (fromMaybe "" outputDir+  alreadyDone <- doesFileExist (fromMaybe "" outputDir+                                </> "GI" </> T.unpack (ucFirst name) <.> "hs")+  when (not alreadyDone) $ do+    void $ writeModuleTree verbosity outputDir m+    genPkgInfo ((pkgconfigDepends . libBuildInfo . condTreeData .+                  fromJust . condLibrary) gpd)+               (configConfigurationsFlags flags)+               (fromMaybe "" outputDir                    </> "GI" </> T.unpack (ucFirst name) </> "PkgInfo.hs")-                  pkgInfoMod+               pkgInfoMod    lbi <- defaultConfHook (gpd', hbi) flags 

@@ -1,6 +1,7 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.GI.CodeGen.Code-    ( Code(..)-    , ModuleInfo(..)+    ( Code+    , ModuleInfo(moduleCode, moduleDoc)     , ModuleFlag(..)     , BaseCodeGen     , CodeGen@@ -29,10 +30,13 @@     , missingInfoError      , indent+    , increaseIndent     , bline     , line     , blank     , group+    , cppIf+    , CPPGuard(..)     , hsBoot     , submodule     , setLanguagePragmas@@ -66,13 +70,15 @@ import Control.Monad.Except import qualified Data.Foldable as F import Data.Maybe (fromMaybe, catMaybes)-import Data.Monoid ((<>))-import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|))+import Data.Monoid ((<>), mempty) import qualified Data.Map.Strict as M-import qualified Data.Sequence as S+import Data.Sequence (ViewL ((:<)), viewl, (|>))+import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy as LT  import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory)@@ -87,25 +93,37 @@ import Data.GI.CodeGen.Util (tshow, terror, padTo, utf8WriteFile) import Data.GI.CodeGen.ProjectInfo (authors, license, maintainers) -data Code-    = NoCode              -- ^ No code-    | Line Text           -- ^ A single line, indented to current indentation-    | Indent Code         -- ^ Indented region-    | Sequence (Seq Code) -- ^ The basic sequence of code-    | Group Code          -- ^ A grouped set of lines-    deriving (Eq, Show)+-- | Set of CPP conditionals understood by the code generator.+data CPPConditional = CPPIfdef Text -- ^ #ifdef Foo+  deriving (Eq, Show, Ord) -instance Monoid Code where-    mempty = NoCode+-- | The generated `Code` is a sequence of `CodeToken`s.+newtype Code = Code (Seq.Seq CodeToken)+  deriving (Monoid, Eq, Show, Ord) -    NoCode `mappend` NoCode = NoCode-    x `mappend` NoCode = x-    NoCode `mappend` x = x-    (Sequence a) `mappend` (Sequence b) = Sequence (a >< b)-    (Sequence a) `mappend` b = Sequence (a |> b)-    a `mappend` (Sequence b) = Sequence (a <| b)-    a `mappend` b = Sequence (a <| b <| S.empty)+-- | Initializes a code block to the empty sequence.+emptyCode :: Code+emptyCode = Code Seq.empty +-- | Checks whether the given code block is empty.+isCodeEmpty :: Code -> Bool+isCodeEmpty (Code seq) = Seq.null seq++-- | A block of code consisting of a single token.+codeSingleton :: CodeToken -> Code+codeSingleton t = Code (Seq.singleton t)++-- | Possible code tokens.+data CodeToken+    = Line Text           -- ^ A single line, indented to current indentation.+    | Indent Code         -- ^ Indented region.+    | Group Code          -- ^ A grouped set of lines+    | IncreaseIndent      -- ^ Increase the indentation for the rest+                          -- of the lines in the group.+    | CPPBlock CPPConditional Code -- ^ A block of code guarded by the+                                   -- given CPP conditional+    deriving (Eq, Ord, Show)+ type Deps = Set.Set Text  -- | Subsection of the haddock documentation where the export should@@ -122,6 +140,8 @@ data Export = Export {       exportType    :: ExportType       -- ^ Which kind of export.     , exportSymbol  :: SymbolName       -- ^ Actual symbol to export.+    , exportGuards  :: [CPPConditional] -- ^ Protect the export by the+                                        -- given CPP export guards.     } deriving (Show, Eq, Ord)  -- | Possible types of exports.@@ -137,12 +157,12 @@ data ModuleInfo = ModuleInfo {       modulePath :: ModulePath -- ^ Full module name: ["Gtk", "Label"].     , moduleCode :: Code       -- ^ Generated code for the module.-    , bootCode   :: Code       -- ^ Interface going into the .hs-boot file.+    , bootCode   :: Code       -- ^ Interfaces going into the .hs-boot file.     , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative                                           -- module name.     , moduleDeps :: Deps -- ^ Set of dependencies for this module.-    , moduleExports :: Seq Export -- ^ Exports for the module.-    , qualifiedImports :: Set.Set ModulePath -- ^ Qualified (source) imports+    , moduleExports :: Seq.Seq Export -- ^ Exports for the module.+    , qualifiedImports :: Set.Set ModulePath -- ^ Qualified (source) imports.     , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.     , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module.     , moduleFlags   :: Set.Set ModuleFlag -- ^ Flags for the module.@@ -169,11 +189,11 @@ -- | Generate the empty module. emptyModule :: ModulePath -> ModuleInfo emptyModule m = ModuleInfo { modulePath = m-                           , moduleCode = NoCode-                           , bootCode = NoCode+                           , moduleCode = emptyCode+                           , bootCode = emptyCode                            , submodules = M.empty                            , moduleDeps = Set.empty-                           , moduleExports = S.empty+                           , moduleExports = Seq.empty                            , qualifiedImports = Set.empty                            , modulePragmas = Set.empty                            , moduleGHCOpts = Set.empty@@ -190,13 +210,26 @@                                           -- to Haskell symbols.     } +-- | Set of errors for the code generator. data CGError = CGErrorNotImplemented Text              | CGErrorBadIntrospectionInfo Text              | CGErrorMissingInfo Text                deriving (Show) +-- | Temporaty state for the code generator.+data CGState = CGState {+  cgsCPPConditionals :: [CPPConditional] -- ^ Active CPP conditionals,+                                         -- outermost condition first.+  }++-- | Clean slate for `CGState`.+emptyCGState = CGState {+  cgsCPPConditionals = []+  }++-- | The base type for the code generator monad. type BaseCodeGen excType a =-    ReaderT CodeGenConfig (StateT ModuleInfo (ExceptT excType IO)) a+  ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a  -- | The code generator monad, for generators that cannot throw -- errors. The fact that they cannot throw errors is encoded in the@@ -210,18 +243,20 @@ -- | Code generators that can throw errors. type ExcCodeGen a = BaseCodeGen CGError a --- | Run a `CodeGen` with given `Config` and initial `ModuleInfo`,--- returning either the resulting exception, or the result and final--- state of the codegen.-runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> ModuleInfo ->-              IO (Either e (a, ModuleInfo))-runCodeGen cg cfg state = runExceptT (runStateT (runReaderT cg cfg) state)+-- | Run a `CodeGen` with given `Config` and initial state, returning+-- either the resulting exception, or the result and final module info.+runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) ->+              (Either e (a, ModuleInfo))+runCodeGen cg cfg state =+  dropCGState <$> runExcept (runStateT (runReaderT cg cfg) state)+  where dropCGState :: (a, (CGState, ModuleInfo)) -> (a, ModuleInfo)+        dropCGState (x, (_, m)) = (x, m)  -- | This is useful when we plan run a subgenerator, and `mconcat` the -- result to the original structure later. cleanInfo :: ModuleInfo -> ModuleInfo-cleanInfo info = info { moduleCode = NoCode, submodules = M.empty,-                        bootCode = NoCode, moduleExports = S.empty,+cleanInfo info = info { moduleCode = emptyCode, submodules = M.empty,+                        bootCode = emptyCode, moduleExports = Seq.empty,                         qualifiedImports = Set.empty,                         moduleDoc = Nothing, moduleMinBase = Base47 } @@ -229,29 +264,35 @@ -- ambient CodeGen, but without adding the generated code to -- `moduleCode`, instead returning it explicitly. recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)-recurseCG cg = do+recurseCG = recurseWithState id++-- | Like `recurseCG`, but we allow for explicitly setting the state+-- of the inner code generator.+recurseWithState :: (CGState -> CGState) -> BaseCodeGen e a+                 -> BaseCodeGen e (a, Code)+recurseWithState cgsSet cg = do   cfg <- ask-  oldInfo <- get+  (cgs, oldInfo) <- get   -- Start the subgenerator with no code and no submodules.   let info = cleanInfo oldInfo-  liftIO (runCodeGen cg cfg info) >>= \case+  case runCodeGen cg cfg (cgsSet cgs, info) of      Left e -> throwError e-     Right (r, new) -> put (mergeInfoState oldInfo new) >>+     Right (r, new) -> put (cgs, mergeInfoState oldInfo new) >>                        return (r, moduleCode new) --- | Like `recurse`, giving explicitly the set of loaded APIs and C to+-- | Like `recurseCG`, giving explicitly the set of loaded APIs and C to -- Haskell map for the subgenerator. recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen () recurseWithAPIs apis cg = do   cfg <- ask-  oldInfo <- get+  (cgs, oldInfo) <- get   -- Start the subgenerator with no code and no submodules.   let info = cleanInfo oldInfo       cfg' = cfg {loadedAPIs = apis,                   c2hMap = cToHaskellMap (M.toList apis)}-  liftIO (runCodeGen cg cfg' info) >>= \case-     Left e -> throwError e-     Right (_, new) -> put (mergeInfo oldInfo new)+  case runCodeGen cg cfg' (cgs, info) of+    Left e -> throwError e+    Right (_, new) -> put (cgs, mergeInfo oldInfo new)  -- | Merge everything but the generated code for the two given `ModuleInfo`. mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo@@ -281,8 +322,10 @@  -- | Add the given submodule to the list of submodules of the current -- module.-addSubmodule :: Text -> ModuleInfo -> ModuleInfo -> ModuleInfo-addSubmodule modName submodule current = current { submodules = M.insertWith mergeInfo modName submodule (submodules current)}+addSubmodule :: Text -> ModuleInfo -> (CGState, ModuleInfo)+             -> (CGState, ModuleInfo)+addSubmodule modName submodule (cgs, current) =+  (cgs, current { submodules = M.insertWith mergeInfo modName submodule (submodules current)})  -- | Run the given CodeGen in order to generate a single submodule of the -- current module. Note that we do not generate the submodule if the@@ -291,14 +334,14 @@ submodule' :: Text -> BaseCodeGen e () -> BaseCodeGen e () submodule' modName cg = do   cfg <- ask-  oldInfo <- get+  (_, oldInfo) <- get   let info = emptyModule (modulePath oldInfo /. modName)-  liftIO (runCodeGen cg cfg info) >>= \case-         Left e -> throwError e-         Right (_, smInfo) -> if moduleCode smInfo == NoCode &&-                                 M.null (submodules smInfo)-                              then return ()-                              else modify' (addSubmodule modName smInfo)+  case runCodeGen cg cfg (emptyCGState, info) of+    Left e -> throwError e+    Right (_, smInfo) -> if isCodeEmpty (moduleCode smInfo) &&+                            M.null (submodules smInfo)+                         then return ()+                         else modify' (addSubmodule modName smInfo)  -- | Run the given CodeGen in order to generate a submodule (specified -- an an ordered list) of the current module.@@ -312,17 +355,17 @@ handleCGExc fallback  action = do     cfg <- ask-    oldInfo <- get+    (cgs, oldInfo) <- get     let info = cleanInfo oldInfo-    liftIO (runCodeGen action cfg info) >>= \case-        Left e -> fallback e-        Right (r, newInfo) -> do-            put (mergeInfo oldInfo newInfo)-            return r+    case runCodeGen action cfg (cgs, info) of+      Left e -> fallback e+      Right (r, newInfo) -> do+        put (cgs, mergeInfo oldInfo newInfo)+        return r  -- | Return the currently loaded set of dependencies. getDeps :: CodeGen Deps-getDeps = moduleDeps <$> get+getDeps = moduleDeps . snd <$> get  -- | Return the ambient configuration for the code generator. config :: CodeGen Config@@ -331,7 +374,7 @@ -- | Return the name of the current module. currentModule :: CodeGen Text currentModule = do-  s <- get+  (_, s) <- get   return (dotWithPrefix (modulePath s))  -- | Return the list of APIs available to the generator.@@ -343,40 +386,40 @@ getC2HMap = c2hMap <$> ask  -- | Due to the `forall` in the definition of `CodeGen`, if we want to--- run the monad transformer stack until we get an `IO` action, our--- only option is ignoring the possible error code from--- `runExceptT`. This is perfectly safe, since there is no way to--- construct a computation in the `CodeGen` monad that throws an--- exception, due to the higher rank type.-unwrapCodeGen :: CodeGen a -> CodeGenConfig -> ModuleInfo ->-                 IO (a, ModuleInfo)+-- run the monad transformer stack until we get a result, our only+-- option is ignoring the possible error code from `runExcept`. This+-- is perfectly safe, since there is no way to construct a computation+-- in the `CodeGen` monad that throws an exception, due to the higher+-- rank type.+unwrapCodeGen :: CodeGen a -> CodeGenConfig -> (CGState, ModuleInfo)+              -> (a, ModuleInfo) unwrapCodeGen cg cfg info =-    runCodeGen cg cfg info >>= \case-        Left _ -> error "unwrapCodeGen:: The impossible happened!"-        Right (r, newInfo) -> return (r, newInfo)---- | Like `evalCodeGen`, but discard the resulting output value.-genCode :: Config -> M.Map Name API ->-           ModulePath -> CodeGen () -> IO ModuleInfo-genCode cfg apis mPath cg = snd <$> evalCodeGen cfg apis mPath cg+    case runCodeGen cg cfg info of+      Left _ -> error "unwrapCodeGen:: The impossible happened!"+      Right (r, newInfo) -> (r, newInfo)  -- | Run a code generator, and return the information for the -- generated module together with the return value of the generator. evalCodeGen :: Config -> M.Map Name API ->-               ModulePath -> CodeGen a -> IO (a, ModuleInfo)-evalCodeGen cfg apis mPath cg = do+               ModulePath -> CodeGen a -> (a, ModuleInfo)+evalCodeGen cfg apis mPath cg =   let initialInfo = emptyModule mPath       cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis,                             c2hMap = cToHaskellMap (M.toList apis)}-  unwrapCodeGen cg cfg' initialInfo+  in unwrapCodeGen cg cfg' (emptyCGState, initialInfo) +-- | Like `evalCodeGen`, but discard the resulting output value.+genCode :: Config -> M.Map Name API ->+           ModulePath -> CodeGen () -> ModuleInfo+genCode cfg apis mPath cg = snd $ evalCodeGen cfg apis mPath cg+ -- | Mark the given dependency as used by the module. registerNSDependency :: Text -> CodeGen () registerNSDependency name = do     deps <- getDeps     unless (Set.member name deps) $ do         let newDeps = Set.insert name deps-        modify' $ \s -> s {moduleDeps = newDeps}+        modify' $ \(cgs, s) -> (cgs, s {moduleDeps = newDeps})  -- | Return the transitive set of dependencies, i.e. the union of -- those of the module and (transitively) its submodules.@@ -393,7 +436,7 @@   -- Make sure the module is listed as a dependency.   when (modName cfg /= ns) $     registerNSDependency ns-  minfo <- get+  (_, minfo) <- get   if mp == modulePath minfo   then return s   else do@@ -405,7 +448,7 @@ -- under which the module was imported. qualifiedImport :: ModulePath -> CodeGen Text qualifiedImport mp = do-  modify' $ \s -> s {qualifiedImports = Set.insert mp (qualifiedImports s)}+  modify' $ \(cgs, s) -> (cgs, s {qualifiedImports = Set.insert mp (qualifiedImports s)})   return (qualifiedModuleName mp)  -- | Construct a simplified version of the module name, suitable for a@@ -461,8 +504,9 @@             terror $ "couldn't find API description for " <> ns <> "." <> name n  -- | Add some code to the current generator.-tellCode :: Code -> CodeGen ()-tellCode c = modify' (\s -> s {moduleCode = moduleCode s <> c})+tellCode :: CodeToken -> CodeGen ()+tellCode c = modify' (\(cgs, s) -> (cgs, s {moduleCode = moduleCode s <>+                                                         codeSingleton c}))  -- | Print out a (newline-terminated) line. line :: Text -> CodeGen ()@@ -484,6 +528,11 @@   tellCode (Indent code)   return x +-- | Increase the indentation level for the rest of the lines in the+-- current group.+increaseIndent :: CodeGen ()+increaseIndent = tellCode IncreaseIndent+ -- | Group a set of related code. group :: BaseCodeGen e a -> BaseCodeGen e a group cg = do@@ -492,17 +541,42 @@   blank   return x +-- | Guard a block of code with @#ifdef@.+cppIfdef :: Text -> BaseCodeGen e a -> BaseCodeGen e a+cppIfdef cond cg = do+  (x, code) <- recurseWithState addConditional cg+  tellCode (CPPBlock (CPPIfdef cond) code)+  blank+  return x+    where addConditional :: CGState -> CGState+          addConditional cgs = CGState {cgsCPPConditionals = CPPIfdef cond :+                                         cgsCPPConditionals cgs}++-- | Possible features to test via CPP.+data CPPGuard = CPPOverloading -- ^ Enable overloading++-- | Guard a code block with CPP code, such that it is included only+-- if the specified feature is enabled.+cppIf :: CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a+cppIf CPPOverloading = cppIfdef "ENABLE_OVERLOADING"+ -- | Write the given code into the .hs-boot file for the current module. hsBoot :: BaseCodeGen e a -> BaseCodeGen e a hsBoot cg = do   (x, code) <- recurseCG cg-  modify' (\s -> s{bootCode = bootCode s <> code})+  modify' (\(cgs, s) -> (cgs, s{bootCode = bootCode s <>+                               addGuards (cgsCPPConditionals cgs) code}))   return x+  where addGuards :: [CPPConditional] -> Code -> Code+        addGuards [] c = c+        addGuards (cond : conds) c = codeSingleton $ CPPBlock cond (addGuards conds c)  -- | Add a export to the current module.-export :: Export -> CodeGen ()-export e =-    modify' $ \s -> s{moduleExports = moduleExports s |> e}+export :: ([CPPConditional] -> Export) -> CodeGen ()+export partial =+    modify' $ \(cgs, s) -> (cgs,+                            let e = partial $ cgsCPPConditionals cgs+                            in s{moduleExports = moduleExports s |> e})  -- | Reexport a whole module. exportModule :: SymbolName -> CodeGen ()@@ -531,36 +605,43 @@ -- | Set the language pragmas for the current module. setLanguagePragmas :: [Text] -> CodeGen () setLanguagePragmas ps =-    modify' $ \s -> s{modulePragmas = Set.fromList ps}+    modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps})  -- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma). setGHCOptions :: [Text] -> CodeGen () setGHCOptions opts =-    modify' $ \s -> s{moduleGHCOpts = Set.fromList opts}+    modify' $ \(cgs, s) -> (cgs, s{moduleGHCOpts = Set.fromList opts})  -- | Set the given flags for the module. setModuleFlags :: [ModuleFlag] -> CodeGen () setModuleFlags flags =-    modify' $ \s -> s{moduleFlags = Set.fromList flags}+    modify' $ \(cgs, s) -> (cgs, s{moduleFlags = Set.fromList flags})  -- | Set the minimum base version supported by the current module. setModuleMinBase :: BaseVersion -> CodeGen () setModuleMinBase v =-    modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)}+    modify' $ \(cgs, s) -> (cgs, s{moduleMinBase = max v (moduleMinBase s)}) +-- | Format a CPP conditional.+cppCondFormat :: CPPConditional -> (Text, Text)+cppCondFormat (CPPIfdef c) = ("#ifdef " <> c <> "\n", "#endif\n")+ -- | Return a text representation of the `Code`. codeToText :: Code -> Text-codeToText c = T.concat $ str 0 c []-    where-      str :: Int -> Code -> [Text] -> [Text]-      str _ NoCode cont = cont-      str n (Line s) cont =  paddedLine n s : cont-      str n (Indent c) cont = str (n + 1) c cont-      str n (Sequence s) cont = deseq n (S.viewl s) cont-      str n (Group c) cont = str n c cont--      deseq _ S.EmptyL cont = cont-      deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)+codeToText (Code seq) = LT.toStrict . B.toLazyText $ genCode 0 (viewl seq)+  where genCode :: Int -> ViewL CodeToken -> B.Builder+        genCode _ Seq.EmptyL = mempty+        genCode n (Line s :< rest) = B.fromText (paddedLine n s) <>+                                      genCode n (viewl rest)+        genCode n (Indent (Code seq) :< rest) = genCode (n+1) (viewl seq) <>+                                      genCode n (viewl rest)+        genCode n (Group (Code seq) :< rest) = genCode n (viewl seq) <>+                                               genCode n (viewl rest)+        genCode n (CPPBlock cond (Code seq) :< rest) =+          let (condBegin, condEnd) = cppCondFormat cond+          in B.fromText condBegin <> genCode n (viewl seq) <>+             B.fromText condEnd <> genCode n (viewl rest)+        genCode n (IncreaseIndent :< rest) = genCode (n+1) (viewl rest)  -- | Pad a line to the given number of leading spaces, and add a -- newline at the end.@@ -571,21 +652,26 @@ comma :: Text -> Text comma s = padTo 40 s <> "," +-- | Format the given export symbol.+formatExport :: (Export -> Text) -> Export -> Text+formatExport formatName export = go (exportGuards export)+  where go :: [CPPConditional] -> Text+        go [] = (paddedLine 1 . comma . formatName) export+        go (c:cs) = let (begin, end) = cppCondFormat c+                    in begin <> go cs <> end+ -- | Format the list of exported modules. formatExportedModules :: [Export] -> Maybe Text formatExportedModules [] = Nothing formatExportedModules exports =-    Just . T.concat . map ( paddedLine 1-                           . comma-                           . ("module " <>)-                           . exportSymbol)+    Just . T.concat . map (formatExport (("module " <>) . exportSymbol))           . filter ((== ExportModule) . exportType) $ exports  -- | Format the toplevel exported symbols. formatToplevel :: [Export] -> Maybe Text formatToplevel [] = Nothing formatToplevel exports =-    Just . T.concat . map (paddedLine 1 . comma . exportSymbol)+    Just . T.concat . map (formatExport exportSymbol)          . filter ((== ExportToplevel) . exportType) $ exports  -- | Format the type declarations section.@@ -595,9 +681,7 @@     in if exportedTypes == []        then Nothing        else Just . T.unlines $ [ "-- * Exported types"-                               , T.concat . map ( paddedLine 1-                                                . comma-                                                . exportSymbol )+                               , T.concat . map ( formatExport exportSymbol )                                       $ exportedTypes ]  -- | A subsection name, with an optional anchor name.@@ -611,7 +695,7 @@              , subsectionAnchor = Just (prefix <> ":" <> title) }  -- | Format a given section made of subsections.-formatSection :: Text -> (Export -> Maybe (Subsection, SymbolName)) ->+formatSection :: Text -> (Export -> Maybe (Subsection, Export)) ->                  [Export] -> Maybe Text formatSection section filter exports =     if M.null exportedSubsections@@ -622,49 +706,49 @@                               . M.toList ) exportedSubsections]      where-      filteredExports :: [(Subsection, SymbolName)]+      filteredExports :: [(Subsection, Export)]       filteredExports = catMaybes (map filter exports) -      exportedSubsections :: M.Map Subsection (Set.Set SymbolName)+      exportedSubsections :: M.Map Subsection (Set.Set Export)       exportedSubsections = foldr extract M.empty filteredExports -      extract :: (Subsection, SymbolName) -> M.Map Subsection (Set.Set Text)-              -> M.Map Subsection (Set.Set Text)+      extract :: (Subsection, Export) -> M.Map Subsection (Set.Set Export)+              -> M.Map Subsection (Set.Set Export)       extract (subsec, m) secs =           M.insertWith Set.union subsec (Set.singleton m) secs -      formatSubsection :: (Subsection, Set.Set SymbolName) -> Text+      formatSubsection :: (Subsection, Set.Set Export) -> Text       formatSubsection (subsec, symbols) =           T.unlines [ "-- ** " <> case subsectionAnchor subsec of                                     Just anchor -> subsectionTitle subsec <>                                                    " #" <> anchor <> "#"                                     Nothing -> subsectionTitle subsec                     , ( T.concat-                      . map (paddedLine 1 . comma)+                      . map (formatExport exportSymbol)                       . Set.toList ) symbols]  -- | Format the list of methods. formatMethods :: [Export] -> Maybe Text formatMethods = formatSection "Methods" toMethod-    where toMethod :: Export -> Maybe (Subsection, SymbolName)-          toMethod (Export (ExportMethod s) m) =-            Just (subsecWithPrefix "method" s, m)+    where toMethod :: Export -> Maybe (Subsection, Export)+          toMethod e@(Export (ExportMethod s) _ _) =+            Just (subsecWithPrefix "method" s, e)           toMethod _ = Nothing  -- | Format the list of properties. formatProperties :: [Export] -> Maybe Text formatProperties = formatSection "Properties" toProperty-    where toProperty :: Export -> Maybe (Subsection, SymbolName)-          toProperty (Export (ExportProperty s) m) =-            Just (subsecWithPrefix "attr" s, m)+    where toProperty :: Export -> Maybe (Subsection, Export)+          toProperty e@(Export (ExportProperty s) _ _) =+            Just (subsecWithPrefix "attr" s, e)           toProperty _ = Nothing  -- | Format the list of signals. formatSignals :: [Export] -> Maybe Text formatSignals = formatSection "Signals" toSignal-    where toSignal :: Export -> Maybe (Subsection, SymbolName)-          toSignal (Export (ExportSignal s) m) =-            Just (subsecWithPrefix "signal" s, m)+    where toSignal :: Export -> Maybe (Subsection, Export)+          toSignal e@(Export (ExportSignal s) _ _) =+            Just (subsecWithPrefix "signal" s, e)           toSignal _ = Nothing  -- | Format the given export list. This is just the inside of the@@ -709,12 +793,12 @@     <> "    ) where\n" modulePrelude name [] reexportedModules =     "module " <> name <> "\n    ( "-    <> formatExportList (map (Export ExportModule) reexportedModules)+    <> formatExportList (map (\m -> Export ExportModule m []) reexportedModules)     <> "    ) where\n\n"     <> T.unlines (map ("import " <>) reexportedModules) modulePrelude name exports reexportedModules =     "module " <> name <> "\n    ( "-    <> formatExportList (map (Export ExportModule) reexportedModules)+    <> formatExportList (map (\m -> Export ExportModule m []) reexportedModules)     <> "\n"     <> formatExportList exports     <> "    ) where\n\n"@@ -788,7 +872,7 @@   createDirectoryIfMissing True dirname   utf8WriteFile fname (T.unlines [pragmas, optionsGHC, haddock,                                  prelude, imports, deps, code])-  when (bootCode minfo /= NoCode) $ do+  when (not . isCodeEmpty $ bootCode minfo) $ do     let bootFName = modulePathToFilePath dirPrefix (modulePath minfo) ".hs-boot"     utf8WriteFile bootFName (genHsBoot minfo) 

@@ -18,7 +18,6 @@  import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (genCCallableWrapper)-import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.Constant (genConstant) import Data.GI.CodeGen.Code import Data.GI.CodeGen.EnumFlags (genEnum, genFlags)@@ -109,8 +108,7 @@        else return Nothing     -- Overloaded methods-   cfg <- config-   when (cgOverloadedMethods (cgFlags cfg)) $+   cppIf CPPOverloading $         genMethodList n (catMaybes methods)  -- | Generated wrapper for unions.@@ -152,8 +150,7 @@       else return Nothing    -- Overloaded methods-  cfg <- config-  when (cgOverloadedMethods (cgFlags cfg)) $+  cppIf CPPOverloading $        genMethodList n (catMaybes methods)  -- | When parsing the GIR file we add the implicit object argument to@@ -230,8 +227,7 @@     genCCallableWrapper mn' sym c''     exportMethod (lowerName mn) (lowerName mn') -    cfg <- config-    when (cgOverloadedMethods (cgFlags cfg)) $+    cppIf CPPOverloading $          genMethodInfo cn (m {methodCallable = c''})  -- Type casting with type checking@@ -293,8 +289,7 @@      noName name' -    cfg <- config-    when (cgOverloadedMethods (cgFlags cfg)) $+    cppIf CPPOverloading $          fullObjectMethodList n o >>= genMethodList n      forM_ (objSignals o) $ \s ->@@ -305,9 +300,9 @@      (genSignal s n)      genObjectProperties n o-    when (cgOverloadedProperties (cgFlags cfg)) $+    cppIf CPPOverloading $          genNamespacedPropLabels n (objProperties o) (objMethods o)-    when (cgOverloadedSignals (cgFlags cfg)) $+    cppIf CPPOverloading $          genObjectSignals n o      -- Methods@@ -316,7 +311,7 @@       handleCGExc (\e -> line ("-- XXX Could not generate method "                               <> name' <> "::" <> name mn <> "\n"                               <> "-- Error was : " <> describeCGError e)-                  >> (when (cgOverloadedMethods (cgFlags cfg)) $+                  >> (cppIf CPPOverloading $                            genUnsupportedMethodInfo n f))                   (genMethod n f) @@ -333,15 +328,13 @@    noName name' -  cfg <- config-   forM_ (ifSignals iface) $ \s -> handleCGExc      (line . (T.concat ["-- XXX Could not generate signal ", name', "::"                      , sigName s                      , "\n", "-- Error was : "] <>) . describeCGError)      (genSignal s n) -  when (cgOverloadedSignals (cgFlags cfg)) $+  cppIf CPPOverloading $      genInterfaceSignals n iface    isGO <- apiIsGObject n (APIInterface iface)@@ -354,7 +347,7 @@     genGObjectCasts n cn_ uniqueParents      genInterfaceProperties n iface-    when (cgOverloadedProperties (cgFlags cfg)) $+    cppIf CPPOverloading $        genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)    else group $ do@@ -368,7 +361,7 @@        line $ "-- XXX Skipping property generation for non-GObject interface"    -- Methods-  when (cgOverloadedMethods (cgFlags cfg)) $+  cppIf CPPOverloading $        fullInterfaceMethodList n iface >>= genMethodList n    forM_ (ifMethods iface) $ \f -> do@@ -379,7 +372,7 @@              (\e -> line ("-- XXX Could not generate method "                           <> name' <> "::" <> name mn <> "\n"                           <> "-- Error was : " <> describeCGError e)-             >> (when (cgOverloadedMethods (cgFlags cfg)) $+             >> (cppIf CPPOverloading $                       genUnsupportedMethodInfo n f))              (genMethod n f) 

@@ -1,29 +1,16 @@ -- | Configuration for the code generator. module Data.GI.CodeGen.Config     ( Config(..)-    , CodeGenFlags(..)     ) where  import Data.Text (Text) import Data.GI.CodeGen.Overrides (Overrides) --- | Flags controlling different aspects of the code generator.-data CodeGenFlags = CodeGenFlags {-    -- | Whether to generate overloaded properties.-      cgOverloadedProperties :: Bool-    -- | Whether to generate support for overloaded signals.-    , cgOverloadedSignals    :: Bool-    -- | Whether to generate support for overloaded methods.-    , cgOverloadedMethods    :: Bool-    } deriving Show- data Config = Config {       -- | Name of the module being generated.       modName        :: Text,       -- | Whether to print extra info.       verbose        :: Bool,       -- | List of loaded overrides for the code generator.-      overrides      :: Overrides,-      -- | List of flags for the code generator.-      cgFlags        :: CodeGenFlags+      overrides      :: Overrides     } deriving Show

@@ -10,6 +10,7 @@      , hToF     , fToH+    , transientToH     , haskellType     , isoHaskellType     , foreignType@@ -88,6 +89,7 @@     fromString = P . T.pack  data FExpr next = Apply Constructor next+                | LambdaConvert Text next                 | MapC Map Constructor next                 | Literal Constructor next                   deriving (Show, Functor)@@ -125,6 +127,9 @@ literal :: Constructor -> Converter literal f = liftF $ Literal f () +lambdaConvert :: Text -> Converter+lambdaConvert c = liftF $ LambdaConvert c ()+ genConversion :: Text -> Converter -> CodeGen Text genConversion l (Pure ()) = return l genConversion l (Free k) = do@@ -146,6 +151,11 @@            genConversion l' next     MapC _ Id next -> genConversion l next +    LambdaConvert conv next ->+        do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do"+           increaseIndent+           genConversion l' next+     Literal (P f) next ->         do line $ "let " <> l <> " = " <> f            genConversion l next@@ -563,6 +573,51 @@   fType <- foreignType t   constructor <- fToH' t a hType fType transfer   return $ apply constructor++-- | Somewhat like `fToH`, but with slightly different borrowing+-- semantics: in the case of `TransferNothing` we wrap incoming+-- pointers to boxed structs into transient `ManagedPtr`s (every other+-- case behaves as `fToH`). These are `ManagedPtr`s for which we do+-- not make a copy, and which will be disowned when the function+-- exists, instead of making a copy that the GC will collect+-- eventually.+--+-- This is necessary in order to get the semantics of callbacks and+-- signals right: in some cases making a copy of the object does not+-- simply increase the refcount, but rather makes a full copy. In this+-- cases modification of the original object is not possible, but this+-- is sometimes useful, see for example+--+-- https://github.com/haskell-gi/haskell-gi/issues/97+--+-- Another situation where making a copy of incoming arguments is+-- problematic is when the underlying library is not thread-safe. When+-- running under the threaded GHC runtime it can happen that the GC+-- runs on a different OS thread than the thread where the object was+-- created, and this leads to rather mysterious bugs, see for example+--+-- https://github.com/haskell-gi/haskell-gi/issues/96+--+-- This case is particularly nasty, since it affects `onWidgetDraw`,+-- which is very common.+transientToH :: Type -> Transfer -> ExcCodeGen Converter+transientToH t@(TInterface _) TransferNothing = do+  a <- findAPI t+  case a of+    Just (APIStruct s) -> if structIsBoxed s+                          then wrapTransient t+                          else fToH t TransferNothing+    Just (APIUnion u) -> if unionIsBoxed u+                         then wrapTransient t+                         else fToH t TransferNothing+    _ -> fToH t TransferNothing+transientToH t transfer = fToH t transfer++-- | Wrap the given transient.+wrapTransient :: Type -> CodeGen Converter+wrapTransient t = do+  hCon <- typeConName <$> haskellType t+  return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon  unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter unpackCArray length (TCArray False _ _ t) transfer =

@@ -279,6 +279,6 @@     Just raw -> do       c2h <- getC2HMap       docBase <- getDocBase-      modify' $ \s -> s{moduleDoc = moduleDoc s <>-                                    Just (formatHaddock c2h docBase-                                           (parseGtkDoc raw))}+      modify' $ \(cgs, s) -> (cgs, s{moduleDoc = moduleDoc s <>+                                      Just (formatHaddock c2h docBase+                                            (parseGtkDoc raw))})

@@ -17,8 +17,6 @@ import Foreign.Storable (sizeOf)  import Data.GI.CodeGen.API-import Data.GI.CodeGen.Config (Config(cgFlags),-                               CodeGenFlags(cgOverloadedProperties)) import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code import Data.GI.CodeGen.GObject@@ -263,9 +261,8 @@                         then parenthesize sOutType                         else sOutType -  -- Polymorphic _label style lens-  cfg <- config-  when (cgOverloadedProperties (cgFlags cfg)) $ group $ do+  -- Polymorphic #label style lens+  cppIf CPPOverloading $ do     cls <- classConstraint owner     inConstraint <- if writable || constructOnly                     then do@@ -334,19 +331,15 @@ genProperties n ownedProps allProps = do   let name = upperName n -  cfg <- config   forM_ ownedProps $ \prop -> do       handleCGExc (\err -> do                      line $ "-- XXX Generation of property \""                               <> propName prop <> "\" of object \""                               <> name <> "\" failed: " <> describeCGError err-                     (when (cgOverloadedProperties (cgFlags cfg)) $-                           genPlaceholderProperty n prop))+                     cppIf CPPOverloading (genPlaceholderProperty n prop))                   (genOneProperty n prop) -  cfg <- config--  when (cgOverloadedProperties (cgFlags cfg)) $ group $ do+  cppIf CPPOverloading $ do     let propListType = name <> "AttributeList"     line $ "instance O.HasAttributeList " <> name     line $ "type instance O.AttributeList " <> name <> " = " <> propListType

@@ -177,7 +177,7 @@   case argType arg of     t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name     _ -> do-      let c = convert name $ fToH (argType arg) (transfer arg)+      let c = convert name $ transientToH (argType arg) (transfer arg)       wrapMaybe arg >>= bool c (convertNullable name c)  prepareInoutArg :: Arg -> ExcCodeGen Text@@ -224,7 +224,7 @@   line $ dropper <> " _f " <> T.unwords argNames <> " = _f "            <> T.unwords (catMaybes (map passOrIgnore inWithClosures)) --- | The wrapper itself, marshalling to and from Haskell. The first+-- | The wrapper itself, marshalling to and from Haskell. The `Callable` -- argument is possibly a pointer to a FunPtr to free (via -- freeHaskellFunPtr) once the callback is run once, or Nothing if the -- FunPtr will be freed by someone else (the function registering the

@@ -21,7 +21,6 @@ import Data.GI.CodeGen.API import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code-import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util@@ -277,10 +276,7 @@               exportProperty (lcFirst $ fName field) (fieldClear n field)            Nothing -> return () -     cfg <- config-     if cgOverloadedProperties (cgFlags cfg)-     then Just <$> genAttrInfo n field-     else return Nothing+     Just <$> cppIf CPPOverloading (genAttrInfo n field)      where privateType :: Type -> Bool           privateType (TInterface n) = "Private" `T.isSuffixOf` name n@@ -299,8 +295,7 @@    blank -  cfg <- config-  when (cgOverloadedProperties (cgFlags cfg)) $ group $ do+  cppIf CPPOverloading $ do     let attrListName = name' <> "AttributeList"     line $ "instance O.HasAttributeList " <> name'     line $ "type instance O.AttributeList " <> name' <> " = " <> attrListName