haskell-gi 0.24.7 → 0.25.0

raw patch · 25 files changed

+524/−446 lines, 25 filesdep ~haskell-gi-basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-gi-base

API changes (from Hackage documentation)

Files

• haskell-gi.cabal +2/−3
• lib/Data/GI/CodeGen/Cabal.hs +1/−1
• lib/Data/GI/CodeGen/CabalHooks.hs +22/−19
• lib/Data/GI/CodeGen/Callable.hs +8/−8
• lib/Data/GI/CodeGen/Code.hs +91/−74
• lib/Data/GI/CodeGen/CodeGen.hs +67/−41
• lib/Data/GI/CodeGen/Config.hs +8/−1
• lib/Data/GI/CodeGen/Constant.hs +2/−2
• lib/Data/GI/CodeGen/Conversions.hsc +33/−29
• lib/Data/GI/CodeGen/CtoHaskellMap.hs +5/−10
• lib/Data/GI/CodeGen/EnumFlags.hs +5/−5
• lib/Data/GI/CodeGen/GObject.hs +5/−5
• lib/Data/GI/CodeGen/Haddock.hs +7/−7
• lib/Data/GI/CodeGen/Inheritance.hs +14/−14
• lib/Data/GI/CodeGen/LibGIRepository.hs +3/−0
• lib/Data/GI/CodeGen/OverloadedLabels.hs +0/−97
• lib/Data/GI/CodeGen/OverloadedMethods.hs +97/−16
• lib/Data/GI/CodeGen/OverloadedSignals.hs +3/−44
• lib/Data/GI/CodeGen/Properties.hs +58/−25
• lib/Data/GI/CodeGen/Signal.hs +11/−11
• lib/Data/GI/CodeGen/Struct.hs +24/−23
• lib/Data/GI/CodeGen/SymbolNaming.hs +38/−7
• lib/Data/GI/CodeGen/Transfer.hs +3/−3
• lib/Data/GI/GIR/Arg.hs +7/−1
• lib/Data/GI/GIR/Object.hs +10/−0

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.24.7+version:             0.25.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.@@ -33,7 +33,7 @@   default-language:    Haskell2010   pkgconfig-depends:   gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32   build-depends:       base >= 4.9 && < 5,-                       haskell-gi-base >= 0.24.5 && <0.25,+                       haskell-gi-base >= 0.25.0 && <0.26,                        Cabal >= 1.24,                        attoparsec >= 0.13,                        containers,@@ -104,7 +104,6 @@                        Data.GI.CodeGen.LibGIRepository,                        Data.GI.CodeGen.ModulePath,                        Data.GI.CodeGen.OverloadedSignals,-                       Data.GI.CodeGen.OverloadedLabels,                        Data.GI.CodeGen.OverloadedMethods,                        Data.GI.CodeGen.Overrides,                        Data.GI.CodeGen.PkgConfig,

@@ -127,7 +127,7 @@  -- | Generate the cabal project. genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] ->-                   [Text] -> BaseVersion -> CodeGen ()+                   [Text] -> BaseVersion -> CodeGen e () genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major,                                pkgMinor = minor})   deps exposedModules minBaseVersion = do

@@ -1,8 +1,7 @@ -- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks-    ( setupHaskellGIBinding-    , setupBinding+    ( setupBinding     , configureDryRun     , TaggedOverride(..)     ) where@@ -52,10 +51,12 @@ -- | Generate the code for the given module. genModuleCode :: Text -- ^ name               -> Text -- ^ version+              -> Text -- ^ pkgName+              -> Text -- ^ pkgVersion               -> Bool -- ^ verbose               -> [TaggedOverride] -- ^ Explicit overrides               -> IO ModuleInfo-genModuleCode name version verbosity overrides = do+genModuleCode name version pkgName pkgVersion verbosity overrides = do   setupTypelibSearchPath []    parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do@@ -71,6 +72,9 @@   let (apis, deps) = filterAPIsAndDeps ovs gir girDeps       allAPIs = M.union apis deps       cfg = Config {modName = name,+                    modVersion = version,+                    ghcPkgName = pkgName,+                    ghcPkgVersion = pkgVersion,                     verbose = verbosity,                     overrides = ovs} @@ -111,19 +115,22 @@ -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name                 -> Text -- ^ version+                -> Text -- ^ pkgName+                -> Text -- ^ pkgVersion                 -> Bool -- ^ verbose                 -> Maybe FilePath -- ^ overrides file                 -> [TaggedOverride] -- ^ other overrides                 -> Maybe FilePath -- ^ output dir                 -> ConfHook -- ^ previous `confHook`                 -> ConfHook-confCodeGenHook name version verbosity overridesFile inheritedOverrides outputDir+confCodeGenHook name version pkgName pkgVersion verbosity+                overridesFile inheritedOverrides 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 verbosity ovs+  m <- genModuleCode name version pkgName pkgVersion verbosity ovs    let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config"       em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m)@@ -147,26 +154,20 @@   return (lbi {withOptimization = NoOptimisation})  -- | The entry point for @Setup.hs@ files in bindings.-setupHaskellGIBinding :: Text -- ^ name-                      -> Text -- ^ version-                      -> Bool -- ^ verbose-                      -> Maybe FilePath -- ^ overrides file-                      -> 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+             -> Text -- ^ pkgName+             -> Text -- ^ pkgVersion              -> Bool -- ^ verbose              -> Maybe FilePath -- ^ overrides file              -> [TaggedOverride] -- ^ Explicit overrides              -> Maybe FilePath -- ^ output dir              -> IO ()-setupBinding name version verbose overridesFile overrides outputDir =+setupBinding name version pkgName pkgVersion verbose overridesFile overrides outputDir =     defaultMainWithHooks (simpleUserHooks {-                            confHook = confCodeGenHook name version verbose+                            confHook = confCodeGenHook name version+                                       pkgName pkgVersion+                                       verbose                                        overridesFile overrides outputDir                                        (confHook simpleUserHooks)                           })@@ -176,14 +177,16 @@ -- generating the code. configureDryRun :: Text -- ^ name                 -> Text -- ^ version+                -> Text -- ^ pkgName+                -> Text -- ^ pkgVersion                 -> Maybe FilePath -- ^ Overrides file                 -> [TaggedOverride] -- ^ Other overrides to load                 -> IO ([Text], S.Set Text)-configureDryRun name version overridesFile inheritedOverrides = do+configureDryRun name version pkgName pkgVersion overridesFile inheritedOverrides = do   givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile    let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs-  m <- genModuleCode name version False ovs+  m <- genModuleCode name version pkgName pkgVersion False ovs    return (("GI." <> ucFirst name <> ".Config") : listModuleTree m,            transitiveModuleDeps m)

@@ -68,7 +68,7 @@  -- | Generate a foreign import for the given C symbol. Return the name -- of the corresponding Haskell identifier.-mkForeignImport :: Text -> Callable -> CodeGen Text+mkForeignImport :: Text -> Callable -> CodeGen e Text mkForeignImport cSymbol callable = do     line first     indent $ do@@ -96,7 +96,7 @@  -- | Make a wrapper for foreign `FunPtr`s of the given type. Return -- the name of the resulting dynamic Haskell wrapper.-mkDynamicImport :: Text -> CodeGen Text+mkDynamicImport :: Text -> CodeGen e Text mkDynamicImport typeSynonym = do   line $ "foreign import ccall \"dynamic\" " <> dynamic <> " :: FunPtr "            <> typeSynonym <> " -> " <> typeSynonym@@ -108,7 +108,7 @@ -- sanity checking to make sure that the argument is actually nullable -- (a relatively common annotation mistake is to mix up (optional) -- with (nullable)).-wrapMaybe :: Arg -> CodeGen Bool+wrapMaybe :: Arg -> CodeGen e Bool wrapMaybe arg = if mayBeNull arg                 then typeIsNullable (argType arg)                 else return False@@ -310,7 +310,7 @@                 return maybeName)  -- | Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen Text+prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen e Text prepareInCallback arg callback@(Callback {cbCallable = cb}) expose = do   let name = escapedArgName arg       ptrName = "ptr" <> name@@ -765,7 +765,7 @@     forM hOutArgs (convertOutArg callable nameMap)  -- | Invoke the given C function, taking care of errors.-invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen ()+invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen e () invokeCFunction callable symbol argNames = do   let returnBind = case returnType callable of                      Nothing -> ""@@ -783,7 +783,7 @@            <> call <> (T.concat . map (" " <>)) argNames  -- | Return the result of the call, possibly including out arguments.-returnResult :: Callable -> Text -> [Text] -> CodeGen ()+returnResult :: Callable -> Text -> [Text] -> CodeGen e () returnResult callable result pps =     if skipRetVal callable || returnType callable == Nothing     then case pps of@@ -911,7 +911,7 @@     }  -- | Some debug info for the callable.-genCallableDebugInfo :: Callable -> CodeGen ()+genCallableDebugInfo :: Callable -> CodeGen e () genCallableDebugInfo callable =     group $ do       commentShow "Args" (args callable)@@ -922,7 +922,7 @@       when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $            do line "-- XXX return value ignored, but it is not a boolean."               line "--     This may be a memory leak?"-  where commentShow :: Show a => Text -> a -> CodeGen ()+  where commentShow :: Show a => Text -> a -> CodeGen e ()         commentShow prefix s =           let padding = T.replicate (T.length prefix + 2) " "               padded = case T.lines (T.pack $ ppShow s) of

@@ -3,10 +3,9 @@     ( Code     , ModuleInfo(moduleCode, sectionDocs)     , ModuleFlag(..)-    , BaseCodeGen     , CodeGen     , ExcCodeGen-    , CGError(..)+    , CGError     , genCode     , evalCodeGen @@ -56,6 +55,7 @@     , NamedSection(..)      , addSectionFormattedDocs+    , prependSectionFormattedDocs      , findAPI     , getAPI@@ -141,6 +141,7 @@ -- | Subsection of the haddock documentation where the export should -- be located, or alternatively the toplevel section. data HaddockSection = ToplevelSection+                    | Section NamedSection                     | NamedSubsection NamedSection Text   deriving (Show, Eq, Ord) @@ -259,25 +260,17 @@                        , cgsNextAvailableTyvar = SingleCharTyvar 'a'                        } --- | The base type for the code generator monad.-type BaseCodeGen excType a =+-- | The base type for the code generator monad. Generators that+-- cannot throw errors are parametric in the exception type 'excType'.+type CodeGen excType 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--- forall, which disallows any operation on the error, except--- discarding it or passing it along without inspecting. This last--- operation is useful in order to allow embedding `CodeGen`--- computations inside `ExcCodeGen` computations, while disallowing--- the opposite embedding without explicit error handling.-type CodeGen a = forall e. BaseCodeGen e a- -- | Code generators that can throw errors.-type ExcCodeGen a = BaseCodeGen CGError a+type ExcCodeGen a = CodeGen CGError a  -- | 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) ->+runCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) ->               (Either e (a, ModuleInfo)) runCodeGen cg cfg state =   dropCGState <$> runExcept (runStateT (runReaderT cg cfg) state)@@ -295,13 +288,13 @@ -- | Run the given code generator using the state and config of an -- ambient CodeGen, but without adding the generated code to -- `moduleCode`, instead returning it explicitly.-recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)+recurseCG :: CodeGen e a -> CodeGen e (a, Code) 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 :: (CGState -> CGState) -> CodeGen e a+                 -> CodeGen e (a, Code) recurseWithState cgsSet cg = do   cfg <- ask   (cgs, oldInfo) <- get@@ -314,7 +307,7 @@  -- | 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 :: M.Map Name API -> CodeGen e () -> CodeGen e () recurseWithAPIs apis cg = do   cfg <- ask   (cgs, oldInfo) <- get@@ -363,7 +356,7 @@ -- current module. Note that we do not generate the submodule if the -- code generator generated no code and the module does not have -- submodules.-submodule' :: Text -> BaseCodeGen e () -> BaseCodeGen e ()+submodule' :: Text -> CodeGen e () -> CodeGen e () submodule' modName cg = do   cfg <- ask   (_, oldInfo) <- get@@ -377,13 +370,13 @@  -- | Run the given CodeGen in order to generate a submodule (specified -- an an ordered list) of the current module.-submodule :: ModulePath -> BaseCodeGen e () -> BaseCodeGen e ()+submodule :: ModulePath -> CodeGen e () -> CodeGen e () submodule (ModulePath []) cg = cg submodule (ModulePath (m:ms)) cg = submodule' m (submodule (ModulePath ms) cg)  -- | Try running the given `action`, and if it fails run `fallback` -- instead.-handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a+handleCGExc :: (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a handleCGExc fallback  action = do     cfg <- ask@@ -396,25 +389,25 @@         return r  -- | Return the currently loaded set of dependencies.-getDeps :: CodeGen Deps+getDeps :: CodeGen e Deps getDeps = moduleDeps . snd <$> get  -- | Return the ambient configuration for the code generator.-config :: CodeGen Config+config :: CodeGen e Config config = hConfig <$> ask  -- | Return the name of the current module.-currentModule :: CodeGen Text+currentModule :: CodeGen e Text currentModule = do   (_, s) <- get   return (dotWithPrefix (modulePath s))  -- | Return the list of APIs available to the generator.-getAPIs :: CodeGen (M.Map Name API)+getAPIs :: CodeGen e (M.Map Name API) getAPIs = loadedAPIs <$> ask  -- | Return the C -> Haskell available to the generator.-getC2HMap :: CodeGen (M.Map CRef Hyperlink)+getC2HMap :: CodeGen e (M.Map CRef Hyperlink) getC2HMap = c2hMap <$> ask  -- | Due to the `forall` in the definition of `CodeGen`, if we want to@@ -423,7 +416,7 @@ -- 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)+unwrapCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo)               -> (a, ModuleInfo) unwrapCodeGen cg cfg info =     case runCodeGen cg cfg info of@@ -433,7 +426,7 @@ -- | 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 -> (a, ModuleInfo)+               ModulePath -> CodeGen e a -> (a, ModuleInfo) evalCodeGen cfg apis mPath cg =   let initialInfo = emptyModule mPath       cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis,@@ -442,11 +435,11 @@  -- | Like `evalCodeGen`, but discard the resulting output value. genCode :: Config -> M.Map Name API ->-           ModulePath -> CodeGen () -> ModuleInfo+           ModulePath -> CodeGen e () -> 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 :: Text -> CodeGen e () registerNSDependency name = do     deps <- getDeps     unless (Set.member name deps) $ do@@ -462,7 +455,7 @@  -- | Given a module name and a symbol in the module (including a -- proper namespace), return a qualified name for the symbol.-qualified :: ModulePath -> Name -> CodeGen Text+qualified :: ModulePath -> Name -> CodeGen e Text qualified mp (Name ns s) = do   cfg <- config   -- Make sure the module is listed as a dependency.@@ -478,7 +471,7 @@ -- | Import the given module name qualified (as a source import if the -- namespace is the same as the current one), and return the name -- under which the module was imported.-qualifiedImport :: ModulePath -> CodeGen Text+qualifiedImport :: ModulePath -> CodeGen e Text qualifiedImport mp = do   modify' $ \(cgs, s) -> (cgs, s {qualifiedImports = Set.insert mp (qualifiedImports s)})   return (qualifiedModuleName mp)@@ -500,7 +493,7 @@             : map minBaseVersion (M.elems $ submodules minfo))  -- | Print, as a comment, a friendly textual description of the error.-printCGError :: CGError -> CodeGen ()+printCGError :: CGError -> CodeGen e () printCGError (CGErrorNotImplemented e) = do   comment $ "Not implemented: " <> e printCGError (CGErrorBadIntrospectionInfo e) =@@ -518,7 +511,7 @@ missingInfoError s = throwError $ CGErrorMissingInfo s  -- | Get a type variable unused in the current scope.-getFreshTypeVariable :: CodeGen Text+getFreshTypeVariable :: CodeGen e Text getFreshTypeVariable = do   (cgs@(CGState{cgsNextAvailableTyvar = available}), s) <- get   let (tyvar, next) =@@ -535,23 +528,23 @@  -- | Introduce a new scope for type variable naming: the next fresh -- variable will be called 'a'.-resetTypeVariableScope :: CodeGen ()+resetTypeVariableScope :: CodeGen e () resetTypeVariableScope =   modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s))  -- | Try to find the API associated with a given type, if known.-findAPI :: HasCallStack => Type -> CodeGen (Maybe API)+findAPI :: HasCallStack => Type -> CodeGen e (Maybe API) findAPI (TInterface n) = Just <$> findAPIByName n findAPI _ = return Nothing  -- | Find the API associated with a given type. If the API cannot be -- found this raises an `error`.-getAPI :: HasCallStack => Type -> CodeGen API+getAPI :: HasCallStack => Type -> CodeGen e API getAPI t = findAPI t >>= \case            Just a -> return a            Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".") -findAPIByName :: HasCallStack => Name -> CodeGen API+findAPIByName :: HasCallStack => Name -> CodeGen e API findAPIByName n@(Name ns _) = do     apis <- getAPIs     case M.lookup n apis of@@ -560,29 +553,29 @@             terror $ "couldn't find API description for " <> ns <> "." <> name n  -- | Add some code to the current generator.-tellCode :: CodeToken -> CodeGen ()+tellCode :: CodeToken -> CodeGen e () tellCode c = modify' (\(cgs, s) -> (cgs, s {moduleCode = moduleCode s <>                                                          codeSingleton c}))  -- | Print out a (newline-terminated) line.-line :: Text -> CodeGen ()+line :: Text -> CodeGen e () line = tellCode . Line  -- | Print out the given line both to the normal module, and to the -- HsBoot file.-bline :: Text -> CodeGen ()+bline :: Text -> CodeGen e () bline l = hsBoot (line l) >> line l  -- | A blank line-blank :: CodeGen ()+blank :: CodeGen e () blank = line ""  -- | A (possibly multi line) comment, separated by newlines-comment :: Text -> CodeGen ()+comment :: Text -> CodeGen e () comment = tellCode . Comment . T.lines  -- | Increase the indent level for code generation.-indent :: BaseCodeGen e a -> BaseCodeGen e a+indent :: CodeGen e a -> CodeGen e a indent cg = do   (x, code) <- recurseCG cg   tellCode (Indent code)@@ -590,11 +583,11 @@  -- | Increase the indentation level for the rest of the lines in the -- current group.-increaseIndent :: CodeGen ()+increaseIndent :: CodeGen e () increaseIndent = tellCode IncreaseIndent  -- | Group a set of related code.-group :: BaseCodeGen e a -> BaseCodeGen e a+group :: CodeGen e a -> CodeGen e a group cg = do   (x, code) <- recurseCG cg   tellCode (Group code)@@ -602,7 +595,7 @@   return x  -- | Guard a block of code with @#if@.-cppIfBlock :: Text -> BaseCodeGen e a -> BaseCodeGen e a+cppIfBlock :: Text -> CodeGen e a -> CodeGen e a cppIfBlock cond cg = do   (x, code) <- recurseWithState addConditional cg   tellCode (CPPBlock (CPPIf cond) code)@@ -614,14 +607,18 @@  -- | Possible features to test via CPP. data CPPGuard = CPPOverloading -- ^ Enable overloading+              | CPPMinVersion Text (Integer, Integer, Integer)+                -- ^ Require a specific version of the given package.  -- | 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 :: CPPGuard -> CodeGen e a -> CodeGen e a cppIf CPPOverloading = cppIfBlock "defined(ENABLE_OVERLOADING)"+cppIf (CPPMinVersion pkg (a,b,c)) = cppIfBlock $ "MIN_VERSION_" <> pkg <>+  "(" <> tshow a <> "," <> tshow b <> "," <> tshow c <> ")"  -- | Write the given code into the .hs-boot file for the current module.-hsBoot :: BaseCodeGen e a -> BaseCodeGen e a+hsBoot :: CodeGen e a -> CodeGen e a hsBoot cg = do   (x, code) <- recurseCG cg   modify' (\(cgs, s) -> (cgs, s{bootCode = bootCode s <>@@ -632,56 +629,62 @@         addGuards (cond : conds) c = codeSingleton $ CPPBlock cond (addGuards conds c)  -- | Add a export to the current module.-exportPartial :: ([CPPConditional] -> Export) -> CodeGen ()+exportPartial :: ([CPPConditional] -> Export) -> CodeGen e () exportPartial partial =     modify' $ \(cgs, s) -> (cgs,                             let e = partial $ cgsCPPConditionals cgs                             in s{moduleExports = moduleExports s |> e})  -- | Reexport a whole module.-exportModule :: SymbolName -> CodeGen ()+exportModule :: SymbolName -> CodeGen e () exportModule m = exportPartial (Export ExportModule m)  -- | Add a type declaration-related export.-exportDecl :: SymbolName -> CodeGen ()+exportDecl :: SymbolName -> CodeGen e () exportDecl d = exportPartial (Export ExportTypeDecl d)  -- | Export a symbol in the given haddock subsection.-export :: HaddockSection -> SymbolName -> CodeGen ()+export :: HaddockSection -> SymbolName -> CodeGen e () export s n = exportPartial (Export (ExportSymbol s) n)  -- | Set the language pragmas for the current module.-setLanguagePragmas :: [Text] -> CodeGen ()+setLanguagePragmas :: [Text] -> CodeGen e () setLanguagePragmas ps =     modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps})  -- | Add a language pragma for the current module.-addLanguagePragma :: Text -> CodeGen ()+addLanguagePragma :: Text -> CodeGen e () addLanguagePragma p =   modify' $ \(cgs, s) -> (cgs, s{modulePragmas =                                  Set.insert p (modulePragmas s)})  -- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).-setGHCOptions :: [Text] -> CodeGen ()+setGHCOptions :: [Text] -> CodeGen e () setGHCOptions opts =     modify' $ \(cgs, s) -> (cgs, s{moduleGHCOpts = Set.fromList opts})  -- | Set the given flags for the module.-setModuleFlags :: [ModuleFlag] -> CodeGen ()+setModuleFlags :: [ModuleFlag] -> CodeGen e () setModuleFlags flags =     modify' $ \(cgs, s) -> (cgs, s{moduleFlags = Set.fromList flags})  -- | Set the minimum base version supported by the current module.-setModuleMinBase :: BaseVersion -> CodeGen ()+setModuleMinBase :: BaseVersion -> CodeGen e () setModuleMinBase v =     modify' $ \(cgs, s) -> (cgs, s{moduleMinBase = max v (moduleMinBase s)})  -- | Add documentation for a given section.-addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen ()+addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e () addSectionFormattedDocs section docs =-    modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (<>) section-                                                 docs (sectionDocs s)})+    modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (flip (<>))+                                                 section docs (sectionDocs s)}) +-- | Prepend documentation at the beginning of a given section.+prependSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e ()+prependSectionFormattedDocs section docs =+    modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (<>)+                                                 section docs (sectionDocs s)})+ -- | Format a CPP conditional. cppCondFormat :: CPPConditional -> (Text, Text) cppCondFormat (CPPIf c) = ("#if " <> c <> "\n", "#endif\n")@@ -785,18 +788,26 @@ mainSectionName FlagSection = "Flags"  -- | Format a given section made of subsections.-formatSection :: NamedSection -> [(Subsection, Export)] -> Maybe Text-formatSection section exports =-    if null exports+formatSection :: M.Map HaddockSection Text -> NamedSection ->+                 (Set.Set Export, [(Subsection, Export)]) -> Maybe Text+formatSection docs section (sectionExports, subsectionExports) =+    if null subsectionExports && Set.null sectionExports     then Nothing-    else Just . T.unlines $ [" -- * " <> mainSectionName section+    else let docstring = case M.lookup (Section section) docs of+                           Nothing -> ""+                           Just s -> formatHaddockComment s+      in Just . T.unlines $ [" -- * " <> mainSectionName section+                            , docstring+                            , ( T.concat+                              . map (formatExport exportSymbol)+                              . Set.toList ) sectionExports                             , ( T.unlines                               . map formatSubsection                               . M.toList ) exportedSubsections]      where       exportedSubsections :: M.Map Subsection (Set.Set Export)-      exportedSubsections = foldr extract M.empty exports+      exportedSubsections = foldr extract M.empty subsectionExports        extract :: (Subsection, Export) -> M.Map Subsection (Set.Set Export)               -> M.Map Subsection (Set.Set Export)@@ -818,18 +829,23 @@  -- | Format the list of exports into grouped sections. formatSubsectionExports :: M.Map HaddockSection Text -> [Export] -> [Maybe Text]-formatSubsectionExports docs exports = map (uncurry formatSection)+formatSubsectionExports docs exports = map (uncurry (formatSection docs))                                        (M.toAscList collectedExports)-  where collectedExports :: M.Map NamedSection [(Subsection, Export)]+  where collectedExports :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)])         collectedExports = foldl classifyExport M.empty exports -        classifyExport :: M.Map NamedSection [(Subsection, Export)] ->-                          Export -> M.Map NamedSection [(Subsection, Export)]+        classifyExport :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) ->+                          Export ->+                          M.Map NamedSection (Set.Set Export, [(Subsection, Export)])         classifyExport m export =-          case exportType export of+          let join (snew, exnew) (sold, exold) = (Set.union snew sold,+                                                  exnew ++ exold)+          in case exportType export of             ExportSymbol hs@(NamedSubsection ms n) ->               let subsec = subsecWithPrefix ms n (M.lookup hs docs)-              in M.insertWith (++) ms [(subsec, export)] m+              in M.insertWith join ms (Set.empty, [(subsec, export)]) m+            ExportSymbol (Section s) ->+              M.insertWith join s (Set.singleton export, []) m             _ -> m  -- | Format the given export list. This is just the inside of the@@ -940,7 +956,8 @@                 , "import qualified Data.ByteString.Char8 as B"                 , "import qualified Data.Map as Map"                 , "import qualified Foreign.Ptr as FP"-                , "import qualified GHC.OverloadedLabels as OL" ]+                , "import qualified GHC.OverloadedLabels as OL"+                , "import qualified GHC.Records as R" ]  -- | Like `dotModulePath`, but add a "GI." prefix. dotWithPrefix :: ModulePath -> Text

@@ -39,11 +39,11 @@                   genBoxed, genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint,                                      submoduleLocation, lowerName, qualifiedAPI,-                                     normalizedAPIName)+                                     normalizedAPIName, safeCast) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) -genFunction :: Name -> Function -> CodeGen ()+genFunction :: Name -> Function -> CodeGen e () genFunction n (Function symbol fnMovedTo callable) =     -- Only generate the function if it has not been moved.     when (Nothing == fnMovedTo) $@@ -60,7 +60,7 @@                         )  -- | Create the newtype wrapping the ManagedPtr for the given type.-genNewtype :: Text -> CodeGen ()+genNewtype :: Text -> CodeGen e () genNewtype name' = do   group $ do     bline $ "newtype " <> name' <> " = " <> name' <> " (SP.ManagedPtr " <> name' <> ")"@@ -71,7 +71,7 @@     indent $ line $ "toManagedPtr (" <> name' <> " p) = p"  -- | Generate wrapper for structures.-genStruct :: Name -> Struct -> CodeGen ()+genStruct :: Name -> Struct -> CodeGen e () genStruct n s = unless (ignoreStruct n s) $ do    let Name _ name' = normalizedAPIName (APIStruct s) n @@ -105,11 +105,10 @@        else return Nothing     -- Overloaded methods-   cppIf CPPOverloading $-        genMethodList n (catMaybes methods)+   cppIf CPPOverloading (genMethodList n (catMaybes methods))  -- | Generated wrapper for unions.-genUnion :: Name -> Union -> CodeGen ()+genUnion :: Name -> Union -> CodeGen e () genUnion n u = do   let Name _ name' = normalizedAPIName (APIUnion u) n @@ -143,8 +142,7 @@       else return Nothing    -- Overloaded methods-  cppIf CPPOverloading $-       genMethodList n (catMaybes methods)+  cppIf CPPOverloading $ genMethodList n (catMaybes methods)  -- | When parsing the GIR file we add the implicit object argument to -- methods of an object.  Since we are prepending an argument we need@@ -223,28 +221,48 @@     cppIf CPPOverloading $          genMethodInfo cn (m {methodCallable = c''}) +-- | Generate an import for the gvalue getter for the given type. It+-- returns the name of the function on the Haskell side.+genGValueGetter :: Text -> Text -> CodeGen e Text+genGValueGetter name' get_value_fn = group $ do+  let symb = "gv_get_" <> get_value_fn+  line $ "foreign import ccall \"" <> get_value_fn <> "\" " <> symb <> " ::"+  indent $ line $ "FP.Ptr B.GValue.GValue -> IO (FP.Ptr " <> name' <> ")"+  return symb++-- | Generate an import for the gvalue setter for the given type. It+-- returns the name of the function on the Haskell side.+genGValueSetter :: Text -> Text -> CodeGen e Text+genGValueSetter name' set_value_fn = group $ do+  let symb = "gv_set_" <> set_value_fn+  line $ "foreign import ccall \"" <> set_value_fn <> "\" " <> symb <> " ::"+  indent $ line $ "FP.Ptr B.GValue.GValue -> FP.Ptr " <> name' <> " -> IO ()"+  return symb+ -- | Generate the GValue instances for the given GObject.-genGObjectGValueInstance :: Name -> Text -> CodeGen ()-genGObjectGValueInstance n get_type_fn = do+genGValueInstance :: Name -> Text -> Text -> Text -> Text -> CodeGen e ()+genGValueInstance n get_type_fn newFn get_value_fn set_value_fn = do   let name' = upperName n-      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."+      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."    writeHaddock DocBeforeSymbol doc    group $ do-    bline $ "instance B.GValue.IsGValue " <> name' <> " where"+    bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where"     indent $ group $ do-      line $ "toGValue o = do"-      indent $ group $ do-        line $ "gtype <- " <> get_type_fn-        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_object)"-      line $ "fromGValue gv = do"+      line $ "gvalueGType_ = " <> get_type_fn+      line $ "gvalueSet_ gv P.Nothing = " <> set_value_fn <> " gv (FP.nullPtr :: FP.Ptr " <> name' <> ")"+      line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (" <> set_value_fn <> " gv)"+      line $ "gvalueGet_ gv = do"       indent $ group $ do-        line $ "ptr <- B.GValue.get_object gv :: IO (Ptr " <> name' <> ")"-        line $ "B.ManagedPtr.newObject " <> name' <> " ptr"+        line $ "ptr <- " <> get_value_fn <> " gv :: IO (FP.Ptr " <> name' <> ")"+        line $ "if ptr /= FP.nullPtr"+        line $ "then P.Just <$> " <> newFn <> " " <> name' <> " ptr"+        line $ "else return P.Nothing" --- Type casting with type checking-genCasts :: Name -> Text -> [Name] -> CodeGen ()+-- | Type casting with type checking, returns the function returning the+-- GType for the oject.+genCasts :: Name -> Text -> [Name] -> CodeGen e Text genCasts n ti parents = do   isGO <- isGObject (TInterface n)   let name' = upperName n@@ -264,8 +282,6 @@   when isGO $ group $ do       bline $ "instance B.Types.GObject " <> name' -  when isGO $ genGObjectGValueInstance n get_type_fn-   className <- classConstraint n   group $ do     exportDecl className@@ -294,12 +310,14 @@    -- Safe downcasting.   group $ do-    let safeCast = "to" <> name'-    exportDecl safeCast+    cast <- safeCast n+    exportDecl cast     writeHaddock DocBeforeSymbol (castDoc name')-    line $ safeCast <> " :: (MonadIO m, " <> className <> " o) => o -> m " <> name'-    line $ safeCast <> " = liftIO . unsafeCastTo " <> name'+    bline $ cast <> " :: (MIO.MonadIO m, " <> className <> " o) => o -> m " <> name'+    line $ cast <> " = MIO.liftIO . B.ManagedPtr.unsafeCastTo " <> name' +  return get_type_fn+   where castDoc :: Text -> Text         castDoc name' = "Cast to `" <> name' <>                         "`, for types for which this is known to be safe. " <>@@ -312,7 +330,7 @@ -- | Wrap a given Object. We enforce that every Object that we wrap is a -- GObject. This is the case for everything except the ParamSpec* set -- of objects, we deal with these separately.-genObject :: Name -> Object -> CodeGen ()+genObject :: Name -> Object -> CodeGen e () genObject n o = do   let Name _ name' = normalizedAPIName (APIObject o) n   let t = TInterface n@@ -326,11 +344,19 @@    -- Type safe casting to parent objects, and implemented interfaces.   parents <- instanceTree n-  genCasts n (objTypeInit o) (parents <> objInterfaces o)+  get_type_fn <- genCasts n (objTypeInit o) (parents <> objInterfaces o) -  cppIf CPPOverloading $-       fullObjectMethodList n o >>= genMethodList n+  if isGO+    then genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object"+    else case (objGetValueFunc o, objSetValueFunc o) of+           (Just get_value_fn, Just set_value_fn) -> do+             getter <- genGValueGetter name' get_value_fn+             setter <- genGValueSetter name' set_value_fn+             genGValueInstance n get_type_fn "B.ManagedPtr.newPtr" getter setter+           _ -> line $ "--- XXX Missing getter and/or setter, so no GValue instance could be generated." +  cppIf CPPOverloading $ fullObjectMethodList n o >>= genMethodList n+   if isGO     then do       forM_ (objSignals o) $ \s -> genSignal s n@@ -362,7 +388,7 @@                             genUnsupportedMethodInfo n f)                 (genMethod n f) -genInterface :: Name -> Interface -> CodeGen ()+genInterface :: Name -> Interface -> CodeGen e () genInterface n iface = do   let Name _ name' = normalizedAPIName (APIInterface iface) n @@ -381,7 +407,8 @@     gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)     allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p     let uniqueParents = nub (concat allParents)-    genCasts n cn_ uniqueParents+    get_type_fn <- genCasts n cn_ uniqueParents+    genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object"      genInterfaceProperties n iface     cppIf CPPOverloading $@@ -410,8 +437,7 @@        comment $ "XXX Skipping property generation for non-GObject interface"    -- Methods-  cppIf CPPOverloading $-       fullInterfaceMethodList n iface >>= genMethodList n+  cppIf CPPOverloading $ fullInterfaceMethodList n iface >>= genMethodList n    forM_ (ifMethods iface) $ \f -> do       let mn = methodName f@@ -440,7 +466,7 @@ -- "moved-to" annotation), we don't generate the method. -- -- It may be more expedient to keep a map of symbol -> function.-symbolFromFunction :: Text -> CodeGen Bool+symbolFromFunction :: Text -> CodeGen e Bool symbolFromFunction sym = do     apis <- getAPIs     return $ any (hasSymbol sym . snd) $ M.toList apis@@ -450,7 +476,7 @@             sym1 == sym2 && movedTo == Nothing         hasSymbol _ _ = False -genAPI :: Name -> API -> CodeGen ()+genAPI :: Name -> API -> CodeGen e () genAPI n (APIConst c) = genConstant n c genAPI n (APIFunction f) = genFunction n f genAPI n (APIEnum e) = genEnum n e@@ -462,10 +488,10 @@ genAPI n (APIInterface i) = genInterface n i  -- | Generate the code for a given API in the corresponding module.-genAPIModule :: Name -> API -> CodeGen ()+genAPIModule :: Name -> API -> CodeGen e () genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api -genModule' :: M.Map Name API -> CodeGen ()+genModule' :: M.Map Name API -> CodeGen e () genModule' apis = do   mapM_ (uncurry genAPIModule)     -- We provide these ourselves@@ -496,7 +522,7 @@     handWritten (Name "GObject" "Closure", _) = True     handWritten _ = False -genModule :: M.Map Name API -> CodeGen ()+genModule :: M.Map Name API -> CodeGen e () genModule apis = do   -- Reexport Data.GI.Base for convenience (so it does not need to be   -- imported separately).

@@ -7,8 +7,15 @@ import Data.GI.CodeGen.Overrides (Overrides)  data Config = Config {-      -- | Name of the module being generated.+      -- | GIR name of the module being generated (Gtk, GObject, ...).       modName        :: Text,+      -- | Version of the GIR API for the package being generated+      -- ("3.0", "2.0", ...).+      modVersion     :: Text,+      -- | Haskell package being generated (gi-gtk, gi-gobject, ...).+      ghcPkgName        :: Text,+      -- | Version of the haskell package ("3.0.35", "2.0.21", ...).+      ghcPkgVersion     :: Text,       -- | Whether to print extra info.       verbose        :: Bool,       -- | List of loaded overrides for the code generator.

@@ -29,7 +29,7 @@ type PSView = Text type PSExpression = Text -writePattern :: Text -> PatternSynonym -> CodeGen ()+writePattern :: Text -> PatternSynonym -> CodeGen e () writePattern name (SimpleSynonym value t) = line $       "pattern " <> ucFirst name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do@@ -40,7 +40,7 @@   indent $ line $           ucFirst name <> " = " <> expression <> " " <> value <> " :: " <> t -genConstant :: Name -> Constant -> CodeGen ()+genConstant :: Name -> Constant -> CodeGen e () genConstant (Name _ name) c = group $ do   setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"]   deprecatedPragma name (constantDeprecated c)

@@ -39,6 +39,10 @@  #include <glib-object.h> +#if !MIN_VERSION_base(4,13,0)+import Data.Monoid ((<>))+#endif+ import Control.Monad (when) import Data.Maybe (isJust) import Data.Text (Text)@@ -129,7 +133,7 @@ lambdaConvert :: Text -> Converter lambdaConvert c = liftF $ LambdaConvert c () -genConversion :: Text -> Converter -> CodeGen Text+genConversion :: Text -> Converter -> CodeGen e Text genConversion l (Pure ()) = return l genConversion l (Free k) = do   let l' = prime l@@ -176,7 +180,7 @@     notImplementedError $ "computeArrayLength called on non-CArray type "                             <> tshow t -convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text+convert :: Text -> CodeGen e Converter -> CodeGen e Text convert l c = do   c' <- c   genConversion l c'@@ -195,25 +199,25 @@   -- type.   else return $ M "unsafeManagedPtrCastPtr" -hVariantToF :: Transfer -> CodeGen Constructor+hVariantToF :: Transfer -> CodeGen e Constructor hVariantToF transfer =   if transfer == TransferEverything   then return $ M "B.GVariant.disownGVariant"   else return $ M "unsafeManagedPtrGetPtr" -hValueToF :: Transfer -> CodeGen Constructor+hValueToF :: Transfer -> CodeGen e Constructor hValueToF transfer =   if transfer == TransferEverything   then return $ M "B.GValue.disownGValue"   else return $ M "unsafeManagedPtrGetPtr" -hParamSpecToF :: Transfer -> CodeGen Constructor+hParamSpecToF :: Transfer -> CodeGen e Constructor hParamSpecToF transfer =   if transfer == TransferEverything   then return $ M "B.GParamSpec.disownGParamSpec"   else return $ M "unsafeManagedPtrGetPtr" -hClosureToF :: Transfer -> Maybe Type -> CodeGen Constructor+hClosureToF :: Transfer -> Maybe Type -> CodeGen e Constructor -- Untyped closures hClosureToF transfer Nothing =   if transfer == TransferEverything@@ -228,7 +232,7 @@   then return $ M "B.GClosure.disownGClosure"   else return $ M "unsafeManagedPtrGetPtr" -hBoxedToF :: Transfer -> CodeGen Constructor+hBoxedToF :: Transfer -> CodeGen e Constructor hBoxedToF transfer =   if transfer == TransferEverything   then return $ M "B.ManagedPtr.disownBoxed"@@ -420,13 +424,13 @@   constructor <- hToF' t a hType fType transfer   return $ apply constructor -boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor+boxedForeignPtr :: Text -> Transfer -> CodeGen e Constructor boxedForeignPtr constructor transfer = return $    case transfer of      TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor      _ -> M $ parenthesize $ "newBoxed " <> constructor -suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor+suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen e Constructor suForeignPtr isBoxed hType transfer = do   let constructor = typeConName hType   if isBoxed then@@ -436,11 +440,11 @@          TransferEverything -> "wrapPtr " <> constructor          _ -> "newPtr " <> constructor -structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor+structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen e Constructor structForeignPtr s =     suForeignPtr (structIsBoxed s) -unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor+unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen e Constructor unionForeignPtr u =     suForeignPtr (unionIsBoxed u) @@ -467,25 +471,25 @@   notImplementedError ("ForeignCallback with unsupported transfer type `"                        <> tshow transfer <> "'") -fVariantToH :: Transfer -> CodeGen Constructor+fVariantToH :: Transfer -> CodeGen e Constructor fVariantToH transfer =   return $ M $ case transfer of                   TransferEverything -> "B.GVariant.wrapGVariantPtr"                   _ -> "B.GVariant.newGVariantFromPtr" -fValueToH :: Transfer -> CodeGen Constructor+fValueToH :: Transfer -> CodeGen e Constructor fValueToH transfer =   return $ M $ case transfer of                   TransferEverything -> "B.GValue.wrapGValuePtr"                   _ -> "B.GValue.newGValueFromPtr" -fParamSpecToH :: Transfer -> CodeGen Constructor+fParamSpecToH :: Transfer -> CodeGen e Constructor fParamSpecToH transfer =   return $ M $ case transfer of                   TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr"                   _ -> "B.GParamSpec.newGParamSpecFromPtr" -fClosureToH :: Transfer -> Maybe Type -> CodeGen Constructor+fClosureToH :: Transfer -> Maybe Type -> CodeGen e Constructor -- Untyped closures fClosureToH transfer Nothing =   return $ M $ case transfer of@@ -654,7 +658,7 @@ transientToH t transfer = fToH t transfer  -- | Wrap the given transient.-wrapTransient :: Type -> CodeGen Converter+wrapTransient :: Type -> CodeGen e Converter wrapTransient t = do   hCon <- typeConName <$> haskellType t   return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon@@ -719,7 +723,7 @@ -- | Given a type find the typeclasses the type belongs to, and return -- the representation of the type in the function signature and the -- list of typeclass constraints for the type.-argumentType :: Type -> ExposeClosures -> CodeGen (Text, [Text])+argumentType :: Type -> ExposeClosures -> CodeGen e (Text, [Text]) argumentType (TGList a) expose = do   (name, constraints) <- argumentType a expose   return ("[" <> name <> "]", constraints)@@ -789,7 +793,7 @@ haskellBasicType TUIntPtr  = con0 "CUIntPtr"  -- | This translates GI types to the types used for generated Haskell code.-haskellType :: Type -> CodeGen TypeRep+haskellType :: Type -> CodeGen e TypeRep haskellType (TBasicType bt) = return $ haskellBasicType bt -- There is no great choice in this case, so we simply pass the -- pointer along. This is useful for GdkPixbufNotify, for example.@@ -847,7 +851,7 @@ callableHasClosures = any (/= -1) . map argClosure . args  -- | Check whether the given type corresponds to a callback.-typeIsCallback :: Type -> CodeGen Bool+typeIsCallback :: Type -> CodeGen e Bool typeIsCallback t@(TInterface _) = do   api <- findAPI t   case api of@@ -867,7 +871,7 @@ -- want this when they appear as arguments to callbacks/signals, or -- return types of properties, as it would force the type synonym/type -- family to depend on the type variable.-isoHaskellType :: Type -> CodeGen TypeRep+isoHaskellType :: Type -> CodeGen e TypeRep isoHaskellType (TGClosure Nothing) =   return $ "GClosure" `con` [con0 "()"] isoHaskellType t@(TInterface n) = do@@ -893,7 +897,7 @@ foreignBasicType t         = haskellBasicType t  -- This translates GI types to the types used in foreign function calls.-foreignType :: Type -> CodeGen TypeRep+foreignType :: Type -> CodeGen e TypeRep foreignType (TBasicType t) = return $ foreignBasicType t foreignType (TCArray _ _ _ TGValue) = return $ ptr ("B.GValue.GValue" `con` []) foreignType (TCArray zt _ _ t) = do@@ -946,7 +950,7 @@       return (ptr $ tname `con` [])  -- | Whether the give type corresponds to an enum or flag.-typeIsEnumOrFlag :: Type -> CodeGen Bool+typeIsEnumOrFlag :: Type -> CodeGen e Bool typeIsEnumOrFlag t = do   a <- findAPI t   case a of@@ -960,7 +964,7 @@ data TypeAllocInfo = TypeAlloc Text Int  -- | Information on how to allocate the given type, if known.-typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo)+typeAllocInfo :: Type -> CodeGen e (Maybe TypeAllocInfo) typeAllocInfo TGValue =   let n = #{size GValue}   in return $ Just $ TypeAlloc ("SP.callocBytes " <> tshow n) n@@ -986,7 +990,7 @@  -- | Returns whether the given type corresponds to a `ManagedPtr` -- instance (a thin wrapper over a `ForeignPtr`).-isManaged   :: Type -> CodeGen Bool+isManaged   :: Type -> CodeGen e Bool isManaged TError = return True isManaged TVariant = return True isManaged TGValue = return True@@ -1004,7 +1008,7 @@  -- | Returns whether the given type is represented by a pointer on the -- C side.-typeIsPtr :: Type -> CodeGen Bool+typeIsPtr :: Type -> CodeGen e Bool typeIsPtr t = isJust <$> typePtrType t  -- | Distinct types of foreign pointers.@@ -1013,7 +1017,7 @@  -- | For those types represented by pointers on the C side, return the -- type of pointer which represents them on the Haskell FFI.-typePtrType :: Type -> CodeGen (Maybe FFIPtrType)+typePtrType :: Type -> CodeGen e (Maybe FFIPtrType) typePtrType (TBasicType TPtr) = return (Just FFIPtr) typePtrType (TBasicType TUTF8) = return (Just FFIPtr) typePtrType (TBasicType TFileName) = return (Just FFIPtr)@@ -1027,7 +1031,7 @@ -- | If the passed in type is nullable, return the conversion function -- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the -- corresponding `Maybe` type.-maybeNullConvert :: Type -> CodeGen (Maybe Text)+maybeNullConvert :: Type -> CodeGen e (Maybe Text) maybeNullConvert (TBasicType TPtr) = return Nothing maybeNullConvert (TGList _) = return Nothing maybeNullConvert (TGSList _) = return Nothing@@ -1040,7 +1044,7 @@  -- | An appropriate NULL value for the given type, for types which are -- represented by pointers on the C side.-nullPtrForType :: Type -> CodeGen (Maybe Text)+nullPtrForType :: Type -> CodeGen e (Maybe Text) nullPtrForType t = do   pt <- typePtrType t   case pt of@@ -1054,7 +1058,7 @@ -- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers, -- which we just pass through to the Haskell side. Notice that -- introspection annotations can override this.-typeIsNullable :: Type -> CodeGen Bool+typeIsNullable :: Type -> CodeGen e Bool typeIsNullable t = isJust <$> maybeNullConvert t  -- | If the given type maps to a list in Haskell, return the type of the

@@ -19,8 +19,8 @@                             Interface(..), Object(..),                             Function(..), Method(..), Struct(..), Union(..),                             Signal(..))-import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.))-import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName,+import Data.GI.CodeGen.ModulePath (dotModulePath)+import Data.GI.CodeGen.SymbolNaming (moduleLocation, lowerName, upperName,                                      signalHaskellName) import Data.GI.CodeGen.Util (ucFirst) @@ -64,20 +64,15 @@                     (TypeRef "GVariant", TypeIdentifier "GVariant"),                     (ConstantRef "NULL", ValueIdentifier "P.Nothing")] --- | Obtain the absolute location of the module where the given `API`--- lives.-location :: Name -> API -> ModulePath-location n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api- -- | Obtain the fully qualified symbol pointing to a value. fullyQualifiedValue :: Name -> API -> Text -> Hyperlink fullyQualifiedValue n api symbol =-  ValueIdentifier $ dotModulePath (location n api) <> "." <> symbol+  ValueIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol  -- | Obtain the fully qualified symbol pointing to a type. fullyQualifiedType :: Name -> API -> Text -> Hyperlink fullyQualifiedType n api symbol =-  TypeIdentifier $ dotModulePath (location n api) <> "." <> symbol+  TypeIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol  -- | Extract the C name of a constant. These are often referred to as -- types, so we allow that too.@@ -118,7 +113,7 @@ signalRefs n api maybeCName signals = map signalRef signals   where signalRef :: Signal -> (CRef, Hyperlink)         signalRef (Signal {sigName = sn}) =-          let mod = dotModulePath (location n api)+          let mod = dotModulePath (moduleLocation n api)               sn' = signalHaskellName sn               ownerCName = case maybeCName of                 Just cname -> cname

@@ -87,7 +87,7 @@    maybe (return ()) (genErrorDomain docSection name') (enumErrorDomain e) -genBoxedEnum :: Name -> Text -> CodeGen ()+genBoxedEnum :: Name -> Text -> CodeGen e () genBoxedEnum n typeInit = do   let name' = upperName n @@ -106,7 +106,7 @@   group $ do     bline $ "instance B.Types.BoxedEnum " <> name' -genEnum :: Name -> Enumeration -> CodeGen ()+genEnum :: Name -> Enumeration -> CodeGen e () genEnum n@(Name _ name) enum = do   line $ "-- Enum " <> name @@ -119,7 +119,7 @@                     Nothing -> return ()                     Just ti -> genBoxedEnum n ti) -genBoxedFlags :: Name -> Text -> CodeGen ()+genBoxedFlags :: Name -> Text -> CodeGen e () genBoxedFlags n typeInit = do   let name' = upperName n @@ -140,7 +140,7 @@  -- | Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass.-genFlags :: Name -> Flags -> CodeGen ()+genFlags :: Name -> Flags -> CodeGen e () genFlags n@(Name _ name) (Flags enum) = do   line $ "-- Flags " <> name @@ -159,7 +159,7 @@                 group $ bline $ "instance IsGFlag " <> name')  -- | Support for enums encapsulating error codes.-genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen ()+genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen e () genErrorDomain docSection name' domain = do   group $ do     line $ "instance GErrorClass " <> name' <> " where"

@@ -13,12 +13,12 @@ import Data.GI.CodeGen.Type  -- Returns whether the given type is a descendant of the given parent.-typeDoParentSearch :: Name -> Type -> CodeGen Bool+typeDoParentSearch :: Name -> Type -> CodeGen e Bool typeDoParentSearch parent (TInterface n) = findAPIByName n >>=                                            apiDoParentSearch parent n typeDoParentSearch _ _ = return False -apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool+apiDoParentSearch :: Name -> Name -> API -> CodeGen e Bool apiDoParentSearch parent n api     | parent == n = return True     | otherwise   = case api of@@ -33,13 +33,13 @@       _ -> return False  -- | Check whether the given type descends from GObject.-isGObject :: Type -> CodeGen Bool+isGObject :: Type -> CodeGen e Bool isGObject = typeDoParentSearch $ Name "GObject" "Object"  -- | Check whether the given name descends from GObject.-nameIsGObject :: Name -> CodeGen Bool+nameIsGObject :: Name -> CodeGen e Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n  -- | Check whether the given API descends from GObject.-apiIsGObject :: Name -> API -> CodeGen Bool+apiIsGObject :: Name -> API -> CodeGen e Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"

@@ -189,7 +189,7 @@  -- | Get the base url for the online C language documentation for the -- module being currently generated.-getDocBase :: CodeGen Text+getDocBase :: CodeGen e Text getDocBase = do   mod <- modName <$> config   docsMap <- (onlineDocsMap . overrides) <$> config@@ -200,7 +200,7 @@  -- | Write the deprecation pragma for the given `DeprecationInfo`, if -- not `Nothing`.-deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen ()+deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen e () deprecatedPragma _  Nothing = return () deprecatedPragma name (Just info) = do   c2h <- getC2HMap@@ -228,7 +228,7 @@                    Just ver -> "\n\n/Since: " <> ver <> "/"  -- | Write the given documentation into generated code.-writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen ()+writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen e () writeDocumentation pos doc = do   c2h <- getC2HMap   docBase <- getDocBase@@ -236,7 +236,7 @@  -- | Like `writeDocumentation`, but allows us to pass explicitly the -- Haddock comment to write.-writeHaddock :: RelativeDocPosition -> Text -> CodeGen ()+writeHaddock :: RelativeDocPosition -> Text -> CodeGen e () writeHaddock pos haddock =   let marker = case pos of         DocBeforeSymbol -> "|"@@ -247,7 +247,7 @@   in mapM_ line lines  -- | Write the documentation for the given argument.-writeArgDocumentation :: Arg -> CodeGen ()+writeArgDocumentation :: Arg -> CodeGen e () writeArgDocumentation arg =   case rawDocText (argDoc arg) of     Nothing -> return ()@@ -259,7 +259,7 @@       writeHaddock DocAfterSymbol haddock  -- | Write the documentation for the given return value.-writeReturnDocumentation :: Callable -> Bool -> CodeGen ()+writeReturnDocumentation :: Callable -> Bool -> CodeGen e () writeReturnDocumentation callable skip = do   c2h <- getC2HMap   docBase <- getDocBase@@ -278,7 +278,7 @@     writeHaddock DocAfterSymbol fullInfo  -- | Add the given text to the documentation for the section being generated.-addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen ()+addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen e () addSectionDocumentation section doc = do   c2h <- getC2HMap   docBase <- getDocBase

@@ -34,7 +34,7 @@ getParent _ = Nothing  -- | Compute the (ordered) list of parents of the current object.-instanceTree :: Name -> CodeGen [Name]+instanceTree :: Name -> CodeGen e [Name] instanceTree n = do   api <- findAPIByName n   case getParent api of@@ -67,7 +67,7 @@ -- (including those defined by its ancestors and the interfaces it -- implements), together with the name of the interface defining the -- property.-apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)]+apiInheritables :: Inheritable i => Name -> CodeGen e [(Name, i)] apiInheritables n = do   api <- findAPIByName n   case dropMovedItems api of@@ -75,7 +75,7 @@     Just (APIObject object) -> return $ map ((,) n) (objInheritables object)     _ -> error $ "apiInheritables : Unexpected API : " ++ show n -fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)]+fullAPIInheritableList :: Inheritable i => Name -> CodeGen e [(Name, i)] fullAPIInheritableList n = do   api <- findAPIByName n   case api of@@ -84,14 +84,14 @@     _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n  fullObjectInheritableList :: Inheritable i => Name -> Object ->-                             CodeGen [(Name, i)]+                             CodeGen e [(Name, i)] fullObjectInheritableList n obj = do   iT <- instanceTree n   (++) <$> (concat <$> mapM apiInheritables (n : iT))        <*> (concat <$> mapM apiInheritables (objInterfaces obj))  fullInterfaceInheritableList :: Inheritable i => Name -> Interface ->-                                CodeGen [(Name, i)]+                                CodeGen e [(Name, i)] fullInterfaceInheritableList n iface =   (++) (map ((,) n) (ifInheritables iface))     <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface))@@ -103,13 +103,13 @@ -- setters/getters that we can call, but they are all isomorphic). If -- they are not isomorphic we print a warning, and choose to use the -- one closest to the leaves of the object hierarchy.-removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) =>-                        Bool -> [(Name, i)] -> CodeGen [(Name, i)]+removeDuplicates :: forall i e. (Eq i, Show i, Inheritable i) =>+                        Bool -> [(Name, i)] -> CodeGen e [(Name, i)] removeDuplicates verbose inheritables =     (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables     where       filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->-                    CodeGen (M.Map Text (Bool, Name, i))+                    CodeGen e (M.Map Text (Bool, Name, i))       filterDups m (name, prop) =         case M.lookup (iName prop) m of           Just (tainted, n, p)@@ -129,36 +129,36 @@  -- | List all properties defined for an object, including those -- defined by its ancestors.-fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)]+fullObjectPropertyList :: Name -> Object -> CodeGen e [(Name, Property)] fullObjectPropertyList n o = fullObjectInheritableList n o >>=                          removeDuplicates True  -- | List all properties defined for an interface, including those -- defined by its prerequisites.-fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)]+fullInterfacePropertyList :: Name -> Interface -> CodeGen e [(Name, Property)] fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=                             removeDuplicates True  -- | List all signals defined for an object, including those -- defined by its ancestors.-fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)]+fullObjectSignalList :: Name -> Object -> CodeGen e [(Name, Signal)] fullObjectSignalList n o = fullObjectInheritableList n o >>=                            removeDuplicates True  -- | List all signals defined for an interface, including those -- defined by its prerequisites.-fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)]+fullInterfaceSignalList :: Name -> Interface -> CodeGen e [(Name, Signal)] fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=                               removeDuplicates True  -- | List all methods defined for an object, including those defined -- by its ancestors.-fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)]+fullObjectMethodList :: Name -> Object -> CodeGen e [(Name, Method)] fullObjectMethodList n o = fullObjectInheritableList n o >>=                            removeDuplicates False  -- | List all methods defined for an interface, including those -- defined by its prerequisites.-fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)]+fullInterfaceMethodList :: Name -> Interface -> CodeGen e [(Name, Method)] fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>=                               removeDuplicates False

@@ -15,6 +15,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid ((<>))+#endif  import Control.Monad (forM, (>=>)) import qualified Data.Map as M

@@ -1,97 +0,0 @@-module Data.GI.CodeGen.OverloadedLabels-    ( genOverloadedLabels-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Data.Maybe (isNothing)-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif-import Control.Monad (forM_)-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T--import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code-import Data.GI.CodeGen.SymbolNaming-import Data.GI.CodeGen.Util (lcFirst)---- | A list of all overloadable identifiers in the set of APIs (current--- properties and methods).-findOverloaded :: [(Name, API)] -> CodeGen [Text]-findOverloaded apis = S.toList <$> go apis S.empty-    where-      go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)-      go [] set = return set-      go ((_, api):apis) set =-        case api of-          APIInterface iface -> go apis (scanInterface iface set)-          APIObject object -> go apis (scanObject object set)-          APIStruct s -> go apis (scanStruct s set)-          APIUnion u -> go apis (scanUnion u set)-          _ -> go apis set--      scanObject :: Object -> S.Set Text -> S.Set Text-      scanObject o set =-          let props = (map propToLabel . objProperties) o-              methods = (map methodToLabel . filterMethods . objMethods) o-          in S.unions [set, S.fromList props, S.fromList methods]--      scanInterface :: Interface -> S.Set Text -> S.Set Text-      scanInterface i set =-          let props = (map propToLabel . ifProperties) i-              methods = (map methodToLabel . filterMethods . ifMethods) i-          in S.unions [set, S.fromList props, S.fromList methods]--      scanStruct :: Struct -> S.Set Text -> S.Set Text-      scanStruct s set =-          let attrs = (map fieldToLabel . filterFields . structFields) s-              methods = (map methodToLabel . filterMethods . structMethods) s-          in S.unions [set, S.fromList attrs, S.fromList methods]--      scanUnion :: Union -> S.Set Text -> S.Set Text-      scanUnion u set =-          let attrs = (map fieldToLabel . filterFields . unionFields) u-              methods = (map methodToLabel . filterMethods . unionMethods) u-          in S.unions [set, S.fromList attrs, S.fromList methods]--      propToLabel :: Property -> Text-      propToLabel = lcFirst . hyphensToCamelCase . propName--      methodToLabel :: Method -> Text-      methodToLabel = lowerName . methodName--      fieldToLabel :: Field -> Text-      fieldToLabel = lcFirst . underscoresToCamelCase . fieldName--      filterMethods :: [Method] -> [Method]-      filterMethods = filter (\m -> (isNothing . methodMovedTo) m &&-                                    methodType m == OrdinaryMethod)--      filterFields :: [Field] -> [Field]-      filterFields = filter (\f -> fieldVisible f &&-                            (not . T.null . fieldName) f)--genOverloadedLabel :: Text -> CodeGen ()-genOverloadedLabel l = group $ do-  line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a"-  line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \""-           <> l <> "\")"-  export ToplevelSection ("_" <> l)--genOverloadedLabels :: [(Name, API)] -> CodeGen ()-genOverloadedLabels allAPIs = do-  setLanguagePragmas ["DataKinds", "FlexibleContexts", "CPP"]-  setModuleFlags [ImplicitPrelude]--  line $ "import Data.Proxy (Proxy(..))"-  line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))"-  blank--  labels <- findOverloaded allAPIs-  forM_ labels $ \l -> do-      genOverloadedLabel l-      blank

@@ -16,23 +16,25 @@ import Data.GI.CodeGen.Callable (callableSignature, Signature(..),                                  ForeignSymbol(..), fixupCallerAllocates) import Data.GI.CodeGen.Code-import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol)+import Data.GI.CodeGen.ModulePath (dotModulePath)+import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol,+                                     moduleLocation, hackageModuleLink) import Data.GI.CodeGen.Util (ucFirst)  -- | Qualified name for the info for a given method.-methodInfoName :: Name -> Method -> CodeGen Text+methodInfoName :: Name -> Method -> CodeGen e Text methodInfoName n method =     let infoName = upperName n <> (ucFirst . lowerName . methodName) method                    <> "MethodInfo"     in qualifiedSymbol infoName n  -- | Appropriate instances so overloaded labels are properly resolved.-genMethodResolver :: Text -> CodeGen ()+genMethodResolver :: Text -> CodeGen e () genMethodResolver n = do   addLanguagePragma "TypeApplications"   group $ do     line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "-          <> "O.MethodInfo info " <> n <> " p) => OL.IsLabel t ("+          <> "O.OverloadedMethod info " <> n <> " p) => OL.IsLabel t ("           <> n <> " -> p) where"     line $ "#if MIN_VERSION_base(4,10,0)"     indent $ line $ "fromLabel = O.overloadedMethod @info"@@ -40,9 +42,32 @@     indent $ line $ "fromLabel _ = O.overloadedMethod @info"     line $ "#endif" +  -- The circular instance trick is to avoid the liberal coverage+  -- condition. We should be using DYSFUNCTIONAL pragmas instead, once+  -- those are implemented:+  -- https://github.com/ghc-proposals/ghc-proposals/pull/374+  cppIf (CPPMinVersion "base" (4,13,0)) $ group $ do+    line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+          <> "O.OverloadedMethod info " <> n <> " p, "+          <> "R.HasField t " <> n <> " p) => "+          <> "R.HasField t " <> n <> " p where"+    indent $ line $ "getField = O.overloadedMethod @info"++  group $ do+    line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+          <> "O.OverloadedMethodInfo info " <> n <> ") => "+          <> "OL.IsLabel t (O.MethodProxy info "+          <> n <> ") where"+    line $ "#if MIN_VERSION_base(4,10,0)"+    indent $ line $ "fromLabel = O.MethodProxy"+    line $ "#else"+    indent $ line $ "fromLabel _ = O.MethodProxy"+    line $ "#endif"+ -- | Generate the `MethodList` instance given the list of methods for--- the given named type.-genMethodList :: Name -> [(Name, Method)] -> CodeGen ()+-- the given named type. Returns a Haddock comment summarizing the+-- list of methods available.+genMethodList :: Name -> [(Name, Method)] -> CodeGen e () genMethodList n methods = do   let name = upperName n   let filteredMethods = filter isOrdinaryMethod methods@@ -55,7 +80,7 @@               return ((lowerName . methodName) method, mi)   group $ do     let resolver = "Resolve" <> name <> "Method"-    export (NamedSubsection MethodSection "Overloaded methods") resolver+    export (Section MethodSection) resolver     line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where"     indent $ forM_ infos $ \(label, info) -> do         line $ resolver <> " \"" <> label <> "\" o = " <> info@@ -63,6 +88,9 @@    genMethodResolver name +  docs <- methodListDocumentation others gets sets+  prependSectionFormattedDocs (Section MethodSection) docs+   where isOrdinaryMethod :: (Name, Method) -> Bool         isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod @@ -72,11 +100,38 @@         isSet :: (Name, Method) -> Bool         isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m +-- | Format a haddock comment with the information about available+-- methods.+methodListDocumentation :: [(Name, Method)] -> [(Name, Method)]+                           -> [(Name, Method)] -> CodeGen e Text+methodListDocumentation [] [] [] = return ""+methodListDocumentation ordinary getters setters = do+  ordinaryFormatted <- formatMethods ordinary+  gettersFormatted <- formatMethods getters+  settersFormatted <- formatMethods setters++  return $ "\n\n === __Click to display all available methods, including inherited ones__\n"+    <> "==== Methods\n" <> ordinaryFormatted+    <> "\n==== Getters\n" <> gettersFormatted+    <> "\n==== Setters\n" <> settersFormatted++  where formatMethods :: [(Name, Method)] -> CodeGen e Text+        formatMethods [] = return "/None/.\n"+        formatMethods methods = do+          qualifiedMethods <- forM methods $ \(owner, m) -> do+            api <- findAPIByName owner+            let mn = lowerName (methodName m)+            return $ "[" <> mn <>+              "](\"" <> dotModulePath (moduleLocation owner api)+              <> "#g:method:" <> mn <> "\")"+          return $ T.intercalate ", " qualifiedMethods <> ".\n"+ -- | Generate the `MethodInfo` type and instance for the given method. genMethodInfo :: Name -> Method -> ExcCodeGen () genMethodInfo n m =     when (methodType m == OrdinaryMethod) $       group $ do+        api <- findAPIByName n         infoName <- methodInfoName n m         let callable = fixupCallerAllocates (methodCallable m)         sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures@@ -88,24 +143,50 @@         let (obj:otherTypes) = map snd (signatureArgTypes sig)             sigConstraint = "signature ~ (" <> T.intercalate " -> "               (otherTypes ++ [signatureReturnType sig]) <> ")"-        line $ "instance (" <> T.intercalate ", " (sigConstraint :-                                                   signatureConstraints sig)-                 <> ") => O.MethodInfo " <> infoName <> " " <> obj <> " signature where"++        hackageLink <- hackageModuleLink n         let mn = methodName m             mangled = lowerName (mn {name = name n <> "_" <> name mn})-        indent $ line $ "overloadedMethod = " <> mangled+            dbgInfo = dotModulePath (moduleLocation n api) <> "." <> mangled++        group $ do+          line $ "instance ("+            <> T.intercalate ", " (sigConstraint : signatureConstraints sig)+            <> ") => O.OverloadedMethod " <> infoName <> " " <> obj+            <> " signature where"+          indent $ line $ "overloadedMethod = " <> mangled++        group $ do+          line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj+            <> " where"+          indent $ do+            line $ "overloadedMethodInfo = O.MethodInfo {"+            indent $ do+              line $ "O.overloadedMethodName = \"" <> dbgInfo <> "\","+              line $ "O.overloadedMethodURL = \"" <>+                hackageLink <> "#v:" <> mangled <> "\""+              line $ "}"+         export (NamedSubsection MethodSection $ lowerName mn) infoName  -- | Generate a method info that is not actually callable, but rather -- gives a type error when trying to use it.-genUnsupportedMethodInfo :: Name -> Method -> CodeGen ()+genUnsupportedMethodInfo :: Name -> Method -> CodeGen e () genUnsupportedMethodInfo n m = do   infoName <- methodInfoName n m   line $ "-- XXX: Dummy instance, since code generation failed.\n"            <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi."   bline $ "data " <> infoName-  line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \""-           <> lowerName (methodName m) <> "\" " <> name n-           <> ") => O.MethodInfo " <> infoName <> " o p where"-  indent $ line $ "overloadedMethod = undefined"+  group $ do+    line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \""+      <> lowerName (methodName m) <> "\" " <> name n+      <> ") => O.OverloadedMethod " <> infoName <> " o p where"+    indent $ line $ "overloadedMethod = undefined"++  group $ do+    line $ "instance (o ~ O.UnsupportedMethodError \""+      <> lowerName (methodName m) <> "\" " <> name n+      <> ") => O.OverloadedMethodInfo " <> infoName <> " o where"+    indent $ line $ "overloadedMethodInfo = undefined"+   export ToplevelSection infoName

@@ -1,20 +1,17 @@ module Data.GI.CodeGen.OverloadedSignals     ( genObjectSignals     , genInterfaceSignals-    , genOverloadedSignalConnectors     ) where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif-import Control.Monad (forM_, when)+import Control.Monad (when)  #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif-import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Set as S  import Data.GI.CodeGen.API import Data.GI.CodeGen.Code@@ -24,46 +21,8 @@                                      signalInfoName) import Data.GI.CodeGen.Util (lcFirst) --- A list of distinct signal names for all GObjects appearing in the--- given list of APIs.-findSignalNames :: [(Name, API)] -> CodeGen [Text]-findSignalNames apis = S.toList <$> go apis S.empty-    where-      go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)-      go [] set = return set-      go ((_, api):apis) set =-          case api of-            APIInterface iface ->-                go apis $ insertSignals (ifSignals iface) set-            APIObject object ->-                go apis $ insertSignals (objSignals object) set-            _ -> go apis set--      insertSignals :: [Signal] -> S.Set Text -> S.Set Text-      insertSignals props set = foldr (S.insert . sigName) set props---- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...-genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()-genOverloadedSignalConnectors allAPIs = do-  setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP",-                      -- For ghc 7.8 support-                      "RankNTypes", "ScopedTypeVariables", "TypeFamilies"]-  setModuleFlags [ImplicitPrelude]--  line "import Data.GI.Base.Signals (SignalProxy(..))"-  line "import Data.GI.Base.Overloading (ResolveSignal)"-  blank-  signalNames <- findSignalNames allAPIs-  forM_ signalNames $ \sn -> group $ do-    let camelName = hyphensToCamelCase sn-    line $ "pattern " <> camelName <>-             " :: SignalProxy object (ResolveSignal \""-             <> lcFirst camelName <> "\" object)"-    line $ "pattern " <> camelName <> " = SignalProxy"-    exportDecl $ "pattern " <> camelName- -- | Signal instances for (GObject-derived) objects.-genObjectSignals :: Name -> Object -> CodeGen ()+genObjectSignals :: Name -> Object -> CodeGen e () genObjectSignals n o = do   let name = upperName n   isGO <- apiIsGObject n (APIObject o)@@ -80,7 +39,7 @@                   <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"  -- | Signal instances for interfaces.-genInterfaceSignals :: Name -> Interface -> CodeGen ()+genInterfaceSignals :: Name -> Interface -> CodeGen e () genInterfaceSignals n iface = do   let name = upperName n   infos <- fullInterfaceSignalList n iface >>=

@@ -29,7 +29,7 @@                                      hyphensToCamelCase, qualifiedSymbol,                                      typeConstraint, callbackDynamicWrapper,                                      callbackHaskellToForeign,-                                     callbackWrapperAllocator)+                                     callbackWrapperAllocator, safeCast) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -78,11 +78,13 @@        APIUnion u -> if unionIsBoxed u                      then return "Boxed"                      else notImplementedError $ "Unboxed union property : " <> tshow t-       APIObject _ -> do+       APIObject o -> do                 isGO <- isGObject t                 if isGO                 then return "Object"-                else notImplementedError $ "Non-GObject object property : " <> tshow t+                else case (objGetValueFunc o, objSetValueFunc o) of+                  (Just _, Just _) -> return "IsGValueInstance"+                  _ -> notImplementedError $ "Non-GObject object property without known gvalue_set and/or gvalue_get: " <> tshow t        APIInterface _ -> do                 isGO <- isGObject t                 if isGO@@ -91,8 +93,33 @@        _ -> notImplementedError $ "Unknown interface property of type : " <> tshow t    _ -> notImplementedError $ "Don't know how to handle properties of type " <> tshow t +-- | Some types need casting to a concrete type before we can set or+-- construct properties. For example, for non-GObject object+-- properties we accept any instance of @IsX@ for convenience, but+-- instance resolution of the IsGValueSetter requires a concrete+-- type. The following code implements the cast on the given variable,+-- if needed, and returns the name of the new variable of concrete+-- type.+castProp :: Type -> Text -> CodeGen e Text+castProp t@(TInterface n) val = do+  api <- findAPIByName n+  case api of+    APIObject o -> do+      isGO <- isGObject t+      if not isGO+        then case (objGetValueFunc o, objSetValueFunc o) of+               (Just _, Just _) -> do+                 let val' = prime val+                 cast <- safeCast n+                 line $ val' <> " <- " <> cast <> " " <> val+                 return val'+               _ -> return val+        else return val+    _ -> return val+castProp _ val = return val+ -- | The constraint for setting the given type in properties.-propSetTypeConstraint :: Type -> CodeGen Text+propSetTypeConstraint :: Type -> CodeGen e Text propSetTypeConstraint (TGClosure Nothing) =   return $ "(~) " <> parenthesize (typeShow ("GClosure" `con` [con0 "()"])) propSetTypeConstraint t = do@@ -109,7 +136,7 @@                          else hInType  -- | The constraint for transferring the given type into a property.-propTransferTypeConstraint :: Type -> CodeGen Text+propTransferTypeConstraint :: Type -> CodeGen e Text propTransferTypeConstraint t = do   isGO <- isGObject t   if isGO@@ -122,7 +149,7 @@  -- | The type of the return value of @attrTransfer@ for the given -- type.-propTransferType :: Type -> CodeGen Text+propTransferType :: Type -> CodeGen e Text propTransferType (TGClosure Nothing) =   return $ typeShow ("GClosure" `con` [con0 "()"]) propTransferType t = do@@ -134,7 +161,7 @@ -- | Given a value "v" of the given Haskell type, satisfying the -- constraint generated by 'propTransferTypeConstraint', convert it -- (allocating memory is necessary) to the type given by 'propTransferType'.-genPropTransfer :: Text -> Type -> CodeGen ()+genPropTransfer :: Text -> Type -> CodeGen e () genPropTransfer var (TGClosure Nothing) = line $ "return " <> var genPropTransfer var t = do   isGO <- isGObject t@@ -157,7 +184,7 @@  -- | Given a property, return the set of constraints on the types, and -- the type variables for the object and its value.-attrType :: Property -> CodeGen ([Text], Text)+attrType :: Property -> CodeGen e ([Text], Text) attrType prop = do   resetTypeVariableScope   isCallback <- typeIsCallback (propType prop)@@ -191,11 +218,14 @@   writeHaddock DocBeforeSymbol (setterDoc n prop)   line $ setter <> " :: (" <> T.intercalate ", " constraints'            <> ") => o -> " <> t <> " -> m ()"-  line $ setter <> " obj val = liftIO $ B.Properties.setObjectProperty" <> tStr-           <> " obj \"" <> propName prop-           <> if isNullable && (not isCallback)-              then "\" (Just val)"-              else "\" val"+  line $ setter <> " obj val = MIO.liftIO $ do"+  indent $ do+    val' <- castProp (propType prop) "val"+    line $ "B.Properties.setObjectProperty" <> tStr+             <> " obj \"" <> propName prop+             <> if isNullable && (not isCallback)+                then "\" (Just " <> val' <> ")"+                else "\" " <> val'   export docSection setter  -- | Generate documentation for the given getter.@@ -238,7 +268,7 @@   writeHaddock DocBeforeSymbol (getterDoc n prop)   line $ getter <> " :: " <> constraints <>                 " => o -> " <> returnType-  line $ getter <> " obj = liftIO $ " <> getProp+  line $ getter <> " obj = MIO.liftIO $ " <> getProp            <> " obj \"" <> propName prop <> "\"" <> constructorArg   export docSection getter @@ -260,11 +290,14 @@   writeHaddock DocBeforeSymbol (constructorDoc prop)   line $ constructor <> " :: " <> pconstraints            <> t <> " -> m (GValueConstruct o)"-  line $ constructor <> " val = MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr+  line $ constructor <> " val = MIO.liftIO $ do"+  indent $ do+    val' <- castProp (propType prop) "val"+    line $ "MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr            <> " \"" <> propName prop            <> if isNullable && (not isCallback)-              then "\" (P.Just val)"-              else "\" val"+              then "\" (P.Just " <> val' <> ")"+              else "\" " <> val'   export docSection constructor  -- | Generate documentation for the given setter.@@ -301,7 +334,7 @@ hPropName :: Property -> Text hPropName = lcFirst . hyphensToCamelCase . propName -genObjectProperties :: Name -> Object -> CodeGen ()+genObjectProperties :: Name -> Object -> CodeGen e () genObjectProperties n o = do   isGO <- apiIsGObject n (APIObject o)   -- We do not generate bindings for objects not descending from GObject.@@ -313,7 +346,7 @@                                    <> "\", " <> pi <> ")")     genProperties n (objProperties o) allProps -genInterfaceProperties :: Name -> Interface -> CodeGen ()+genInterfaceProperties :: Name -> Interface -> CodeGen e () genInterfaceProperties n iface = do   allProps <- fullInterfacePropertyList n iface >>=                 mapM (\(owner, prop) -> do@@ -325,7 +358,7 @@ -- If the given accesor is available (indicated by available == True), -- generate a fully qualified accesor name, otherwise just return -- "undefined". accessor is "get", "set" or "construct"-accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text+accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen e Text accessorOrUndefined available accessor owner@(Name _ on) cName =     if not available     then return "undefined"@@ -333,7 +366,7 @@  -- | The name of the type encoding the information for the property of -- the object.-infoType :: Name -> Property -> CodeGen Text+infoType :: Name -> Property -> CodeGen e Text infoType owner prop =     let infoType = upperName owner <> (hyphensToCamelCase . propName) prop                    <> "PropertyInfo"@@ -450,7 +483,7 @@  -- | Generate a placeholder property for those cases in which code -- generation failed.-genPlaceholderProperty :: Name -> Property -> CodeGen ()+genPlaceholderProperty :: Name -> Property -> CodeGen e () genPlaceholderProperty owner prop = do   line $ "-- XXX Placeholder"   it <- infoType owner prop@@ -474,7 +507,7 @@     line $ "attrClear = undefined"     line $ "attrTransfer = undefined" -genProperties :: Name -> [Property] -> [Text] -> CodeGen ()+genProperties :: Name -> [Property] -> [Text] -> CodeGen e () genProperties n ownedProps allProps = do   let name = upperName n @@ -500,12 +533,12 @@ -- name clashes (an example is Auth::is_for_proxy method in libsoup, -- and the corresponding Auth::is-for-proxy property). When there is a -- clash we give priority to the method.-genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen ()+genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen e () genNamespacedPropLabels owner props methods =     let lName = lcFirst . hyphensToCamelCase . propName     in genNamespacedAttrLabels owner (map lName props) methods -genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen ()+genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen e () genNamespacedAttrLabels owner attrNames methods = do   let name = upperName owner 

@@ -80,7 +80,7 @@  -- | Generate the type synonym for the prototype of the callback on -- the C side. Returns the name given to the type synonym.-genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen Text+genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen e Text genCCallbackPrototype subsec cb name' isSignal = group $ do     let ctypeName = callbackCType name' @@ -110,7 +110,7 @@     ccallbackDoc = "Type for the callback on the (unwrapped) C side."  -- | Generator for wrappers callable from C-genCallbackWrapperFactory :: Text -> Text -> CodeGen ()+genCallbackWrapperFactory :: Text -> Text -> CodeGen e () genCallbackWrapperFactory subsec name' = group $ do     let factoryName = callbackWrapperAllocator name'     writeHaddock DocBeforeSymbol factoryDoc@@ -125,7 +125,7 @@  -- | Wrap the Haskell `cb` callback into a foreign function of the -- right type. Returns the name of the wrapped value.-genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text+genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen e Text genWrappedCallback cb cbArg callback isSignal = do   drop <- if callableHasClosures cb           then do@@ -141,7 +141,7 @@   return (prime drop)  -- | Generator of closures-genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen ()+genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen e () genClosure subsec cb callback name isSignal = group $ do   let closure = callbackClosureGenerator name   export (NamedSubsection SignalSection subsec) closure@@ -160,7 +160,7 @@  -- Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL.-convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text+convertNullable :: Text -> CodeGen e Text -> CodeGen e Text convertNullable aname c = do   line $ "maybe" <> ucFirst aname <> " <-"   indent $ do@@ -241,7 +241,7 @@   line $ "poke " <> name <> " " <> name''  -- | A simple wrapper that drops every closure argument.-genDropClosures :: Text -> Callable -> Text -> CodeGen ()+genDropClosures :: Text -> Callable -> Text -> CodeGen e () genDropClosures subsec cb name' = group $ do   let dropper = callbackDropClosures name'       (inWithClosures, _) = callableHInArgs cb WithClosures@@ -330,7 +330,7 @@                result' <- convert rname $ hToF r (returnTransfer cb)                line $ "return " <> result' -genCallback :: Name -> Callback -> CodeGen ()+genCallback :: Name -> Callback -> CodeGen e () genCallback n callback@(Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do   let Name _ name' = normalizedAPIName (APICallback callback) n       cb' = fixupCallerAllocates cb@@ -383,7 +383,7 @@         genCallbackWrapper name' cb' name' False  -- | Generate the given signal instance for the given API object.-genSignalInfoInstance :: Name -> Signal -> CodeGen ()+genSignalInfoInstance :: Name -> Signal -> CodeGen e () genSignalInfoInstance owner signal = group $ do   let name = upperName owner   let sn = (ucFirst . signalHaskellName . sigName) signal@@ -400,7 +400,7 @@  -- | Write some simple debug message when signal generation fails, and -- generate a placeholder SignalInfo instance.-processSignalError :: Signal -> Name -> CGError -> CodeGen ()+processSignalError :: Signal -> Name -> CGError -> CodeGen e () processSignalError signal owner err = do   let qualifiedSignalName = upperName owner <> "::" <> sigName signal       sn = (ucFirst . signalHaskellName . sigName) signal@@ -422,7 +422,7 @@     export (NamedSubsection SignalSection $ lcFirst sn) si  -- | Generate a wrapper for a signal.-genSignal :: Signal -> Name -> CodeGen ()+genSignal :: Signal -> Name -> CodeGen e () genSignal s@(Signal { sigName = sn, sigCallable = cb }) on =   handleCGExc (processSignalError s on) $ do   let on' = upperName on@@ -538,7 +538,7 @@                    -> Text -- ^ Callback type                    -> Text -- ^ SignalConnectBefore or SignalConnectAfter                    -> Text -- ^ Detail-                   -> CodeGen ()+                   -> CodeGen e () genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail = do   cb' <- genWrappedCallback cb "cb" cbType True   let cb'' = prime cb'

@@ -42,7 +42,7 @@                                (not $ structForceVisible s)  -- | Whether the given type corresponds to an ignored struct.-isIgnoredStructType :: Type -> CodeGen Bool+isIgnoredStructType :: Type -> CodeGen e Bool isIgnoredStructType t =   case t of     TInterface n -> do@@ -97,7 +97,7 @@  -- | The name of the type encoding the information for a field in a -- struct/union.-infoType :: Name -> Field -> CodeGen Text+infoType :: Name -> Field -> CodeGen e Text infoType owner field = do   let name = upperName owner   let fName = (underscoresToCamelCase . fieldName) field@@ -256,7 +256,7 @@ -- | Return whether the given type corresponds to a callback that does -- not throw exceptions. See [Note: Callables that throw] for the -- reason why we do not try to wrap callbacks that throw exceptions.-isRegularCallback :: Type -> CodeGen Bool+isRegularCallback :: Type -> CodeGen e Bool isRegularCallback t@(TInterface _) = do   api <- getAPI t   case api of@@ -267,7 +267,7 @@  -- | The types accepted by the allocating set function -- 'Data.GI.Base.Attributes.(:&=)'.-fieldTransferTypeConstraint :: Type -> CodeGen Text+fieldTransferTypeConstraint :: Type -> CodeGen e Text fieldTransferTypeConstraint t = do   isPtr <- typeIsPtr t   isRegularCallback <- isRegularCallback t@@ -281,7 +281,7 @@ -- | The type generated by 'Data.GI.Base.attrTransfer' for this -- field. This type should satisfy the -- 'Data.GI.Base.Attributes.AttrSetTypeConstraint' for the type.-fieldTransferType :: Type -> CodeGen Text+fieldTransferType :: Type -> CodeGen e Text fieldTransferType t = do   isPtr <- typeIsPtr t   inType <- if isPtr@@ -293,7 +293,7 @@  -- | Generate the field transfer function, which marshals Haskell -- values to types that we can set, even if we need to allocate memory.-genFieldTransfer :: Text -> Type -> CodeGen ()+genFieldTransfer :: Text -> Type -> CodeGen e () genFieldTransfer var t@(TInterface tn@(Name _ n)) = do   isRegularCallback <- isRegularCallback t   if isRegularCallback@@ -420,7 +420,7 @@           docSection = NamedSubsection PropertySection $ lcFirst $ fName field  -- | Generate code for the given list of fields.-genStructOrUnionFields :: Name -> [Field] -> CodeGen ()+genStructOrUnionFields :: Name -> [Field] -> CodeGen e () genStructOrUnionFields n fields = do   let name' = upperName n @@ -443,7 +443,7 @@  -- | Generate a constructor for a zero-filled struct/union of the given -- type, using the boxed (or GLib, for unboxed types) allocator.-genZeroSU :: Name -> Int -> Bool -> CodeGen ()+genZeroSU :: Name -> Int -> Bool -> CodeGen e () genZeroSU n size isBoxed = group $ do       let name = upperName n       let builder = "newZero" <> name@@ -472,49 +472,50 @@               line $ "return o"  -- | Specialization for structs of `genZeroSU`.-genZeroStruct :: Name -> Struct -> CodeGen ()+genZeroStruct :: Name -> Struct -> CodeGen e () genZeroStruct n s =     when (allocCalloc (structAllocationInfo s) /= AllocationOp "none" &&           structSize s /= 0) $     genZeroSU n (structSize s) (structIsBoxed s)  -- | Specialization for unions of `genZeroSU`.-genZeroUnion :: Name -> Union -> CodeGen ()+genZeroUnion :: Name -> Union -> CodeGen e () genZeroUnion n u =     when (allocCalloc (unionAllocationInfo u ) /= AllocationOp "none" &&           unionSize u /= 0) $     genZeroSU n (unionSize u) (unionIsBoxed u)  -- | Construct a import with the given prefix.-prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text+prefixedForeignImport :: Text -> Text -> Text -> CodeGen e Text prefixedForeignImport prefix symbol prototype = group $ do   line $ "foreign import ccall \"" <> symbol <> "\" " <> prefix <> symbol            <> " :: " <> prototype   return (prefix <> symbol)  -- | Generate a GValue instance for @GBoxed@ objects.-genBoxedGValueInstance :: Name -> Text -> CodeGen ()+genBoxedGValueInstance :: Name -> Text -> CodeGen e () genBoxedGValueInstance n get_type_fn = do   let name' = upperName n-      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."+      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."    writeHaddock DocBeforeSymbol doc    group $ do-    bline $ "instance B.GValue.IsGValue " <> name' <> " where"+    bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where"     indent $ group $ do-      line $ "toGValue o = do"-      indent $ group $ do-        line $ "gtype <- " <> get_type_fn-        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"-      line $ "fromGValue gv = do"+      line $ "gvalueGType_ = " <> get_type_fn+      line $ "gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.Ptr " <> name' <> ")"+      line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)"+      line $ "gvalueGet_ gv = do"       indent $ group $ do         line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")"-        line $ "B.ManagedPtr.newBoxed " <> name' <> " ptr"+        line $ "if ptr /= FP.nullPtr"+        line $ "then P.Just <$> B.ManagedPtr.newBoxed " <> name' <> " ptr"+        line $ "else return P.Nothing"  -- | Allocation and deallocation for types registered as `GBoxed` in -- the GLib type system.-genBoxed :: Name -> Text -> CodeGen ()+genBoxed :: Name -> Text -> CodeGen e () genBoxed n typeInit = do   let name' = upperName n       get_type_fn = "c_" <> typeInit@@ -539,7 +540,7 @@  -- | Generate the typeclass with information for how to -- allocate/deallocate a given type which is not a `GBoxed`.-genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen ()+genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen e () genWrappedPtr n info size = group $ do   let prefix = \op -> "_" <> name' <> "_" <> op <> "_" @@ -586,7 +587,7 @@    where name' = upperName n -        callocInstance :: Text -> CodeGen()+        callocInstance :: Text -> CodeGen e ()         callocInstance calloc = group $ do           bline $ "instance CallocPtr " <> name' <> " where"           indent $ do

@@ -7,6 +7,7 @@      , classConstraint     , typeConstraint+    , safeCast      , hyphensToCamelCase     , underscoresToCamelCase@@ -24,9 +25,12 @@     , signalInfoName      , submoduleLocation+    , moduleLocation     , qualifiedAPI     , qualifiedSymbol     , normalizedAPIName++    , hackageModuleLink     ) where  #if !MIN_VERSION_base(4,11,0)@@ -36,19 +40,25 @@ import qualified Data.Text as T  import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI)-import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath)+import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI, findAPIByName, config)+import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath, dotModulePath) import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified)  -- | Return a qualified form of the constraint for the given name -- (which should correspond to a valid `TInterface`).-classConstraint :: Name -> CodeGen Text+classConstraint :: Name -> CodeGen e Text classConstraint n@(Name _ s) = qualifiedSymbol ("Is" <> s) n +-- | Return a qualified form of the function mapping instances of+-- @IsX@ to haskell values of type @X@.+safeCast :: Name -> CodeGen e Text+safeCast n@(Name _ s) = qualifiedSymbol ("to" <> ucFirst s) n+ -- | Same as `classConstraint`, but applicable directly to a type. The -- type should be a `TInterface`, otherwise an error will be raised.-typeConstraint :: Type -> CodeGen Text+typeConstraint :: Type -> CodeGen e Text typeConstraint (TInterface n) = classConstraint n typeConstraint t = error $ "Class constraint for non-interface type: " <> show t @@ -146,6 +156,12 @@ submoduleLocation n (APIStruct _) = "Structs" /. upperName n submoduleLocation n (APIUnion _) = "Unions" /. upperName n +-- | Obtain the absolute location of the module where the given `API`+-- lives.+moduleLocation :: Name -> API -> ModulePath+moduleLocation n api =+  ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api+ -- | Construct the Haskell version of the name associated to the given -- API. normalizedAPIName :: API -> Name -> Name@@ -161,13 +177,13 @@  -- | Return an identifier for the given interface type valid in the current -- module.-qualifiedAPI :: API -> Name -> CodeGen Text+qualifiedAPI :: API -> Name -> CodeGen e Text qualifiedAPI api n@(Name ns _) =   let normalized = normalizedAPIName api n   in qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) normalized  -- | Construct an identifier for the given symbol in the given API.-qualifiedSymbol :: Text -> Name -> CodeGen Text+qualifiedSymbol :: Text -> Name -> CodeGen e Text qualifiedSymbol s n@(Name ns _) = do   api <- getAPI (TInterface n)   qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s)@@ -205,6 +221,7 @@ -- argument name (and escaping it if not). escapedArgName :: Arg -> Text escapedArgName arg+    | argCName arg == "_" = "_'"  -- "_" denotes a hole, so we need to escape it     | "_" `T.isPrefixOf` argCName arg = argCName arg     | otherwise =         escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg@@ -243,7 +260,7 @@     | otherwise = s  -- | Qualified name for the "(sigName, info)" tag for a given signal.-signalInfoName :: Name -> Signal -> CodeGen Text+signalInfoName :: Name -> Signal -> CodeGen e Text signalInfoName n signal = do   let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal                  <> "SignalInfo"@@ -253,3 +270,17 @@ signalHaskellName :: Text -> Text signalHaskellName sn = let (w:ws) = T.split (== '-') sn                        in w <> T.concat (map ucFirst ws)+++-- | Return a link to the hackage package for the given name. Note+-- that the generated link will only be valid if the name belongs to+-- the binding which is currently being generated.+hackageModuleLink :: Name -> CodeGen e Text+hackageModuleLink n = do+  api <- findAPIByName n+  cfg <- config+  let location = T.replace "." "-" $ dotModulePath (moduleLocation n api)+      pkg = ghcPkgName cfg <> "-" <> ghcPkgVersion cfg+  return $ "https://hackage.haskell.org/package/" <> pkg <> "/docs/"+           <> location <> ".html"+

@@ -51,7 +51,7 @@ -- run in the exception handler, so any type which we ref/allocate -- with the expectation that the called function will consume it (on -- TransferEverything) should be freed here.-basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text)+basicFreeFnOnError :: Type -> Transfer -> CodeGen e (Maybe Text) basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType _) _ = return Nothing@@ -119,7 +119,7 @@ basicFreeFnOnError (TError) _ = return Nothing  -- Free just the container, but not the elements.-freeContainer :: Type -> Text -> CodeGen [Text]+freeContainer :: Type -> Text -> CodeGen e [Text] freeContainer t label =     case basicFreeFn t of       Nothing -> return []@@ -228,7 +228,7 @@                         <> label freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label] -freeOut :: Text -> CodeGen [Text]+freeOut :: Text -> CodeGen e [Text] freeOut label = return ["freeMem " <> label]  -- | Given an input argument to a C callable, and its label in the code,

@@ -69,6 +69,12 @@   closure <- optionalAttr "closure" (-1) parseIntegral   destroy <- optionalAttr "destroy" (-1) parseIntegral   nullable <- optionalAttr "nullable" False parseBool+  allowNone <- optionalAttr "allow-none" False parseBool+  -- "allow-none" is deprecated, but still produced by Vala. Support+  -- it for in arguments.+  let mayBeNull = if d == DirectionIn+                  then nullable || allowNone+                  else nullable   callerAllocates <- optionalAttr "caller-allocates" False parseBool   t <- parseType   doc <- parseDocumentation@@ -76,7 +82,7 @@                , argType = t                , argDoc = doc                , direction = d-               , mayBeNull = nullable+               , mayBeNull = mayBeNull                , argScope = scope                , argClosure = closure                , argDestroy = destroy

@@ -4,6 +4,10 @@     , parseObject     ) where +#if !MIN_VERSION_base(4,13,0)+import Data.Monoid ((<>))+#endif+ import Data.Text (Text)  import Data.GI.GIR.Method (Method, parseMethod, MethodType(..))@@ -19,6 +23,8 @@     objCType :: Maybe Text,     objRefFunc :: Maybe Text,     objUnrefFunc :: Maybe Text,+    objSetValueFunc :: Maybe Text,+    objGetValueFunc :: Maybe Text,     objInterfaces :: [Name],     objDeprecated :: Maybe DeprecationInfo,     objDocumentation :: Documentation,@@ -46,6 +52,8 @@   signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal   refFunc <- queryAttrWithNamespace GLibGIRNS "ref-func"   unrefFunc <- queryAttrWithNamespace GLibGIRNS "unref-func"+  setValueFunc <- queryAttrWithNamespace GLibGIRNS "set-value-func"+  getValueFunc <- queryAttrWithNamespace GLibGIRNS "get-value-func"    ctype <- queryCType   return (name,@@ -55,6 +63,8 @@           , objCType = ctype           , objRefFunc = refFunc           , objUnrefFunc = unrefFunc+          , objSetValueFunc = setValueFunc+          , objGetValueFunc = getValueFunc           , objTypeName = typeName           , objInterfaces = interfaces           , objDeprecated = deprecated