haskell-gi 0.20 → 0.20.1

raw patch · 46 files changed

+1764/−463 lines, 46 filesdep +attoparsecdep +doctestdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• DocTests.hs +17/−0
• cmdline/haskell-gi.hs +21/−18
• haskell-gi.cabal +14/−1
• lib/Data/GI/CodeGen/API.hs +5/−3
• lib/Data/GI/CodeGen/Cabal.hs +39/−15
• lib/Data/GI/CodeGen/CabalHooks.hs +9/−6
• lib/Data/GI/CodeGen/Callable.hs +97/−79
• lib/Data/GI/CodeGen/Code.hs +111/−95
• lib/Data/GI/CodeGen/CodeGen.hs +33/−24
• lib/Data/GI/CodeGen/Config.hs +1/−1
• lib/Data/GI/CodeGen/Constant.hs +9/−8
• lib/Data/GI/CodeGen/Conversions.hs +47/−22
• lib/Data/GI/CodeGen/CtoHaskellMap.hs +133/−0
• lib/Data/GI/CodeGen/CtoHaskellMap.hs-boot +10/−0
• lib/Data/GI/CodeGen/EnumFlags.hs +23/−19
• lib/Data/GI/CodeGen/Fixups.hs +2/−2
• lib/Data/GI/CodeGen/GObject.hs +0/−8
• lib/Data/GI/CodeGen/GtkDoc.hs +453/−0
• lib/Data/GI/CodeGen/Haddock.hs +284/−0
• lib/Data/GI/CodeGen/LibGIRepository.hs +27/−1
• lib/Data/GI/CodeGen/ModulePath.hs +63/−0
• lib/Data/GI/CodeGen/OverloadedMethods.hs +9/−9
• lib/Data/GI/CodeGen/Overrides.hs +31/−14
• lib/Data/GI/CodeGen/Signal.hs +47/−13
• lib/Data/GI/CodeGen/Struct.hs +18/−13
• lib/Data/GI/CodeGen/SymbolNaming.hs +66/−28
• lib/Data/GI/CodeGen/Util.hs +31/−0
• lib/Data/GI/GIR/Alias.hs +5/−4
• lib/Data/GI/GIR/Arg.hs +3/−0
• lib/Data/GI/GIR/Callable.hs +14/−5
• lib/Data/GI/GIR/Callback.hs +10/−3
• lib/Data/GI/GIR/Constant.hs +11/−2
• lib/Data/GI/GIR/Deprecation.hs +1/−17
• lib/Data/GI/GIR/Documentation.hs +14/−8
• lib/Data/GI/GIR/Enum.hs +31/−8
• lib/Data/GI/GIR/Field.hs +14/−11
• lib/Data/GI/GIR/Function.hs +0/−3
• lib/Data/GI/GIR/Interface.hs +10/−0
• lib/Data/GI/GIR/Method.hs +0/−3
• lib/Data/GI/GIR/Object.hs +5/−1
• lib/Data/GI/GIR/Parser.hs +2/−2
• lib/Data/GI/GIR/Repository.hs +2/−2
• lib/Data/GI/GIR/Struct.hs +5/−1
• lib/Data/GI/GIR/Type.hs +18/−14
• lib/Data/GI/GIR/Union.hs +8/−0

@@ -0,0 +1,11 @@+### 0.20.1++	+ gtk-doc parser and haddock generator: while no means perfect,+	now the autogenerated bindings come with some reasonable+	autogenerated documentation.++	+ Many bugfixes. A particularly important one is for+	[issue 82](https://github.com/haskell-gi/haskell-gi/issues/82), which+	made compilation of+	[gi-glib](http://hackage.haskell.org/package/gi-glib) fail, for+	the latest version of gobject-introspection.

@@ -0,0 +1,17 @@+import Test.DocTest++main :: IO ()+main = doctest [ "-XCPP", "-XOverloadedStrings", "-XRankNTypes", "-XLambdaCase"+               , "-ilib"+               -- For the autogenerated Data.GI.CodeGen.GType (hsc)+               , "-idist/build"+               , "dist/build/lib/c/enumStorage.o"+               -- For gobject-introspection+               , "-lgirepository-1.0"+               , "-lgobject-2.0"+               , "-lglib-2.0"+               -- The actual modules to test+               , "Data.GI.CodeGen.GtkDoc"+               , "Data.GI.CodeGen.ModulePath"+               , "Data.GI.CodeGen.SymbolNaming"+               , "Data.GI.CodeGen.Haddock" ]

@@ -21,7 +21,6 @@  import qualified Data.Map as M import qualified Data.Text as T-import qualified Data.Text.IO as TIO import qualified Data.Set as S  import Data.GI.Base.GError@@ -32,11 +31,13 @@ import Data.GI.CodeGen.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, moduleCode, codeToText, minBaseVersion) import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.CodeGen (genModule)+import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)+import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.OverloadedLabels (genOverloadedLabels) import Data.GI.CodeGen.OverloadedSignals (genOverloadedSignalConnectors) import Data.GI.CodeGen.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps, girFixups) import Data.GI.CodeGen.ProjectInfo (licenseText)-import Data.GI.CodeGen.Util (ucFirst)+import Data.GI.CodeGen.Util (ucFirst, utf8ReadFile, utf8WriteFile)  data Mode = GenerateCode | Dump | Labels | Signals | Help @@ -94,8 +95,8 @@                          (\arg opt -> opt {optOutputDir = Just arg}) "DIR")     "\tset the output directory",   Option "s" ["search"] (ReqArg-    (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH")-    "\tprepend a directory to the typelib search path",+    (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt}) "PATH")+    "\tprepend a directory to the GIR and typelib search path",   Option "M" ["noMethodOverloading"] (NoArg $ \opt -> opt {optOvMethods = False})     "\tdo not generate method overloading support",   Option "P" ["noPropertyOverloading"] (NoArg $ \opt -> opt {optOvProperties = False})@@ -134,38 +135,38 @@ genLabels options ovs modules extraPaths = do   apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules   let allAPIs = M.unions (map M.fromList apis)-      cfg = Config {modName = Nothing,+      cfg = Config {modName = "<<GI autogenerated labels>>",                     verbose = optVerbose options,                     overrides = ovs,                     cgFlags = genFlags options                    }   putStrLn $ "\t* Generating GI.OverloadedLabels"-  m <- genCode cfg allAPIs ["GI", "OverloadedLabels"]+  m <- genCode cfg allAPIs  "OverloadedLabels"        (genOverloadedLabels (M.toList allAPIs))   _ <- writeModuleTree (optVerbose options) (optOutputDir options) m   return () --- Generate generic signal connectors ("Clicked", "Activate", ...)+-- | Generate generic signal connectors ("Clicked", "Activate", ...) genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO () genGenericConnectors options ovs modules extraPaths = do   apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules   let allAPIs = M.unions (map M.fromList apis)-      cfg = Config {modName = Nothing,+      cfg = Config {modName = "<<GI autogenerated connectors>>",                     verbose = optVerbose options,                     overrides = ovs,                     cgFlags = genFlags options                    }   putStrLn $ "\t* Generating GI.Signals"-  m <- genCode cfg allAPIs ["GI", "Signals"] (genOverloadedSignalConnectors (M.toList allAPIs))+  m <- genCode cfg allAPIs "Signals" (genOverloadedSignalConnectors (M.toList allAPIs))   _ <- writeModuleTree (optVerbose options) (optOutputDir options) m   return () --- Generate the code for the given module, and return the dependencies+-- | Generate the code for the given module, and return the dependencies -- for this module. processMod :: Options -> Overrides -> [FilePath] -> Text -> IO () processMod options ovs extraPaths name = do   let version = M.lookup name (nsChooseVersion ovs)-      cfg = Config {modName = Just name,+      cfg = Config {modName = name,                     verbose = optVerbose options,                     overrides = ovs,                     cgFlags = genFlags options@@ -180,7 +181,7 @@   let (apis, deps) = filterAPIsAndDeps ovs gir girDeps       allAPIs = M.union apis deps -  m <- genCode cfg allAPIs ["GI", nm] (genModule apis)+  m <- genCode cfg allAPIs (toModulePath nm) (genModule apis)   let modDeps = transitiveModuleDeps m   moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m @@ -198,17 +199,18 @@         actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps         baseVersion = minBaseVersion m         p = \n -> joinPath [fromMaybe "" (optOutputDir options), n]-    (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList baseVersion)+    (err, m) <- evalCodeGen cfg allAPIs (error "undefined module path")+                (genCabalProject gir actualDeps moduleList baseVersion)     case err of       Nothing -> do                putStrLn $ "\t\t+ " ++ fname-               TIO.writeFile (p fname) (codeToText (moduleCode m))+               utf8WriteFile (p fname) (codeToText (moduleCode m))                putStrLn "\t\t+ cabal.config"-               TIO.writeFile (p "cabal.config") cabalConfig+               utf8WriteFile (p "cabal.config") cabalConfig                putStrLn "\t\t+ Setup.hs"-               TIO.writeFile (p "Setup.hs") setupHs+               utf8WriteFile (p "Setup.hs") setupHs                putStrLn "\t\t+ LICENSE"-               TIO.writeFile (p "LICENSE") licenseText+               utf8WriteFile (p "LICENSE") licenseText       Just msg -> putStrLn $ "ERROR: could not generate " ++ fname                   ++ "\nError was: " ++ T.unpack msg @@ -221,7 +223,8 @@ process :: Options -> [Text] -> IO () process options names = do   let extraPaths = optSearchPaths options-  configs <- traverse TIO.readFile (optOverridesFiles options)+  configs <- traverse utf8ReadFile (optOverridesFiles options)+  setupTypelibSearchPath (optSearchPaths options)   parseOverridesFile (concatMap T.lines configs) >>= \case     Left errorMsg -> do       hPutStr stderr "Error when parsing the config file(s):\n"

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.20+version:             0.20.1 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.@@ -17,6 +17,8 @@ tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 cabal-version:       >=1.8 +extra-source-files: ChangeLog.md+ source-repository head   type: git   location: git://github.com/haskell-gi/haskell-gi.git@@ -26,6 +28,7 @@   build-depends:       base >= 4.7 && < 5,                        haskell-gi-base == 0.20.*,                        Cabal >= 1.20,+                       attoparsec == 0.13.*,                        containers,                        directory,                        filepath,@@ -79,12 +82,16 @@                        Data.GI.CodeGen.Config,                        Data.GI.CodeGen.Constant,                        Data.GI.CodeGen.Conversions,+                       Data.GI.CodeGen.CtoHaskellMap,                        Data.GI.CodeGen.EnumFlags,                        Data.GI.CodeGen.Fixups,                        Data.GI.CodeGen.GObject,+                       Data.GI.CodeGen.GtkDoc,                        Data.GI.CodeGen.GType,+                       Data.GI.CodeGen.Haddock,                        Data.GI.CodeGen.Inheritance,                        Data.GI.CodeGen.LibGIRepository,+                       Data.GI.CodeGen.ModulePath,                        Data.GI.CodeGen.OverloadedSignals,                        Data.GI.CodeGen.OverloadedLabels,                        Data.GI.CodeGen.OverloadedMethods,@@ -100,6 +107,12 @@                        Data.GI.CodeGen.Util    other-modules:       Paths_haskell_gi++test-suite doctests+  type:          exitcode-stdio-1.0+  ghc-options:   -threaded+  main-is:       DocTests.hs+  build-depends: base, doctest >= 0.8  executable haskell-gi   main-is:             haskell-gi.hs

@@ -25,9 +25,11 @@     , Scope(..)      -- Reexported from Data.GI.GIR.Deprecation-    , deprecatedPragma     , DeprecationInfo +    -- Reexported from Data.GI.GIR.Enumeration+    , EnumerationMember(..)+     -- Reexported from Data.GI.GIR.Property     , PropertyFlag(..) @@ -81,8 +83,8 @@ import Data.GI.GIR.Callable (Callable(..)) import Data.GI.GIR.Callback (Callback(..), parseCallback) import Data.GI.GIR.Constant (Constant(..), parseConstant)-import Data.GI.GIR.Deprecation (DeprecationInfo, deprecatedPragma)-import Data.GI.GIR.Enum (Enumeration(..), parseEnum)+import Data.GI.GIR.Deprecation (DeprecationInfo)+import Data.GI.GIR.Enum (Enumeration(..), EnumerationMember(..), parseEnum) import Data.GI.GIR.Field (Field(..)) import Data.GI.GIR.Flags (Flags(..), parseFlags) import Data.GI.GIR.Function (Function(..), parseFunction)

@@ -14,8 +14,10 @@ import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T+import qualified Data.Text.IO as TIO import Data.Text (Text) import Text.Read+import System.IO (stderr)  import Data.GI.CodeGen.API (GIRInfo(..)) import Data.GI.CodeGen.Code@@ -89,20 +91,28 @@ giNextMinor major minor = (T.intercalate "." . map tshow)                           [haskellGIAPIVersion, major, minor+1] +-- | Info for a given package.+data PkgInfo = PkgInfo { pkgName  :: Text+                       , pkgMajor :: Int+                       , pkgMinor :: Int+                       } deriving Show+ -- | Determine the pkg-config name and installed version (major.minor -- only) for a given module, or throw an exception if that fails. tryPkgConfig :: Text -> Text -> [Text] -> Bool              -> M.Map Text Text-             -> ExcCodeGen (Text, Int, Int)+             -> CodeGen (Either Text PkgInfo) tryPkgConfig name version packages verbose overridenNames =     liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case            Just (n,v) ->                case readMajorMinor v of-                 Just (major, minor) -> return (n, major, minor)-                 Nothing -> notImplementedError $-                            "Cannot parse version \""-                            <> v <> "\" for module " <> name-           Nothing -> missingInfoError $+                 Just (major, minor) ->+                   return $ Right (PkgInfo { pkgName = n+                                           , pkgMajor = major+                                           , pkgMinor = minor})+                 Nothing -> return $ Left $ "Cannot parse version \"" <> v <>+                            "\" for module " <> name+           Nothing -> return $ Left $                       "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <>                       "Try adding an override with the proper package name:\n"                       <> "pkg-config-name " <> name <> " [matching pkg-config name here]"@@ -120,8 +130,7 @@ -- corresponding error string. genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion ->                    CodeGen (Maybe Text)-genCabalProject gir deps exposedModules minBaseVersion =-    handleCGExc (return . Just . describeCGError) $ do+genCabalProject gir deps exposedModules minBaseVersion = do       cfg <- config       let pkMap = pkgConfigMap (overrides cfg)           name = girNSName gir@@ -130,9 +139,14 @@        line $ "-- Autogenerated, do not edit."       line $ padTo 20 "name:" <> "gi-" <> T.toLower name-      (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap-      let cabalVersion = fromMaybe (giModuleVersion major minor)-                                   (cabalPkgVersion $ overrides cfg)+      eitherPkgInfo <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap+      cabalVersion <- case eitherPkgInfo of+                        Left err -> do+                          liftIO $ TIO.hPutStrLn stderr $ "Warning: " <> err+                          return "0.0.1"+                        Right (PkgInfo _ major minor) ->+                          return $ fromMaybe (giModuleVersion major minor)+                                             (cabalPkgVersion $ overrides cfg)       line $ padTo 20 "version:" <> cabalVersion       line $ padTo 20 "synopsis:" <> name                <> " bindings"@@ -158,8 +172,13 @@         line $ padTo 20 "exposed-modules:" <> head exposedModules         forM_ (tail exposedModules) $ \mod ->               line $ padTo 20 "" <> mod-        line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= "-                 <> tshow major <> "." <> tshow minor+        case eitherPkgInfo of+          Left _ -> do+            line $ padTo 20 "-- pkg-config info for the module not found:"+            line $ padTo 20 "-- pkgconfig-depends: XXX"+          Right (PkgInfo pcName major minor) ->+            line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <>+                   tshow major <> "." <> tshow minor         line $ "build-depends:"         indent $ do           line $ "haskell-gi-base >= "@@ -169,9 +188,14 @@               let depName = girNSName dep                   depVersion = girNSVersion dep                   depPackages = girPCPackages dep-              (_, depMajor, depMinor) <- tryPkgConfig depName depVersion+              eitherDepInfo <- tryPkgConfig depName depVersion                                          depPackages (verbose cfg) pkMap-              line $ "gi-" <> T.toLower depName <> " >= "+              case eitherDepInfo of+                Left err -> do+                  liftIO $ TIO.hPutStrLn stderr $ "Warning: " <> err+                  line $ "-- gi-" <> T.toLower depName <> " >= XXX & < YYY"+                Right (PkgInfo _ depMajor depMinor) ->+                  line $ "gi-" <> T.toLower depName <> " >= "                        <> giModuleVersion depMajor depMinor                        <> " && < "                        <> giNextMinor depMajor depMinor

@@ -16,10 +16,12 @@ import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..))+import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)+import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.Overrides (parseOverridesFile, girFixups,                                   filterAPIsAndDeps) import Data.GI.CodeGen.PkgConfig (tryPkgConfig)-import Data.GI.CodeGen.Util (ucFirst, tshow)+import Data.GI.CodeGen.Util (ucFirst, tshow, utf8ReadFile, utf8WriteFile)  import Control.Monad (when) @@ -28,7 +30,6 @@ import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO as TIO  import System.Directory (doesFileExist) import System.FilePath ((</>), (<.>))@@ -42,7 +43,7 @@ genPkgInfo :: [Dependency] -> [(FlagName, Bool)] -> FilePath -> Text -> IO () genPkgInfo deps flags fName modName = do   versions <- mapM findVersion deps-  TIO.writeFile fName $ T.unlines+  utf8WriteFile fName $ T.unlines          [ "module " <> modName <> " (pkgConfigVersions, flags) where"          , ""          , "import Prelude (String, Bool(..))"@@ -90,9 +91,11 @@                 -> ConfHook confCodeGenHook name version verbosity overrides outputDir                 defaultConfHook (gpd, hbi) flags = do+  setupTypelibSearchPath []+   ovsData <- case overrides of                Nothing -> return ""-               Just fname -> TIO.readFile fname+               Just fname -> utf8ReadFile fname   ovs <- parseOverridesFile (T.lines ovsData) >>= \case          Left err -> error $ "Error when parsing overrides file: "                      ++ T.unpack err@@ -101,12 +104,12 @@   (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs)   let (apis, deps) = filterAPIsAndDeps ovs gir girDeps       allAPIs = M.union apis deps-      cfg = Config {modName = Just name,+      cfg = Config {modName = name,                     verbose = verbosity,                     overrides = ovs,                     cgFlags = parseFlags (configConfigurationsFlags flags)} -  m <- genCode cfg allAPIs ["GI", ucFirst name] (genModule apis)+  m <- genCode cfg allAPIs (toModulePath name) (genModule apis)   alreadyDone <- doesFileExist (fromMaybe "" outputDir                                 </> "GI" </> T.unpack (ucFirst name) <.> "hs")   moduleList <- if not alreadyDone

@@ -6,9 +6,11 @@     , ExposeClosures(..)      , hOutType+    , skipRetVal     , arrayLengths     , arrayLengthsMap     , callableSignature+    , Signature(..)     , fixupCallerAllocates      , callableHInArgs@@ -35,6 +37,9 @@ import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.Haddock (deprecatedPragma,+                                writeDocumentation, RelativeDocPosition(..),+                                writeArgDocumentation, writeReturnDocumentation) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer import Data.GI.CodeGen.Type@@ -47,11 +52,11 @@ data ExposeClosures = WithClosures                     | WithoutClosures -hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep-hOutType callable outArgs ignoreReturn = do+hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep+hOutType callable outArgs = do   hReturnType <- case returnType callable of                    Nothing -> return $ typeOf ()-                   Just r -> if ignoreReturn+                   Just r -> if skipRetVal callable                              then return $ typeOf ()                              else haskellType r   hOutArgTypes <- forM outArgs $ \outarg ->@@ -59,7 +64,8 @@                                 (haskellType (argType outarg))                                 (maybeT <$> haskellType (argType outarg))   nullableReturnType <- maybe (return False) typeIsNullable (returnType callable)-  let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn+  let maybeHReturnType = if returnMayBeNull callable+                            && not (skipRetVal callable)                             && nullableReturnType                          then maybeT hReturnType                          else hReturnType@@ -70,12 +76,12 @@  -- | Generate a foreign import for the given C symbol. Return the name -- of the corresponding Haskell identifier.-mkForeignImport :: Text -> Callable -> Bool -> CodeGen Text-mkForeignImport cSymbol callable throwsGError = do+mkForeignImport :: Text -> Callable -> CodeGen Text+mkForeignImport cSymbol callable = do     line first     indent $ do         mapM_ (\a -> line =<< fArgStr a) (args callable)-        when throwsGError $+        when (callableThrows callable) $                line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error"         line =<< last     return hSymbol@@ -224,7 +230,7 @@   indent $ line $ "error \"" <> funcName <> " : length of '" <> avar <>              "' does not agree with that of '" <> pvar <> "'.\"" --- Whether to skip the return value in the generated bindings. The+-- | Whether to skip the return value in the generated bindings. The -- C convention is that functions throwing an error and returning -- a gboolean set the boolean to TRUE iff there is no error, so -- the information is always implicit in whether we emit an@@ -232,10 +238,10 @@ -- generated bindings without loss of information (and omitting it -- gives rise to a nicer API). See -- https://bugzilla.gnome.org/show_bug.cgi?id=649657-skipRetVal :: Callable -> Bool -> Bool-skipRetVal callable throwsGError =-    (skipReturn callable) ||-         (throwsGError && returnType callable == Just (TBasicType TBoolean))+skipRetVal :: Callable -> Bool+skipRetVal callable = (skipReturn callable) ||+                      (callableThrows callable &&+                        returnType callable == Just (TBasicType TBoolean))  freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) ->                Callable -> Map.Map Text Text -> ExcCodeGen [Text]@@ -280,7 +286,10 @@     DirectionIn -> if arg `elem` omitted                    then return . escapedArgName $ arg                    else case callback of-                        Just c -> prepareInCallback arg c+                        Just c -> if callableThrows (cbCallable c)+                                  -- See [Note: Callables that throw]+                                  then return (escapedArgName arg)+                                  else prepareInCallback arg c                         Nothing -> prepareInArg arg     DirectionInout -> prepareInoutArg arg     DirectionOut -> prepareOutArg arg@@ -303,9 +312,9 @@                          line $ "return " <> converted                 return maybeName) --- Callbacks are a fairly special case, we treat them separately.+-- | Callbacks are a fairly special case, we treat them separately. prepareInCallback :: Arg -> Callback -> CodeGen Text-prepareInCallback arg (Callback cb) = do+prepareInCallback arg (Callback {cbCallable = cb}) = do   let name = escapedArgName arg       ptrName = "ptr" <> name       scope = argScope arg@@ -551,41 +560,56 @@        when (argScope arg == ScopeTypeCall) $             line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' -formatHSignature :: Callable -> ForeignSymbol -> Bool -> ExcCodeGen ()-formatHSignature callable symbol throwsGError = do-  (constraints, vars) <- callableSignature callable symbol throwsGError+-- | Format the signature of the Haskell binding for the `Callable`.+formatHSignature :: Callable -> ForeignSymbol -> ExcCodeGen ()+formatHSignature callable symbol = do+  sig <- callableSignature callable symbol   indent $ do+      let constraints = "B.CallStack.HasCallStack" : signatureConstraints sig       line $ "(" <> T.intercalate ", " constraints <> ") =>"-      forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) ->-           line $ withComment (prefix <> t) name+      forM_ (zip ("" : repeat "-> ") (signatureArgTypes sig)) $+        \(prefix, (maybeArg, t)) -> do+          line $ prefix <> t+          case maybeArg of+            Nothing -> return ()+            Just arg -> writeArgDocumentation arg+      let resultPrefix = if null (signatureArgTypes sig)+                         then ""+                         else "-> "+      line $ resultPrefix <> signatureReturnType sig+      writeReturnDocumentation (signatureCallable sig) (skipRetVal callable)  -- | Name for the first argument in dynamic wrappers (the `FunPtr`). funPtr :: Text funPtr = "__funPtr" +-- | Signature for a callable.+data Signature = Signature { signatureCallable    :: Callable+                           , signatureConstraints :: [Text]+                           , signatureArgTypes    :: [(Maybe Arg, Text)]+                           , signatureReturnType  :: Text+                           }+ -- | The Haskell signature for the given callable. It returns a tuple -- ([constraints], [(type, argname)]).-callableSignature :: Callable -> ForeignSymbol -> Bool ->-                     ExcCodeGen ([Text], [(Text, Text)])-callableSignature callable symbol throwsGError = do+callableSignature :: Callable -> ForeignSymbol -> ExcCodeGen Signature+callableSignature callable symbol = do   let (hInArgs, _) = callableHInArgs callable                                     (case symbol of                                        KnownForeignSymbol _ -> WithoutClosures                                        DynamicForeignSymbol _ -> WithClosures)   (argConstraints, types) <- inArgInterfaces hInArgs   let constraints = ("MonadIO m" : argConstraints)-      ignoreReturn = skipRetVal callable throwsGError-  outType <- hOutType callable (callableHOutArgs callable) ignoreReturn-  case symbol of-    KnownForeignSymbol _ -> do-      let allNames = map escapedArgName hInArgs ++ ["result"]-          allTypes = types ++ [tshow ("m" `con` [outType])]-      return (constraints, zip allTypes allNames)-    DynamicForeignSymbol w -> do-      let allNames = funPtr : map escapedArgName hInArgs ++ ["result"]-          allTypes = ("FunPtr " <> dynamicType w) :-                     types ++ [tshow ("m" `con` [outType])]-      return (constraints, zip allTypes allNames)+  outType <- hOutType callable (callableHOutArgs callable)+  return $ Signature {+      signatureCallable = callable,+      signatureConstraints = constraints,+      signatureReturnType = tshow ("m" `con` [outType]),+      signatureArgTypes = case symbol of+          KnownForeignSymbol _ -> zip (map Just hInArgs) types+          DynamicForeignSymbol w -> zip (Nothing : map Just hInArgs)+                                    ("FunPtr " <> dynamicType w : types)+      }  -- | "In" arguments for the given callable on the Haskell side, -- together with the omitted arguments.@@ -609,10 +633,10 @@     in filter (`notElem` (arrayLengths callable)) outArgs  -- | Convert the result of the foreign call to Haskell.-convertResult :: Name -> Callable -> Bool -> Map.Map Text Text ->+convertResult :: Name -> Callable -> Map.Map Text Text ->                  ExcCodeGen Text-convertResult n callable ignoreReturn nameMap =-    if ignoreReturn || returnType callable == Nothing+convertResult n callable nameMap =+    if skipRetVal callable || returnType callable == Nothing     then return (error "convertResult: unreachable code reached, bug!")     else do       nullableReturnType <- maybe (return False) typeIsNullable (returnType callable)@@ -709,15 +733,14 @@     forM hOutArgs (convertOutArg callable nameMap)  -- | Invoke the given C function, taking care of errors.-invokeCFunction :: Callable -> ForeignSymbol -> Bool -> Bool -> [Text] ->-                   CodeGen ()-invokeCFunction callable symbol throwsGError ignoreReturn argNames = do+invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen ()+invokeCFunction callable symbol argNames = do   let returnBind = case returnType callable of                      Nothing -> ""-                     _       -> if ignoreReturn+                     _       -> if skipRetVal callable                                 then "_ <- "                                 else "result <- "-      maybeCatchGErrors = if throwsGError+      maybeCatchGErrors = if callableThrows callable                           then "propagateGError $ "                           else ""       call = case symbol of@@ -728,9 +751,9 @@            <> call <> (T.concat . map (" " <>)) argNames  -- | Return the result of the call, possibly including out arguments.-returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen ()-returnResult callable ignoreReturn result pps =-    if ignoreReturn || returnType callable == Nothing+returnResult :: Callable -> Text -> [Text] -> CodeGen ()+returnResult callable result pps =+    if skipRetVal callable || returnType callable == Nothing     then case pps of         []      -> line "return ()"         (pp:[]) -> line $ "return " <> pp@@ -740,33 +763,30 @@         _  -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")"  -- | Generate a Haskell wrapper for the given foreign function.-genHaskellWrapper :: Name -> ForeignSymbol -> Callable -> Bool ->+genHaskellWrapper :: Name -> ForeignSymbol -> Callable ->                      ExposeClosures -> ExcCodeGen Text-genHaskellWrapper n symbol callable throwsGError expose = group $ do+genHaskellWrapper n symbol callable expose = group $ do     let name = case symbol of                  KnownForeignSymbol _ -> lowerName n                  DynamicForeignSymbol _ -> callbackDynamicWrapper (upperName n)         (hInArgs, omitted) = callableHInArgs callable expose         hOutArgs = callableHOutArgs callable-        ignoreReturn = skipRetVal callable throwsGError      line $ name <> " ::"-    formatHSignature callable symbol ignoreReturn+    formatHSignature callable symbol     let argNames = case symbol of                      KnownForeignSymbol _ -> map escapedArgName hInArgs                      DynamicForeignSymbol _ ->                          funPtr : map escapedArgName hInArgs     line $ name <> " " <> T.intercalate " " argNames <> " = liftIO $ do"-    indent (genWrapperBody n symbol callable throwsGError-                           ignoreReturn hInArgs hOutArgs omitted)+    indent (genWrapperBody n symbol callable hInArgs hOutArgs omitted)     return name  -- | Generate the body of the Haskell wrapper for the given foreign symbol.-genWrapperBody :: Name -> ForeignSymbol -> Callable -> Bool ->-                  Bool -> [Arg] -> [Arg] -> [Arg] ->+genWrapperBody :: Name -> ForeignSymbol -> Callable ->+                  [Arg] -> [Arg] -> [Arg] ->                   ExcCodeGen ()-genWrapperBody n symbol callable throwsGError-               ignoreReturn hInArgs hOutArgs omitted = do+genWrapperBody n symbol callable hInArgs hOutArgs omitted = do     readInArrayLengths n callable hInArgs     inArgNames <- forM (args callable) $ \arg ->                   prepareArgForCall omitted arg@@ -774,19 +794,18 @@     let nameMap = Map.fromList $ flip zip inArgNames                                $ map escapedArgName $ args callable     prepareClosures callable nameMap-    if throwsGError+    if callableThrows callable     then do         line "onException (do"         indent $ do-            invokeCFunction callable symbol throwsGError-                            ignoreReturn inArgNames+            invokeCFunction callable symbol inArgNames             readOutArrayLengths callable nameMap-            result <- convertResult n callable ignoreReturn nameMap+            result <- convertResult n callable nameMap             pps <- convertOutArgs callable nameMap hOutArgs             freeCallCallbacks callable nameMap             forM_ (args callable) touchInArg             mapM_ line =<< freeInArgs callable nameMap-            returnResult callable ignoreReturn result pps+            returnResult callable result pps         line " ) (do"         indent $ do             freeCallCallbacks callable nameMap@@ -796,15 +815,14 @@                 _ -> mapM_ line actions         line " )"     else do-        invokeCFunction callable symbol throwsGError-                        ignoreReturn inArgNames+        invokeCFunction callable symbol inArgNames         readOutArrayLengths callable nameMap-        result <- convertResult n callable ignoreReturn nameMap+        result <- convertResult n callable nameMap         pps <- convertOutArgs callable nameMap hOutArgs         freeCallCallbacks callable nameMap         forM_ (args callable) touchInArg         mapM_ line =<< freeInArgs callable nameMap-        returnResult callable ignoreReturn result pps+        returnResult callable result pps  -- | caller-allocates arguments are arguments that the caller -- allocates, and the called function modifies. They are marked as@@ -859,32 +877,33 @@     }  -- | Some debug info for the callable.-genCallableDebugInfo :: Callable -> Bool -> CodeGen ()-genCallableDebugInfo callable throwsGError =+genCallableDebugInfo :: Callable -> CodeGen ()+genCallableDebugInfo callable =     group $ do       line $ "-- Args : " <> (tshow $ args callable)       line $ "-- Lengths : " <> (tshow $ arrayLengths callable)       line $ "-- returnType : " <> (tshow $ returnType callable)-      line $ "-- throws : " <> (tshow throwsGError)+      line $ "-- throws : " <> (tshow $ callableThrows callable)       line $ "-- Skip return : " <> (tshow $ skipReturn callable)       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?"  -- | Generate a wrapper for a known C symbol.-genCCallableWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genCCallableWrapper n cSymbol callable throwsGError = do-  genCallableDebugInfo callable throwsGError+genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen ()+genCCallableWrapper n cSymbol callable = do+  genCallableDebugInfo callable    let callable' = fixupCallerAllocates callable -  hSymbol <- mkForeignImport cSymbol callable' throwsGError+  hSymbol <- mkForeignImport cSymbol callable'    blank -  line $ deprecatedPragma (lowerName n) (callableDeprecated callable)+  deprecatedPragma (lowerName n) (callableDeprecated callable)+  writeDocumentation DocBeforeSymbol (callableDocumentation callable)   void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'-                          throwsGError WithoutClosures)+         WithoutClosures)  -- | For callbacks we do not need to keep track of which arguments are -- closures.@@ -897,10 +916,10 @@ -- function that will invoke its first argument, which should be a -- `FunPtr` of the appropriate type). The caller should have created a -- type synonym with the right type for the foreign symbol.-genDynamicCallableWrapper :: Name -> Text -> Callable -> Bool ->+genDynamicCallableWrapper :: Name -> Text -> Callable ->                              ExcCodeGen Text-genDynamicCallableWrapper n typeSynonym callable throwsGError = do-  genCallableDebugInfo callable throwsGError+genDynamicCallableWrapper n typeSynonym callable = do+  genCallableDebugInfo callable    let callable' = forgetClosures (fixupCallerAllocates callable) @@ -910,5 +929,4 @@    let dyn = DynamicWrapper { dynamicWrapper = wrapper                            , dynamicType    = typeSynonym }-  genHaskellWrapper n (DynamicForeignSymbol dyn) callable'-                    throwsGError WithClosures+  genHaskellWrapper n (DynamicForeignSymbol dyn) callable' WithClosures

@@ -17,7 +17,6 @@     , BaseVersion(..)     , showBaseVersion -    , ModuleName     , registerNSDependency     , qualified     , getDeps@@ -40,7 +39,6 @@     , setGHCOptions     , setModuleFlags     , setModuleMinBase-    , addModuleDocumentation      , exportToplevel     , exportModule@@ -53,6 +51,7 @@     , getAPI     , findAPIByName     , getAPIs+    , getC2HMap      , config     , currentModule@@ -65,7 +64,6 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Except-import qualified Data.ByteString as B import qualified Data.Foldable as F import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid ((<>))@@ -75,17 +73,19 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as TE  import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory)  import Data.GI.CodeGen.API (API, Name(..)) import Data.GI.CodeGen.Config (Config(..))+import {-# SOURCE #-} Data.GI.CodeGen.CtoHaskellMap (cToHaskellMap,+                                                     Hyperlink)+import Data.GI.CodeGen.GtkDoc (CRef)+import Data.GI.CodeGen.ModulePath (ModulePath(..), dotModulePath, (/.)) import Data.GI.CodeGen.Type (Type(..))-import Data.GI.CodeGen.Util (tshow, terror, padTo)+import Data.GI.CodeGen.Util (tshow, terror, padTo, utf8WriteFile) import Data.GI.CodeGen.ProjectInfo (authors, license, maintainers)-import Data.GI.GIR.Documentation (Documentation(..))  data Code     = NoCode              -- ^ No code@@ -107,7 +107,6 @@     a `mappend` b = Sequence (a <| b <| S.empty)  type Deps = Set.Set Text-type ModuleName = [Text]  -- | Subsection of the haddock documentation where the export should -- be located.@@ -136,14 +135,14 @@  -- | Information on a generated module. data ModuleInfo = ModuleInfo {-      moduleName :: ModuleName -- ^ Full module name: ["GI", "Gtk", "Label"].+      modulePath :: ModulePath -- ^ Full module name: ["Gtk", "Label"].     , moduleCode :: Code       -- ^ Generated code for the module.     , bootCode   :: Code       -- ^ Interface going into the .hs-boot file.     , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative                                           -- module name.     , moduleDeps :: Deps -- ^ Set of dependencies for this module.     , moduleExports :: Seq Export -- ^ Exports for the module.-    , qualifiedImports :: Set.Set ModuleName -- ^ Qualified (source) imports+    , qualifiedImports :: Set.Set ModulePath -- ^ Qualified (source) imports     , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.     , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module.     , moduleFlags   :: Set.Set ModuleFlag -- ^ Flags for the module.@@ -168,8 +167,8 @@ showBaseVersion Base48 = "4.8"  -- | Generate the empty module.-emptyModule :: ModuleName -> ModuleInfo-emptyModule m = ModuleInfo { moduleName = m+emptyModule :: ModulePath -> ModuleInfo+emptyModule m = ModuleInfo { modulePath = m                            , moduleCode = NoCode                            , bootCode = NoCode                            , submodules = M.empty@@ -185,8 +184,10 @@  -- | Information for the code generator. data CodeGenConfig = CodeGenConfig {-      hConfig     :: Config        -- ^ Ambient config.-    , loadedAPIs :: M.Map Name API -- ^ APIs available to the generator.+      hConfig     :: Config          -- ^ Ambient config.+    , loadedAPIs  :: M.Map Name API  -- ^ APIs available to the generator.+    , c2hMap      :: M.Map CRef Hyperlink -- ^ Map from C references+                                          -- to Haskell symbols.     }  data CGError = CGErrorNotImplemented Text@@ -238,15 +239,16 @@      Right (r, new) -> put (mergeInfoState oldInfo new) >>                        return (r, moduleCode new) --- | Like `recurse`, giving explicitly the set of loaded APIs for the--- subgenerator.+-- | Like `recurse`, giving explicitly the set of loaded APIs and C to+-- Haskell map for the subgenerator. recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen () recurseWithAPIs apis cg = do   cfg <- ask   oldInfo <- get   -- Start the subgenerator with no code and no submodules.   let info = cleanInfo oldInfo-      cfg' = cfg {loadedAPIs = apis}+      cfg' = cfg {loadedAPIs = apis,+                  c2hMap = cToHaskellMap (M.toList apis)}   liftIO (runCodeGen cg cfg' info) >>= \case      Left e -> throwError e      Right (_, new) -> put (mergeInfo oldInfo new)@@ -290,7 +292,7 @@ submodule' modName cg = do   cfg <- ask   oldInfo <- get-  let info = emptyModule (moduleName oldInfo ++ [modName])+  let info = emptyModule (modulePath oldInfo /. modName)   liftIO (runCodeGen cg cfg info) >>= \case          Left e -> throwError e          Right (_, smInfo) -> if moduleCode smInfo == NoCode &&@@ -300,9 +302,9 @@  -- | Run the given CodeGen in order to generate a submodule (specified -- an an ordered list) of the current module.-submodule :: [Text] -> BaseCodeGen e () -> BaseCodeGen e ()-submodule [] cg = cg-submodule (m:ms) cg = submodule' m (submodule ms cg)+submodule :: ModulePath -> BaseCodeGen e () -> BaseCodeGen 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.@@ -330,12 +332,16 @@ currentModule :: CodeGen Text currentModule = do   s <- get-  return (T.intercalate "." (moduleName s))+  return (dotWithPrefix (modulePath s))  -- | Return the list of APIs available to the generator. getAPIs :: CodeGen (M.Map Name API) getAPIs = loadedAPIs <$> ask +-- | Return the C -> Haskell available to the generator.+getC2HMap :: CodeGen (M.Map CRef Hyperlink)+getC2HMap = c2hMap <$> ask+ -- | Due to the `forall` in the definition of `CodeGen`, if we want to -- run the monad transformer stack until we get an `IO` action, our -- only option is ignoring the possible error code from@@ -350,17 +356,18 @@         Right (r, newInfo) -> return (r, newInfo)  -- | Like `evalCodeGen`, but discard the resulting output value.-genCode :: Config -> M.Map Name API -> ModuleName -> CodeGen () ->-           IO ModuleInfo-genCode cfg apis mName cg = snd <$> evalCodeGen cfg apis mName cg+genCode :: Config -> M.Map Name API ->+           ModulePath -> CodeGen () -> IO ModuleInfo+genCode cfg apis mPath cg = snd <$> evalCodeGen cfg apis mPath cg  -- | 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 -> ModuleName -> CodeGen a ->-               IO (a, ModuleInfo)-evalCodeGen cfg apis mName cg = do-  let initialInfo = emptyModule mName-      cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis}+evalCodeGen :: Config -> M.Map Name API ->+               ModulePath -> CodeGen a -> IO (a, ModuleInfo)+evalCodeGen cfg apis mPath cg = do+  let initialInfo = emptyModule mPath+      cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis,+                            c2hMap = cToHaskellMap (M.toList apis)}   unwrapCodeGen cg cfg' initialInfo  -- | Mark the given dependency as used by the module.@@ -380,36 +387,35 @@  -- | Given a module name and a symbol in the module (including a -- proper namespace), return a qualified name for the symbol.-qualified :: ModuleName -> Name -> CodeGen Text-qualified mn (Name ns s) = do+qualified :: ModulePath -> Name -> CodeGen Text+qualified mp (Name ns s) = do   cfg <- config   -- Make sure the module is listed as a dependency.-  when (modName cfg /= Just ns) $+  when (modName cfg /= ns) $     registerNSDependency ns   minfo <- get-  if mn == moduleName minfo+  if mp == modulePath minfo   then return s   else do-    qm <- qualifiedImport mn+    qm <- qualifiedImport mp     return (qm <> "." <> s)  -- | 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 :: ModuleName -> CodeGen Text-qualifiedImport mn = do-  modify' $ \s -> s {qualifiedImports = Set.insert mn (qualifiedImports s)}-  return (qualifiedModuleName mn)+qualifiedImport :: ModulePath -> CodeGen Text+qualifiedImport mp = do+  modify' $ \s -> s {qualifiedImports = Set.insert mp (qualifiedImports s)}+  return (qualifiedModuleName mp)  -- | Construct a simplified version of the module name, suitable for a -- qualified import.-qualifiedModuleName :: ModuleName -> Text-qualifiedModuleName ["GI", ns, "Objects", o] = ns <> "." <> o-qualifiedModuleName ["GI", ns, "Interfaces", i] = ns <> "." <> i-qualifiedModuleName ["GI", ns, "Structs", s] = ns <> "." <> s-qualifiedModuleName ["GI", ns, "Unions", u] = ns <> "." <> u-qualifiedModuleName ("GI" : rest) = dotModuleName rest-qualifiedModuleName mn = dotModuleName mn+qualifiedModuleName :: ModulePath -> Text+qualifiedModuleName (ModulePath [ns, "Objects", o]) = ns <> "." <> o+qualifiedModuleName (ModulePath [ns, "Interfaces", i]) = ns <> "." <> i+qualifiedModuleName (ModulePath [ns, "Structs", s]) = ns <> "." <> s+qualifiedModuleName (ModulePath [ns, "Unions", u]) = ns <> "." <> u+qualifiedModuleName mp = dotModulePath mp  -- | Return the minimal base version supported by the module and all -- its submodules.@@ -542,13 +548,6 @@ setModuleMinBase v =     modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)} --- | Add the given text to the module-level documentation for the--- module being generated.-addModuleDocumentation :: Maybe Documentation -> CodeGen ()-addModuleDocumentation Nothing = return ()-addModuleDocumentation (Just doc) =-    modify' $ \s -> s{moduleDoc = moduleDoc s <> Just (docText doc)}- -- | Return a text representation of the `Code`. codeToText :: Code -> Text codeToText c = T.concat $ str 0 c []@@ -601,8 +600,18 @@                                                 . exportSymbol )                                       $ exportedTypes ] +-- | A subsection name, with an optional anchor name.+data Subsection = Subsection { subsectionTitle  :: Text+                             , subsectionAnchor :: Maybe Text+                             } deriving (Eq, Show, Ord)++-- | A subsection with an anchor given by the title and @prefix:title@ anchor.+subsecWithPrefix prefix title =+  Subsection { subsectionTitle = title+             , subsectionAnchor = Just (prefix <> ":" <> title) }+ -- | Format a given section made of subsections.-formatSection :: Text -> (Export -> Maybe (HaddockSection, SymbolName)) ->+formatSection :: Text -> (Export -> Maybe (Subsection, SymbolName)) ->                  [Export] -> Maybe Text formatSection section filter exports =     if M.null exportedSubsections@@ -613,20 +622,23 @@                               . M.toList ) exportedSubsections]      where-      filteredExports :: [(HaddockSection, SymbolName)]+      filteredExports :: [(Subsection, SymbolName)]       filteredExports = catMaybes (map filter exports) -      exportedSubsections :: M.Map HaddockSection (Set.Set SymbolName)+      exportedSubsections :: M.Map Subsection (Set.Set SymbolName)       exportedSubsections = foldr extract M.empty filteredExports -      extract :: (HaddockSection, SymbolName) ->-                 M.Map Text (Set.Set Text) -> M.Map Text (Set.Set Text)+      extract :: (Subsection, SymbolName) -> M.Map Subsection (Set.Set Text)+              -> M.Map Subsection (Set.Set Text)       extract (subsec, m) secs =           M.insertWith Set.union subsec (Set.singleton m) secs -      formatSubsection :: (HaddockSection, Set.Set SymbolName) -> Text+      formatSubsection :: (Subsection, Set.Set SymbolName) -> Text       formatSubsection (subsec, symbols) =-          T.unlines [ "-- ** " <> subsec+          T.unlines [ "-- ** " <> case subsectionAnchor subsec of+                                    Just anchor -> subsectionTitle subsec <>+                                                   " #" <> anchor <> "#"+                                    Nothing -> subsectionTitle subsec                     , ( T.concat                       . map (paddedLine 1 . comma)                       . Set.toList ) symbols]@@ -634,22 +646,25 @@ -- | Format the list of methods. formatMethods :: [Export] -> Maybe Text formatMethods = formatSection "Methods" toMethod-    where toMethod :: Export -> Maybe (HaddockSection, SymbolName)-          toMethod (Export (ExportMethod s) m) = Just (s, m)+    where toMethod :: Export -> Maybe (Subsection, SymbolName)+          toMethod (Export (ExportMethod s) m) =+            Just (subsecWithPrefix "method" s, m)           toMethod _ = Nothing  -- | Format the list of properties. formatProperties :: [Export] -> Maybe Text formatProperties = formatSection "Properties" toProperty-    where toProperty :: Export -> Maybe (HaddockSection, SymbolName)-          toProperty (Export (ExportProperty s) m) = Just (s, m)+    where toProperty :: Export -> Maybe (Subsection, SymbolName)+          toProperty (Export (ExportProperty s) m) =+            Just (subsecWithPrefix "attr" s, m)           toProperty _ = Nothing  -- | Format the list of signals. formatSignals :: [Export] -> Maybe Text formatSignals = formatSection "Signals" toSignal-    where toSignal :: Export -> Maybe (HaddockSection, SymbolName)-          toSignal (Export (ExportSignal s) m) = Just (s, m)+    where toSignal :: Export -> Maybe (Subsection, SymbolName)+          toSignal (Export (ExportSignal s) m) =+            Just (subsecWithPrefix "signal" s, m)           toSignal _ = Nothing  -- | Format the given export list. This is just the inside of the@@ -709,18 +724,18 @@ -- prefix for the namespace being currently generated, modules with -- this prefix will be imported as {-# SOURCE #-}, and otherwise will -- be imported normally.-importDeps :: ModuleName -> [ModuleName] -> Text+importDeps :: ModulePath -> [ModulePath] -> Text importDeps _ [] = ""-importDeps prefix deps = T.unlines . map toImport $ deps-    where toImport :: ModuleName -> Text+importDeps (ModulePath prefix) deps = T.unlines . map toImport $ deps+    where toImport :: ModulePath -> Text           toImport dep = let impSt = if importSource dep                                      then "import {-# SOURCE #-} qualified "                                      else "import qualified "-                         in impSt <> dotModuleName dep <>+                         in impSt <> dotWithPrefix dep <>                                 " as " <> qualifiedModuleName dep-          importSource :: ModuleName -> Bool-          importSource ["GI", _, "Callbacks"] = False-          importSource mn = take (length prefix) mn == prefix+          importSource :: ModulePath -> Bool+          importSource (ModulePath [_, "Callbacks"]) = False+          importSource (ModulePath mp) = take (length prefix) mp == prefix  -- | Standard imports. moduleImports :: Text@@ -732,74 +747,75 @@                 , ""                 , "import qualified Data.GI.Base.Attributes as GI.Attributes"                 , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"+                , "import qualified Data.GI.Base.GError as B.GError"                 , "import qualified Data.GI.Base.GVariant as B.GVariant"                 , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec"+                , "import qualified Data.GI.Base.CallStack as B.CallStack"                 , "import qualified Data.Text as T"                 , "import qualified Data.ByteString.Char8 as B"                 , "import qualified Data.Map as Map"                 , "import qualified Foreign.Ptr as FP" ] +-- | Like `dotModulePath`, but add a "GI." prefix.+dotWithPrefix :: ModulePath -> Text+dotWithPrefix mp = dotModulePath ("GI" <> mp)+ -- | Write to disk the code for a module, under the given base -- directory. Does not write submodules recursively, for that use -- `writeModuleTree`. writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO () writeModuleInfo verbose dirPrefix minfo = do-  let submoduleNames = map (moduleName) (M.elems (submodules minfo))+  let submodulePaths = map (modulePath) (M.elems (submodules minfo))       -- We reexport any submodules.-      submoduleExports = map dotModuleName submoduleNames-      fname = moduleNameToPath dirPrefix (moduleName minfo) ".hs"+      submoduleExports = map dotWithPrefix submodulePaths+      fname = modulePathToFilePath dirPrefix (modulePath minfo) ".hs"       dirname = takeDirectory fname       code = codeToText (moduleCode minfo)       pragmas = languagePragmas (Set.toList $ modulePragmas minfo)       optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo)-      prelude = modulePrelude (dotModuleName $ moduleName minfo)+      prelude = modulePrelude (dotWithPrefix $ modulePath minfo)                 (F.toList (moduleExports minfo))                 submoduleExports       imports = if ImplicitPrelude `Set.member` moduleFlags minfo                 then ""                 else moduleImports-      pkgRoot = take 2 (moduleName minfo)+      pkgRoot = ModulePath (take 1 (modulePathToList $ modulePath minfo))       deps = importDeps pkgRoot (Set.toList $ qualifiedImports minfo)       haddock = moduleHaddock (moduleDoc minfo) -  when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo+  when verbose $ putStrLn ((T.unpack . dotWithPrefix . modulePath) minfo                            ++ " -> " ++ fname)   createDirectoryIfMissing True dirname-  B.writeFile fname (TE.encodeUtf8 $ T.unlines [pragmas, optionsGHC, haddock,-                                                prelude, imports, deps, code])+  utf8WriteFile fname (T.unlines [pragmas, optionsGHC, haddock,+                                 prelude, imports, deps, code])   when (bootCode minfo /= NoCode) $ do-    let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"-    B.writeFile bootFName (TE.encodeUtf8 (genHsBoot minfo))+    let bootFName = modulePathToFilePath dirPrefix (modulePath minfo) ".hs-boot"+    utf8WriteFile bootFName (genHsBoot minfo)  -- | Generate the .hs-boot file for the given module. genHsBoot :: ModuleInfo -> Text genHsBoot minfo =-    "module " <> (dotModuleName . moduleName) minfo <> " where\n\n" <>+    "module " <> (dotWithPrefix . modulePath) minfo <> " where\n\n" <>     moduleImports <> "\n" <>     codeToText (bootCode minfo)  -- | Construct the filename corresponding to the given module.-moduleNameToPath :: Maybe FilePath -> ModuleName -> FilePath -> FilePath-moduleNameToPath dirPrefix mn ext =-    joinPath (fromMaybe "" dirPrefix : map T.unpack mn) ++ ext---- | Turn an abstract module name into its dotted representation. For--- instance, ["GI", "Gtk", "Types"] -> GI.Gtk.Types.-dotModuleName :: ModuleName -> Text-dotModuleName mn = T.intercalate "." mn+modulePathToFilePath :: Maybe FilePath -> ModulePath -> FilePath -> FilePath+modulePathToFilePath dirPrefix (ModulePath mp) ext =+    joinPath (fromMaybe "" dirPrefix : "GI" : map T.unpack mp) ++ ext  -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules. writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text] writeModuleTree verbose dirPrefix minfo = do-  submoduleNames <- concat <$> forM (M.elems (submodules minfo))+  submodulePaths <- concat <$> forM (M.elems (submodules minfo))                                     (writeModuleTree verbose dirPrefix)   writeModuleInfo verbose dirPrefix minfo-  return $ (dotModuleName (moduleName minfo) : submoduleNames)+  return $ (dotWithPrefix (modulePath minfo) : submodulePaths)  -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk. listModuleTree :: ModuleInfo -> [Text] listModuleTree minfo =-    let submoduleNames = concatMap listModuleTree (M.elems (submodules minfo))-    in dotModuleName (moduleName minfo) : submoduleNames+    let submodulePaths = concatMap listModuleTree (M.elems (submodules minfo))+    in dotWithPrefix (modulePath minfo) : submodulePaths

@@ -24,6 +24,7 @@ import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability) import Data.GI.CodeGen.GObject+import Data.GI.CodeGen.Haddock (deprecatedPragma, addModuleDocumentation) import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,                        fullInterfaceMethodList) import Data.GI.CodeGen.Properties (genInterfaceProperties, genObjectProperties,@@ -41,7 +42,7 @@ import Data.GI.CodeGen.Util (tshow)  genFunction :: Name -> Function -> CodeGen ()-genFunction n (Function symbol throws fnMovedTo callable) =+genFunction n (Function symbol fnMovedTo callable) =     -- Only generate the function if it has not been moved.     when (Nothing == fnMovedTo) $       group $ do@@ -50,7 +51,7 @@                            <> symbol                            <> "\n-- Error was : " <> describeCGError e))                         (do-                          genCCallableWrapper n symbol callable throws+                          genCCallableWrapper n symbol callable                           exportMethod (lowerName n) (lowerName n)                         ) @@ -120,6 +121,8 @@   hsBoot decl   decl +  addModuleDocumentation (unionDocumentation u)+   if unionIsBoxed u   then genBoxedObject n (fromJust $ unionTypeInit u)   else genWrappedPtr n (unionAllocationInfo u) (unionSize u)@@ -209,8 +212,7 @@                   methodName = mn,                   methodSymbol = sym,                   methodCallable = c,-                  methodType = t,-                  methodThrows = throws+                  methodType = t                 }) = do     let name' = upperName cn     returnsGObject <- maybe (return False) isGObject (returnType c)@@ -224,7 +226,7 @@         c'' = if OrdinaryMethod == t               then fixMethodArgs c'               else c'-    genCCallableWrapper mn' sym c'' throws+    genCCallableWrapper mn' sym c''     exportMethod (lowerName mn) (lowerName mn')      cfg <- config@@ -232,8 +234,8 @@          genMethodInfo cn (m {methodCallable = c''})  -- Type casting with type checking-genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen ()-genGObjectCasts isIU n cn_ parents = do+genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()+genGObjectCasts n cn_ parents = do   let name' = upperName n    group $ do@@ -243,7 +245,6 @@   group $ do     bline $ "instance GObject " <> name' <> " where"     indent $ group $ do-            line $ "gobjectIsInitiallyUnowned _ = " <> tshow isIU             line $ "gobjectType _ = c_" <> cn_    className <- classConstraint n@@ -283,10 +284,11 @@     bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"     exportDecl (name' <> "(..)") +    addModuleDocumentation (objDocumentation o)+     -- Type safe casting to parent objects, and implemented interfaces.-    isIU <- isInitiallyUnowned t     parents <- instanceTree n-    genGObjectCasts isIU n (objTypeInit o) (parents <> objInterfaces o)+    genGObjectCasts n (objTypeInit o) (parents <> objInterfaces o)      noName name' @@ -322,45 +324,52 @@   let name' = upperName n    line $ "-- interface " <> name' <> " "-  line $ deprecatedPragma name' $ ifDeprecated iface+  deprecatedPragma name' $ ifDeprecated iface   bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"   exportDecl (name' <> "(..)") +  addModuleDocumentation (ifDocumentation iface)+   noName name'    cfg <- config-  when (cgOverloadedMethods (cgFlags cfg)) $-       fullInterfaceMethodList n iface >>= genMethodList n    forM_ (ifSignals iface) $ \s -> handleCGExc-       (line . (T.concat ["-- XXX Could not generate signal ", name', "::"-                       , sigName s-                       , "\n", "-- Error was : "] <>) . describeCGError)-       (genSignal s n)+     (line . (T.concat ["-- XXX Could not generate signal ", name', "::"+                     , sigName s+                     , "\n", "-- Error was : "] <>) . describeCGError)+     (genSignal s n) -  genInterfaceProperties n iface-  when (cgOverloadedProperties (cgFlags cfg)) $-       genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)   when (cgOverloadedSignals (cgFlags cfg)) $-       genInterfaceSignals n iface+     genInterfaceSignals n iface    isGO <- apiIsGObject n (APIInterface iface)   if isGO   then do     let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)-    isIU <- apiIsInitiallyUnowned n (APIInterface iface)     gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)     allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p     let uniqueParents = nub (concat allParents)-    genGObjectCasts isIU n cn_ uniqueParents+    genGObjectCasts n cn_ uniqueParents +    genInterfaceProperties n iface+    when (cgOverloadedProperties (cgFlags cfg)) $+       genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)+   else group $ do     cls <- classConstraint n     exportDecl cls     bline $ "class ManagedPtrNewtype a => " <> cls <> " a"     line $ "instance " <> cls <> " " <> name'+    genWrappedPtr n (ifAllocationInfo iface) 0 +    when (not . null . ifProperties $ iface) $ group $ do+       line $ "-- XXX Skipping property generation for non-GObject interface"+   -- Methods+  when (cgOverloadedMethods (cgFlags cfg)) $+       fullInterfaceMethodList n iface >>= genMethodList n+   forM_ (ifMethods iface) $ \f -> do       let mn = methodName f       isFunction <- symbolFromFunction (methodSymbol f)@@ -427,7 +436,7 @@    -- Make sure we generate a "Callbacks" module, since it is imported   -- by other modules. It is fine if it ends up empty.-  submodule ["Callbacks"] (return ())+  submodule "Callbacks" (return ())  genModule :: M.Map Name API -> CodeGen () genModule apis = do

@@ -19,7 +19,7 @@  data Config = Config {       -- | Name of the module being generated.-      modName        :: Maybe Text,+      modName        :: Text,       -- | Whether to print extra info.       verbose        :: Bool,       -- | List of loaded overrides for the code generator.

@@ -12,6 +12,8 @@ import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation,+                                RelativeDocPosition(..)) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) @@ -41,15 +43,14 @@           name <> " = " <> expression <> " " <> value <> " :: " <> t  genConstant :: Name -> Constant -> CodeGen ()-genConstant (Name _ name) (Constant t value deprecated) =-    group $ do-      setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables",-                          "ViewPatterns"]-      line $ deprecatedPragma name deprecated+genConstant (Name _ name) c = group $ do+  setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"]+  deprecatedPragma name (constantDeprecated c) -      handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)-                  (assignValue name t value >>-                   exportToplevel ("pattern " <> name))+  handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)+    (do writeDocumentation DocBeforeSymbol (constantDocumentation c)+        assignValue name (constantType c) (constantValue c)+        exportToplevel ("pattern " <> name))  -- | Assign to the given name the given constant value, in a way that -- can be assigned to the corresponding Haskell type.

@@ -349,8 +349,18 @@                                  keyDestroy, elemDestroy]))  hToF :: Type -> Transfer -> ExcCodeGen Converter-hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer-hToF (TGSList t) transfer = hToF_PackedType t "packGSList" transfer+hToF (TGList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot pack into a GList.")+  hToF_PackedType t "packGList" transfer+hToF (TGSList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot pack into a GSList.")+  hToF_PackedType t "packGSList" transfer hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb@@ -414,17 +424,16 @@ fObjectToH t hType transfer = do   let constructor = T.pack . tyConName . typeRepTyCon $ hType   isGO <- isGObject t-  case transfer of+  return $ M $ parenthesize $+    case transfer of     TransferEverything ->         if isGO-        then return $ M $ parenthesize $ "wrapObject " <> constructor-        else badIntroError ("Got a transfer of something not a GObject: " <>-                            constructor)+        then "wrapObject " <> constructor+        else "wrapPtr " <> constructor     _ ->         if isGO-        then return $ M $ parenthesize $ "newObject " <> constructor-        else badIntroError ("Wrapping not a GObject with no copy: " <>-                            constructor)+        then "newObject " <> constructor+        else "newPtr " <> constructor  fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor fCallbackToH hType TransferNothing = do@@ -526,9 +535,18 @@     apply (P "Map.fromList")  fToH :: Type -> Transfer -> ExcCodeGen Converter--fToH (TGList t) transfer = fToH_PackedType t "unpackGList" transfer-fToH (TGSList t) transfer = fToH_PackedType t "unpackGSList" transfer+fToH (TGList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot unpack from a GList.")+  fToH_PackedType t "unpackGList" transfer+fToH (TGSList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot unpack from a GSList.")+  fToH_PackedType t "unpackGSList" transfer fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer@@ -610,15 +628,22 @@     -- Instead of restricting to the actual class,     -- we allow for any object descending from it.     Just (APIInterface _) -> do-             cls <- typeConstraint t-             return (ls, T.singleton l, [cls <> " " <> T.singleton l])+      cls <- typeConstraint t+      return (ls, T.singleton l, [cls <> " " <> T.singleton l])     Just (APIObject _) -> do-             isGO <- isGObject t-             if isGO-             then do-               cls <- typeConstraint t-               return (ls, T.singleton l, [cls <> " " <> T.singleton l])-             else return (letters, s, [])+      isGO <- isGObject t+      if isGO+        then do cls <- typeConstraint t+                return (ls, T.singleton l, [cls <> " " <> T.singleton l])+        else return (letters, s, [])+    Just (APICallback cb) ->+      -- See [Note: Callables that throw]+      if callableThrows (cbCallable cb)+      then do+        ft <- tshow <$> foreignType t+        return (letters, ft, [])+      else+        return (letters, s, [])     _ -> return (letters, s, [])  haskellBasicType TPtr      = ptr $ typeOf ()@@ -709,9 +734,9 @@ isoHaskellType t@(TInterface n) = do   api <- findAPI t   case api of-    Just (APICallback (Callback c)) -> do+    Just (APICallback cb) -> do         tname <- qualifiedAPI n-        if callableHasClosures c+        if callableHasClosures (cbCallable cb)         then return ((callbackHTypeWithClosures tname) `con` [])         else return (tname `con` [])     _ -> haskellType t

@@ -0,0 +1,133 @@+-- | Construct a map from C identifiers to the corresponding Haskell+-- elements in the bindings.+module Data.GI.CodeGen.CtoHaskellMap+  ( cToHaskellMap+  , Hyperlink(..)+  ) where++import qualified Data.Map as M+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.String (IsString(..))++import Data.GI.CodeGen.GtkDoc (CRef(..))+import Data.GI.CodeGen.API (API(..), Name(..), Callback(..),+                            Constant(..), Flags(..),+                            Enumeration(..), EnumerationMember(..),+                            Interface(..), Object(..),+                            Function(..), Method(..), Struct(..), Union(..))+import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.))+import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName)+import Data.GI.CodeGen.Util (ucFirst)++-- | Link to an identifier, module, etc.+data Hyperlink = IdentifierLink Text+               | ModuleLink Text+               | ModuleLinkWithAnchor Text Text+  deriving (Show, Eq)++-- Just for convenience+instance IsString Hyperlink where+  fromString = IdentifierLink . T.pack++-- | Given a set of APIs, build a `Map` that given a Text+-- corresponding to a certain C identifier returns the corresponding+-- Haskell element in the bindings. For instance, `gtk_widget_show`+-- will get mapped to `GI.Gtk.Objects.Widget.show`.+cToHaskellMap :: [(Name, API)] -> M.Map CRef Hyperlink+cToHaskellMap apis = M.union (M.fromList builtins)+                     (M.fromList $ concatMap extractRefs apis)+  where extractRefs :: (Name, API) -> [(CRef, Hyperlink)]+        extractRefs (n, APIConst c) = constRefs n c+        extractRefs (n, APIFunction f) = funcRefs n f+        extractRefs (n, api@(APIEnum e)) = enumRefs api n e+        extractRefs (n, api@(APIFlags (Flags e))) = enumRefs api n e+        extractRefs (n, APICallback c) = callbackRefs n c+        extractRefs (n, APIStruct s) = structRefs n s+        extractRefs (n, APIUnion u) = unionRefs n u+        extractRefs (n, APIInterface i) = ifaceRefs n i+        extractRefs (n, APIObject o) = objectRefs n o++        builtins :: [(CRef, Hyperlink)]+        builtins = [(TypeRef "gboolean", "Bool"),+                    (ConstantRef "TRUE", "True"),+                    (ConstantRef "FALSE", "False"),+                    (TypeRef "GError", "GError"),+                    (TypeRef "GType", "GType"),+                    (TypeRef "GVariant", "GVariant"),+                    (ConstantRef "NULL", "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.+fullyQualified :: Name -> API -> Text -> Hyperlink+fullyQualified n api symbol =+  IdentifierLink $ dotModulePath (location n api) <> "." <> symbol++-- | Extract the C name of a constant. These are often referred to as+-- types, so we allow that too.+constRefs :: Name -> Constant -> [(CRef, Hyperlink)]+constRefs n c = [(ConstantRef (constantCType c),+                  fullyQualified n (APIConst c) $ name n),+                 (TypeRef (constantCType c),+                  fullyQualified n (APIConst c) $ name n)]++-- | Extract the C name of a function.+funcRefs :: Name -> Function -> [(CRef, Hyperlink)]+funcRefs n f = [(FunctionRef (fnSymbol f),+                 fullyQualified n (APIFunction f) $ lowerName n)]++-- | Extract the C names of the fields in an enumeration/flags, and+-- the name of the type itself.+enumRefs :: API -> Name -> Enumeration -> [(CRef, Hyperlink)]+enumRefs api n e = (TypeRef (enumCType e), fullyQualified n api $ upperName n) :+                   map memberToRef (enumMembers e)+  where memberToRef :: EnumerationMember -> (CRef, Hyperlink)+        memberToRef em = (ConstantRef (enumMemberCId em),+                          fullyQualified n api $ upperName $+                          n {name = name n <> "_" <> enumMemberName em})++-- | Given an optional C type and the API constructor construct the+-- list of associated refs.+maybeCType :: Name -> API -> Maybe Text -> [(CRef, Hyperlink)]+maybeCType _ _ Nothing = []+maybeCType n api (Just ctype) = [(TypeRef ctype,+                                  fullyQualified n api (upperName n))]++-- | Refs to the methods for a given owner.+methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)]+methodRefs n api methods = map methodRef methods+  where methodRef :: Method -> (CRef, Hyperlink)+        methodRef m@(Method {methodName = mn}) =+          -- Method name namespaced by the owner.+          let mn' = mn {name = name n <> "_" <> name mn}+          in (FunctionRef (methodSymbol m),+              fullyQualified n api $ lowerName mn')++-- | Extract the C name of a callback.+callbackRefs :: Name -> Callback -> [(CRef, Hyperlink)]+callbackRefs n cb = maybeCType n (APICallback cb) (cbCType cb)++-- | Extract the C references in a struct.+structRefs :: Name -> Struct -> [(CRef, Hyperlink)]+structRefs n s = maybeCType n (APIStruct s) (structCType s)+                 <> methodRefs n (APIStruct s) (structMethods s)++-- | Extract the C references in a union.+unionRefs :: Name -> Union -> [(CRef, Hyperlink)]+unionRefs n u = maybeCType n (APIUnion u) (unionCType u)+                 <> methodRefs n (APIUnion u) (unionMethods u)++-- | Extract the C references in an interface.+ifaceRefs :: Name -> Interface -> [(CRef, Hyperlink)]+ifaceRefs n i = maybeCType n (APIInterface i) (ifCType i)+                 <> methodRefs n (APIInterface i) (ifMethods i)++-- | Extract the C references in an object.+objectRefs :: Name -> Object -> [(CRef, Hyperlink)]+objectRefs n o = maybeCType n (APIObject o) (objCType o)+                 <> methodRefs n (APIObject o) (objMethods o)

@@ -0,0 +1,10 @@+module Data.GI.CodeGen.CtoHaskellMap ( cToHaskellMap, Hyperlink )+  where++import qualified Data.Map as M+import Data.GI.CodeGen.GtkDoc (CRef(..))+import Data.GI.CodeGen.API (API(..), Name(..))++data Hyperlink++cToHaskellMap :: [(Name, API)] -> M.Map CRef Hyperlink

@@ -4,68 +4,72 @@     , genFlags     ) where -import Control.Monad (when, forM_, forM)-import qualified Data.Map as M+import Control.Monad (when, forM_) import Data.Monoid ((<>)) import Data.Text (Text)-import Data.Tuple (swap)  import Foreign.C (CUInt) import Foreign.Storable (sizeOf)  import Data.GI.CodeGen.API import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation,+                                writeHaddock, RelativeDocPosition(..)) import Data.GI.CodeGen.SymbolNaming (upperName) import Data.GI.CodeGen.Util (tshow)  genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen ()-genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain _maybeTypeInit storageBytes isDeprecated) = do+genEnumOrFlags n@(Name ns name) e = do   -- Conversion functions expect enums and flags to map to CUInt,   -- which we assume to be of 32 bits. Fail early, instead of giving   -- strange errors at runtime.   when (sizeOf (0 :: CUInt) /= 4) $        notImplementedError $ "Unsupported CUInt size: " <> tshow (sizeOf (0 :: CUInt))-  when (storageBytes /= 4) $-       notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes+  when (enumStorageBytes e /= 4) $+       notImplementedError $ "Storage of size /= 4 not supported : " <> tshow (enumStorageBytes e)    let name' = upperName n-  fields' <- forM fields $ \(fieldName, value) -> do-      let n = upperName $ Name ns (name <> "_" <> fieldName)-      return (n, value)+      members' = flip map (enumMembers e) $ \member ->+        let n = upperName $ Name ns (name <> "_" <> enumMemberName member)+        in (n, member) -  line $ deprecatedPragma name' isDeprecated+  deprecatedPragma name' (enumDeprecated e)    group $ do     exportDecl (name' <> "(..)")     hsBoot . line $ "data " <> name'+    writeDocumentation DocBeforeSymbol (enumDocumentation e)     line $ "data " <> name' <> " = "     indent $-      case fields' of-        ((fieldName, _value):fs) -> do+      case members' of+        ((fieldName, firstMember):fs) -> do           line $ "  " <> fieldName-          forM_ fs $ \(n, _) -> line $ "| " <> n+          writeDocumentation DocAfterSymbol (enumMemberDoc firstMember)+          forM_ fs $ \(n, member) -> do+            line $ "| " <> n+            writeDocumentation DocAfterSymbol (enumMemberDoc member)           line $ "| Another" <> name' <> " Int"+          writeHaddock DocAfterSymbol "Catch-all for unknown values"           line "deriving (Show, Eq)"         _ -> return ()    group $ do     bline $ "instance P.Enum " <> name' <> " where"     indent $ do-            forM_ fields' $ \(n, v) ->-                line $ "fromEnum " <> n <> " = " <> tshow v+            forM_ members' $ \(n, m) ->+                line $ "fromEnum " <> n <> " = " <> tshow (enumMemberValue m)             line $ "fromEnum (Another" <> name' <> " k) = k"-    let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields'     blank     indent $ do-            forM_ valueNames $ \(v, n) ->-                line $ "toEnum " <> tshow v <> " = " <> n+            forM_ members' $ \(n, m) ->+                line $ "toEnum " <> tshow (enumMemberValue m) <> " = " <> n             line $ "toEnum k = Another" <> name' <> " k"    group $ do     line $ "instance P.Ord " <> name' <> " where"     indent $ line "compare a b = P.compare (P.fromEnum a) (P.fromEnum b)" -  maybe (return ()) (genErrorDomain name') eDomain+  maybe (return ()) (genErrorDomain name') (enumErrorDomain e)  genBoxedEnum :: Name -> Text -> CodeGen () genBoxedEnum n typeInit = do

@@ -78,7 +78,7 @@                       returnType c == Just (propType p) &&                       returnTransfer c == TransferNothing &&                       skipReturn c == False &&-                      methodThrows m == False &&+                      callableThrows c == False &&                       methodType m == OrdinaryMethod &&                       methodMovedTo m == Nothing                       then Just (returnMayBeNull c)@@ -106,7 +106,7 @@                           (direction . last . args) c == DirectionIn &&                           methodMovedTo m == Nothing &&                           methodType m == OrdinaryMethod &&-                          methodThrows m == False+                          callableThrows c == False                       then Just ((mayBeNull . last . args) c)                       else Nothing 

@@ -2,8 +2,6 @@     ( isGObject     , apiIsGObject     , nameIsGObject-    , isInitiallyUnowned-    , apiIsInitiallyUnowned     ) where  #if !MIN_VERSION_base(4,8,0)@@ -43,9 +41,3 @@  apiIsGObject :: Name -> API -> CodeGen Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"--isInitiallyUnowned :: Type -> CodeGen Bool-isInitiallyUnowned = typeDoParentSearch $ Name "GObject" "InitiallyUnowned"--apiIsInitiallyUnowned :: Name -> API -> CodeGen Bool-apiIsInitiallyUnowned = apiDoParentSearch $ Name "GObject" "InitiallyUnowned"

@@ -0,0 +1,453 @@+-- | A parser for gtk-doc formatted documentation, see+-- https://developer.gnome.org/gtk-doc-manual/ for the spec.+module Data.GI.CodeGen.GtkDoc+  ( parseGtkDoc+  , GtkDoc(..)+  , Token(..)+  , Language(..)+  , Link(..)+  , ListItem(..)+  , CRef(..)+  ) where++import Prelude hiding (takeWhile)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*))+#endif+import Data.Monoid ((<>))+import Control.Applicative ((<|>))++import Data.Attoparsec.Text+import Data.Char (isAsciiUpper, isAsciiLower, isDigit)+import qualified Data.Text as T+import Data.Text (Text)++-- | A parsed gtk-doc token.+data Token = Literal Text+           | Verbatim Text+           | CodeBlock (Maybe Language) Text+           | ExternalLink Link+           | Image Link+           | List [ListItem]+           | SectionHeader Int GtkDoc -- ^ A section header of the given depth.+           | SymbolRef CRef+  deriving (Show, Eq)++-- | A link to a resource, either offline or a section of the documentation.+data Link = Link { linkName :: Text+                 , linkAddress :: Text }+  deriving (Show, Eq)++-- | An item in a list, given by a list of lines (not including ending+-- newlines). The list is always non-empty, so we represent it by the+-- first line and then a possibly empty list with the rest of the lines.+data ListItem = ListItem GtkDoc [GtkDoc]+  deriving (Show, Eq)++-- | The language for an embedded code block.+newtype Language = Language Text+  deriving (Show, Eq)++-- | A reference to some symbol in the API.+data CRef = FunctionRef Text+          | ParamRef Text+          | ConstantRef Text+          | SignalRef Text Text+          | PropertyRef Text Text+          | VMethodRef Text Text+          | StructFieldRef Text Text+          | TypeRef Text+  deriving (Show, Eq, Ord)++-- | A parsed representation of gtk-doc formatted documentation.+newtype GtkDoc = GtkDoc [Token]+  deriving (Show, Eq)++-- | Parse the given gtk-doc formatted documentation.+--+-- === __Examples__+-- >>> parseGtkDoc ""+-- GtkDoc []+--+-- >>> parseGtkDoc "func()"+-- GtkDoc [SymbolRef (FunctionRef "func")]+--+-- >>> parseGtkDoc "literal"+-- GtkDoc [Literal "literal"]+--+-- >>> parseGtkDoc "This is a long literal"+-- GtkDoc [Literal "This is a long literal"]+--+-- >>> parseGtkDoc "Call foo() for free cookies"+-- GtkDoc [Literal "Call ",SymbolRef (FunctionRef "foo"),Literal " for free cookies"]+--+-- >>> parseGtkDoc "The signal ##%#GtkButton::activate is related to gtk_button_activate()."+-- GtkDoc [Literal "The signal ##%",SymbolRef (SignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."]+--+-- >>> parseGtkDoc "# A section\n\n## and a subsection ##\n"+-- GtkDoc [SectionHeader 1 (GtkDoc [Literal "A section"]),Literal "\n",SectionHeader 2 (GtkDoc [Literal "and a subsection "])]+--+-- >>> parseGtkDoc "Compact list:\n- First item\n- Second item"+-- GtkDoc [Literal "Compact list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]]+--+-- >>> parseGtkDoc "Spaced list:\n\n- First item\n\n- Second item"+-- GtkDoc [Literal "Spaced list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]]+--+-- >>> parseGtkDoc "List with urls:\n- [test](http://test)\n- ![](image.png)"+-- GtkDoc [Literal "List with urls:\n",List [ListItem (GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})]) [],ListItem (GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]) []]]+parseGtkDoc :: Text -> GtkDoc+parseGtkDoc raw =+  case parseOnly (parseTokens <* endOfInput) raw of+    Left e ->+      error $ "gtk-doc parsing failed with error \"" <> e+      <> "\" on the input \"" <> T.unpack raw <> "\""+    Right tks -> GtkDoc . coalesceLiterals+                 . restoreSHPreNewlines . restoreListPreNewline $ tks++-- | `parseSectionHeader` eats the newline before the section header,+-- but `parseInitialSectionHeader` does not, since it only matches at+-- the beginning of the text. This restores the newlines eaten by+-- `parseSectionHeader`, so a `SectionHeader` returned by the parser+-- can always be assumed /not/ to have an implicit starting newline.+restoreSHPreNewlines :: [Token] -> [Token]+restoreSHPreNewlines [] = []+restoreSHPreNewlines (i : rest) = i : restoreNewlines rest+  where restoreNewlines :: [Token] -> [Token]+        restoreNewlines [] = []+        restoreNewlines (s@(SectionHeader _ _) : rest) =+          Literal "\n" : s : restoreNewlines rest+        restoreNewlines (x : rest) = x : restoreNewlines rest++-- | `parseList` eats the newline before the list, restore it.+restoreListPreNewline :: [Token] -> [Token]+restoreListPreNewline [] = []+restoreListPreNewline (l@(List _) : rest) =+  Literal "\n" : l : restoreListPreNewline rest+restoreListPreNewline (x : rest) = x : restoreListPreNewline rest++-- | Accumulate consecutive literals into a single literal.+coalesceLiterals :: [Token] -> [Token]+coalesceLiterals tks = go Nothing tks+  where+    go :: Maybe Text -> [Token] -> [Token]+    go Nothing  [] = []+    go (Just l) [] = [Literal l]+    go Nothing (Literal l : rest) = go (Just l) rest+    go (Just l) (Literal l' : rest) = go (Just (l <> l')) rest+    go Nothing (tk : rest) = tk : go Nothing rest+    go (Just l) (tk : rest) = Literal l : tk : go Nothing rest++-- | Parser for tokens.+parseTokens :: Parser [Token]+parseTokens = headerAndTokens <|> justTokens+  where -- In case the input starts by a section header.+        headerAndTokens :: Parser [Token]+        headerAndTokens = do+          header <- parseInitialSectionHeader+          tokens <- justTokens+          return (header : tokens)++        justTokens :: Parser [Token]+        justTokens = many' parseToken++-- | Parse a single token.+--+-- === __Examples__+-- >>> parseOnly (parseToken <* endOfInput) "func()"+-- Right (SymbolRef (FunctionRef "func"))+parseToken :: Parser Token+parseToken = -- Note that the parsers overlap, so this is not as+             -- efficient as it could be (if we had combined parsers+             -- and then branched, so that there is no+             -- backtracking). But speed is not an issue here, so for+             -- clarity we keep the parsers distinct. The exception+             -- is parseFunctionRef, since it does not complicate the+             -- parser much, and it is the main source of+             -- backtracking.+                 parseFunctionRef+             <|> parseSignal+             <|> parseProperty+             <|> parseVMethod+             <|> parseStructField+             <|> parseType+             <|> parseConstant+             <|> parseParam+             <|> parseEscaped+             <|> parseVerbatim+             <|> parseCodeBlock+             <|> parseUrl+             <|> parseImage+             <|> parseSectionHeader+             <|> parseList+             <|> parseBoringLiteral++-- | Parse a signal name, of the form+-- > #Object::signal+--+-- === __Examples__+-- >>> parseOnly (parseSignal <* endOfInput) "#GtkButton::activate"+-- Right (SymbolRef (SignalRef "GtkButton" "activate"))+parseSignal :: Parser Token+parseSignal = do+  _ <- char '#'+  obj <- parseCIdent+  _ <- string "::"+  signal <- signalOrPropName+  return (SymbolRef (SignalRef obj signal))++-- | Parse a property name, of the form+-- > #Object:property+--+-- === __Examples__+-- >>> parseOnly (parseProperty <* endOfInput) "#GtkButton:always-show-image"+-- Right (SymbolRef (PropertyRef "GtkButton" "always-show-image"))+parseProperty :: Parser Token+parseProperty = do+  _ <- char '#'+  obj <- parseCIdent+  _ <- char ':'+  property <- signalOrPropName+  return (SymbolRef (PropertyRef obj property))++-- | Parse a reference to a virtual method, of the form+-- > #Struct.method()+--+-- === __Examples__+-- >>> parseOnly (parseVMethod <* endOfInput) "#Foo.bar()"+-- Right (SymbolRef (VMethodRef "Foo" "bar"))+parseVMethod :: Parser Token+parseVMethod = do+  _ <- char '#'+  obj <- parseCIdent+  _ <- char '.'+  method <- parseCIdent+  _ <- string "()"+  return (SymbolRef (VMethodRef obj method))++-- | Parse a reference to a struct field, of the form+-- > #Struct.field+--+-- === __Examples__+-- >>> parseOnly (parseStructField <* endOfInput) "#Foo.bar"+-- Right (SymbolRef (StructFieldRef "Foo" "bar"))+parseStructField :: Parser Token+parseStructField = do+  _ <- char '#'+  obj <- parseCIdent+  _ <- char '.'+  field <- parseCIdent+  return (SymbolRef (StructFieldRef obj field))++-- | Parse a reference to a C type, of the form+-- > #Type+--+-- === __Examples__+-- >>> parseOnly (parseType <* endOfInput) "#Foo"+-- Right (SymbolRef (TypeRef "Foo"))+parseType :: Parser Token+parseType = do+  _ <- char '#'+  obj <- parseCIdent+  return (SymbolRef (TypeRef obj))++-- | Parse a constant, of the form+-- > %CONSTANT_NAME+--+-- === __Examples__+-- >>> parseOnly (parseConstant <* endOfInput) "%TEST_CONSTANT"+-- Right (SymbolRef (ConstantRef "TEST_CONSTANT"))+parseConstant :: Parser Token+parseConstant = do+  _ <- char '%'+  c <- parseCIdent+  return (SymbolRef (ConstantRef c))++-- | Parse a reference to a parameter, of the form+-- > @param_name+--+-- === __Examples__+-- >>> parseOnly (parseParam <* endOfInput) "@test_param"+-- Right (SymbolRef (ParamRef "test_param"))+parseParam :: Parser Token+parseParam = do+  _ <- char '@'+  param <- parseCIdent+  return (SymbolRef (ParamRef param))++-- | Whether the given character is valid in a C identifier.+isCIdent :: Char -> Bool+isCIdent '_' = True+isCIdent c   = isDigit c || isAsciiUpper c || isAsciiLower c++-- | Name of a signal or property name. Similar to a C identifier, but+-- hyphens are allowed too.+signalOrPropName :: Parser Text+signalOrPropName = takeWhile1 isSignalOrPropIdent+  where isSignalOrPropIdent :: Char -> Bool+        isSignalOrPropIdent '-' = True+        isSignalOrPropIdent c = isCIdent c++-- | Something that could be a valid C identifier (loosely speaking,+-- we do not need to be too strict here).+parseCIdent :: Parser Text+parseCIdent = takeWhile1 isCIdent++-- | Parse a function ref, given by a valid C identifier followed by+-- '()', for instance 'gtk_widget_show()'. If the identifier is not+-- followed by "()", return it as a literal instead.+--+-- === __Examples__+-- >>> parseOnly (parseFunctionRef <* endOfInput) "test_func()"+-- Right (SymbolRef (FunctionRef "test_func"))+--+-- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func"+-- Right (Literal "not_a_func")+parseFunctionRef :: Parser Token+parseFunctionRef = do+  ident <- parseCIdent+  option (Literal ident) (string "()" >>+                          return (SymbolRef (FunctionRef ident)))++-- | Parse a escaped special character, i.e. one preceded by '\'.+parseEscaped :: Parser Token+parseEscaped = do+  _ <- char '\\'+  c <- satisfy (`elem` ("#@%\\`" :: [Char]))+  return $ Literal (T.singleton c)++-- | Parse a literal, i.e. anything without a known special+-- meaning. Note that this parser always consumes the first character,+-- regardless of what it is.+parseBoringLiteral :: Parser Token+parseBoringLiteral = do+  c <- anyChar+  boring <- takeWhile (not . special)+  return $ Literal (T.cons c boring)++-- | List of special characters from the point of view of the parser+-- (in the sense that they may be the beginning of something with a+-- special interpretation).+special :: Char -> Bool+special '#' = True+special '@' = True+special '%' = True+special '\\' = True+special '`' = True+special '|' = True+special '[' = True+special '!' = True+special '\n' = True+special c = isCIdent c++-- | Parse a verbatim string, of the form+-- > `verbatim text`+--+-- === __Examples__+-- >>> parseOnly (parseVerbatim <* endOfInput) "`Example quote!`"+-- Right (Verbatim "Example quote!")+parseVerbatim :: Parser Token+parseVerbatim = do+  _ <- char '`'+  v <- takeWhile1 (/= '`')+  _ <- char '`'+  return $ Verbatim v++-- | Parse a URL in Markdown syntax, of the form+-- > [name](url)+--+-- === __Examples__+-- >>> parseOnly (parseUrl <* endOfInput) "[haskell](http://haskell.org)"+-- Right (ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"}))+parseUrl :: Parser Token+parseUrl = do+  _ <- char '['+  name <- takeWhile1 (/= ']')+  _ <- string "]("+  address <- takeWhile1 (/= ')')+  _ <- char ')'+  return $ ExternalLink $ Link {linkName = name, linkAddress = address}++-- | Parse an image reference, of the form+-- > ![label](url)+--+-- === __Examples__+-- >>> parseOnly (parseImage <* endOfInput) "![](diagram.png)"+-- Right (Image (Link {linkName = "", linkAddress = "diagram.png"}))+parseImage :: Parser Token+parseImage = do+  _ <- string "!["+  name <- takeWhile (/= ']')+  _ <- string "]("+  address <- takeWhile1 (/= ')')+  _ <- char ')'+  return $ Image $ Link {linkName = name, linkAddress = address}++-- | Parse a code block embedded in the documentation.+parseCodeBlock :: Parser Token+parseCodeBlock = do+  _ <- string "|["+  lang <- (Just <$> parseLanguage) <|> return Nothing+  code <- T.pack <$> manyTill anyChar (string "]|")+  return $ CodeBlock lang code++-- | Parse the language of a code block, specified as a comment.+parseLanguage :: Parser Language+parseLanguage = do+  _ <- string "<!--"+  skipSpace+  _ <- string "language=\""+  lang <- takeWhile1 (/= '"')+  _ <- char '"'+  skipSpace+  _ <- string "-->"+  return $ Language lang++-- | Parse a section header, given by a number of hash symbols, and+-- then ordinary text. Note that this parser "eats" the newline before+-- and after the section header.+parseSectionHeader :: Parser Token+parseSectionHeader = char '\n' >> parseInitialSectionHeader++-- | Parse a section header at the beginning of the text. I.e. this is+-- the same as `parseSectionHeader`, but we do not expect a newline as+-- a first character.+--+-- === __Examples__+-- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "### Hello! ###\n"+-- Right (SectionHeader 3 (GtkDoc [Literal "Hello! "]))+--+-- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "# Hello!\n"+-- Right (SectionHeader 1 (GtkDoc [Literal "Hello!"]))+parseInitialSectionHeader :: Parser Token+parseInitialSectionHeader = do+  hashes <- takeWhile1 (== '#')+  _ <- many1 space+  heading <- takeWhile1 (notInClass "#\n")+  _ <- (string hashes >> char '\n') <|> (char '\n')+  return $ SectionHeader (T.length hashes) (parseGtkDoc heading)++-- | Parse a list header. Note that the newline before the start of+-- the list is "eaten" by this parser, but is restored later by+-- `parseGtkDoc`.+--+-- === __Examples__+-- >>> parseOnly (parseList <* endOfInput) "\n- First item\n- Second item"+-- Right (List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []])+--+-- >>> parseOnly (parseList <* endOfInput) "\n\n- Two line\n  item\n\n- Second item,\n  also two lines"+-- Right (List [ListItem (GtkDoc [Literal "Two line"]) [GtkDoc [Literal "item"]],ListItem (GtkDoc [Literal "Second item,"]) [GtkDoc [Literal "also two lines"]]])+parseList :: Parser Token+parseList = do+  items <- many1 parseListItem+  return $ List items+  where parseListItem :: Parser ListItem+        parseListItem = do+          _ <- char '\n'+          _ <- string "\n- " <|> string "- "+          first <- takeWhile1 (/= '\n')+          rest <- many' parseLine+          return $ ListItem (parseGtkDoc first) (map parseGtkDoc rest)++        parseLine :: Parser Text+        parseLine = string "\n  " >> takeWhile1 (/= '\n')

@@ -0,0 +1,284 @@+-- | Render an abstract representation of documentation (as produced+-- by `parseGtkDoc`) as Haddock formatted documentation.+module Data.GI.CodeGen.Haddock+  ( deprecatedPragma+  , writeDocumentation+  , RelativeDocPosition(..)+  , writeHaddock+  , writeArgDocumentation+  , writeReturnDocumentation+  , addModuleDocumentation+  ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (mapM_, unless)+import Control.Monad.State.Strict (modify')+import qualified Data.Map as M+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.GIR.Arg (Arg(..))+import Data.GI.GIR.Callable (Callable(..))+import Data.GI.GIR.Deprecation (DeprecationInfo(..))+import Data.GI.GIR.Documentation (Documentation(..))++import Data.GI.CodeGen.Code (CodeGen, config, line, blank,+                             getC2HMap, ModuleInfo(moduleDoc))+import Data.GI.CodeGen.Config (modName, overrides)+import Data.GI.CodeGen.CtoHaskellMap (Hyperlink(..))+import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..),+                               Link(..), ListItem(..), parseGtkDoc)+import Data.GI.CodeGen.Overrides (onlineDocsMap)+import Data.GI.CodeGen.SymbolNaming (lowerSymbol)++-- | Where is the documentation located with respect to the relevant+-- symbol, useful for determining whether we want to start with @|@ or @^@.+data RelativeDocPosition = DocBeforeSymbol+                         | DocAfterSymbol++-- | Given a `GtkDoc`, a map from C identifiers to Haskell symbols,+-- and a location online where to find the C documentation, render the+-- corresponding Haddock-formatted text. Note that the comment+-- delimiters are not included in the output.+--+-- === __Examples__+-- >>> formatHaddock M.empty "" (GtkDoc [Literal "Hello ", Literal "World!"])+-- "Hello World!"+--+-- >>> let c2h = M.fromList [(FunctionRef "foo", "foo()")]+-- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")])+-- "'foo()'"+--+-- >>> let onlineDocs = "http://wiki.haskell.org"+-- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")])+-- "<http://wiki.haskell.org/GObjectIntrospection GI>"+--+-- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]])+-- "\n* <<a/test.png test>>\n"+formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text+formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc+  where formatToken :: Token -> Text+        formatToken (Literal l) = escape l+        formatToken (Verbatim v) = "@" <> escape v <> "@"+        formatToken (CodeBlock l c) = formatCodeBlock l c+        formatToken (ExternalLink l) = formatLink l docBase+        formatToken (Image l) = formatImage l docBase+        formatToken (SectionHeader l h) = formatSectionHeader c2h docBase l h+        formatToken (List l) = formatList c2h docBase l+        formatToken (SymbolRef (ParamRef p)) = "/@" <> lowerSymbol p <> "@/"+        formatToken (SymbolRef cr) = case M.lookup cr c2h of+          Just hr -> formatHyperlink hr+          Nothing -> formatUnknownCRef c2h cr++-- | Format a `CRef` whose Haskell representation is not known.+formatUnknownCRef :: M.Map CRef Hyperlink -> CRef -> Text+formatUnknownCRef _ (FunctionRef f) = formatCRef $ f <> "()"+formatUnknownCRef _ (ParamRef _) = error $ "Should not be reached"+formatUnknownCRef c2h (SignalRef owner signal) =+  case M.lookup (TypeRef owner) c2h of+    Nothing -> formatCRef $ owner <> "::" <> signal+    Just r -> formatHyperlink r <> "::" <> formatCRef signal+formatUnknownCRef c2h (PropertyRef owner prop) =+  case M.lookup (TypeRef owner) c2h of+    Nothing -> formatCRef $ owner <> ":" <> prop+    Just r -> formatHyperlink r <> ":" <> formatCRef prop+formatUnknownCRef c2h (VMethodRef owner vmethod) =+  case M.lookup (TypeRef owner) c2h of+    Nothing -> formatCRef $ owner <> "." <> vmethod <> "()"+    Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()"+formatUnknownCRef c2h (StructFieldRef owner field) =+  case M.lookup (TypeRef owner) c2h of+    Nothing -> formatCRef $ owner <> "." <> field+    Just r -> formatHyperlink r <> "." <> formatCRef field+formatUnknownCRef _ (TypeRef t) = formatCRef t+formatUnknownCRef _ (ConstantRef t) = formatCRef t++-- | Formatting for an unknown C reference.+formatCRef :: Text -> Text+formatCRef t = "@/" <> escape t <> "/@"++-- | Format a `Hyperlink` into plain `Text`.+formatHyperlink :: Hyperlink -> Text+formatHyperlink (IdentifierLink t) = "'" <> t <> "'"+formatHyperlink (ModuleLink m) = "\"" <> m <> "\""+formatHyperlink (ModuleLinkWithAnchor m a) = "\"" <> m <> "#" <> a <> "\""++-- | Format a code block in a specified language.+formatCodeBlock :: Maybe Language -> Text -> Text+formatCodeBlock maybeLang code =+  let header = case maybeLang of+        Nothing -> ""+        Just (Language lang) -> "\n=== /" <> lang <> " code/\n"+      birdTrack = T.unlines . map (T.cons '>') . T.lines+  in header <> birdTrack code++-- | Qualify the given address with the docBase, if it is not an+-- absolute address.+qualifiedWith :: Text -> Text -> Text+qualifiedWith address docBase =+  if "http://" `T.isPrefixOf` address || "https://" `T.isPrefixOf` address+  then address+  else if "/" `T.isSuffixOf` docBase+       then docBase <> address+       else docBase <> "/" <> address++-- | Format a link to some external resource.+formatLink :: Link -> Text -> Text+formatLink (Link {linkName = name, linkAddress = address}) docBase =+  let address' = address `qualifiedWith` docBase+      name' = T.replace ">" "\\>" name+  in "<" <> address' <> " " <>  name' <> ">"++-- | Format an embedded image.+formatImage :: Link -> Text -> Text+formatImage (Link {linkName = name, linkAddress = address}) docBase =+  let address' = address `qualifiedWith` docBase+      name' = T.replace ">" "\\>" name+  in if T.null name'+     then "<<" <> address' <> ">>"+     else "<<" <> address' <> " " <>  name' <> ">>"++-- | Format a section header of the given level and with the given+-- text. Note that the level will be truncated to 2, if it is larger+-- than that.+formatSectionHeader :: M.Map CRef Hyperlink -> Text -> Int -> GtkDoc -> Text+formatSectionHeader c2h docBase level header =+  T.replicate level "=" <> " " <> formatHaddock c2h docBase header <> "\n"++-- | Format a list of items.+formatList :: M.Map CRef Hyperlink -> Text -> [ListItem] -> Text+formatList c2h docBase items = "\n" <> T.concat (map formatListItem items)+  where formatListItem :: ListItem -> Text+        formatListItem (ListItem first rest) =+          "* " <> format first <> "\n"+          <> T.concat (map ((<> "\n") . format) rest)++        format :: GtkDoc -> Text+        format = formatHaddock c2h docBase++-- | Escape the reserved Haddock characters in a given `Text`.+--+-- === __Examples__+-- >>> escape "\""+-- "\\\""+--+-- >>> escape "foo@bar.com"+-- "foo\\@bar.com"+--+-- >>> escape "C:\\Applications"+-- "C:\\\\Applications"+escape :: Text -> Text+escape = T.concatMap escapeChar+  where+    escapeChar :: Char -> Text+    escapeChar c = if c `elem` ("\\/'`\"@<" :: [Char])+                   then "\\" <> T.singleton c+                   else T.singleton c++-- | Get the base url for the online C language documentation for the+-- module being currently generated.+getDocBase :: CodeGen Text+getDocBase = do+  mod <- modName <$> config+  docsMap <- (onlineDocsMap . overrides) <$> config+  return $ case M.lookup mod docsMap of+             Just url -> url+             Nothing -> "http://developer.gnome.org/" <> T.toLower mod <>+                        "/stable"++-- | Write the deprecation pragma for the given `DeprecationInfo`, if+-- not `Nothing`.+deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen ()+deprecatedPragma _  Nothing = return ()+deprecatedPragma name (Just info) = do+  c2h <- getC2HMap+  docBase <- getDocBase+  line $ "{-# DEPRECATED " <> name <> " " <>+    (T.pack . show) (note <> reason c2h docBase) <> " #-}"+        where reason c2h docBase =+                case deprecationMessage info of+                  Nothing -> []+                  Just msg -> map (formatHaddock c2h docBase . parseGtkDoc)+                                  (T.lines msg)+              note = case deprecatedSinceVersion info of+                       Nothing -> []+                       Just v -> ["(Since version " <> v <> ")"]++-- | Write the given documentation into a Haddock comment.+writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen ()+writeDocumentation pos doc = do+  c2h <- getC2HMap+  docBase <- getDocBase+  let description = case rawDocText doc of+        Just raw -> formatHaddock c2h docBase (parseGtkDoc raw)+        Nothing -> "/No description available in the introspection data./"+  line $ case pos of+           DocBeforeSymbol -> "{- |"+           DocAfterSymbol ->  "{- ^"+  mapM_ line (T.lines description)+  case sinceVersion doc of+    Nothing -> return ()+    Just ver -> do+      blank+      line $ "@since " <> ver+  line "-}"++-- | Like `writeDocumentation`, but allows us to pass explicitly the+-- Haddock comment to write.+writeHaddock :: RelativeDocPosition -> Text -> CodeGen ()+writeHaddock pos haddock =+  let marker = case pos of+        DocBeforeSymbol -> "|"+        DocAfterSymbol -> "^"+  in if T.any (== '\n') haddock+     then do+        line $ "{- " <> marker+        mapM_ line (T.lines haddock)+        line $ "-}"+     else line $ "-- " <> marker <> " " <> haddock++-- | Write the documentation for the given argument.+writeArgDocumentation :: Arg -> CodeGen ()+writeArgDocumentation arg =+  case rawDocText (argDoc arg) of+    Nothing -> return ()+    Just raw -> do+      c2h <- getC2HMap+      docBase <- getDocBase+      line $ "{- ^ /@" <> lowerSymbol (argCName arg) <> "@/: " <>+        formatHaddock c2h docBase (parseGtkDoc raw) <> " -}"++-- | Write the documentation for the given return value.+writeReturnDocumentation :: Callable -> Bool -> CodeGen ()+writeReturnDocumentation callable skip = do+  c2h <- getC2HMap+  docBase <- getDocBase+  let returnValInfo = if skip+                      then []+                      else case rawDocText (returnDocumentation callable) of+                             Nothing -> []+                             Just raw -> ["__Returns:__ " <>+                                           formatHaddock c2h docBase+                                           (parseGtkDoc raw)]+      throwsInfo = if callableThrows callable+                   then ["/(Can throw 'Data.GI.Base.GError.GError')/"]+                   else []+  let fullInfo = T.intercalate " " (returnValInfo ++ throwsInfo)+  unless (T.null fullInfo) $+    line $ "{- ^ " <>  fullInfo <> " -}"++-- | Add the given text to the module-level documentation for the+-- module being generated.+addModuleDocumentation :: Documentation -> CodeGen ()+addModuleDocumentation doc =+  case rawDocText doc of+    Nothing -> return ()+    Just raw -> do+      c2h <- getC2HMap+      docBase <- getDocBase+      modify' $ \s -> s{moduleDoc = moduleDoc s <>+                                    Just (formatHaddock c2h docBase+                                           (parseGtkDoc raw))}

@@ -2,6 +2,7 @@ -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository     ( girRequire+    , setupTypelibSearchPath     , FieldInfo(..)     , girStructFieldInfo     , girUnionFieldInfo@@ -18,14 +19,18 @@ import qualified Data.Text as T  import Foreign.C.Types (CInt(..), CSize(..))-import Foreign.C.String (CString)+import Foreign.C.String (CString, withCString) import Foreign (nullPtr, Ptr, FunPtr, peek) +import System.Environment (lookupEnv)+import System.FilePath (searchPathSeparator)+ import Data.GI.Base.BasicConversions (withTextCString, cstringToText) import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) import Data.GI.Base.Utils (allocMem, freeMem)+import Data.GI.CodeGen.Util (splitOn)  -- | Wrapper for 'GIBaseInfo' newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo)@@ -45,9 +50,30 @@ instance BoxedObject BaseInfo where     boxedType _ = c_g_base_info_gtype_get_type +foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO ()++-- | Add the given directory to the typelib search path, this is a+-- thin wrapper over `g_irepository_prepend_search_path`.+girPrependSearchPath :: FilePath -> IO ()+girPrependSearchPath fp = withCString fp g_irepository_prepend_search_path+ foreign import ccall "g_irepository_require" g_irepository_require ::     Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError)     -> IO (Ptr Typelib)++-- | A convenience function for setting up the typelib search path+-- from the environment. Note that for efficiency reasons this should+-- only be called once per program run. If the list of paths passed in+-- is empty, the environment variable @HASKELL_GI_TYPELIB_SEARCH_PATH@+-- will be checked. In either case the system directories will be+-- searched after the passed in directories.+setupTypelibSearchPath :: [FilePath] -> IO ()+setupTypelibSearchPath [] = do+  env <- lookupEnv "HASKELL_GI_TYPELIB_SEARCH_PATH"+  case env of+    Nothing -> return ()+    Just paths -> mapM_ girPrependSearchPath (splitOn searchPathSeparator paths)+setupTypelibSearchPath paths = mapM_ girPrependSearchPath paths  -- | Ensure that the given version of the namespace is loaded. If that -- is not possible we error out.

@@ -0,0 +1,63 @@+-- | Abstract representation for paths into modules.+module Data.GI.CodeGen.ModulePath+  ( ModulePath(..)+  , toModulePath+  , (/.)+  , dotModulePath+  ) where++import Data.Monoid (Monoid(..), (<>))+import Data.String (IsString(..))+import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.CodeGen.Util (ucFirst)++-- | A path to a module.+newtype ModulePath = ModulePath { modulePathToList :: [Text] }+  deriving (Eq, Show, Ord)++-- | Construct a `ModulePath` from a `String`.+instance IsString ModulePath where+  fromString = toModulePath . T.pack++-- | `ModulePath`s are `Monoid`s.+instance Monoid ModulePath where+  mempty = ModulePath []+  mappend (ModulePath as) (ModulePath bs) = ModulePath (as <> bs)++-- | Construct a path into the given GIR namespace. The given `Text`+-- will be split along ".".+--+-- === __Examples__+-- >>> dotModulePath (toModulePath "Foo")+-- "Foo"+--+-- >>> dotModulePath ("Foo" <> toModulePath "Bar.Baz")+-- "Foo.Bar.Baz"+--+-- >>> dotModulePath ("Foo" <> toModulePath "bar.baz")+-- "Foo.Bar.Baz"+toModulePath :: Text -> ModulePath+toModulePath p = ModulePath (map ucFirst (T.split (== '.') p))++-- | Turn a module path into the corresponding dotted string. Note+-- that the implementation ensures that the module names start with a+-- capital letter.+--+-- === __Examples__+-- >>> dotModulePath ("Foo" /. "Bar" /. "Baz")+-- "Foo.Bar.Baz"+--+-- >>> dotModulePath ("foo" /. "bar" /. "baz")+-- "Foo.Bar.Baz"+dotModulePath :: ModulePath -> Text+dotModulePath (ModulePath mp) = T.intercalate "." mp++-- | Append the given component to the given module path.+--+-- === __Examples__+-- >>> dotModulePath ("Foo" /. "Bar")+-- "Foo.Bar"+(/.) :: ModulePath -> Text -> ModulePath+(/.) mp p = mp <> toModulePath p

@@ -10,8 +10,8 @@ import qualified Data.Text as T  import Data.GI.CodeGen.API-import Data.GI.CodeGen.Callable (callableSignature, ForeignSymbol(..),-                                 fixupCallerAllocates)+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.Util (ucFirst)@@ -77,17 +77,17 @@       group $ do         infoName <- methodInfoName n m         let callable = fixupCallerAllocates (methodCallable m)-        (constraints, types) <- callableSignature callable-                                (KnownForeignSymbol undefined) (methodThrows m)+        sig <- callableSignature callable (KnownForeignSymbol undefined)         bline $ "data " <> infoName         -- This should not happen, since ordinary methods always         -- have the instance as first argument.-        when (null types) $+        when (null (signatureArgTypes sig)) $           error $ "Internal error: too few parameters! " ++ show m-        let (obj:otherTypes) = map fst types-            sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes-                            <> ")"-        line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints)+        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"         let mn = methodName m             mangled = lowerName (mn {name = name n <> "_" <> name mn})

@@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.Overrides-    ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups)+    ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups,+                onlineDocsMap)     , parseOverridesFile     , filterAPIsAndDeps     ) where@@ -24,7 +25,6 @@ import Text.ParserCombinators.ReadP (readP_to_S)  import qualified System.Info as SI-import qualified System.Environment as SE  import Data.GI.CodeGen.API import qualified Text.XML as XML@@ -40,7 +40,7 @@       ignoredAPIs     :: S.Set Name,       -- | Structs for which accessors should not be auto-generated.       sealedStructs   :: S.Set Name,-      -- | Explicit calloc/copy/free for structs/unions.+      -- | Explicit calloc\/copy\/free for structs/unions.       allocInfo       :: M.Map Name AllocationInfo,       -- | Mapping from GObject Introspection namespaces to pkg-config       pkgConfigMap    :: M.Map Text Text,@@ -49,7 +49,9 @@       -- | Prefered version of the namespace.       nsChooseVersion :: M.Map Text Text,       -- | Fixups for the GIR data.-      girFixups       :: [GIRRule]+      girFixups       :: [GIRRule],+      -- | Known places where to find the C docs.+      onlineDocsMap   :: M.Map Text Text } deriving (Show)  -- | Construct the generic config for a module.@@ -62,7 +64,8 @@                      pkgConfigMap    = M.empty,                      cabalPkgVersion = Nothing,                      nsChooseVersion = M.empty,-                     girFixups       = []+                     girFixups       = [],+                     onlineDocsMap   = M.empty                    }  -- | There is a sensible notion of zero and addition of Overridess,@@ -80,7 +83,8 @@                         then cabalPkgVersion b                         else cabalPkgVersion a,       nsChooseVersion = nsChooseVersion a <> nsChooseVersion b,-      girFixups = girFixups a <> girFixups b+      girFixups = girFixups a <> girFixups b,+      onlineDocsMap = onlineDocsMap a <> onlineDocsMap b     }  -- | The state of the overrides parser.@@ -147,6 +151,8 @@     withFlags $ parseNsVersion s parseOneLine (T.stripPrefix "set-attr " -> Just s) =     withFlags $ parseSetAttr s+parseOneLine (T.stripPrefix "C-docs-url " -> Just u) =+    withFlags $ parseDocsUrl u parseOneLine (T.stripPrefix "if " -> Just s) = parseIf s parseOneLine (T.stripPrefix "endif" -> Just s) = parseEndif s parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"."@@ -238,6 +244,15 @@                "\t\"set-attr nodePath attrName newValue\"\n" <>                "Got \"set-attr " <> t <> "\" instead.") +-- | Parse a documentation URL for the given module.+parseDocsUrl :: Text -> Parser ()+parseDocsUrl (T.words -> [ns, url]) = do+  tell $ defaultOverrides { onlineDocsMap = M.singleton ns url }+parseDocsUrl t =+  throwError ("C-docs-url syntax of of the form\n" <>+              "\t\"C-docs-url namespace url\"\n" <>+              "Got \"C-docs-url " <> t <> "\" instead.")+ -- | Parse a path specification, which is of the form -- "nodeSpec1/nodeSpec2/../nodeSpecN", where nodeSpec is a node -- specification of the form "nodeType[:name attribute]".@@ -274,13 +289,9 @@             | Windows               deriving (Show) --- | Check whether we are running under the given OS. We take the OS--- from `System.Info.os`, but it is possible to override this value by--- setting the environment variable @HASKELL_GI_OVERRIDE_OS@.+-- | Check whether we are running under the given OS. checkOS :: String -> Parser Bool-checkOS os = liftIO (SE.lookupEnv "HASKELL_GI_OVERRIDE_OS") >>= \case-             Nothing -> return (SI.os == os)-             Just ov -> return (ov == os)+checkOS os = return (SI.os == os)  -- | Parse a textual representation of a version into a `Data.Version.Version`. parseVersion :: Text -> Parser V.Version@@ -391,10 +402,16 @@                      objSignals = filter ((`S.notMember` ignores) . sigName)                                   (objSignals o)                     })-filterOneAPI _ (n, APIInterface i, Just ignores) =+filterOneAPI ovs (n, APIInterface i, Just ignores) =     (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores,                         ifSignals = filter ((`S.notMember` ignores) . sigName)-                                    (ifSignals i)+                                    (ifSignals i),+                        ifAllocationInfo =+                           let ai = ifAllocationInfo i+                           in case M.lookup n (allocInfo ovs) of+                                Just info -> filterAllocInfo ai info+                                Nothing -> ai+                        }) filterOneAPI _ (n, api, _) = (n, api) 

@@ -25,13 +25,14 @@                                  callableHInArgs, callableHOutArgs) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.Haddock (deprecatedPragma) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror,                              lcFirst, ucFirst, prime) --- The prototype of the callback on the Haskell side (what users of+-- | The prototype of the callback on the Haskell side (what users of -- the binding will see) genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures ->                                ExcCodeGen ()@@ -50,9 +51,11 @@         wrapMaybe arg >>= bool                           (line $ tshow ht <> " ->")                           (line $ tshow (maybeT ht) <> " ->")-      ret <- hOutType cb hOutArgs False+      ret <- hOutType cb hOutArgs       line $ tshow $ io ret +    blank+     -- For optional parameters, in case we want to pass Nothing.     exportSignal subsec ("no" <> name')     line $ "no" <> name' <> " :: Maybe " <> name'@@ -74,6 +77,8 @@                   then ptr ht                   else ht         line $ tshow ht' <> " ->"+      when (callableThrows cb) $+        line "Ptr (Ptr GError) ->"       when isSignal $ line $ withComment "Ptr () ->" "user_data"       ret <- io <$> case returnType cb of                       Nothing -> return $ typeOf ()@@ -219,7 +224,7 @@   line $ dropper <> " _f " <> T.unwords argNames <> " = _f "            <> T.unwords (catMaybes (map passOrIgnore inWithClosures)) --- The wrapper itself, marshalling to and from Haskell. The first+-- | The wrapper itself, marshalling to and from Haskell. The first -- argument is possibly a pointer to a FunPtr to free (via -- freeHaskellFunPtr) once the callback is run once, or Nothing if the -- FunPtr will be freed by someone else (the function registering the@@ -253,6 +258,8 @@                   then ptr ht                   else ht         line $ tshow ht' <> " ->"+      when (callableThrows cb) $+        line "Ptr (Ptr GError) ->"       when isSignal $ line "Ptr () ->"       ret <- io <$> case returnType cb of                       Nothing -> return $ typeOf ()@@ -271,10 +278,11 @@                           Nothing -> []                           _       -> ["result"]           returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs+          mkTuple = parenthesize . T.intercalate ", "           returnBind = case returnVars of                          []  -> ""                          [r] -> r <> " <- "-                         _   -> parenthesize (T.intercalate ", " returnVars) <> " <- "+                         _   -> mkTuple returnVars <> " <- "       line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames)        forM_ hOutArgs saveOutArg@@ -296,7 +304,7 @@                line $ "return " <> result'  genCallback :: Name -> Callback -> CodeGen ()-genCallback n (Callback cb) = do+genCallback n (Callback {cbCallable = cb}) = do   let name' = upperName n   line $ "-- callback " <> name'   line $ "--          -> " <> tshow (fixupCallerAllocates cb)@@ -312,18 +320,40 @@     handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "                              <> name' <>                              "\n-- Error was : " <> describeCGError e)) $ do-      genClosure name' cb' name' name' False       typeSynonym <- genCCallbackPrototype name' cb' name' False-      dynamic <- genDynamicCallableWrapper n typeSynonym cb False+      dynamic <- genDynamicCallableWrapper n typeSynonym cb       exportSignal name' dynamic       genCallbackWrapperFactory name' name'-      line $ deprecatedPragma name' (callableDeprecated cb')+      deprecatedPragma name' (callableDeprecated cb')       genHaskellCallbackPrototype name' cb' name' WithoutClosures       when (callableHasClosures cb') $ do            genHaskellCallbackPrototype name' cb' name' WithClosures            genDropClosures name' cb' name'-      genCallbackWrapper name' cb' name' False+      if callableThrows cb'+      then do+        {- [Note: Callables that throw] +          In the case that the Callable throws (GErrors) we cannot+          simply take a Haskell functions that throws and wrap it into+          a foreign function, since in the case that an exception is+          raised the return value of the function is undefined, but we+          need to provide some value to the FFI.++          Alternatively, we could ask the Haskell function to provide+          a return value and optionally a GError. If the GError is+          present we should then release the memory associated with+          the out/return values (the caller will not do it, since+          there was an error), and then return some bogus values. This+          is fairly complicated, and callbacks raising GErrors are+          fairly rare, so for the moment we do not generate wrappers+          for these cases.+        -}+        line $ "-- No Haskell->C wrapper generated since the function throws."+        blank+      else do+        genClosure name' cb' name' name' False+        genCallbackWrapper name' cb' name' False+ -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text signalHaskellName sn = let (w:ws) = T.split (== '-') sn@@ -339,16 +369,20 @@       signalConnectorName = on' <> ucFirst sn'       cbType = signalConnectorName <> "Callback" -  line $ deprecatedPragma cbType (callableDeprecated cb)+  deprecatedPragma cbType (callableDeprecated cb)   genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures    _ <- genCCallbackPrototype (lcFirst sn') cb cbType True    genCallbackWrapperFactory (lcFirst sn') cbType -  genClosure (lcFirst sn') cb cbType signalConnectorName True--  genCallbackWrapper (lcFirst sn') cb cbType True+  if callableThrows cb+    then do+      line $ "-- No Haskell->C wrapper generated since the function throws."+      blank+    else do+      genClosure (lcFirst sn') cb cbType signalConnectorName True+      genCallbackWrapper (lcFirst sn') cb cbType True    -- Wrapper for connecting functions to the signal   -- We can connect to a signal either before the default handler runs

@@ -83,15 +83,18 @@   return $ name <> fName <> "FieldInfo"  -- | Whether a given field is an embedded struct/union.-isEmbedded :: Field -> CodeGen Bool-isEmbedded field-    | fieldIsPointer field = return False-    | otherwise = do+isEmbedded :: Field -> ExcCodeGen Bool+isEmbedded field = do   api <- findAPI (fieldType field)   case api of-    Just (APIStruct _) -> return True-    Just (APIUnion _) -> return True+    Just (APIStruct _) -> checkEmbedding+    Just (APIUnion _) -> checkEmbedding     _ -> return False+  where+    checkEmbedding :: ExcCodeGen Bool+    checkEmbedding = case fieldIsPointer field of+      Nothing -> badIntroError "Cannot determine whether the field is embedded."+      Just isPtr -> return (not isPtr)  -- Notice that when reading the field we return a copy of any embedded -- structs, so modifications of the returned struct will not affect@@ -199,7 +202,7 @@ -- | Support for modifying fields as attributes. Returns a tuple with -- the name of the overloaded label to be used for the field, and the -- associated info type.-genAttrInfo :: Name -> Field -> CodeGen Text+genAttrInfo :: Name -> Field -> ExcCodeGen Text genAttrInfo owner field = do   it <- infoType owner field   let on = upperName owner@@ -360,14 +363,14 @@   return (prefix <> symbol)  -- | Generate the typeclass with information for how to--- allocate/deallocate unboxed structs and unions.+-- allocate/deallocate a given type. genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () genWrappedPtr n info size = group $ do   let name' = upperName n    let prefix = \op -> "_" <> name' <> "_" <> op <> "_" -  when (size == 0) $+  when (size == 0 && allocFree info == AllocationOpUnknown) $        line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"    calloc <- case allocCalloc info of@@ -381,11 +384,14 @@                   else return "return nullPtr"    copy <- case allocCopy info of-            AllocationOp op ->-                prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)"+            AllocationOp op -> do+                copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)"+                return ("\\p -> withManagedPtr p (" <> copy <>+                        " >=> wrapPtr " <> name' <> ")")             AllocationOpUnknown ->                 if size > 0-                then return ("copyPtr " <> tshow size)+                then return ("\\p -> withManagedPtr p (copyBytes "+                              <> tshow size <> " >=> wrapPtr " <> name' <> ")")                 else return "return"    free <- case allocFree info of@@ -403,4 +409,3 @@       line $ "wrappedPtrFree = " <> free    hsBoot $ line $ "instance WrappedPtr " <> name' <> " where"-

@@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.SymbolNaming     ( lowerName+    , lowerSymbol     , upperName     , noName     , escapedArgName@@ -30,8 +31,9 @@ import qualified Data.Text as T  import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code (CodeGen, ModuleName, group, line, exportDecl,+import Data.GI.CodeGen.Code (CodeGen, group, line, exportDecl,                              qualified, getAPI)+import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath) import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified) @@ -89,48 +91,69 @@ callbackClosureGenerator :: Text -> Text callbackClosureGenerator = modifyQualified ("genClosure_" <>) --- | Move leading underscores to the end (for example in--- GObject::_Value_Data_Union -> GObject::Value_Data_Union_)+-- | Move leading underscores to the end.+--+-- === Examples+-- >>> sanitize "_Value_Data_Union"+-- "Value_Data_Union_" sanitize :: Text -> Text sanitize (T.uncons -> Just ('_', xs)) = sanitize xs <> "_" sanitize xs = xs +-- | Same as `lowerSymbol`, but accepts a `Name`. The namespace part+-- of the name will be discarded.+--+-- === __Examples__+-- >>> lowerName (Name "Gtk" "main_quit")+-- "mainQuit" lowerName :: Name -> Text-lowerName (Name _ s) =-    case underscoresToCamelCase (sanitize s) of-      "" -> error "empty name!!"-      n -> lcFirst n+lowerName (Name _ s) = lowerSymbol s +-- | Turn the given identifier into camelCase, starting with a+-- lowercase letter.+--+-- === __Examples__+-- >>> lowerSymbol "main_quit"+-- "mainQuit"+lowerSymbol :: Text -> Text+lowerSymbol s = case underscoresToCamelCase (sanitize s) of+                  "" -> error "empty name!!"+                  n -> lcFirst n++-- | Turn the given `Name` into CamelCase, starting with a capital letter.+--+-- === __Examples__+-- >>> upperName (Name "Foo" "bar_baz")+-- "BarBaz" upperName :: Name -> Text upperName (Name _ s) = underscoresToCamelCase (sanitize s) +-- | Construct the submodule path where the given API element will+-- live. This is the path relative to the root for the corresponding+-- namespace. I.e. the "GI.Gtk" part is not prepended.+submoduleLocation :: Name -> API -> ModulePath+submoduleLocation _ (APIConst _) = "Constants"+submoduleLocation _ (APIFunction _) = "Functions"+submoduleLocation _ (APICallback _) = "Callbacks"+submoduleLocation _ (APIEnum _) = "Enums"+submoduleLocation _ (APIFlags _) = "Flags"+submoduleLocation n (APIInterface _) = "Interfaces" /. upperName n+submoduleLocation n (APIObject _) = "Objects" /. upperName n+submoduleLocation n (APIStruct _) = "Structs" /. upperName n+submoduleLocation n (APIUnion _) = "Unions" /. upperName n+ -- | Return an identifier for the given interface type valid in the current -- module. qualifiedAPI :: Name -> CodeGen Text qualifiedAPI n@(Name ns _) = do   api <- getAPI (TInterface n)-  qualified ("GI" : ucFirst ns : submoduleLocation n api) n+  qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) n  -- | Construct an identifier for the given symbol in the given API. qualifiedSymbol :: Text -> Name -> CodeGen Text qualifiedSymbol s n@(Name ns _) = do   api <- getAPI (TInterface n)-  qualified ("GI" : ucFirst ns : submoduleLocation n api) (Name ns s)---- | Construct the submodule name (as a list, to be joined by--- intercalating ".") where the given API element will live. This is--- the path relative to the root for the corresponding--- namespace. I.e. the "GI.Gtk" part is not prepended.-submoduleLocation :: Name -> API -> ModuleName-submoduleLocation _ (APIConst _) = ["Constants"]-submoduleLocation _ (APIFunction _) = ["Functions"]-submoduleLocation _ (APICallback _) = ["Callbacks"]-submoduleLocation _ (APIEnum _) = ["Enums"]-submoduleLocation _ (APIFlags _) = ["Flags"]-submoduleLocation n (APIInterface _) = ["Interfaces", upperName n]-submoduleLocation n (APIObject _) = ["Objects", upperName n]-submoduleLocation n (APIStruct _) = ["Structs", upperName n]-submoduleLocation n (APIUnion _) = ["Unions", upperName n]+  qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s)  -- | Save a bit of typing for optional arguments in the case that we -- want to pass Nothing.@@ -140,13 +163,28 @@                  line $ "no" <> name' <> " = Nothing"                  exportDecl ("no" <> name') --- | For a string of the form "one-sample-string" return "OneSampleString"+-- | Turn a hyphen-separated identifier into camel case.+--+-- === __Examples__+-- >>> hyphensToCamelCase "one-sample-string"+-- "OneSampleString" hyphensToCamelCase :: Text -> Text hyphensToCamelCase = T.concat . map ucFirst . T.split (== '-') --- | Similarly, turn a name separated_by_underscores into--- CamelCase. We preserve final and initial underscores, and n>1--- consecutive underscores are transformed into n-1 underscores.+-- | Similarly to `hyphensToCamelCase`, turn a name+-- separated_by_underscores into CamelCase. We preserve final and+-- initial underscores, and n>1 consecutive underscores are+-- transformed into n-1 underscores.+--+-- === __Examples__+-- >>> underscoresToCamelCase "sample_id"+-- "SampleId"+--+-- >>> underscoresToCamelCase "_internal_id_"+-- "_InternalId_"+--+-- >>> underscoresToCamelCase "multiple___underscores"+-- "Multiple__Underscores" underscoresToCamelCase :: Text -> Text underscoresToCamelCase =     T.concat . map normalize . map ucFirst . T.split (== '_')

@@ -12,13 +12,22 @@    , tshow   , terror++  , utf8ReadFile+  , utf8WriteFile++  , splitOn   ) where  import Data.Monoid ((<>)) import Data.Char (toLower, toUpper)++import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE + padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " " @@ -59,3 +68,25 @@           modify (a:[]) = f a : []           modify (a:as) = a : modify as +-- | Split a list into sublists delimited by the given element.+splitOn :: Eq a => a -> [a] -> [[a]]+splitOn x xs = go xs []+    where go [] acc = [reverse acc]+          go (y : ys) acc = if x == y+                            then reverse acc : go ys []+                            else go ys (y : acc)++-- | Read a file assuming it is UTF-8 encoded. If decoding fails this+-- calls `error`.+utf8ReadFile :: FilePath -> IO T.Text+utf8ReadFile fname = do+  bytes <- B.readFile fname+  case TE.decodeUtf8' bytes of+    Right text -> return text+    Left error -> terror ("Input file " <> tshow fname <>+                          " seems not to be valid UTF-8. Error was:\n" <>+                          tshow error)++-- | Write the given `Text` into an UTF-8 encoded file.+utf8WriteFile :: FilePath -> T.Text -> IO ()+utf8WriteFile fname text = B.writeFile fname (TE.encodeUtf8 text)

@@ -3,12 +3,13 @@     ) where  import qualified Data.Map as M+import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Text.XML (Element(elementAttributes), Document(documentRoot)) -import Data.GI.GIR.BasicTypes (Alias(..), Type)-import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.BasicTypes (Alias(..), Type(..), BasicType(..))+import Data.GI.GIR.Type (parseOptionalType) import Data.GI.GIR.Parser import Data.GI.GIR.XMLUtils (childElemsWithLocalName) @@ -30,8 +31,8 @@ parseAlias :: Parser (Text, Type) parseAlias = do   name <- getAttr "name"-  t <- parseType-  return (name, t)+  t <- parseOptionalType+  return (name, fromMaybe (TBasicType TPtr) t)  -- | Find all aliases in a given document. documentListAliases :: Document -> M.Map Alias Type

@@ -31,6 +31,7 @@         argType :: Type,         direction :: Direction,         mayBeNull :: Bool,+        argDoc :: Documentation,         argScope :: Scope,         argClosure :: Int,         argDestroy :: Int,@@ -68,8 +69,10 @@   nullable <- optionalAttr "nullable" False parseBool   callerAllocates <- optionalAttr "caller-allocates" False parseBool   t <- parseType+  doc <- parseDocumentation   return $ Arg { argCName = name                , argType = t+               , argDoc = doc                , direction = d                , mayBeNull = nullable                , argScope = scope

@@ -12,9 +12,12 @@         returnType :: Maybe Type,         returnMayBeNull :: Bool,         returnTransfer :: Transfer,+        returnDocumentation :: Documentation,         args :: [Arg],         skipReturn :: Bool,-        callableDeprecated :: Maybe DeprecationInfo+        callableThrows :: Bool,+        callableDeprecated :: Maybe DeprecationInfo,+        callableDocumentation :: Documentation     } deriving (Show, Eq)  parseArgs :: Parser [Arg]@@ -26,16 +29,17 @@     _ -> parseError $ "Unexpected multiple \"parameters\" tag"   where parseArgSet = parseChildrenWithLocalName "parameter" parseArg -parseOneReturn :: Parser (Maybe Type, Bool, Transfer, Bool)+parseOneReturn :: Parser (Maybe Type, Bool, Transfer, Bool, Documentation) parseOneReturn = do   returnType <- parseOptionalType   allowNone <- optionalAttr "allow-none" False parseBool   nullable <- optionalAttr "nullable" False parseBool   transfer <- parseTransfer+  doc <- parseDocumentation   skip <- optionalAttr "skip" False parseBool-  return (returnType, allowNone || nullable, transfer, skip)+  return (returnType, allowNone || nullable, transfer, skip, doc) -parseReturn :: Parser (Maybe Type, Bool, Transfer, Bool)+parseReturn :: Parser (Maybe Type, Bool, Transfer, Bool, Documentation) parseReturn = do   returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn   case returnSets of@@ -46,13 +50,18 @@ parseCallable :: Parser Callable parseCallable = do   args <- parseArgs-  (returnType, mayBeNull, transfer, skip) <- parseReturn+  (returnType, mayBeNull, transfer, skip, returnDoc) <- parseReturn   deprecated <- parseDeprecation+  docs <- parseDocumentation+  throws <- optionalAttr "throws" False parseBool   return $ Callable {                   returnType = returnType                 , returnMayBeNull = mayBeNull                 , returnTransfer = transfer+                , returnDocumentation = returnDoc                 , args = args                 , skipReturn = skip+                , callableThrows = throws                 , callableDeprecated = deprecated+                , callableDocumentation = docs                 }

@@ -4,14 +4,21 @@     , parseCallback     ) where -import Data.GI.GIR.Parser+import Data.Text (Text)+ import Data.GI.GIR.Callable (Callable, parseCallable)+import Data.GI.GIR.Parser+import Data.GI.GIR.Type (queryCType) -data Callback = Callback Callable+data Callback = Callback { cbCallable :: Callable+                         , cbCType    :: Maybe Text+                         }     deriving Show  parseCallback :: Parser (Name, Callback) parseCallback = do   name <- parseName   callable <- parseCallable-  return (name, Callback callable)+  ctype <- queryCType+  return (name, Callback { cbCallable = callable+                         , cbCType = ctype })

@@ -7,13 +7,15 @@ import Data.Text (Text)  import Data.GI.GIR.BasicTypes (Type)-import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.Type (parseType, parseCType) import Data.GI.GIR.Parser  -- | Info about a constant. data Constant = Constant {       constantType        :: Type,       constantValue       :: Text,+      constantCType       :: Text,+      constantDocumentation :: Documentation,       constantDeprecated  :: Maybe DeprecationInfo     } deriving (Show) @@ -24,4 +26,11 @@   deprecated <- parseDeprecation   value <- getAttr "value"   t <- parseType-  return (name, Constant t value deprecated)+  ctype <- parseCType+  doc <- parseDocumentation+  return (name, Constant { constantType = t+                         , constantValue = value+                         , constantCType = ctype+                         , constantDocumentation = doc+                         , constantDeprecated = deprecated+                         })

@@ -1,12 +1,9 @@ module Data.GI.GIR.Deprecation-    ( DeprecationInfo-    , deprecatedPragma+    ( DeprecationInfo(..)     , queryDeprecated     ) where -import Data.Monoid ((<>)) import qualified Data.Map as M-import qualified Data.Text as T import Data.Text (Text) import Text.XML (Element(elementAttributes)) @@ -17,19 +14,6 @@       deprecatedSinceVersion :: Maybe Text,       deprecationMessage     :: Maybe Text     } deriving (Show, Eq)---- | Encode the given `DeprecationInfo` for the given symbol as a--- deprecation pragma.-deprecatedPragma :: Text -> Maybe DeprecationInfo -> Text-deprecatedPragma _    Nothing     = ""-deprecatedPragma name (Just info) = "{-# DEPRECATED " <> name <> " " <>-                                    (T.pack . show) (note <> reason) <> "#-}"-        where reason = case deprecationMessage info of-                         Nothing -> []-                         Just msg -> T.lines msg-              note = case deprecatedSinceVersion info of-                       Nothing -> []-                       Just v -> ["(Since version " <> v <> ")"]  -- | Parse the deprecation information for the given element of the GIR file. queryDeprecated :: Element -> Maybe DeprecationInfo

@@ -7,14 +7,20 @@ import Data.Text (Text) import Text.XML (Element) -import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)+import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent,+                             lookupAttr) --- | Documentation for a given element.-data Documentation = Documentation {-      docText :: Text-    } deriving (Show, Eq)+-- | Documentation for a given element. The documentation text is+-- typically encoded in the gtk-doc format, see+-- https://developer.gnome.org/gtk-doc-manual/ . This can be parsed+-- with `Data.GI.GIR.parseGtkDoc`.+data Documentation = Documentation { rawDocText   :: Maybe Text+                                   , sinceVersion :: Maybe Text+                                   } deriving (Show, Eq, Ord)  -- | Parse the documentation node for the given element of the GIR file.-queryDocumentation :: Element -> Maybe Documentation-queryDocumentation element = fmap Documentation-    (firstChildWithLocalName "doc" element >>= getElementContent)+queryDocumentation :: Element -> Documentation+queryDocumentation element = Documentation {+  rawDocText = firstChildWithLocalName "doc" element >>= getElementContent,+  sinceVersion = lookupAttr "version" element+  }

@@ -1,6 +1,7 @@ -- | Parsing of Enums. module Data.GI.GIR.Enum     ( Enumeration(..)+    , EnumerationMember(..)     , parseEnum     ) where @@ -9,21 +10,39 @@ import Foreign.C (CInt(..))  import Data.GI.GIR.Parser+import Data.GI.GIR.Type (parseCType)  data Enumeration = Enumeration {-    enumValues :: [(Text, Int64)],-    errorDomain :: Maybe Text,+    enumMembers :: [EnumerationMember],+    enumErrorDomain :: Maybe Text,     enumTypeInit :: Maybe Text,+    enumDocumentation :: Documentation,+    enumCType    :: Text,     enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct.     enumDeprecated :: Maybe DeprecationInfo }     deriving Show +-- | Member of an enumeration.+data EnumerationMember = EnumerationMember {+  enumMemberName   :: Text,+  enumMemberValue  :: Int64,+  enumMemberCId    :: Text,+  enumMemberDoc    :: Documentation+  } deriving Show+ -- | Parse a struct member.-parseEnumMember :: Parser (Text, Int64)+parseEnumMember :: Parser EnumerationMember parseEnumMember = do   name <- getAttr "name"   value <- getAttr "value" >>= parseIntegral-  return (name, value)+  cid <- getAttrWithNamespace CGIRNS "identifier"+  doc <- parseDocumentation+  return $ EnumerationMember {+    enumMemberName = name,+    enumMemberValue = value,+    enumMemberCId = cid,+    enumMemberDoc = doc+    }  foreign import ccall "_gi_get_enum_storage_bytes" get_storage_bytes ::     Int64 -> Int64 -> CInt@@ -38,15 +57,19 @@ parseEnum :: Parser (Name, Enumeration) parseEnum = do   name <- parseName+  ctype <- parseCType+  doc <- parseDocumentation   deprecated <- parseDeprecation   errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain"   typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"-  values <- parseChildrenWithLocalName "member" parseEnumMember+  members <- parseChildrenWithLocalName "member" parseEnumMember   return (name,           Enumeration {-            enumValues = values-          , errorDomain = errorDomain+            enumMembers = members+          , enumErrorDomain = errorDomain+          , enumDocumentation = doc           , enumTypeInit = typeInit-          , enumStorageBytes = extractEnumStorageBytes (map snd values)+          , enumCType = ctype+          , enumStorageBytes = extractEnumStorageBytes (map enumMemberValue members)           , enumDeprecated = deprecated           })

@@ -5,19 +5,20 @@     , parseFields     ) where +import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Text (Text, isSuffixOf)  import Data.GI.GIR.BasicTypes (Type(..)) import Data.GI.GIR.Callback (Callback, parseCallback)-import Data.GI.GIR.Type (parseType, parseCType)+import Data.GI.GIR.Type (parseType, queryElementCType) import Data.GI.GIR.Parser  data Field = Field {       fieldName :: Text,       fieldVisible :: Bool,       fieldType :: Type,-      fieldIsPointer :: Bool,+      fieldIsPointer :: Maybe Bool, -- ^ `Nothing` if not known.       fieldCallback :: Maybe Callback,       fieldOffset :: Int,       fieldFlags :: [FieldInfoFlag],@@ -41,7 +42,7 @@              <> if writable then [FieldIsWritable] else []   introspectable <- optionalAttr "introspectable" True parseBool   private <- optionalAttr "private" False parseBool-  (t, ctype, callback) <-+  (t, isPtr, callback) <-       if introspectable       then do         callbacks <- parseChildrenWithLocalName "callback" parseCallback@@ -49,27 +50,29 @@                              [] -> return (Nothing, Nothing)                              [(n, cb)] -> return (Just n, Just cb)                              _ -> parseError "Multiple callbacks in field"-        (t, ct) <- case cbn of+        (t, isPtr) <- case cbn of                Nothing -> do                  t <- parseType-                 ct <- parseCType-                 return (t, Just ct)+                 ct <- queryElementCType+                 return (t, fmap ("*" `isSuffixOf`) ct)                Just n -> return (TInterface n, Nothing)-        return (t, ct, callback)+        return (t, isPtr, callback)       else do         callbacks <- parseAllChildrenWithLocalName "callback" parseName         case callbacks of           [] -> do                t <- parseType-               ct <- parseCType-               return (t, Just ct, Nothing)-          [n] -> return (TInterface n, Nothing, Nothing)+               ct <- queryElementCType+               return (t, fmap ("*" `isSuffixOf`) ct, Nothing)+          [n] -> return (TInterface n, Just True, Nothing)           _ -> parseError "Multiple callbacks in field"   return $ Field {                fieldName = name              , fieldVisible = introspectable && not private              , fieldType = t-             , fieldIsPointer = maybe True ("*" `isSuffixOf`) ctype+             , fieldIsPointer = if isJust callback+                                then Just True+                                else isPtr              , fieldCallback = callback              , fieldOffset = error ("unfixed field offset " ++ show name)              , fieldFlags = flags

@@ -10,7 +10,6 @@  data Function = Function {       fnSymbol   :: Text-    , fnThrows   :: Bool     , fnMovedTo  :: Maybe Text     , fnCallable :: Callable     } deriving Show@@ -24,12 +23,10 @@                       Nothing -> name   callable <- parseCallable   symbol <- getAttrWithNamespace CGIRNS "identifier"-  throws <- optionalAttr "throws" False parseBool   movedTo <- queryAttr "moved-to"   return $ (exposedName,             Function {               fnSymbol = symbol             , fnCallable = callable-            , fnThrows = throws             , fnMovedTo = movedTo             })

@@ -5,17 +5,22 @@  import Data.Text (Text) +import Data.GI.GIR.Allocation (AllocationInfo, unknownAllocationInfo) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Property (Property, parseProperty) import Data.GI.GIR.Signal (Signal, parseSignal) import Data.GI.GIR.Parser+import Data.GI.GIR.Type (queryCType)  data Interface = Interface {         ifTypeInit :: Maybe Text,+        ifCType :: Maybe Text,+        ifDocumentation :: Documentation,         ifPrerequisites :: [Name],         ifProperties :: [Property],         ifSignals :: [Signal],         ifMethods :: [Method],+        ifAllocationInfo :: AllocationInfo,         ifDeprecated :: Maybe DeprecationInfo     } deriving Show @@ -29,12 +34,17 @@   functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)   constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)   deprecated <- parseDeprecation+  doc <- parseDocumentation+  ctype <- queryCType   return (name,          Interface {             ifProperties = props           , ifPrerequisites = error ("unfixed interface " ++ show name)           , ifSignals = signals           , ifTypeInit = typeInit+          , ifCType = ctype+          , ifDocumentation = doc           , ifMethods = constructors ++ methods ++ functions+          , ifAllocationInfo = unknownAllocationInfo           , ifDeprecated = deprecated           })

@@ -19,7 +19,6 @@ data Method = Method {       methodName        :: Name,       methodSymbol      :: Text,-      methodThrows      :: Bool,       methodType        :: MethodType,       methodMovedTo     :: Maybe Text,       methodCallable    :: Callable@@ -49,12 +48,10 @@                 instanceArg <- parseInstanceArg                 return $ c {args = instanceArg : args c}   symbol <- getAttrWithNamespace CGIRNS "identifier"-  throws <- optionalAttr "throws" False parseBool   movedTo <- queryAttr "moved-to"   return $ Method {               methodName = exposedName             , methodSymbol = symbol-            , methodThrows = throws             , methodType = mType             , methodMovedTo = movedTo             , methodCallable = callable

@@ -10,14 +10,16 @@ import Data.GI.GIR.Property (Property, parseProperty) import Data.GI.GIR.Signal (Signal, parseSignal) import Data.GI.GIR.Parser+import Data.GI.GIR.Type (queryCType)  data Object = Object {     objParent :: Maybe Name,     objTypeInit :: Text,     objTypeName :: Text,+    objCType :: Maybe Text,     objInterfaces :: [Name],     objDeprecated :: Maybe DeprecationInfo,-    objDocumentation :: Maybe Documentation,+    objDocumentation :: Documentation,     objMethods :: [Method],     objProperties :: [Property],     objSignals :: [Signal]@@ -37,10 +39,12 @@   typeInit <- getAttrWithNamespace GLibGIRNS "get-type"   typeName <- getAttrWithNamespace GLibGIRNS "type-name"   signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+  ctype <- queryCType   return (name,          Object {             objParent = parent           , objTypeInit = typeInit+          , objCType = ctype           , objTypeName = typeName           , objInterfaces = interfaces           , objDeprecated = deprecated

@@ -170,8 +170,8 @@   ctx <- ask   return $ queryDeprecated (currentElement ctx) --- | Parse the documentation text, if present.-parseDocumentation :: Parser (Maybe Documentation)+-- | Parse the documentation info for the current node.+parseDocumentation :: Parser Documentation parseDocumentation = do   ctx <- ask   return $ queryDocumentation (currentElement ctx)

@@ -17,7 +17,7 @@ import System.Directory import System.Environment (lookupEnv) import System.Environment.XDG.BaseDir (getSystemDataDirs)-import System.FilePath+import System.FilePath (searchPathSeparator, takeBaseName, (</>), (<.>))  girDataDirs :: IO [FilePath] girDataDirs = getSystemDataDirs "gir-1.0"@@ -63,7 +63,7 @@   paths <- case extraPaths of              [] -> lookupEnv "HASKELL_GI_GIR_SEARCH_PATH" >>= \case                    Nothing -> return []-                   Just s -> return (splitOn ':' s)+                   Just s -> return (splitOn searchPathSeparator s)              ps -> return ps   dataDirs <- girDataDirs   firstJust <$> (mapM (girFile' name version) (paths ++ dataDirs))

@@ -10,11 +10,13 @@ import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser+import Data.GI.GIR.Type (queryCType)  data Struct = Struct {     structIsBoxed :: Bool,     structAllocationInfo :: AllocationInfo,     structTypeInit :: Maybe Text,+    structCType :: Maybe Text,     structSize :: Int,     gtypeStructFor :: Maybe Name,     -- https://bugzilla.gnome.org/show_bug.cgi?id=560248@@ -22,7 +24,7 @@     structFields :: [Field],     structMethods :: [Method],     structDeprecated :: Maybe DeprecationInfo,-    structDocumentation :: Maybe Documentation }+    structDocumentation :: Documentation }     deriving Show  parseStruct :: Parser (Name, Struct)@@ -34,6 +36,7 @@                Just t -> (fmap Just . qualifyName) t                Nothing -> return Nothing   typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+  maybeCType <- queryCType   disguised <- optionalAttr "disguised" False parseBool   fields <- parseFields   constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)@@ -44,6 +47,7 @@             structIsBoxed = error ("[boxed] unfixed struct " ++ show name)           , structAllocationInfo = unknownAllocationInfo           , structTypeInit = typeInit+          , structCType = maybeCType           , structSize = error ("[size] unfixed struct " ++ show name)           , gtypeStructFor = structFor           , structIsDisguised = disguised

@@ -2,7 +2,9 @@ -- | Parsing type information from GIR files. module Data.GI.GIR.Type     ( parseType+    , queryCType     , parseCType+    , queryElementCType     , parseOptionalType     ) where @@ -10,6 +12,7 @@ import Control.Applicative ((<$>)) #endif +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T@@ -141,18 +144,20 @@   arrays <- parseChildrenWithLocalName "array" parseArrayInfo   return (types ++ map Just arrays) --- | Find the C name (or if not present, the introspection name) for--- the current element.-parseCTypeName :: Parser Text-parseCTypeName = queryAttrWithNamespace CGIRNS "type"-                 >>= maybe (getAttr "name") return+-- | Find the C name for the current element.+queryCType :: Parser (Maybe Text)+queryCType = queryAttrWithNamespace CGIRNS "type" +-- | Parse the C type for the current node.+parseCType :: Parser Text+parseCType = getAttrWithNamespace CGIRNS "type"+ -- | Find the children giving the C type for the element. parseCTypeNameElements :: Parser [Text] parseCTypeNameElements = do-  types <- parseChildrenWithLocalName "type" parseCTypeName-  arrays <- parseChildrenWithLocalName "array" parseCTypeName-  return (types ++ arrays)+  types <- parseChildrenWithLocalName "type" queryCType+  arrays <- parseChildrenWithLocalName "array" queryCType+  return (catMaybes (types ++ arrays))  -- | Try to find a type node, but do not error out if it is not -- found. This _does_ give an error if more than one type node is@@ -181,10 +186,9 @@            [] -> parseError $ "Did not find a type for the element."            _ -> parseError $ "Found more than one type for the element." --- | Parse the C-type associated to the element. If there is no--- "c:type" attribute we return the type name.-parseCType :: Parser Text-parseCType = parseCTypeNameElements >>= \case-             [e] -> return e-             [] -> parseError $ "Did not find a C type for the element."+-- | Parse the C-type associated to the element, if found.+queryElementCType :: Parser (Maybe Text)+queryElementCType = parseCTypeNameElements >>= \case+             [ctype] -> return (Just ctype)+             [] -> return Nothing              _ -> parseError $ "Found more than one type for the element."

@@ -11,14 +11,17 @@ import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser+import Data.GI.GIR.Type (queryCType)  data Union = Union {     unionIsBoxed :: Bool,     unionAllocationInfo :: AllocationInfo,+    unionDocumentation :: Documentation,     unionSize :: Int,     unionTypeInit :: Maybe Text,     unionFields :: [Field],     unionMethods :: [Method],+    unionCType :: Maybe Text,     unionDeprecated :: Maybe DeprecationInfo }     deriving Show @@ -26,19 +29,24 @@ parseUnion = do   name <- parseName   deprecated <- parseDeprecation+  doc <- parseDocumentation   typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"   fields <- parseFields   constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)   methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)   functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+  ctype <- queryCType+   return (name,           Union {             unionIsBoxed = isJust typeInit           , unionAllocationInfo = unknownAllocationInfo+          , unionDocumentation = doc           , unionTypeInit = typeInit           , unionSize = error ("unfixed union size " ++ show name)           , unionFields = fields           , unionMethods = constructors ++ methods ++ functions+          , unionCType = ctype           , unionDeprecated = deprecated           })