diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,66 @@ +### 0.26.17 + ++ More robust support for inout arguments, motivated by [issue 472](https://github.com/haskell-gi/haskell-gi/issues/472). + +### 0.26.15 + ++ Fix a code generation mistake when tranferring GClosure arguments of + unknown type. + +### 0.26.12 + ++ Add support for the .gir format dialect generated by vala. + +### 0.26.11 + ++ Don't try to guess which callback arguments are `user_data` arguments, as this can lead to problems, as in [issue 447](https://github.com/haskell-gi/haskell-gi/issues/447). + +### 0.26.9 + ++ Add a workaround for a [GHC issue](https://gitlab.haskell.org/ghc/ghc/-/issues/23392) stopping parallel compilation in GHC >= 9.6. ++ Fix compilation issues regarding `time_t` and similar types in + introspection data. + +### 0.26.8 + ++ Add support for scope type "forever": see [this issue](https://github.com/haskell-gi/haskell-gi/issues/425). + +### 0.26.7 + ++ Work around changing conventions on how to annotate user_data arguments in callbacks, see [this gobject introspection issue](https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450) for background. + +### 0.26.6 + ++ Work around changing conventions about what the `closure n` annotation means: many annotations appear on the callback, pointing to the user_data argument, but sometimes it also appears on the user_data argument, pointing to the callback. See [issue 407](https://github.com/haskell-gi/haskell-gi/issues/407) for a place where this becomes a problem. + +### 0.26.5 + ++ Add a reference to ?self argument in signals. See [issue 408](https://github.com/haskell-gi/haskell-gi/issues/408) for the motivation. + +### 0.26.0 + ++ Support for 'HasField' methods, which allows the syntax 'widget.show' or 'widget.add child' for invoking methods using the new [RecordDotSyntax](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0282-record-dot-syntax.rst) in ghc 9.2. + ++ And an implicit '?self' parameter for callbacks, for accessing the calling object. See [issue 346](https://github.com/haskell-gi/haskell-gi/issues/346) where this is necessary in practice in gtk4 to use event controllers. + ++ Add an 'After' attribute to connect to signals after the default handler on constructors/setters using attribute syntax, similar to [On](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-Attributes.html#t:AttrOp). + ++ Add [resolveSignal](https://hackage.haskell.org/package/haskell-gi-base-0.26.0/docs/Data-GI-Base-Signals.html#v:resolveSignal) for showing what an overloaded signal resolves to: `resolveSignal button #notify` will output [GI.GObject.Objects.Object.Object::notify](https://hackage.haskell.org/package/gi-gobject-2.0.27/docs/GI-GObject-Objects-Object.html#g:signal:notify). + +### 0.25.0 + ++ Support non-GObject object attributes. + ++ Support for ghc 9.0.1. + ++ Improvements in the generated Haddocks. + ++ Remove the command line version of the bindings generator. + ++ Remove support for non-IsLabel overloading. + ++ Add [resolveMethod](https://hackage.haskell.org/package/haskell-gi-base-0.25.0/docs/Data-GI-Base-Overloading.html#v:resolveMethod) for showing what an overloaded method resolves to: `resolveMethod #show widget` will output `GI.Gtk.Objects.Widget.widgetShow`. + ### 0.24.5 + Fix an accidental double free for GValues, see [issue 320](https://github.com/haskell-gi/haskell-gi/issues/320). diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,20 +1,18 @@ name: haskell-gi -version: 0.25.0 +version: 0.26.17 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. + GTK, but many other libraries in the GObject ecosystem provide introspection data too. homepage: https://github.com/haskell-gi/haskell-gi license: LGPL-2.1 -- or above license-file: LICENSE -author: Will Thompson, - Iñaki García Etxebarria, - Jonas Platte -maintainer: Iñaki García Etxebarria (inaki@blueleaf.cc) +author: Will Thompson and Iñaki García Etxebarria +maintainer: Iñaki García Etxebarria (github@the.blueleaf.cc) stability: Experimental category: Development build-type: Custom -tested-with: GHC == 8.8.1, GHC == 8.10.1 +tested-with: GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.2.1, GHC == 9.4, GHC == 9.6, GHC == 9.8, GHC == 9.10, GHC == 9.12 cabal-version: 2.0 extra-source-files: ChangeLog.md @@ -22,18 +20,18 @@ custom-setup setup-depends: base >= 4 && <5, - Cabal, - cabal-doctest >= 1 && <1.1 + Cabal >= 1.24 && < 4, + cabal-doctest >= 1 source-repository head type: git - location: git://github.com/haskell-gi/haskell-gi.git + location: https://github.com/haskell-gi/haskell-gi.git Library default-language: Haskell2010 pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 - build-depends: base >= 4.9 && < 5, - haskell-gi-base >= 0.25.0 && <0.26, + build-depends: base >= 4.11 && < 5, + haskell-gi-base >= 0.26.9 && <0.27, Cabal >= 1.24, attoparsec >= 0.13, containers, @@ -52,9 +50,7 @@ text >= 1.0 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings - ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing - - ghc-options: -Wcompat + ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing -Wcompat c-sources: lib/c/enumStorage.c build-tool-depends: hsc2hs:hsc2hs @@ -85,7 +81,6 @@ Data.GI.GIR.Union, Data.GI.GIR.XMLUtils, Data.GI.CodeGen.API, - Data.GI.CodeGen.Cabal, Data.GI.CodeGen.CabalHooks, Data.GI.CodeGen.Callable, Data.GI.CodeGen.Code, @@ -128,4 +123,4 @@ build-depends: base , process , doctest >= 0.8 - , haskell-gi + , haskell-gi >= 0.26.10 diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Cabal.hs +++ /dev/null @@ -1,182 +0,0 @@ -module Data.GI.CodeGen.Cabal - ( genCabalProject - , cabalConfig - , setupHs - , tryPkgConfig - ) where - -import Control.Monad (forM_) -import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import Data.Version (Version(..)) -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Text (Text) -import Text.Read - -import Data.GI.CodeGen.API (GIRInfo(..)) -import Data.GI.CodeGen.Code -import Data.GI.CodeGen.Config (Config(..)) -import Data.GI.CodeGen.Overrides (cabalPkgVersion) -import Data.GI.CodeGen.PkgConfig (pkgConfigGetVersion) -import qualified Data.GI.CodeGen.ProjectInfo as PI -import Data.GI.CodeGen.Util (padTo, tshow) - -import Paths_haskell_gi (version) - -cabalConfig :: Text -cabalConfig = T.unlines ["optimization: False"] - -setupHs :: Text -setupHs = T.unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main = defaultMain"] - -haskellGIAPIVersion :: Int -haskellGIAPIVersion = (head . versionBranch) version - --- | Obtain the minor version. That is, if the given version numbers --- are x.y.z, so branch is [x,y,z], we return y. -minorVersion :: [Int] -> Int -minorVersion (_:y:_) = y -minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." - --- | Obtain the haskell-gi minor version. Notice that we only append --- the minor version here, ignoring revisions. (So if the version is --- x.y.z, we drop the "z" part.) This gives us a mechanism for --- releasing bug-fix releases of haskell-gi without increasing the --- necessary dependency on haskell-gi-base, which only depends on x.y. -haskellGIMinor :: Int -haskellGIMinor = minorVersion (versionBranch version) - -{- | - -If the haskell-gi version is of the form x.y[.z] and the pkgconfig -version of the package being wrapped is a.b.c, this gives something of -the form x.a.b.y. - -This strange seeming-rule is so that the packages that we produce -follow the PVP, assuming that the package being wrapped follows the -usual semantic versioning convention (http://semver.org) that -increases in "a" indicate non-backwards compatible changes, increases -in "b" backwards compatible additions to the API, and increases in "c" -denote API compatible changes (so we do not need to regenerate -bindings for these, at least in principle, so we do not encode them in -the cabal version). - -In order to follow the PVP, then everything we need to do in the -haskell-gi side is to increase x everytime the generated API changes -(for a fixed a.b.c version). - -In any case, if such "strange" package numbers are undesired, or the -wrapped package does not follow semver, it is possible to add an -explicit cabal-pkg-version override. This needs to be maintained by -hand (including in the list of dependencies of packages depending on -this one), so think carefully before using this override! - --} -giModuleVersion :: Int -> Int -> Text -giModuleVersion major minor = - (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor, - haskellGIMinor] - --- | Determine the next version for which the minor of the package has --- been bumped. -giNextMinor :: Int -> Int -> Text -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 :: GIRInfo -> Bool -> M.Map Text Text -> IO (Either Text PkgInfo) -tryPkgConfig gir verbose overridenNames = do - let name = girNSName gir - version = girNSVersion gir - packages = girPCPackages gir - - pkgConfigGetVersion name version packages verbose overridenNames >>= \case - Just (n,v) -> - case readMajorMinor v of - Just (major, minor) -> - 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]" - --- | Given a string a.b.c..., representing a version number, determine --- the major and minor versions, i.e. "a" and "b". If successful, --- return (a,b). -readMajorMinor :: Text -> Maybe (Int, Int) -readMajorMinor version = - case T.splitOn "." version of - (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b) - _ -> Nothing - --- | Generate the cabal project. -genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] -> - [Text] -> BaseVersion -> CodeGen e () -genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major, - pkgMinor = minor}) - deps exposedModules minBaseVersion = do - cfg <- config - let name = girNSName gir - - line $ "-- Autogenerated, do not edit." - line $ padTo 20 "name:" <> "gi-" <> T.toLower name - - let cabalVersion = fromMaybe (giModuleVersion major minor) - (cabalPkgVersion $ overrides cfg) - line $ padTo 20 "version:" <> cabalVersion - line $ padTo 20 "synopsis:" <> name - <> " bindings" - line $ padTo 20 "description:" <> "Bindings for " <> name - <> ", autogenerated by haskell-gi." - line $ padTo 20 "homepage:" <> PI.homepage - line $ padTo 20 "license:" <> PI.license - line $ padTo 20 "license-file:" <> "LICENSE" - line $ padTo 20 "author:" <> PI.authors - line $ padTo 20 "maintainer:" <> PI.maintainers - line $ padTo 20 "category:" <> PI.category - line $ padTo 20 "build-type:" <> "Simple" - line $ padTo 20 "cabal-version:" <> ">=1.10" - blank - line $ "library" - indent $ do - line $ padTo 20 "default-language:" <> PI.defaultLanguage - line $ padTo 20 "default-extensions:" <> - T.intercalate ", " PI.defaultExtensions - line $ padTo 20 "other-extensions:" <> - T.intercalate ", " PI.otherExtensions - line $ padTo 20 "ghc-options:" <> T.intercalate " " PI.ghcOptions - 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 - line $ "build-depends:" - indent $ do - line $ "haskell-gi-base >= " - <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor - <> " && < " <> tshow (haskellGIAPIVersion + 1) <> "," - forM_ deps $ \(dep, PkgInfo _ depMajor depMinor) -> do - let depName = girNSName dep - line $ "gi-" <> T.toLower depName <> " >= " - <> giModuleVersion depMajor depMinor - <> " && < " - <> giNextMinor depMajor depMinor - <> "," - forM_ PI.standardDeps (line . (<> ",")) - line $ "base >= " <> showBaseVersion minBaseVersion <> " && <5" diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -2,6 +2,7 @@ -- bindings. module Data.GI.CodeGen.CabalHooks ( setupBinding + , setupCompatWrapper , configureDryRun , TaggedOverride(..) ) where @@ -22,12 +23,12 @@ import Data.GI.CodeGen.ModulePath (toModulePath) import Data.GI.CodeGen.Overrides (parseOverrides, girFixups, filterAPIsAndDeps) -import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst) +import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst, splitOn) import System.Directory (createDirectoryIfMissing) -import System.FilePath (joinPath, takeDirectory) +import System.FilePath (joinPath, takeDirectory, ()) -import Control.Monad (void, forM) +import Control.Monad (forM) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M @@ -82,8 +83,9 @@ -- | Write a module containing information about the configuration for -- the package. -genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO () -genConfigModule outputDir modName maybeGiven = do +genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> + [Text] -> IO () +genConfigModule outputDir modName maybeGiven modules = do let fname = joinPath [ fromMaybe "" outputDir , "GI" , T.unpack (ucFirst modName) @@ -95,7 +97,7 @@ utf8WriteFile fname $ T.unlines [ "{-# LANGUAGE OverloadedStrings #-}" , "-- | Build time configuration used during code generation." - , "module GI." <> ucFirst modName <> ".Config ( overrides ) where" + , "module GI." <> ucFirst modName <> ".Config ( overrides, modules ) where" , "" , "import qualified Data.Text as T" , "import Data.Text (Text)" @@ -103,14 +105,23 @@ , "-- | Overrides used when generating these bindings." , "overrides :: Text" , "overrides = T.unlines" - , " [ " <> T.intercalate "\n , " (quoteOverrides maybeGiven) <> "]" + , formatList (overrides maybeGiven) + , "" + , "-- | Modules in this package" + , "modules :: [Text]" + , "modules = " <> + formatList (("GI." <> ucFirst modName <> ".Config") : modules) ] - where quoteOverrides :: Maybe TaggedOverride -> [Text] - quoteOverrides Nothing = [] - quoteOverrides (Just (TaggedOverride _ ovText)) = - map (T.pack . show) (T.lines ovText) + where overrides :: Maybe TaggedOverride -> [Text] + overrides Nothing = [] + overrides (Just (TaggedOverride _ ovText)) = T.lines ovText + formatList :: [Text] -> Text + formatList l = " [ " + <> T.intercalate "\n , " (map (T.pack . show) l) + <> "]" + -- | A convenience helper for `confHook`, such that bindings for the -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name @@ -145,9 +156,9 @@ cL' = ((fromJust . condLibrary) gpd) {condTreeData = lib'} gpd' = gpd {condLibrary = Just cL'} - void $ writeModuleTree verbosity outputDir m + modules <- writeModuleTree verbosity outputDir m - genConfigModule outputDir name givenOvs + genConfigModule outputDir name givenOvs modules lbi <- defaultConfHook (gpd', hbi) flags @@ -169,6 +180,75 @@ pkgName pkgVersion verbose overridesFile overrides outputDir + (confHook simpleUserHooks) + }) + +compatGenConfHook :: String -- ^ New version of the package + -> [Text] -- ^ The list of modules to re-export + -> ConfHook -- ^ previous `confHook` + -> ConfHook +compatGenConfHook newVersion modules defaultConfHook (gpd, hbi) flags = do + let em' = map (MN.fromString . T.unpack) modules + lib = ((condTreeData . fromJust . condLibrary) gpd) + bi = libBuildInfo lib +#if MIN_VERSION_base(4,11,0) + bi' = bi {autogenModules = em'} +#else + bi' = bi +#endif + lib' = lib {exposedModules = em', libBuildInfo = bi'} + cL' = ((fromJust . condLibrary) gpd) {condTreeData = lib'} + gpd' = gpd {condLibrary = Just cL'} + + mapM_ (writeCompatModule . T.unpack) modules + + lbi <- defaultConfHook (gpd', hbi) flags + + return (lbi {withOptimization = NoOptimisation}) + + where + writeCompatModule :: String -> IO () + writeCompatModule modName = do + fname <- case unsnoc (splitOn '.' modName) of + Nothing -> return $ modName <> ".hs" + Just ([], last) -> return $ last <> ".hs" + Just (init, last) -> let path = joinPath init + in do + createDirectoryIfMissing True path + return $ path (last <> ".hs") + utf8WriteFile fname modContents + + where modContents :: Text + modContents = let + mod = T.pack modName + link = "[" <> T.pack newVersion + <> "](https://hackage.haskell.org/package/" + <> T.pack newVersion <> ")" + in T.unlines [ + "{-# LANGUAGE PackageImports #-}" + , "{- | This is a backwards-compatibility module re-exporting the contents of the " + , mod <> " module in the " <> link <> " package." + , "" + , "The link below will take you to the relevant entry in the " <> link <> " documentation." + , "-}" + , "module " <> mod <> " (" + , " module X) where" + , "" + , "import \"" <> T.pack newVersion <> "\" " <> mod <> " as X" + ] + + -- Data.List.unsnoc is relatively recent (base 4.19.0.0), + -- so we just copy the definition. + unsnoc :: [a] -> Maybe ([a], a) + unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing + +-- | The entry point for @Setup.hs@ files in compat bindings. +setupCompatWrapper :: String -- ^ New package + -> [Text] -- ^ List of files in the new package + -> IO () +setupCompatWrapper newPackage modules = + defaultMainWithHooks (simpleUserHooks { + confHook = compatGenConfHook newPackage modules (confHook simpleUserHooks) }) diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -298,9 +298,12 @@ (convert name $ hToF (argType arg) (transfer arg)) (do let maybeName = "maybe" <> ucFirst name + nullPtr <- nullPtrForType (argType arg) >>= \case + Nothing -> terror $ "Unexpected non-pointer type " <> tshow (argType arg) + Just null -> pure null line $ maybeName <> " <- case " <> name <> " of" indent $ do - line $ "Nothing -> return nullPtr" + line $ "Nothing -> return " <> nullPtr let jName = "j" <> ucFirst name line $ "Just " <> jName <> " -> do" indent $ do @@ -360,7 +363,7 @@ let maybeName = "maybe" <> ucFirst name line $ maybeName <> " <- case " <> name <> " of" indent $ do - line $ "Nothing -> return (castPtrToFunPtr nullPtr)" + line $ "Nothing -> return FP.nullFunPtr" let jName = "j" <> ucFirst name jName' = prime jName line $ "Just " <> jName <> " -> do" @@ -387,27 +390,27 @@ prepareInoutArg arg = do name' <- prepareInArg arg ft <- foreignType $ argType arg - allocInfo <- typeAllocInfo (argType arg) - case allocInfo of - Just (TypeAlloc allocator n) -> do - wrapMaybe arg >>= bool - (do - name'' <- genConversion (prime name') $ - literal $ M $ allocator <> - " :: " <> typeShow (io ft) - line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n - return name'') - -- The semantics of this case are somewhat undefined. - (notImplementedError "Nullable inout structs not supported") - Nothing -> do - if argCallerAllocates arg - then return name' - else do - name'' <- genConversion (prime name') $ - literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft) - line $ "poke " <> name'' <> " " <> name' - return name'' + if argCallerAllocates arg + then return name' + else do + -- Check that if the argument type is managed, the C type is a + -- pointer to a pointer. This is not perfect, but it helps to + -- detect some relatively common introspection errors that would + -- lead to crashes. + managed <- isManaged (argType arg) + when managed $ + case argCType arg of + Nothing -> badIntroError $ "Missing C type for argument ‘" <> + argCName arg <> "’" + Just ctype -> when (not $ "**" `T.isSuffixOf` ctype) $ + badIntroError $ "C type for argument ‘" <> + argCName arg <> "’ is not a pointer to a pointer" + name'' <- genConversion (prime name') $ + literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft) + line $ "poke " <> name'' <> " " <> name' + return name'' + prepareOutArg :: Arg -> ExcCodeGen Text prepareOutArg arg = do let name = escapedArgName arg @@ -573,6 +576,7 @@ n -> let destroyName = escapedArgName $ (args callable)!!n in line $ "let " <> destroyName <> " = FP.nullFunPtr" ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr" + ScopeTypeForever -> line $ "let " <> closureName <> " = nullPtr" _ -> badIntroError $ "Closure \"" <> n <> "\" is not a callback." freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () @@ -584,8 +588,11 @@ Nothing -> badIntroError $ "Could not find " <> name <> " in " <> T.pack (ppShow callable) <> "\n" <> T.pack (ppShow nameMap) - when (argScope arg == ScopeTypeCall) $ - line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' + when (argScope arg == ScopeTypeCall) $ do + isCallback <- typeIsCallback (argType arg) + if isCallback + then line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' + else comment $ "XXX: Ignoring scope annotation on a non-callback argument: " <> name -- | Format the signature of the Haskell binding for the `Callable`. formatHSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen () @@ -649,8 +656,9 @@ -- arguments to Haskell code. closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs + callbackUserData = filter argCallbackUserData (args callable) omitted = case expose of - WithoutClosures -> arrayLengths callable <> closures <> destroyers + WithoutClosures -> arrayLengths callable <> closures <> destroyers <> callbackUserData WithClosures -> arrayLengths callable in (filter (`notElem` omitted) inArgs, omitted) @@ -960,7 +968,8 @@ forgetClosures :: Callable -> Callable forgetClosures c = c {args = map forgetClosure (args c)} where forgetClosure :: Arg -> Arg - forgetClosure arg = arg {argClosure = -1} + forgetClosure arg = arg {argClosure = -1, + argCallbackUserData = False} -- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell -- function that will invoke its first argument, which should be a diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -71,11 +71,14 @@ import Control.Applicative ((<$>)) import Data.Monoid (Monoid(..)) #endif +#if MIN_VERSION_base(4,18,0) +import Control.Monad (forM, unless, when) +#endif import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Except import qualified Data.Foldable as F -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes, mapMaybe) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>), mempty) #endif @@ -919,7 +922,6 @@ -- this prefix will be imported as {-# SOURCE #-}, and otherwise will -- be imported normally. importDeps :: ModulePath -> [ModulePath] -> Text -importDeps _ [] = "" importDeps (ModulePath prefix) deps = T.unlines . map toImport $ deps where toImport :: ModulePath -> Text toImport dep = let impSt = if importSource dep @@ -945,6 +947,7 @@ , "import qualified Data.GI.Base.GArray as B.GArray" , "import qualified Data.GI.Base.GClosure as B.GClosure" , "import qualified Data.GI.Base.GError as B.GError" + , "import qualified Data.GI.Base.GHashTable as B.GHT" , "import qualified Data.GI.Base.GVariant as B.GVariant" , "import qualified Data.GI.Base.GValue as B.GValue" , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec" @@ -952,12 +955,18 @@ , "import qualified Data.GI.Base.Properties as B.Properties" , "import qualified Data.GI.Base.Signals as B.Signals" , "import qualified Control.Monad.IO.Class as MIO" + , "import qualified Data.Coerce as Coerce" , "import qualified Data.Text as T" + , "import qualified Data.Kind as DK" , "import qualified Data.ByteString.Char8 as B" , "import qualified Data.Map as Map" , "import qualified Foreign.Ptr as FP" , "import qualified GHC.OverloadedLabels as OL" - , "import qualified GHC.Records as R" ] + , "import qualified GHC.Records as R" + , "import qualified Data.Word as DW" + , "import qualified Data.Int as DI" + , "import qualified System.Posix.Types as SPT" + , "import qualified Foreign.C.Types as FCT"] -- | Like `dotModulePath`, but add a "GI." prefix. dotWithPrefix :: ModulePath -> Text @@ -966,8 +975,9 @@ -- | 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 +writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> + M.Map ModulePath ModuleInfo -> IO () +writeModuleInfo verbose dirPrefix minfo treeMap = do let submodulePaths = map (modulePath) (M.elems (submodules minfo)) -- We reexport any submodules. submoduleExports = map dotWithPrefix submodulePaths @@ -984,7 +994,18 @@ then "" else moduleImports pkgRoot = ModulePath (take 1 (modulePathToList $ modulePath minfo)) - deps = importDeps pkgRoot (Set.toList $ qualifiedImports minfo) + allImports = transitiveImports minfo treeMap + minimalImports = qualifiedImports minfo + allDeps = importDeps pkgRoot (Set.toList allImports) + minimalDeps = importDeps pkgRoot (Set.toList minimalImports) + deps = T.unlines [ + "-- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/23392", + "#if MIN_VERSION_base(4,18,0)", + allDeps, + "#else", + minimalDeps, + "#endif" + ] haddock = moduleHaddock (M.lookup ToplevelSection (sectionDocs minfo)) when verbose $ putStrLn ((T.unpack . dotWithPrefix . modulePath) minfo @@ -996,6 +1017,33 @@ let bootFName = modulePathToFilePath dirPrefix (modulePath minfo) ".hs-boot" utf8WriteFile bootFName (genHsBoot minfo) +-- | Collect the transitive set of imports for this module. In +-- principle just importing the set of strictly necessary imports (via +-- qualifiedImports) should be sufficient; the following is a +-- workaround for a GHC bug: +-- https://gitlab.haskell.org/ghc/ghc/-/issues/23392 +transitiveImports :: ModuleInfo -> M.Map ModulePath ModuleInfo + -> Set.Set ModulePath +transitiveImports root treeMap = collectImports root Set.empty + where + collectImports :: ModuleInfo -> Set.Set ModulePath -> Set.Set ModulePath + collectImports minfo deps = let + isCallbacks (ModulePath [_, "Callbacks"]) = True + isCallbacks _ = False + + -- Deps that we haven't analysed yet. + unseenDeps = Set.filter (\e -> Set.notMember e deps) (qualifiedImports minfo) + -- Make sure we don't try to import ourselves + unrooted = Set.filter (\mp -> mp /= modulePath root) unseenDeps + unseenModules = mapMaybe (\d -> M.lookup d treeMap) (Set.toList unrooted) + -- We don't collect implicit deps from the callbacks module, + -- which is always imported normally (not just the hs-boot) + notCallbacks = filter (not . isCallbacks . modulePath) unseenModules + + -- Imports in unseenDeps + depImports = map (\m -> collectImports m (Set.union deps unseenDeps)) notCallbacks + in Set.unions (unrooted : depImports) + -- | Generate the .hs-boot file for the given module. genHsBoot :: ModuleInfo -> Text genHsBoot minfo = @@ -1012,11 +1060,19 @@ -- | 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 - submodulePaths <- concat <$> forM (M.elems (submodules minfo)) - (writeModuleTree verbose dirPrefix) - writeModuleInfo verbose dirPrefix minfo - return $ (dotWithPrefix (modulePath minfo) : submodulePaths) +writeModuleTree verbose dirPrefix root = doWriteModuleTree root + + where + doWriteModuleTree :: ModuleInfo -> IO [Text] + doWriteModuleTree minfo = do + submodulePaths <- concat <$> forM (M.elems (submodules minfo)) doWriteModuleTree + writeModuleInfo verbose dirPrefix minfo treeMap + return $ (dotWithPrefix (modulePath minfo) : submodulePaths) + + treeMap = M.fromList (gatherSubmodules root) + gatherSubmodules :: ModuleInfo -> [(ModulePath, ModuleInfo)] + gatherSubmodules minfo = (modulePath minfo, minfo) : + concatMap gatherSubmodules (M.elems $ submodules minfo) -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk. diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -21,7 +21,8 @@ import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability, detectGObject, dropDuplicatedFields, - checkClosureDestructors, fixSymbolNaming) + checkClosureDestructors, fixSymbolNaming, + fixClosures, fixCallbackUserData) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation, writeHaddock, @@ -153,7 +154,9 @@ where returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c) args' = map (fixDestroyers . fixClosures . fixLengthArg) (args c) - args'' = fixInstance (head args') : tail args' + args'' = case args' of + inst:rest -> fixInstanceDirection inst : rest + [] -> [] fixLengthArg :: Arg -> Arg fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)} @@ -178,12 +181,12 @@ then arg {argClosure = closure + 1} else arg - -- We always treat the instance argument of a method as non-null - -- and "in", even if sometimes the introspection data may say - -- otherwise. - fixInstance :: Arg -> Arg - fixInstance arg = arg { mayBeNull = False - , direction = DirectionIn} + -- We always treat the instance argument of a method as "in", + -- even if the introspection data says otherwise (this is + -- generally an erroneous annotation, meaning that the structure + -- is modified). + fixInstanceDirection :: Arg -> Arg + fixInstanceDirection arg = arg { direction = DirectionIn} -- For constructors we want to return the actual type of the object, -- rather than a generic superclass (so Gtk.labelNew returns a @@ -219,7 +222,7 @@ export (NamedSubsection MethodSection $ lowerName mn) (lowerName mn') cppIf CPPOverloading $ - genMethodInfo cn (m {methodCallable = c''}) + genMethodInfo cn (m {methodCallable = c''}) -- | Generate an import for the gvalue getter for the given type. It -- returns the name of the function on the Haskell side. @@ -243,7 +246,7 @@ genGValueInstance :: Name -> Text -> Text -> Text -> Text -> CodeGen e () genGValueInstance n get_type_fn newFn get_value_fn set_value_fn = do let name' = upperName n - doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." + doc = "Convert t'" <> name' <> "' to and from t'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." writeHaddock DocBeforeSymbol doc @@ -319,13 +322,13 @@ return get_type_fn where castDoc :: Text -> Text - castDoc name' = "Cast to `" <> name' <> - "`, for types for which this is known to be safe. " <> - "For general casts, use `Data.GI.Base.ManagedPtr.castTo`." + castDoc name' = "Cast to t'" <> name' <> + "', for types for which this is known to be safe. " <> + "For general casts, use 'Data.GI.Base.ManagedPtr.castTo'." classDoc :: Text -> Text - classDoc name' = "Type class for types which can be safely cast to `" - <> name' <> "`, for instance with `to" <> name' <> "`." + classDoc name' = "Type class for types which can be safely cast to t'" + <> name' <> "', for instance with `to" <> name' <> "`." -- | Wrap a given Object. We enforce that every Object that we wrap is a -- GObject. This is the case for everything except the ParamSpec* set @@ -417,8 +420,8 @@ else group $ do cls <- classConstraint n exportDecl cls - writeHaddock DocBeforeSymbol ("Type class for types which implement `" - <> name' <> "`.") + writeHaddock DocBeforeSymbol ("Type class for types which implement t'" + <> name' <> "'.") -- Create the IsX constraint. We cannot simply say -- @@ -553,6 +556,12 @@ -- destructor for a user_data argument has an associated -- user_data argument. $ map checkClosureDestructors + -- Make sure that the argClosure argument refers to a callback, + -- not to the user_data field. + $ map fixClosures + -- Make sure that the user_data argument of callbacks is + -- annotated as such. + $ map fixCallbackUserData -- Make sure that the symbols to be generated are valid -- Haskell identifiers, when necessary. $ map fixSymbolNaming diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs --- a/lib/Data/GI/CodeGen/Constant.hs +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -106,5 +106,16 @@ showBasicType TGType gtype = return $ "GType " <> gtype showBasicType TIntPtr ptr = return ptr showBasicType TUIntPtr ptr = return ptr +showBasicType TShort s = return s +showBasicType TUShort u = return u +showBasicType TSSize s = return s +showBasicType TSize s = return s +showBasicType Ttime_t t = return t +showBasicType Toff_t o = return o +showBasicType Tdev_t d = return d +showBasicType Tgid_t g = return g +showBasicType Tpid_t p = return p +showBasicType Tsocklen_t l = return l +showBasicType Tuid_t u = return u -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer" diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc --- a/lib/Data/GI/CodeGen/Conversions.hsc +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -74,7 +74,6 @@ Free ma <*> b = Free $ (<*> b) <$> ma instance (Functor f) => Monad (Free f) where - return = Pure (Free x) >>= f = Free (fmap (>>= f) x) (Pure r) >>= f = f r @@ -220,11 +219,11 @@ hClosureToF :: Transfer -> Maybe Type -> CodeGen e Constructor -- Untyped closures hClosureToF transfer Nothing = - if transfer == TransferEverything - then return $ M "B.GClosure.disownGClosure" - -- We cast the point here because the foreign type for untyped + -- We cast the pointer here because the foreign type for untyped -- closures is always represented as Ptr (GClosure ()), while the -- corresponding Haskell type is the parametric "GClosure a". + if transfer == TransferEverything + then return $ M "FP.castPtr <$> B.GClosure.disownGClosure" else return $ M "unsafeManagedPtrCastPtr" -- Typed closures hClosureToF transfer (Just _) = @@ -300,13 +299,15 @@ | TCArray False _ _ (TBasicType TUInt8) <- t = return $ M "packByteString" | TCArray False _ _ (TBasicType TBoolean) <- t = - return $ M "(packMapStorableArray (fromIntegral . fromEnum))" + return $ M "(packMapStorableArray (P.fromIntegral . P.fromEnum))" | TCArray False _ _ (TBasicType TGType) <- t = return $ M "(packMapStorableArray gtypeToCGType)" | TCArray False _ _ (TBasicType TFloat) <- t = return $ M "(packMapStorableArray realToFrac)" | TCArray False _ _ (TBasicType TDouble) <- t = return $ M "(packMapStorableArray realToFrac)" + | TCArray False _ _ (TBasicType TUniChar) <- t = + return $ M "(packMapStorableArray (P.fromIntegral . SP.ord))" | TCArray False _ _ (TBasicType _) <- t = return $ M "packStorableArray" | TCArray False _ _ TGValue <- t = @@ -316,8 +317,8 @@ | otherwise = case (typeShow hType, typeShow fType) of ("T.Text", "CString") -> return $ M "textToCString" ("[Char]", "CString") -> return $ M "stringToCString" - ("Char", "CInt") -> return "(fromIntegral . ord)" - ("Bool", "CInt") -> return "(fromIntegral . fromEnum)" + ("Char", "CInt") -> return "(P.fromIntegral . SP.ord)" + ("Bool", "CInt") -> return "(P.fromIntegral . P.fromEnum)" ("Float", "CFloat") -> return "realToFrac" ("Double", "CDouble") -> return "realToFrac" ("GType", "CGType") -> return "gtypeToCGType" @@ -355,11 +356,14 @@ -- (destroy,packer,unpacker) for the given type. hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text) hashTablePtrPackers (TBasicType TPtr) = - return ("Nothing", "ptrPackPtr", "ptrUnpackPtr") + return ("Nothing", "B.GHT.ptrPackPtr", "B.GHT.ptrUnpackPtr") hashTablePtrPackers (TBasicType TUTF8) = - return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr") + return ("(Just ptr_to_g_free)", "B.GHT.cstringPackPtr", "B.GHT.cstringUnpackPtr") +hashTablePtrPackers TGValue = + return ("(Just B.GValue.ptr_to_gvalue_free)", "B.GHT.gvaluePackPtr", + "B.GHT.gvalueUnpackPtr") hashTablePtrPackers t = - notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported." + notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported." hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter hToF_PackGHashTable keys elems = do @@ -649,43 +653,43 @@ a <- findAPI t case a of Just (APIStruct s) -> if structIsBoxed s - then wrapTransient t + then wrapTransient else fToH t TransferNothing Just (APIUnion u) -> if unionIsBoxed u - then wrapTransient t + then wrapTransient else fToH t TransferNothing _ -> fToH t TransferNothing transientToH t transfer = fToH t transfer -- | Wrap the given transient. -wrapTransient :: Type -> CodeGen e Converter -wrapTransient t = do - hCon <- typeConName <$> haskellType t - return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon +wrapTransient :: CodeGen e Converter +wrapTransient = return $ lambdaConvert $ "B.ManagedPtr.withTransient " unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter unpackCArray length (TCArray False _ _ t) transfer = case t of TBasicType TUTF8 -> return $ apply $ M $ parenthesize $ - "unpackUTF8CArrayWithLength " <> length + "unpackUTF8CArrayWithLength " <> length TBasicType TFileName -> return $ apply $ M $ parenthesize $ - "unpackFileNameArrayWithLength " <> length + "unpackFileNameArrayWithLength " <> length TBasicType TUInt8 -> return $ apply $ M $ parenthesize $ - "unpackByteStringWithLength " <> length + "unpackByteStringWithLength " <> length TBasicType TPtr -> return $ apply $ M $ parenthesize $ - "unpackPtrArrayWithLength " <> length + "unpackPtrArrayWithLength " <> length TBasicType TBoolean -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength (/= 0) " <> length + "unpackMapStorableArrayWithLength (/= 0) " <> length TBasicType TGType -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength GType " <> length + "unpackMapStorableArrayWithLength GType " <> length TBasicType TFloat -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength realToFrac " <> length + "unpackMapStorableArrayWithLength realToFrac " <> length TBasicType TDouble -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength realToFrac " <> length + "unpackMapStorableArrayWithLength realToFrac " <> length + TBasicType TUniChar -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (SP.chr . P.fromIntegral) " <> length TBasicType _ -> return $ apply $ M $ parenthesize $ - "unpackStorableArrayWithLength " <> length + "unpackStorableArrayWithLength " <> length TGValue -> return $ apply $ M $ parenthesize $ - "B.GValue.unpackGValueArrayWithLength " <> length + "B.GValue.unpackGValueArrayWithLength " <> length TInterface _ -> do a <- findAPI t isScalar <- typeIsEnumOrFlag t @@ -773,8 +777,8 @@ 4 -> con0 "Word32" n -> error ("Unsupported `guint' length: " ++ show n) -haskellBasicType TLong = con0 "CLong" -haskellBasicType TULong = con0 "CULong" +haskellBasicType TLong = con0 "FCT.CLong" +haskellBasicType TULong = con0 "FCT.CULong" haskellBasicType TInt8 = con0 "Int8" haskellBasicType TUInt8 = con0 "Word8" haskellBasicType TInt16 = con0 "Int16" @@ -791,7 +795,67 @@ haskellBasicType TFileName = con0 "[Char]" haskellBasicType TIntPtr = con0 "CIntPtr" haskellBasicType TUIntPtr = con0 "CUIntPtr" +haskellBasicType TShort = con0 "FCT.CShort" +haskellBasicType TUShort = con0 "FCT.CUShort" +haskellBasicType TSSize = +#if defined(HTYPE_SSIZE_T) + con0 "SPT.CSsize" +#else + int #{size gsize} +#endif +haskellBasicType TSize = con0 "FCT.CSize" +haskellBasicType Ttime_t = con0 "FCT.CTime" +haskellBasicType Toff_t = +#if defined(HTYPE_OFF_T) + con0 "SPT.COff" +#else + -- If the type is not defined there's not much we can do, other than + -- guessing. The values below are correct on Linux amd64. In + -- practice it will hopefully not be much of an issue with newer + -- versions of GHC, since platforms lacking the definition will + -- (hopefully) also not have the relevant types in the available + -- APIs. The same remark applies to the types below. + int 8 +#endif +haskellBasicType Tdev_t = +#if defined(HTYPE_DEV_T) + con0 "SPT.CDev" +#else + uint 8 +#endif +haskellBasicType Tgid_t = +#if defined(HTYPE_GID_T) + con0 "SPT.CGid" +#else + uint 4 +#endif +haskellBasicType Tpid_t = +#if defined(HTYPE_PID_T) + con0 "SPT.CPid" +#else + int 4 +#endif +haskellBasicType Tsocklen_t = +#if defined(HTYPE_SOCKLEN_T) + con0 "SPT.CSocklen" +#else + uint 4 +#endif +haskellBasicType Tuid_t = +#if defined(HTYPE_UID_T) + con0 "SPT.CUid" +#else + uint 4 +#endif +-- | Return the unsigned int type with the given amount of bytes. +uint :: Int -> TypeRep +uint n = con0 ("DW.Word" <> tshow (n*8)) + +-- | Return the (signed) int type with the given amount of bytes. +int :: Int -> TypeRep +int n = con0 ("DI.Int" <> tshow (n*8)) + -- | This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen e TypeRep haskellType (TBasicType bt) = return $ haskellBasicType bt @@ -848,7 +912,9 @@ -- | Whether the callable has closure arguments (i.e. "user_data" -- style arguments). callableHasClosures :: Callable -> Bool -callableHasClosures = any (/= -1) . map argClosure . args +callableHasClosures c = or . concatMap checkArg $ args c + where checkArg :: Arg -> [Bool] + checkArg arg = [argClosure arg /= -1, argCallbackUserData arg] -- | Check whether the given type corresponds to a callback. typeIsCallback :: Type -> CodeGen e Bool @@ -865,12 +931,14 @@ -- to the foreign type, but in some cases, such as callbacks with -- closure arguments, this does not hold, as we omit the closure -- arguments. This function returns a type which is actually --- isomorphic. There is another case this function deals with: for --- convenience untyped `TGClosure` types have a type variable on the --- Haskell side when they are arguments to functions, but we do not --- want this when they appear as arguments to callbacks/signals, or --- return types of properties, as it would force the type synonym/type --- family to depend on the type variable. +-- isomorphic. +-- +-- There is another case this function deals with: for convenience +-- untyped `TGClosure` types have a type variable on the Haskell side +-- when they are arguments to functions, but we do not want this when +-- they appear as arguments to callbacks/signals, or return types of +-- properties, as it would force the type synonym/type family to +-- depend on the type variable. isoHaskellType :: Type -> CodeGen e TypeRep isoHaskellType (TGClosure Nothing) = return $ "GClosure" `con` [con0 "()"] diff --git a/lib/Data/GI/CodeGen/CtoHaskellMap.hs b/lib/Data/GI/CodeGen/CtoHaskellMap.hs --- a/lib/Data/GI/CodeGen/CtoHaskellMap.hs +++ b/lib/Data/GI/CodeGen/CtoHaskellMap.hs @@ -6,23 +6,24 @@ ) where import qualified Data.Map as M -import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) +import qualified Data.Text as T -import Data.GI.CodeGen.GtkDoc (CRef(..)) +import Data.GI.CodeGen.GtkDoc (CRef(..), docName) import Data.GI.CodeGen.API (API(..), Name(..), Callback(..), Constant(..), Flags(..), Enumeration(..), EnumerationMember(..), Interface(..), Object(..), Function(..), Method(..), Struct(..), Union(..), - Signal(..)) + Signal(..), Property(..)) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (moduleLocation, lowerName, upperName, - signalHaskellName) -import Data.GI.CodeGen.Util (ucFirst) + signalHaskellName, haddockSignalAnchor, + haddockAttrAnchor, hyphensToCamelCase) +import Data.GI.CodeGen.Util (ucFirst, lcFirst) -- | Link to an identifier, module, etc. data Hyperlink = ValueIdentifier Text @@ -56,13 +57,18 @@ extractRefs (n, APIObject o) = objectRefs n o builtins :: [(CRef, Hyperlink)] - builtins = [(TypeRef "gboolean", TypeIdentifier "P.Bool"), + builtins = [(CTypeRef "gboolean", TypeIdentifier "P.Bool"), (ConstantRef "TRUE", ValueIdentifier "P.True"), (ConstantRef "FALSE", ValueIdentifier "P.False"), - (TypeRef "GError", TypeIdentifier "GError"), - (TypeRef "GType", TypeIdentifier "GType"), - (TypeRef "GVariant", TypeIdentifier "GVariant"), - (ConstantRef "NULL", ValueIdentifier "P.Nothing")] + (CTypeRef "GError", TypeIdentifier "GError"), + (CTypeRef "GType", TypeIdentifier "GType"), + (CTypeRef "GVariant", TypeIdentifier "GVariant"), + (ConstantRef "NULL", ValueIdentifier "P.Nothing"), + (TypeRef (docName $ Name "GLib" "Variant"), + TypeIdentifier "GVariant"), + (TypeRef (docName $ Name "GLib" "HashTable"), + TypeIdentifier "GHashTable") + ] -- | Obtain the fully qualified symbol pointing to a value. fullyQualifiedValue :: Name -> API -> Text -> Hyperlink @@ -77,41 +83,53 @@ -- | 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), - fullyQualifiedValue n (APIConst c) $ name n), - (TypeRef (constantCType c), - fullyQualifiedValue n (APIConst c) $ name n)] +constRefs n c = [(ConstantRef (constantCType c), qualified), + (CTypeRef (constantCType c), qualified), + (TypeRef (docName n), qualified)] + where qualified = fullyQualifiedValue n (APIConst c) $ name n -- | Extract the C name of a function. funcRefs :: Name -> Function -> [(CRef, Hyperlink)] -funcRefs n f = [(FunctionRef (fnSymbol f), - fullyQualifiedValue n (APIFunction f) $ lowerName n)] +funcRefs n f = [(OldFunctionRef (fnSymbol f), qualified), + (FunctionRef (docName n), qualified)] + where qualified = fullyQualifiedValue 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), - fullyQualifiedType n api $ upperName n) : - map memberToRef (enumMembers e) - where memberToRef :: EnumerationMember -> (CRef, Hyperlink) - memberToRef em = (ConstantRef (enumMemberCId em), +enumRefs api n e = (CTypeRef (enumCType e), qualified) + : (TypeRef (docName n), qualified) + : map memberToOldRef (enumMembers e) + <> map memberToRef (enumMembers e) + where qualified = fullyQualifiedType n api $ upperName n + memberToOldRef :: EnumerationMember -> (CRef, Hyperlink) + memberToOldRef em = (ConstantRef (enumMemberCId em), fullyQualifiedValue n api $ upperName $ n {name = name n <> "_" <> enumMemberName em}) + memberToRef :: EnumerationMember -> (CRef, Hyperlink) + -- Sometimes the references are written in uppercase while the + -- name of the member in the introspection data is written in + -- lowercase, so normalise everything to lowercase. (See the + -- similar annotation in GtkDoc.hs.) + memberToRef em = (EnumMemberRef (docName n) (T.toLower $ enumMemberName em), + fullyQualifiedValue n api $ upperName $ + n {name = name n <> "_" <> enumMemberName em}) -- | Refs to the methods for a given owner. methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)] -methodRefs n api methods = catMaybes $ map methodRef methods - where methodRef :: Method -> Maybe (CRef, Hyperlink) +methodRefs n api methods = concatMap methodRef methods + where methodRef :: Method -> [(CRef, Hyperlink)] methodRef Method{methodSymbol = symbol, methodName = mn} = -- Method name namespaced by the owner. let mn' = mn {name = name n <> "_" <> name mn} - in Just (FunctionRef symbol, - fullyQualifiedValue n api $ lowerName mn') + qualified = fullyQualifiedValue n api $ lowerName mn' + in [(OldFunctionRef symbol, qualified), + (MethodRef (docName n) (name mn), qualified)] -- | Refs to the signals for a given owner. signalRefs :: Name -> API -> Maybe Text -> [Signal] -> [(CRef, Hyperlink)] -signalRefs n api maybeCName signals = map signalRef signals - where signalRef :: Signal -> (CRef, Hyperlink) +signalRefs n@(Name _ owner) api maybeCName signals = concatMap signalRef signals + where signalRef :: Signal -> [(CRef, Hyperlink)] signalRef (Signal {sigName = sn}) = let mod = dotModulePath (moduleLocation n api) sn' = signalHaskellName sn @@ -119,15 +137,34 @@ Just cname -> cname Nothing -> let Name ns owner = n in ucFirst ns <> owner - in (SignalRef ownerCName sn, - ModuleLinkWithAnchor (Just sn') mod ("g:signal:" <> sn')) + label = Just (owner <> "::" <> sn') + link = ModuleLinkWithAnchor label mod (haddockSignalAnchor <> sn') + in [(OldSignalRef ownerCName sn, link), + (SignalRef (docName n) sn, link)] +-- | Refs to the properties for a given owner. +propRefs :: Name -> API -> Maybe Text -> [Property] -> [(CRef, Hyperlink)] +propRefs n@(Name _ owner) api maybeCName props = concatMap propertyRef props + where propertyRef :: Property -> [(CRef, Hyperlink)] + propertyRef (Property {propName = pn}) = + let mod = dotModulePath (moduleLocation n api) + hn = lcFirst . hyphensToCamelCase $ pn + ownerCName = case maybeCName of + Just cname -> cname + Nothing -> let Name ns owner = n + in ucFirst ns <> owner + label = Just (owner <> ":" <> hn) + link = ModuleLinkWithAnchor label mod (haddockAttrAnchor <> hn) + in [(OldPropertyRef ownerCName pn, link), + (PropertyRef (docName n) pn, link)] + -- | 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, - fullyQualifiedType n api (upperName n))] +maybeCType n api (Just ctype) = [(CTypeRef ctype, qualified), + (TypeRef (docName n), qualified)] + where qualified = fullyQualifiedType n api (upperName n) -- | Extract the C name of a callback. callbackRefs :: Name -> Callback -> [(CRef, Hyperlink)] @@ -148,9 +185,11 @@ ifaceRefs n i = maybeCType n (APIInterface i) (ifCType i) <> methodRefs n (APIInterface i) (ifMethods i) <> signalRefs n (APIInterface i) (ifCType i) (ifSignals i) + <> propRefs n (APIInterface i) (ifCType i) (ifProperties 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) <> signalRefs n (APIObject o) (objCType o) (objSignals o) + <> propRefs n (APIObject o) (objCType o) (objProperties o) diff --git a/lib/Data/GI/CodeGen/Fixups.hs b/lib/Data/GI/CodeGen/Fixups.hs --- a/lib/Data/GI/CodeGen/Fixups.hs +++ b/lib/Data/GI/CodeGen/Fixups.hs @@ -5,17 +5,21 @@ , detectGObject , dropDuplicatedFields , checkClosureDestructors + , fixClosures + , fixCallbackUserData , fixSymbolNaming ) where import Data.Char (generalCategory, GeneralCategory(UppercaseLetter)) -import Data.Maybe (isNothing, isJust) +import Data.Maybe (fromMaybe, isNothing, isJust) +import qualified Data.Map as M #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif import qualified Data.Set as S import qualified Data.Text as T +import Data.GI.CodeGen.Type import Data.GI.CodeGen.API -- | Remove functions and methods annotated with "moved-to". @@ -57,14 +61,14 @@ -- | Guess nullability for the properties of an interface. guessInterfacePropertyNullability :: Interface -> Interface guessInterfacePropertyNullability iface = - iface {ifProperties = map (guessNullability (ifMethods iface)) + iface { ifProperties = map (guessNullability (ifMethods iface)) (ifProperties iface)} -- | Guess the nullability for a property, given the list of methods -- for the object/interface. guessNullability :: [Method] -> Property -> Property guessNullability methods = guessReadNullability methods - . guessWriteNullability methods + . guessWriteNullability methods -- | Guess whether "get" on the given property may return NULL, based -- on the corresponding "get_prop_name" method, if it exists. @@ -76,7 +80,8 @@ nullableGetter :: Maybe Bool nullableGetter = let prop_name = T.replace "-" "_" (propName p) - in case findMethod methods ("get_" <> prop_name) of + getter = fromMaybe ("get_" <> prop_name) (propGetter p) + in case findMethod methods getter of Nothing -> Nothing -- Check that it looks like a sensible getter -- for the property. @@ -102,7 +107,8 @@ nullableSetter :: Maybe Bool nullableSetter = let prop_name = T.replace "-" "_" (propName p) - in case findMethod methods ("set_" <> prop_name) of + setter = fromMaybe ("set_" <> prop_name) (propSetter p) + in case findMethod methods setter of Nothing -> Nothing -- Check that it looks like a sensible setter. Just m -> @@ -178,7 +184,7 @@ checkMethod m = m {methodCallable = checkCallableDestructors (methodCallable m)} --- | If any argument for the callable has a associated destroyer for +-- | If any argument for the callable has an associated destroyer for -- the user_data, but no associated user_data, drop the destroyer -- annotation. checkCallableDestructors :: Callable -> Callable @@ -187,6 +193,91 @@ checkArg arg = if argDestroy arg >= 0 && argClosure arg == -1 then arg {argDestroy = -1} else arg + +-- | Sometimes it is the callback that is annotated with the (closure +-- user_data) annotation, and sometimes the user_data parameter +-- itself, with (closure callback) pointing to the callback. The +-- following code makes sure that the annotation is on the callable +-- only. Note that this goes against the official gobject +-- introspection spec, but there is more code using this convention +-- than otherwise, and the gir generator seems to add closure +-- annotations in both directions when using the new convention +-- anyway. +fixCallableClosures :: Callable -> Callable +fixCallableClosures c = c {args = map fixupArg (zip [0..] (args c))} + where fixupArg :: (Int, Arg) -> Arg + fixupArg (n, arg) = if isUserData arg + then arg {argClosure = -1} + else + case M.lookup n reverseMap of + Just user_data -> arg {argClosure = user_data} + Nothing -> arg + + -- Map from callbacks to their corresponding user_data + -- arguments, obtained by looking to the argClosure value for + -- the user_data argument. + reverseMap :: M.Map Int Int + reverseMap = M.fromList + . map (\(n, arg) -> (argClosure arg, n)) + . filter (isUserData . snd) + . filter ((/= -1) . argClosure . snd) + $ zip [0..] (args c) + + isUserData :: Arg -> Bool + isUserData arg = argScope arg == ScopeTypeInvalid || + argType arg == TBasicType TPtr + +-- | Closures are often incorrectly assigned, with the closure +-- annotation on the callback, instead of in the closure (user_data) +-- parameter itself. The following makes sure that things are as they +-- should. +fixClosures :: (Name, API) -> (Name, API) +fixClosures (n, APIObject o) = + (n, APIObject (o {objMethods = fixMethodClosures (objMethods o)})) +fixClosures (n, APIInterface i) = + (n, APIInterface (i {ifMethods = fixMethodClosures (ifMethods i)})) +fixClosures (n, APIStruct s) = + (n, APIStruct (s {structMethods = fixMethodClosures (structMethods s)})) +fixClosures (n, APIUnion u) = + (n, APIUnion (u {unionMethods = fixMethodClosures (unionMethods u)})) +fixClosures (n, APIFunction f) = + (n, APIFunction (f {fnCallable = fixCallableClosures (fnCallable f)})) +fixClosures (n, api) = (n, api) + +fixMethodClosures :: [Method] -> [Method] +fixMethodClosures = map fixMethod + where fixMethod :: Method -> Method + fixMethod m = m {methodCallable = + fixCallableClosures (methodCallable m)} + +-- | The last argument of callbacks is often a @user_data@ argument, +-- but currently gobject-introspection does not have an annotation +-- representing this. This is generally OK, since the gir generator +-- will mark these arguments as @(closure)@ if they are named +-- @user_data@, and we do the right things in this case, but recently +-- there has been a push to "fix" these annotations by removing them +-- without providing any replacement, which breaks the bindings. See +-- https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450 +-- Here we try to guess which arguments in callbacks are user_data +-- arguments. +fixCallbackUserData :: (Name, API) -> (Name, API) +fixCallbackUserData (n, APICallback cb) = + (n, APICallback (cb {cbCallable = fixCallableUserData (cbCallable cb)})) +fixCallbackUserData (n, api) = (n, api) + +-- | Any argument with a closure index pointing to itself is a +-- "user_data" type argument. +fixCallableUserData :: Callable -> Callable +fixCallableUserData c = c {args = fixLast 0 (args c)} + where + fixLast :: Int -> [Arg] -> [Arg] + fixLast _ [] = [] + fixLast n (arg:[]) + | argType arg == TBasicType TPtr && + argClosure arg == n = + [arg {argClosure = -1, argCallbackUserData = True}] + | otherwise = [arg] + fixLast n (arg:rest) = arg : fixLast (n+1) rest -- | Some symbols have names that are not valid Haskell identifiers, -- fix that here. diff --git a/lib/Data/GI/CodeGen/GtkDoc.hs b/lib/Data/GI/CodeGen/GtkDoc.hs --- a/lib/Data/GI/CodeGen/GtkDoc.hs +++ b/lib/Data/GI/CodeGen/GtkDoc.hs @@ -6,8 +6,10 @@ , Token(..) , Language(..) , Link(..) - , ListItem(..) , CRef(..) + , DocSymbolName(..) + , docName + , resolveDocSymbol ) where import Prelude hiding (takeWhile) @@ -15,13 +17,18 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif +import Control.Applicative ((<|>)) +import Control.Monad (forM, guard, when) +import Data.Either (isRight) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif -import Control.Applicative ((<|>)) +import Data.GI.CodeGen.Util (terror) +import Data.GI.GIR.BasicTypes (Name(Name)) + import Data.Attoparsec.Text -import Data.Char (isAsciiUpper, isAsciiLower, isDigit) +import Data.Char (isAlphaNum, isAlpha, isAscii, isDigit) import qualified Data.Text as T import Data.Text (Text) @@ -32,7 +39,11 @@ | CodeBlock (Maybe Language) Text | ExternalLink Link | Image Link - | List [ListItem] + | UnnumberedList [GtkDoc] + -- ^ An unnumbered list of items. + | NumberedList [(Text, GtkDoc)] + -- ^ A list of numbered list items. The first element in + -- the pair is the index. | SectionHeader Int GtkDoc -- ^ A section header of the given depth. | SymbolRef CRef deriving (Show, Eq) @@ -42,29 +53,39 @@ , 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 +data CRef = FunctionRef DocSymbolName + | OldFunctionRef Text + | MethodRef DocSymbolName Text | ParamRef Text | ConstantRef Text - | SignalRef Text Text + | SignalRef DocSymbolName Text + | OldSignalRef Text Text | LocalSignalRef Text - | PropertyRef Text Text + | PropertyRef DocSymbolName Text + | OldPropertyRef Text Text | VMethodRef Text Text + | VFuncRef DocSymbolName Text | StructFieldRef Text Text - | TypeRef Text + | EnumMemberRef DocSymbolName Text + | CTypeRef Text + | TypeRef DocSymbolName + deriving (Show, Eq, Ord) + +-- | Reference to a name (of a class, for instance) in the +-- documentation. It can be either relative to the module where the +-- documentation is, of in some other namespace. +data DocSymbolName = RelativeName Text + -- ^ The symbol without a namespace specified + | AbsoluteName Text Text + -- ^ Namespace and symbol deriving (Show, Eq, Ord) --- | A parsed representation of gtk-doc formatted documentation. +-- | A parsed gtk-doc with fully resolved references. newtype GtkDoc = GtkDoc [Token] deriving (Show, Eq) @@ -75,7 +96,7 @@ -- GtkDoc [] -- -- >>> parseGtkDoc "func()" --- GtkDoc [SymbolRef (FunctionRef "func")] +-- GtkDoc [SymbolRef (OldFunctionRef "func")] -- -- >>> parseGtkDoc "literal" -- GtkDoc [Literal "literal"] @@ -84,54 +105,54 @@ -- GtkDoc [Literal "This is a long literal"] -- -- >>> parseGtkDoc "Call foo() for free cookies" --- GtkDoc [Literal "Call ",SymbolRef (FunctionRef "foo"),Literal " for free cookies"] +-- GtkDoc [Literal "Call ",SymbolRef (OldFunctionRef "foo"),Literal " for free cookies"] -- -- >>> parseGtkDoc "The signal ::activate is related to gtk_button_activate()." --- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."] +-- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> 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 "."] +-- GtkDoc [Literal "The signal ##%",SymbolRef (OldSignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "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"]) []]] +-- GtkDoc [Literal "Compact list:\n",UnnumberedList [GtkDoc [Literal "First item"],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"]) []]] +-- GtkDoc [Literal "Spaced list:\n\n",UnnumberedList [GtkDoc [Literal "First item"],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"})]) []]] +-- GtkDoc [Literal "List with urls:\n",UnnumberedList [GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})],GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]]] parseGtkDoc :: Text -> GtkDoc -parseGtkDoc raw = +parseGtkDoc doc = rawParseGtkDoc (T.cons startOfString doc) + +-- | Like `parseGtkDoc`, but it does not annotate beginning of lines. +rawParseGtkDoc :: Text -> GtkDoc +rawParseGtkDoc 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 + terror $ "gtk-doc parsing failed with error \"" <> T.pack e + <> "\" on the input \"" <> + T.replace (T.singleton startOfString) "" raw <> "\"" + Right tks -> GtkDoc . coalesceLiterals . removeSOS $ 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 +-- | A character indicating the start of the string, to simplify the +-- GtkDoc parser (part of the syntax is sensitive to the start of +-- lines, which we can represent as any character after '\n' or SOS). +startOfString :: Char +startOfString = '\x98' -- Unicode Start Of String (SOS) --- | `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 +-- | Remove the SOS marker from the input. Since this only appears at +-- the beginning of the text, we only need to worry about replacing it +-- in the first token, and only if it's a literal. +removeSOS :: [Token] -> [Token] +removeSOS [] = [] +removeSOS (Literal l : rest) = + if l == T.singleton startOfString + then rest + else Literal (T.replace (T.singleton startOfString) "" l) : rest +removeSOS (other : rest) = other : rest -- | Accumulate consecutive literals into a single literal. coalesceLiterals :: [Token] -> [Token] @@ -153,17 +174,20 @@ headerAndTokens = do header <- parseInitialSectionHeader tokens <- justTokens - return (header : tokens) + return (header <> tokens) justTokens :: Parser [Token] - justTokens = many' parseToken + justTokens = concat <$> many' parseToken --- | Parse a single token. +-- | Parse a single token. This can sometimes return more than a +-- single token, when parsing a logical token produces multiple output +-- tokens (for example when keeping the initial structure requires +-- adding together literals and other tokens). -- -- === __Examples__ -- >>> parseOnly (parseToken <* endOfInput) "func()" --- Right (SymbolRef (FunctionRef "func")) -parseToken :: Parser Token +-- Right [SymbolRef (OldFunctionRef "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 @@ -173,145 +197,349 @@ -- parser much, and it is the main source of -- backtracking. parseFunctionRef + <|> parseMethod + <|> parseConstructor <|> parseSignal + <|> parseId <|> parseLocalSignal <|> parseProperty <|> parseVMethod <|> parseStructField - <|> parseType + <|> parseClass + <|> parseCType <|> parseConstant + <|> parseEnumMember <|> parseParam <|> parseEscaped - <|> parseVerbatim <|> parseCodeBlock + <|> parseVerbatim <|> parseUrl <|> parseImage <|> parseSectionHeader - <|> parseList + <|> parseUnnumberedList + <|> parseNumberedList <|> parseComment <|> parseBoringLiteral --- | Parse a signal name, of the form +-- | Whether the given character is valid in a C identifier. +isCIdent :: Char -> Bool +isCIdent '_' = True +isCIdent c = isAscii c && isAlphaNum 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 +parseFunctionRef :: Parser [Token] +parseFunctionRef = parseOldFunctionRef <|> parseNewFunctionRef + +-- | Parse an unresolved reference to a C symbol in new gtk-doc notation. +parseId :: Parser [Token] +parseId = do + _ <- string "[id@" + ident <- parseCIdent + _ <- char ']' + return [SymbolRef (OldFunctionRef ident)] + +-- | 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 (OldFunctionRef "test_func")] +-- +-- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func" +-- Right [Literal "not_a_func"] +parseOldFunctionRef :: Parser [Token] +parseOldFunctionRef = do + ident <- parseCIdent + option [Literal ident] (string "()" >> + return [SymbolRef (OldFunctionRef ident)]) + +-- | Parse a function name in new style, of the form +-- > [func@Namespace.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseFunctionRef <* endOfInput) "[func@Gtk.init]" +-- Right [SymbolRef (FunctionRef (AbsoluteName "Gtk" "init"))] +parseNewFunctionRef :: Parser [Token] +parseNewFunctionRef = do + _ <- string "[func@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ FunctionRef (AbsoluteName ns n)] + +-- | Parse a method name, of the form +-- > [method@Namespace.Object.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseMethod <* endOfInput) "[method@Gtk.Button.set_child]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Button") "set_child")] +-- +-- >>> parseOnly (parseMethod <* endOfInput) "[func@Gtk.Settings.get_for_display]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Settings") "get_for_display")] +parseMethod :: Parser [Token] +parseMethod = do + _ <- string "[method@" <|> string "[func@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + method <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ MethodRef (AbsoluteName ns n) method] + +-- | Parse a reference to a constructor, of the form +-- > [ctor@Namespace.Object.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseConstructor <* endOfInput) "[ctor@Gtk.Builder.new_from_file]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Builder") "new_from_file")] +parseConstructor :: Parser [Token] +parseConstructor = do + _ <- string "[ctor@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + method <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ MethodRef (AbsoluteName ns n) method] + +-- | Parse a reference to a type, of the form +-- > [class@Namespace.Name] +-- an interface of the form +-- > [iface@Namespace.Name] +-- or an enumeration type, of the form +-- > [enum@Namespace.Name] +-- +-- === __Examples__ +-- >>> parseOnly (parseClass <* endOfInput) "[class@Gtk.Dialog]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "Dialog"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[iface@Gtk.Editable]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "Editable"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[enum@Gtk.SizeRequestMode]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "SizeRequestMode"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[struct@GLib.Variant]" +-- Right [SymbolRef (TypeRef (AbsoluteName "GLib" "Variant"))] +parseClass :: Parser [Token] +parseClass = do + _ <- string "[class@" <|> string "[iface@" <|> + string "[enum@" <|> string "[struct@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ TypeRef (AbsoluteName ns n)] + +-- | Parse a reference to a member of the enum, of the form +-- > [enum@Gtk.FontRendering.AUTOMATIC] +-- +-- === __Examples__ +-- >>> parseOnly (parseEnumMember <* endOfInput) "[enum@Gtk.FontRendering.AUTOMATIC]" +-- Right [SymbolRef (EnumMemberRef (AbsoluteName "Gtk" "FontRendering") "automatic")] +parseEnumMember :: Parser [Token] +parseEnumMember = do + _ <- string "[enum@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + member <- takeWhile1 isCIdent + _ <- char ']' + -- Sometimes the references are written in uppercase while the name + -- of the member in the introspection data is written in lowercase, + -- so normalise everything to lowercase. (See the similar annotation + -- in CtoHaskellMap.hs.) + return [SymbolRef $ EnumMemberRef (AbsoluteName ns n) (T.toLower member)] + +parseSignal :: Parser [Token] +parseSignal = parseOldSignal <|> parseNewSignal + +-- | Parse an old style signal name, of the form -- > #Object::signal -- -- === __Examples__ --- >>> parseOnly (parseSignal <* endOfInput) "#GtkButton::activate" --- Right (SymbolRef (SignalRef "GtkButton" "activate")) -parseSignal :: Parser Token -parseSignal = do +-- >>> parseOnly (parseOldSignal <* endOfInput) "#GtkButton::activate" +-- Right [SymbolRef (OldSignalRef "GtkButton" "activate")] +parseOldSignal :: Parser [Token] +parseOldSignal = do _ <- char '#' obj <- parseCIdent _ <- string "::" signal <- signalOrPropName - return (SymbolRef (SignalRef obj signal)) + return [SymbolRef (OldSignalRef obj signal)] +-- | Parse a new style signal ref, of the form +-- > [signal@Namespace.Object::signal-name] +-- +-- === __Examples__ +-- >>> parseOnly (parseNewSignal <* endOfInput) "[signal@Gtk.AboutDialog::activate-link]" +-- Right [SymbolRef (SignalRef (AbsoluteName "Gtk" "AboutDialog") "activate-link")] +parseNewSignal :: Parser [Token] +parseNewSignal = do + _ <- string "[signal@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- string "::" + signal <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') + _ <- char ']' + return [SymbolRef (SignalRef (AbsoluteName ns n) signal)] + -- | Parse a reference to a signal defined in the current module, of the form -- > ::signal -- -- === __Examples__ -- >>> parseOnly (parseLocalSignal <* endOfInput) "::activate" --- Right (SymbolRef (LocalSignalRef "activate")) -parseLocalSignal :: Parser Token +-- Right [SymbolRef (LocalSignalRef "activate")] +parseLocalSignal :: Parser [Token] parseLocalSignal = do _ <- string "::" signal <- signalOrPropName - return (SymbolRef (LocalSignalRef signal)) + return [SymbolRef (LocalSignalRef signal)] --- | Parse a property name, of the form +-- | Parse a property name in the old style, 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 +-- >>> parseOnly (parseOldProperty <* endOfInput) "#GtkButton:always-show-image" +-- Right [SymbolRef (OldPropertyRef "GtkButton" "always-show-image")] +parseOldProperty :: Parser [Token] +parseOldProperty = do _ <- char '#' obj <- parseCIdent _ <- char ':' property <- signalOrPropName - return (SymbolRef (PropertyRef obj property)) + return [SymbolRef (OldPropertyRef obj property)] +-- | Parse a property name in the new style: +-- > [property@Namespace.Object:property-name] +-- +-- === __Examples__ +-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.ProgressBar:show-text]" +-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "ProgressBar") "show-text")] +-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.Editable:width-chars]" +-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "Editable") "width-chars")] +parseNewProperty :: Parser [Token] +parseNewProperty = do + _ <- string "[property@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- char ':' + property <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') + _ <- char ']' + return [SymbolRef (PropertyRef (AbsoluteName ns n) property)] + +-- | Parse a property +parseProperty :: Parser [Token] +parseProperty = parseOldProperty <|> parseNewProperty + -- | Parse an xml comment, of the form -- > -- Note that this function keeps spaces. -- -- === __Examples__ -- >>> parseOnly (parseComment <* endOfInput) "" --- Right (Comment " comment ") -parseComment :: Parser Token +-- Right [Comment " comment "] +parseComment :: Parser [Token] parseComment = do comment <- string "") - return (Comment $ T.pack comment) + return [Comment $ T.pack comment] --- | Parse a reference to a virtual method, of the form +-- | Parse an old style 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 +-- >>> parseOnly (parseOldVMethod <* endOfInput) "#Foo.bar()" +-- Right [SymbolRef (VMethodRef "Foo" "bar")] +parseOldVMethod :: Parser [Token] +parseOldVMethod = do _ <- char '#' obj <- parseCIdent _ <- char '.' method <- parseCIdent _ <- string "()" - return (SymbolRef (VMethodRef obj method)) + return [SymbolRef (VMethodRef obj method)] +-- | Parse a new style reference to a virtual function, of the form +-- > [vfunc@Namespace.Object.vfunc_name] +-- +-- >>> parseOnly (parseVFunc <* endOfInput) "[vfunc@Gtk.Widget.get_request_mode]" +-- Right [SymbolRef (VFuncRef (AbsoluteName "Gtk" "Widget") "get_request_mode")] +parseVFunc :: Parser [Token] +parseVFunc = do + _ <- string "[vfunc@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- char '.' + vfunc <- parseCIdent + _ <- char ']' + return [SymbolRef (VFuncRef (AbsoluteName ns n) vfunc)] + +-- | Parse a reference to a virtual method +parseVMethod :: Parser [Token] +parseVMethod = parseOldVMethod <|> parseVFunc + -- | 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 +-- Right [SymbolRef (StructFieldRef "Foo" "bar")] +parseStructField :: Parser [Token] parseStructField = do _ <- char '#' obj <- parseCIdent _ <- char '.' field <- parseCIdent - return (SymbolRef (StructFieldRef obj field)) + 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 +-- >>> parseOnly (parseCType <* endOfInput) "#Foo" +-- Right [SymbolRef (CTypeRef "Foo")] +parseCType :: Parser [Token] +parseCType = do _ <- char '#' obj <- parseCIdent - return (SymbolRef (TypeRef obj)) + return [SymbolRef (CTypeRef obj)] -- | Parse a constant, of the form -- > %CONSTANT_NAME -- -- === __Examples__ -- >>> parseOnly (parseConstant <* endOfInput) "%TEST_CONSTANT" --- Right (SymbolRef (ConstantRef "TEST_CONSTANT")) -parseConstant :: Parser Token +-- Right [SymbolRef (ConstantRef "TEST_CONSTANT")] +parseConstant :: Parser [Token] parseConstant = do _ <- char '%' c <- parseCIdent - return (SymbolRef (ConstantRef c)) + 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 +-- 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 + return [SymbolRef (ParamRef param)] -- | Name of a signal or property name. Similar to a C identifier, but -- hyphens are allowed too. @@ -321,42 +549,21 @@ 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 :: Parser [Token] parseEscaped = do _ <- char '\\' c <- satisfy (`elem` ("#@%\\`" :: [Char])) - return $ Literal (T.singleton c) + 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 :: Parser [Token] parseBoringLiteral = do c <- anyChar boring <- takeWhile (not . special) - return $ Literal (T.cons c boring) + 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 @@ -372,6 +579,7 @@ special '!' = True special '\n' = True special ':' = True +special '-' = True special c = isCIdent c -- | Parse a verbatim string, of the form @@ -379,51 +587,93 @@ -- -- === __Examples__ -- >>> parseOnly (parseVerbatim <* endOfInput) "`Example quote!`" --- Right (Verbatim "Example quote!") -parseVerbatim :: Parser Token +-- Right [Verbatim "Example quote!"] +parseVerbatim :: Parser [Token] parseVerbatim = do _ <- char '`' v <- takeWhile1 (/= '`') _ <- char '`' - return $ Verbatim v + 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 +-- 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} + 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 +-- 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} + return [Image $ Link {linkName = name, linkAddress = address}] -- | Parse a code block embedded in the documentation. -parseCodeBlock :: Parser Token -parseCodeBlock = do +parseCodeBlock :: Parser [Token] +parseCodeBlock = parseOldStyleCodeBlock <|> parseNewStyleCodeBlock + +-- | Parse a new style code block, of the form +-- > ```c +-- > some c code +-- > ``` +-- +-- === __Examples__ +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```c\nThis is C code\n```" +-- Right [CodeBlock (Just (Language "c")) "This is C code"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```\nThis is langless\n```" +-- Right [CodeBlock Nothing "This is langless"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```py\n This has space in front\n ```" +-- Right [CodeBlock (Just (Language "py")) " This has space in front"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```c\n new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);\n ```" +-- Right [CodeBlock (Just (Language "c")) " new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);"] +parseNewStyleCodeBlock :: Parser [Token] +parseNewStyleCodeBlock = do + _ <- takeWhile isHorizontalSpace + _ <- string "```" + lang <- T.strip <$> takeWhile (/= '\n') + _ <- char '\n' + let maybeLang = if T.null lang then Nothing + else Just lang + code <- T.pack <$> manyTill anyChar (string "\n" >> + takeWhile isHorizontalSpace >> + string "```") + return [CodeBlock (Language <$> maybeLang) code] + +-- | Parse an old style code block, of the form +-- > |[ code ]| +-- +-- === __Examples__ +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|" +-- Right [CodeBlock Nothing "this is code"] +-- +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is C code]|" +-- Right [CodeBlock (Just (Language "C")) "this is C code"] +parseOldStyleCodeBlock :: Parser [Token] +parseOldStyleCodeBlock = do _ <- string "|[" lang <- (Just <$> parseLanguage) <|> return Nothing code <- T.pack <$> manyTill anyChar (string "]|") - return $ CodeBlock lang code + return [CodeBlock lang code] -- | Parse the language of a code block, specified as a comment. parseLanguage :: Parser Language @@ -437,11 +687,30 @@ _ <- string "-->" return $ Language lang +-- | Parse at least one newline (or Start of String (SOS)), and keep +-- going while we see newlines. Return either the empty list (for the +-- case that we see a single SOS), or a singleton list with the +-- Literal representing the seen newlines, and removing the SOS. +parseInitialNewlines :: Parser [Token] +parseInitialNewlines = do + initial <- char '\n' <|> char startOfString + let initialString = if initial == '\n' + then "\n" + else "" + others <- T.pack <$> many' (char '\n') + let joint = initialString <> others + if T.null joint + then return [] + else return [Literal joint] + -- | 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 +parseSectionHeader :: Parser [Token] +parseSectionHeader = do + initialNewlines <- parseInitialNewlines + sectionHeader <- parseInitialSectionHeader + return $ initialNewlines <> sectionHeader -- | 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 @@ -449,39 +718,230 @@ -- -- === __Examples__ -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "### Hello! ###\n" --- Right (SectionHeader 3 (GtkDoc [Literal "Hello! "])) +-- Right [SectionHeader 3 (GtkDoc [Literal "Hello! "])] -- -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "# Hello!\n" --- Right (SectionHeader 1 (GtkDoc [Literal "Hello!"])) -parseInitialSectionHeader :: Parser Token +-- 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) + 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) +{- | Parse an unnumbered list. - parseLine :: Parser Text - parseLine = string "\n " >> takeWhile1 (/= '\n') +=== __Examples__ +>>> :{ +parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"- First item", +"- Second item" +] +:} +Right [UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] + +>>> :{ +parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +"", +"", +"- Two line", +" item", +"", +"- Second item,", +" with three lines", +" of text." +] +:} +Right [Literal "\n\n",UnnumberedList [GtkDoc [Literal "Two line\nitem"],GtkDoc [Literal "Second item,\nwith three lines\nof text."]]] +-} +parseUnnumberedList :: Parser [Token] +parseUnnumberedList = do + (initialNewlines, entries) <- parseList (string "- ") T.length + return $ initialNewlines <> [UnnumberedList (map snd entries)] + +{- | Parse a numbered list header. + +=== __Examples__ +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. First item,", +" written in two lines", +"", +"2. Second item,", +" also in two lines" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nalso in two lines"])]] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. First item,", +" written in two lines", +"2. Second item,", +" now in three lines,", +" written compactly" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nnow in three lines,\nwritten compactly"])]] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"9. This is a list entry with two lines,", +" with the second line in its own line.", +"10. If the label width changes,", +" the indentation of the second line should also be adjusted.", +"", +"11. You can optionally include an empty line between entries", +" without stopping the list.", +"", +" This also applies within list entries, this is still part of", +" entry 11.", +"12. But you don't have to." +] +:} +Right [NumberedList [("9",GtkDoc [Literal "This is a list entry with two lines,\nwith the second line in its own line."]),("10",GtkDoc [Literal "If the label width changes,\nthe indentation of the second line should also be adjusted."]),("11",GtkDoc [Literal "You can optionally include an empty line between entries\nwithout stopping the list.\n\nThis also applies within list entries, this is still part of\nentry 11."]),("12",GtkDoc [Literal "But you don't have to."])]] + +>>> :{ +parseGtkDoc $ T.stripEnd $ T.unlines [ +"1. A list with a single element", +"", +"And this is text not in the list, so we use parseGtkDoc." +] +:} +GtkDoc [NumberedList [("1",GtkDoc [Literal "A list with a single element"])],Literal "\n\nAnd this is text not in the list, so we use parseGtkDoc."] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. An example of a list in lenient mode,", +"where we don't require indenting this second line.", +"", +"2. In this mode entries can be optionally separated by an empty line.", +"3. But they don't need to" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "An example of a list in lenient mode,\nwhere we don't require indenting this second line."]),("2",GtkDoc [Literal "In this mode entries can be optionally separated by an empty line."]),("3",GtkDoc [Literal "But they don't need to"])]] +-} +parseNumberedList :: Parser [Token] +parseNumberedList = do + (initialNewlines, list) <- parseList (do idx <- takeWhile1 isDigit + _ <- string ". " + return idx) + (\label -> T.length label + 2) + return $ initialNewlines <> [NumberedList list] + +{- | The indent parsing mode. In strict mode we require that all the + text in the lines is indented relative to the label, as in the + following example: + + 1. The first line, + and the second line + + In this mode we allow empty lines in the entry. + 2. This is the second entry. + + In lenient mode we drop this restriction, so the following is valid: + 1. The first line, + and the second line + In this mode we _do not_ allow empty lines in the entry. + 2. This is the second entry. +-} +data IndentParsingMode = Lenient | Strict + deriving (Eq) + +{- | Parse an unnumbered or numbered list. See 'parseNumberedList' and + 'parseUnnumberedList' for examples. +-} +parseList :: Parser Text -> (Text -> Int) -> + Parser ([Token], [(Text, GtkDoc)]) +parseList labelParser indent = + doParseList Lenient <|> doParseList Strict + where + doParseList :: IndentParsingMode -> + Parser ([Token], [(Text, GtkDoc)]) + doParseList mode = do + -- Consume the initial newlines before parseListItem does, so we can + -- restore the initial newlines after. We impose that there is at + -- least a newline (or Start of String symbol) before the start of + -- the list. + initialNewlines <- parseInitialNewlines + (initialSpace, first) <- + parseListItem (takeWhile isHorizontalSpace) (pure ()) + -- We allow either one or zero empty lines between entries. + let newlineParser = (string "\n\n" <|> string "\n") >> pure () + rest <- map snd <$> + many' (parseListItem (string initialSpace) newlineParser) + -- Validate the resulting entries, and assemble them into GtkDoc. + validated <- forM (first : rest) $ \(label, (firstLine, otherLines)) -> do + validate label otherLines + return (label, + parseGtkDoc $ T.strip $ T.unlines $ firstLine : otherLines) + + return (initialNewlines, validated) + + where + parseListItem :: Parser Text -> Parser () -> + Parser (Text, (Text, (Text, [Text]))) + parseListItem parseInitialSpace startingNewlines = do + startingNewlines + initialSpace <- parseInitialSpace + label <- labelParser + first <- takeWhile (/= '\n') + let padding = case mode of + Strict -> initialSpace <> T.replicate (indent label) " " + Lenient -> initialSpace + paddingParser = string padding + + rest <- many' (parseLine paddingParser) + + return (initialSpace, (label, (first, rest))) + + parseLine :: Parser Text -> Parser Text + parseLine paddingParser = do + emptyLines <- case mode of + -- We do not allow empty lines in entries in the lenient + -- indent parser, while the strict indent one allows one + -- at most. + Strict -> option "" emptyLine + Lenient -> pure "" + _ <- char '\n' >> paddingParser + contents <- takeWhile1 (/= '\n') + when (startsWith labelParser contents) $ + fail "Line starting with a label" + return $ emptyLines <> contents + + emptyLine = do + _ <- char '\n' + maybeNext <- peekChar + guard $ maybeNext == Nothing || maybeNext == Just '\n' + return ("\n" :: Text) + + startsWith :: Parser a -> Text -> Bool + startsWith p l = isRight $ parseOnly p l + + validate :: Text -> [Text] -> Parser () + validate _ [] = pure () + validate label lines = case mode of + Strict -> pure () + Lenient -> do + let extraIndent = string $ T.replicate (indent label) " " + + -- If every line has extra padding we are most likely in + -- the wrong mode too. + when (all (startsWith extraIndent) lines) $ + fail "All lines have extra indent" + +-- | Turn an ordinary `Name` into a `DocSymbolName` +docName :: Name -> DocSymbolName +docName (Name ns n) = AbsoluteName ns n + +-- | Return a `Name` from a potentially relative `DocSymbolName`, +-- using the provided default namespace if the name is relative. +resolveDocSymbol :: DocSymbolName -> Text -> Name +resolveDocSymbol (AbsoluteName ns n) _ = Name ns n +resolveDocSymbol (RelativeName n) defaultNS = Name defaultNS n diff --git a/lib/Data/GI/CodeGen/Haddock.hs b/lib/Data/GI/CodeGen/Haddock.hs --- a/lib/Data/GI/CodeGen/Haddock.hs +++ b/lib/Data/GI/CodeGen/Haddock.hs @@ -23,6 +23,7 @@ import Data.Text (Text) import Data.GI.GIR.Arg (Arg(..)) +import Data.GI.GIR.BasicTypes (Name(Name)) import Data.GI.GIR.Callable (Callable(..)) import Data.GI.GIR.Deprecation (DeprecationInfo(..)) import Data.GI.GIR.Documentation (Documentation(..)) @@ -32,9 +33,11 @@ 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) + Link(..), parseGtkDoc, + DocSymbolName(..), resolveDocSymbol, docName) import Data.GI.CodeGen.Overrides (onlineDocsMap) -import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName) +import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName, + haddockSignalAnchor) -- | Where is the documentation located with respect to the relevant -- symbol, useful for determining whether we want to start with @|@ or @^@. @@ -47,60 +50,111 @@ -- delimiters are not included in the output. -- -- === __Examples__ --- >>> formatHaddock M.empty "" (GtkDoc [Literal "Hello ", Literal "World!"]) +-- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "Hello ", Literal "World!"]) -- "Hello World!" -- --- >>> let c2h = M.fromList [(FunctionRef "foo", ValueIdentifier "foo")] --- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")]) +-- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "This is a **bold** world!"]) +-- "This is a __bold__ world!" +-- +-- >>> let c2h = M.fromList [(OldFunctionRef "foo", ValueIdentifier "foo")] +-- >>> formatHaddock c2h "" "Test" (GtkDoc [SymbolRef (OldFunctionRef "foo")]) -- "'foo'" -- -- >>> let onlineDocs = "http://wiki.haskell.org" --- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) +-- >>> formatHaddock M.empty onlineDocs "Test" (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) -- "" -- --- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]]) --- "\n* <>\n" -formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text -formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [UnnumberedList [GtkDoc [Image (Link "test" "test.png")]]]) +-- "* <>\n" +-- +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [NumberedList [("1", GtkDoc [Literal "Hi!"]), ("2", GtkDoc [Literal "Second and very long, so split\n line."])]]) +-- "1. Hi!\n\n2. Second and very long, so split\n line.\n\n" +formatHaddock :: M.Map CRef Hyperlink -> Text -> Text -> GtkDoc -> Text +formatHaddock c2h docBase defaultNS (GtkDoc tokens) = T.concat $ map formatToken tokens where formatToken :: Token -> Text - formatToken (Literal l) = escape l + formatToken (Literal l) = escape (convertBold l) formatToken (Comment _) = "" 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 (SectionHeader l h) = + formatSectionHeader c2h docBase defaultNS l h + formatToken (UnnumberedList l) = + formatUnnumberedList c2h docBase defaultNS l + formatToken (NumberedList l) = + formatNumberedList c2h docBase defaultNS l formatToken (SymbolRef cr) = case M.lookup cr c2h of Just hr -> formatHyperlink hr - Nothing -> formatUnknownCRef c2h cr + Nothing -> formatUnknownCRef c2h defaultNS cr --- | Format a `CRef` whose Haskell representation is not known. -formatUnknownCRef :: M.Map CRef Hyperlink -> CRef -> Text -formatUnknownCRef _ (FunctionRef f) = formatCRef $ f <> "()" -formatUnknownCRef _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" -formatUnknownCRef _ (LocalSignalRef s) = + -- Markdown accepts both two underscores and two stars as + -- indicating bold, but Haddock only accepts two underscores. + convertBold :: Text -> Text + convertBold l = T.replace "**" "__" l + +-- | Format a `CRef` whose Haskell representation is not known, using +-- a provided default namespace for relative symbols. +formatUnknownCRef :: M.Map CRef Hyperlink -> Text -> CRef -> Text +formatUnknownCRef _ _ (OldFunctionRef f) = formatCRef $ f <> "()" +formatUnknownCRef _ defaultNS (FunctionRef n) = + formatCRef $ formatDocSymbol n defaultNS +formatUnknownCRef _ _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" +formatUnknownCRef _ _ (LocalSignalRef s) = let sn = signalHaskellName s - in "[" <> sn <> "](#g:signal:" <> sn <> ")" -formatUnknownCRef c2h (SignalRef owner signal) = - case M.lookup (TypeRef owner) c2h of + in "[" <> sn <> "](#" <> haddockSignalAnchor <> sn <> ")" +formatUnknownCRef c2h defaultNS (SignalRef docSymbol signal) = + let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS + in case M.lookup (TypeRef (docName owner)) c2h of + Nothing -> formatCRef $ ns <> "." <> n <> "::" <> signal + Just r -> formatHyperlink r <> "::" <> formatCRef signal +formatUnknownCRef c2h _ (OldSignalRef owner signal) = + case M.lookup (CTypeRef 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 +formatUnknownCRef c2h _ (OldPropertyRef owner prop) = + case M.lookup (CTypeRef 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 +formatUnknownCRef c2h defaultNS (PropertyRef docSymbol prop) = + let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS + in case M.lookup (TypeRef (docName owner)) c2h of + Nothing -> formatCRef $ ns <> "." <> n <> ":" <> prop + Just r -> formatHyperlink r <> ":" <> formatCRef prop +formatUnknownCRef c2h _ (VMethodRef owner vmethod) = + case M.lookup (CTypeRef 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 +formatUnknownCRef c2h defaultNS (VFuncRef docSymbol vmethod) = + let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS + in case M.lookup (TypeRef (docName owner)) c2h of + Nothing -> formatCRef $ ns <> "." <> n <> "." <> vmethod <> "()" + Just r -> formatHyperlink r <> "." <> formatCRef vmethod <> "()" +formatUnknownCRef c2h defaultNS(MethodRef docSymbol method) = + let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS + in case M.lookup (TypeRef (docName owner)) c2h of + Nothing -> formatCRef $ ns <> "." <> n <> "." <> method <> "()" + Just r -> formatHyperlink r <> "." <> formatCRef method <> "()" +formatUnknownCRef c2h _ (StructFieldRef owner field) = + case M.lookup (CTypeRef owner) c2h of Nothing -> formatCRef $ owner <> "." <> field Just r -> formatHyperlink r <> "." <> formatCRef field -formatUnknownCRef _ (TypeRef t) = formatCRef t -formatUnknownCRef _ (ConstantRef t) = formatCRef t +formatUnknownCRef _ _ (CTypeRef t) = formatCRef t +formatUnknownCRef _ defaultNS (TypeRef n) = + formatCRef $ formatDocSymbol n defaultNS +formatUnknownCRef _ _ (ConstantRef t) = formatCRef t +formatUnknownCRef c2h defaultNS (EnumMemberRef docSymbol member) = + let owner@(Name ns n) = resolveDocSymbol docSymbol defaultNS + in case M.lookup (TypeRef (docName owner)) c2h of + Nothing -> formatCRef $ ns <> "." <> n <> "." <> member + Just r -> formatHyperlink r <> "." <> formatCRef member +-- | Format the given symbol name in a fully qualified way, using the +-- default namespace if needed. +formatDocSymbol :: DocSymbolName -> Text -> Text +formatDocSymbol (RelativeName n) defaultNS = defaultNS <> "." <> n +formatDocSymbol (AbsoluteName ns n) _ = ns <> "." <> n + -- | Formatting for an unknown C reference. formatCRef :: Text -> Text formatCRef t = "@/" <> escape t <> "/@" @@ -119,7 +173,8 @@ formatCodeBlock :: Maybe Language -> Text -> Text formatCodeBlock maybeLang code = let header = case maybeLang of - Nothing -> "" + Nothing -> "\n\t\n" -- This is to convince haddock that we + -- are indeed starting a code block Just (Language lang) -> "\n=== /" <> lang <> " code/\n" birdTrack = T.unlines . map (T.cons '>') . T.lines in header <> birdTrack code @@ -153,21 +208,40 @@ -- | 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" +formatSectionHeader :: M.Map CRef Hyperlink -> Text -> Text -> Int -> GtkDoc -> Text +formatSectionHeader c2h docBase defaultNS level header = + T.replicate level "=" <> " " <> formatHaddock c2h docBase defaultNS 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) +formatUnnumberedList :: M.Map CRef Hyperlink -> Text -> Text -> [GtkDoc] + -> Text +formatUnnumberedList c2h docBase defaultNS items = + T.concat (map formatListItem items) + where formatListItem :: GtkDoc -> Text + formatListItem doc = + let indent l = " " <> T.stripStart l + formatted = formatHaddock c2h docBase defaultNS doc + indented = (T.unlines . map indent . T.lines) formatted + in "* " <> T.stripStart indented - format :: GtkDoc -> Text - format = formatHaddock c2h docBase +-- | Format a numbered list of items. +formatNumberedList :: M.Map CRef Hyperlink -> Text -> Text -> [(Text, GtkDoc)] + -> Text +formatNumberedList c2h docBase defaultNS items = + T.concat (formatEnumeration items) + where + formatEnumeration :: [(Text, GtkDoc)] -> [Text] + formatEnumeration [] = [] + formatEnumeration ((idx, doc):rest) = + formatListItem idx doc <> "\n" : formatEnumeration rest + formatListItem :: Text -> GtkDoc -> Text + formatListItem idx doc = + let indent l = T.replicate (T.length idx + 2) " " <> T.stripStart l + formatted = formatHaddock c2h docBase defaultNS doc + indented = (T.unlines . map indent . T.lines) formatted + in idx <> ". " <> T.stripStart indented + -- | Escape the reserved Haddock characters in a given `Text`. -- -- === __Examples__ @@ -205,12 +279,14 @@ deprecatedPragma name (Just info) = do c2h <- getC2HMap docBase <- getDocBase + defaultNS <- modName <$> config line $ "{-# DEPRECATED " <> name <> " " <> - (T.pack . show) (note <> reason c2h docBase) <> " #-}" - where reason c2h docBase = + (T.pack . show) (note <> reason c2h docBase defaultNS) <> " #-}" + where reason c2h docBase defaultNS = case deprecationMessage info of Nothing -> [] - Just msg -> map (formatHaddock c2h docBase . parseGtkDoc) + Just msg -> map (formatHaddock c2h docBase defaultNS + . parseGtkDoc) (T.lines msg) note = case deprecatedSinceVersion info of Nothing -> [] @@ -218,10 +294,10 @@ -- | Format the given documentation into a set of lines. Note that -- this does include the opening or ending comment delimiters. -formatDocumentation :: M.Map CRef Hyperlink -> Text -> Documentation -> Text -formatDocumentation c2h docBase doc = do +formatDocumentation :: M.Map CRef Hyperlink -> Text -> Text -> Documentation -> Text +formatDocumentation c2h docBase defaultNS doc = do let description = case rawDocText doc of - Just raw -> formatHaddock c2h docBase (parseGtkDoc raw) + Just raw -> formatHaddock c2h docBase defaultNS (parseGtkDoc raw) Nothing -> "/No description available in the introspection data./" description <> case sinceVersion doc of Nothing -> "" @@ -232,7 +308,8 @@ writeDocumentation pos doc = do c2h <- getC2HMap docBase <- getDocBase - writeHaddock pos (formatDocumentation c2h docBase doc) + defaultNS <- modName <$> config + writeHaddock pos (formatDocumentation c2h docBase defaultNS doc) -- | Like `writeDocumentation`, but allows us to pass explicitly the -- Haddock comment to write. @@ -254,8 +331,9 @@ Just raw -> do c2h <- getC2HMap docBase <- getDocBase + defaultNS <- modName <$> config let haddock = "/@" <> lowerSymbol (argCName arg) <> "@/: " <> - formatHaddock c2h docBase (parseGtkDoc raw) + formatHaddock c2h docBase defaultNS (parseGtkDoc raw) writeHaddock DocAfterSymbol haddock -- | Write the documentation for the given return value. @@ -263,12 +341,13 @@ writeReturnDocumentation callable skip = do c2h <- getC2HMap docBase <- getDocBase + defaultNS <- modName <$> config let returnValInfo = if skip then [] else case rawDocText (returnDocumentation callable) of Nothing -> [] Just raw -> ["__Returns:__ " <> - formatHaddock c2h docBase + formatHaddock c2h docBase defaultNS (parseGtkDoc raw)] throwsInfo = if callableThrows callable then ["/(Can throw 'Data.GI.Base.GError.GError')/"] @@ -282,5 +361,6 @@ addSectionDocumentation section doc = do c2h <- getC2HMap docBase <- getDocBase - let formatted = formatDocumentation c2h docBase doc + defaultNS <- modName <$> config + let formatted = formatDocumentation c2h docBase defaultNS doc addSectionFormattedDocs section formatted diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -81,7 +81,7 @@ group $ do let resolver = "Resolve" <> name <> "Method" export (Section MethodSection) resolver - line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where" + line $ "type family " <> resolver <> " (t :: Symbol) (o :: DK.Type) :: DK.Type where" indent $ forM_ infos $ \(label, info) -> do line $ resolver <> " \"" <> label <> "\" o = " <> info indent $ line $ resolver <> " l o = O.MethodResolutionFailed l o" @@ -126,6 +126,15 @@ <> "#g:method:" <> mn <> "\")" return $ T.intercalate ", " qualifiedMethods <> ".\n" +-- | Treat the instance argument of a method as non-null, even if the +-- introspection data may say otherwise. Returns the modified +-- callable, together with a boolean value indicating where the +-- nullability annotation has been erased. +nonNullableInstanceArg :: Callable -> (Callable, Bool) +nonNullableInstanceArg c = case args c of + inst:rest -> (c {args = inst {mayBeNull = False} : rest}, mayBeNull inst) + [] -> (c, False) + -- | Generate the `MethodInfo` type and instance for the given method. genMethodInfo :: Name -> Method -> ExcCodeGen () genMethodInfo n m = @@ -133,14 +142,15 @@ group $ do api <- findAPIByName n infoName <- methodInfoName n m - let callable = fixupCallerAllocates (methodCallable m) + let (callable, nullableInstance) = + nonNullableInstanceArg . fixupCallerAllocates $ methodCallable m sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures bline $ "data " <> infoName - -- This should not happen, since ordinary methods always - -- have the instance as first argument. - when (null (signatureArgTypes sig)) $ - error $ "Internal error: too few parameters! " ++ show m - let (obj:otherTypes) = map snd (signatureArgTypes sig) + let (obj, otherTypes) = case map snd (signatureArgTypes sig) of + -- This should not happen, since ordinary methods always + -- have the instance as first argument. + [] -> error $ "Internal error: too few parameters! " ++ show m + (obj':otherTypes') -> (obj', otherTypes') sigConstraint = "signature ~ (" <> T.intercalate " -> " (otherTypes ++ [signatureReturnType sig]) <> ")" @@ -154,18 +164,20 @@ <> T.intercalate ", " (sigConstraint : signatureConstraints sig) <> ") => O.OverloadedMethod " <> infoName <> " " <> obj <> " signature where" - indent $ line $ "overloadedMethod = " <> mangled + if nullableInstance + then indent $ line $ "overloadedMethod i = " <> mangled <> " (Just i)" + else indent $ line $ "overloadedMethod = " <> mangled group $ do line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj <> " where" indent $ do - line $ "overloadedMethodInfo = O.MethodInfo {" + line $ "overloadedMethodInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do - line $ "O.overloadedMethodName = \"" <> dbgInfo <> "\"," - line $ "O.overloadedMethodURL = \"" <> + line $ "O.resolvedSymbolName = \"" <> dbgInfo <> "\"," + line $ "O.resolvedSymbolURL = \"" <> hackageLink <> "#v:" <> mangled <> "\"" - line $ "}" + line $ "})" export (NamedSubsection MethodSection $ lowerName mn) infoName diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs --- a/lib/Data/GI/CodeGen/OverloadedSignals.hs +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -36,7 +36,7 @@ let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " - <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" + <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen e () @@ -51,4 +51,4 @@ let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " - <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" + <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])" diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs --- a/lib/Data/GI/CodeGen/Overrides.hs +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -11,6 +11,9 @@ import Data.Traversable (traverse) #endif +#if MIN_VERSION_base(4,18,0) +import Control.Monad (foldM) +#endif import Control.Monad.Except import Control.Monad.State import Control.Monad.Writer (WriterT, execWriterT, tell) diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -24,7 +24,7 @@ homepage = "https://github.com/haskell-gi/haskell-gi" authors :: Text -authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte" +authors = "Will Thompson and Iñaki García Etxebarria" maintainers :: Text maintainers = "Iñaki García Etxebarria" @@ -39,7 +39,8 @@ "OverloadedStrings", "NegativeLiterals", "ConstraintKinds", "TypeFamilies", "MultiParamTypeClasses", "KindSignatures", "FlexibleInstances", "UndecidableInstances", "DataKinds", - "FlexibleContexts", "UndecidableSuperClasses"] + "FlexibleContexts", "UndecidableSuperClasses", + "TypeOperators"] -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default. @@ -62,7 +63,7 @@ standardDeps :: [Text] standardDeps = ["bytestring >= 0.10 && < 1", "containers >= 0.5 && < 1", - "text >= 1.0 && < 2", + "text >= 1.0 && < 3", "transformers >= 0.4 && < 1"] -- | Under which category in hackage should the generated bindings be listed. diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -25,11 +25,14 @@ import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint, hyphensToCamelCase, qualifiedSymbol, typeConstraint, callbackDynamicWrapper, callbackHaskellToForeign, - callbackWrapperAllocator, safeCast) + callbackWrapperAllocator, safeCast, + hackageModuleLink, moduleLocation, + haddockAttrAnchor) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -275,7 +278,7 @@ -- | Generate documentation for the given constructor. constructorDoc :: Property -> Text constructorDoc prop = T.unlines [ - "Construct a `GValueConstruct` with valid value for the “@" <> propName prop <> "@” property. This is rarely needed directly, but it is used by `Data.GI.Base.Constructible.new`." + "Construct a t'GValueConstruct' with valid value for the “@" <> propName prop <> "@” property. This is rarely needed directly, but it is used by `Data.GI.Base.Constructible.new`." ] genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () @@ -376,7 +379,8 @@ genOneProperty owner prop = do let name = upperName owner cName = (hyphensToCamelCase . propName) prop - docSection = NamedSubsection PropertySection (lcFirst cName) + lcAttr = lcFirst cName + docSection = NamedSubsection PropertySection lcAttr pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags && @@ -444,6 +448,8 @@ transferType <- if writable || constructOnly then propTransferType (propType prop) else return "()" + let puttable = readable && writable && inConstraint == ("(~) " <> outType) + let allowedOps = (if writable then ["'AttrSet", "'AttrConstruct"] else []) @@ -456,8 +462,16 @@ <> (if isNullable && propWriteNullable prop /= Just False then ["'AttrClear"] else []) + <> (if puttable + then ["'AttrPut"] + else []) it <- infoType owner prop export docSection it + api <- findAPIByName owner + hackageLink <- hackageModuleLink owner + let qualifiedAttrName = dotModulePath (moduleLocation owner api) + <> "." <> lcAttr + attrInfoURL = hackageLink <> "#" <> haddockAttrAnchor <> lcAttr bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do @@ -474,12 +488,20 @@ line $ "type AttrOrigin " <> it <> " = " <> name line $ "attrGet = " <> getter line $ "attrSet = " <> setter + if puttable + then line $ "attrPut = " <> setter + else line $ "attrPut = undefined" if writable || constructOnly then do line $ "attrTransfer _ v = do" indent $ genPropTransfer "v" (propType prop) else line $ "attrTransfer _ = undefined" line $ "attrConstruct = " <> constructor line $ "attrClear = " <> clear + line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\"" + line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\"" + line $ "})" -- | Generate a placeholder property for those cases in which code -- generation failed. @@ -525,7 +547,7 @@ line $ "instance O.HasAttributeList " <> name line $ "type instance O.AttributeList " <> name <> " = " <> propListType line $ "type " <> propListType <> " = ('[ " - <> T.intercalate ", " allProps <> "] :: [(Symbol, *)])" + <> T.intercalate ", " allProps <> "] :: [(Symbol, DK.Type)])" -- | Generate gtk2hs compatible attribute labels (to ease -- porting). These are namespaced labels, for examples diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -6,7 +6,7 @@ import Control.Monad (forM, forM_, when, unless) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -27,6 +27,7 @@ RelativeDocPosition(..), writeHaddock, writeDocumentation, writeArgDocumentation, writeReturnDocumentation) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type @@ -37,8 +38,8 @@ -- | The prototype of the callback on the Haskell side (what users of -- the binding will see) genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures -> - Documentation -> ExcCodeGen () -genHaskellCallbackPrototype subsec cb htype expose doc = group $ do + Bool -> Documentation -> ExcCodeGen () +genHaskellCallbackPrototype subsec cb htype expose isSignal doc = group $ do let name' = case expose of WithClosures -> callbackHTypeWithClosures htype WithoutClosures -> htype @@ -65,13 +66,14 @@ line $ returnArrow <> typeShow (io ret) writeReturnDocumentation cb False - blank + when (not isSignal) $ do + blank - -- For optional parameters, in case we want to pass Nothing. - export (NamedSubsection SignalSection subsec) ("no" <> name') - writeHaddock DocBeforeSymbol (noCallbackDoc name') - line $ "no" <> name' <> " :: Maybe " <> name' - line $ "no" <> name' <> " = Nothing" + -- For optional parameters, in case we want to pass Nothing. + export (NamedSubsection SignalSection subsec) ("no" <> name') + writeHaddock DocBeforeSymbol (noCallbackDoc name') + line $ "no" <> name' <> " :: Maybe " <> name' + line $ "no" <> name' <> " = Nothing" where noCallbackDoc :: Text -> Text noCallbackDoc typeName = @@ -80,25 +82,31 @@ -- | Generate the type synonym for the prototype of the callback on -- the C side. Returns the name given to the type synonym. -genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen e Text -genCCallbackPrototype subsec cb name' isSignal = group $ do +genCCallbackPrototype :: Text -> Callable -> Text -> + Maybe Text -> CodeGen e Text +genCCallbackPrototype subsec cb name' maybeOwner = group $ do let ctypeName = callbackCType name' + isSignal = isJust maybeOwner - export (NamedSubsection SignalSection subsec) ctypeName - writeHaddock DocBeforeSymbol ccallbackDoc + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) ctypeName + writeHaddock DocBeforeSymbol ccallbackDoc line $ "type " <> ctypeName <> " =" indent $ do - when isSignal $ line $ withComment "Ptr () ->" "object" + maybe (return ()) + (\owner -> line $ withComment ("Ptr " <> owner <> " ->") "object") + maybeOwner forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg - let ht' = if direction arg /= DirectionIn + let ht' = if direction arg /= DirectionIn && + not (argCallerAllocates arg) then ptr ht else ht line $ typeShow ht' <> " ->" when (callableThrows cb) $ line "Ptr (Ptr GError) ->" - when isSignal $ line $ withComment "Ptr () ->" "user_data" + when (isJust maybeOwner) $ line $ withComment "Ptr () ->" "user_data" ret <- io <$> case returnType cb of Nothing -> return $ con0 "()" Just t -> foreignType t @@ -110,14 +118,15 @@ ccallbackDoc = "Type for the callback on the (unwrapped) C side." -- | Generator for wrappers callable from C -genCallbackWrapperFactory :: Text -> Text -> CodeGen e () -genCallbackWrapperFactory subsec name' = group $ do +genCallbackWrapperFactory :: Text -> Text -> Bool -> CodeGen e () +genCallbackWrapperFactory subsec name' isSignal = group $ do let factoryName = callbackWrapperAllocator name' writeHaddock DocBeforeSymbol factoryDoc line "foreign import ccall \"wrapper\"" indent $ line $ factoryName <> " :: " <> callbackCType name' <> " -> IO (FunPtr " <> callbackCType name' <> ")" - export (NamedSubsection SignalSection subsec) factoryName + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) factoryName where factoryDoc :: Text factoryDoc = "Generate a function pointer callable from C code, from a `" @@ -141,8 +150,8 @@ return (prime drop) -- | Generator of closures -genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen e () -genClosure subsec cb callback name isSignal = group $ do +genClosure :: Text -> Callable -> Text -> Text -> CodeGen e () +genClosure subsec cb callback name = group $ do let closure = callbackClosureGenerator name export (NamedSubsection SignalSection subsec) closure writeHaddock DocBeforeSymbol closureDoc @@ -151,20 +160,23 @@ <> callbackCType callback <> ")" line $ closure <> " cb = liftIO $ do" indent $ do - wrapped <- genWrappedCallback cb "cb" callback isSignal + wrapped <- genWrappedCallback cb "cb" callback False line $ callbackWrapperAllocator callback <> " " <> wrapped <> " >>= B.GClosure.newGClosure" where closureDoc :: Text closureDoc = "Wrap the callback into a `GClosure`." --- Wrap a conversion of a nullable object into "Maybe" object, by +-- | Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL. -convertNullable :: Text -> CodeGen e Text -> CodeGen e Text -convertNullable aname c = do +convertNullable :: Text -> CodeGen e Text -> Type -> CodeGen e Text +convertNullable aname c t = do + nullPtr <- nullPtrForType t >>= \case + Nothing -> terror $ "Unexpected non-pointer type " <> tshow t + Just null -> pure null line $ "maybe" <> ucFirst aname <> " <-" indent $ do - line $ "if " <> aname <> " == nullPtr" + line $ "if " <> aname <> " == " <> nullPtr line "then return Nothing" line "else do" indent $ do @@ -178,7 +190,7 @@ convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = if length > -1 then wrapMaybe arg >>= bool convertAndFree - (convertNullable aname convertAndFree) + (convertNullable aname convertAndFree t) else -- Not much we can do, we just pass the pointer along, and let -- the callback deal with it. @@ -211,7 +223,7 @@ t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name _ -> do let c = convert name $ transientToH (argType arg) (transfer arg) - wrapMaybe arg >>= bool c (convertNullable name c) + wrapMaybe arg >>= bool c (convertNullable name c (argType arg)) prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do @@ -267,24 +279,26 @@ -- FunPtr will be freed by someone else (the function registering the -- callback for ScopeTypeCall, or a destroy notifier for -- ScopeTypeNotified). -genCallbackWrapper :: Text -> Callable -> Text -> Bool -> ExcCodeGen () -genCallbackWrapper subsec cb name' isSignal = group $ do +genCallbackWrapper :: Text -> Callable -> Text -> + Maybe Text -> CodeGen e () +genCallbackWrapper subsec cb name' maybeOwner = group $ do let wrapperName = callbackHaskellToForeign name' (hInArgs, _) = callableHInArgs cb WithClosures hOutArgs = callableHOutArgs cb wrapperDoc = "Wrap a `" <> name' <> "` into a `" <> callbackCType name' <> "`." + isSignal = isJust maybeOwner - export (NamedSubsection SignalSection subsec) wrapperName - writeHaddock DocBeforeSymbol wrapperDoc + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) wrapperName + writeHaddock DocBeforeSymbol wrapperDoc group $ do - line $ wrapperName <> " ::" + line $ wrapperName <> " :: " indent $ do if isSignal - then do - line $ name' <> " ->" - else do + then line $ "GObject a => (a -> " <> name' <> ") ->" + else do line $ "Maybe (Ptr (FunPtr " <> callbackCType name' <> ")) ->" let hType = if callableHasClosures cb then callbackHTypeWithClosures name' @@ -295,10 +309,15 @@ let cArgNames = map escapedArgName (args cb) allArgs = if isSignal - then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"] - else T.unwords $ ["funptrptr", "_cb"] <> cArgNames + then T.unwords $ ["gi'cb", "gi'selfPtr"] <> cArgNames <> ["_"] + else T.unwords $ ["gi'funptrptr", "gi'cb"] <> cArgNames line $ wrapperName <> " " <> allArgs <> " = do" - indent $ do + handleCGExc (\e -> indent $ do + line $ "-- XXX Could not generate callback wrapper for " + <> name' + printCGError e + line $ "P.error \"The bindings for " <> wrapperName <> " could not be generated, function unsupported.\"" + ) $ indent $ do hInNames <- forM hInArgs (prepareArgForCall cb) let maybeReturn = case returnType cb of @@ -310,11 +329,18 @@ [] -> "" [r] -> r <> " <- " _ -> mkTuple returnVars <> " <- " - line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames) + if isSignal + then line $ returnBind + <> "B.ManagedPtr.withNewObject" + <> " gi'selfPtr $ \\gi'self -> " + <> "gi'cb (Coerce.coerce gi'self) " + <> T.concat (map (" " <>) hInNames) + else line $ returnBind <> "gi'cb " <> T.concat (map (" " <>) hInNames) + forM_ hOutArgs saveOutArg - unless isSignal $ line "maybeReleaseFunPtr funptrptr" + unless isSignal $ line "maybeReleaseFunPtr gi'funptrptr" case returnType cb of Nothing -> return () @@ -322,7 +348,7 @@ nullableReturnType <- typeIsNullable r if returnMayBeNull cb && nullableReturnType then do - line "maybeM nullPtr result $ \\result' -> do" + line "maybeM FP.nullPtr result $ \\result' -> do" indent $ unwrapped "result'" else unwrapped "result" where @@ -348,14 +374,14 @@ line $ "-- XXX Could not generate callback wrapper for " <> name' printCGError e) $ do - typeSynonym <- genCCallbackPrototype name' cb' name' False + typeSynonym <- genCCallbackPrototype name' cb' name' Nothing dynamic <- genDynamicCallableWrapper n typeSynonym cb export (NamedSubsection SignalSection name') dynamic - genCallbackWrapperFactory name' name' + genCallbackWrapperFactory name' name' False deprecatedPragma name' (callableDeprecated cb') - genHaskellCallbackPrototype name' cb' name' WithoutClosures cbDoc + genHaskellCallbackPrototype name' cb' name' WithoutClosures False cbDoc when (callableHasClosures cb') $ do - genHaskellCallbackPrototype name' cb' name' WithClosures cbDoc + genHaskellCallbackPrototype name' cb' name' WithClosures False cbDoc genDropClosures name' cb' name' if callableThrows cb' then do @@ -379,14 +405,19 @@ line $ "-- No Haskell->C wrapper generated since the function throws." blank else do - genClosure name' cb' name' name' False - genCallbackWrapper name' cb' name' False + genClosure name' cb' name' name' + genCallbackWrapper name' cb' name' Nothing -- | Generate the given signal instance for the given API object. genSignalInfoInstance :: Name -> Signal -> CodeGen e () genSignalInfoInstance owner signal = group $ do + api <- findAPIByName owner let name = upperName owner - let sn = (ucFirst . signalHaskellName . sigName) signal + sn = (ucFirst . signalHaskellName . sigName) signal + lcSignal = lcFirst sn + qualifiedSignalName = dotModulePath (moduleLocation owner api) + <> "::" <> sigName signal + hackageLink <- hackageModuleLink owner si <- signalInfoName owner signal bline $ "data " <> si line $ "instance SignalInfo " <> si <> " where" @@ -395,8 +426,14 @@ cbHaskellType = signalConnectorName <> "Callback" line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType line $ "connectSignal obj cb connectMode detail = do" - indent $ genSignalConnector signal cbHaskellType "connectMode" "detail" - export (NamedSubsection SignalSection $ lcFirst sn) si + indent $ do + genSignalConnector signal cbHaskellType "connectMode" "detail" "cb" + line $ "dbgSignalInfo = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> qualifiedSignalName <> "\"" + line $ ", O.resolvedSymbolURL = \"" <> hackageLink <> "#" + <> haddockSignalAnchor <> lcSignal <> "\"})" + export (NamedSubsection SignalSection $ lcSignal) si -- | Write some simple debug message when signal generation fails, and -- generate a placeholder SignalInfo instance. @@ -436,19 +473,18 @@ deprecatedPragma cbType (callableDeprecated cb) - genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures (sigDoc s) + genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures True (sigDoc s) - _ <- genCCallbackPrototype (lcFirst sn') cb cbType True + _ <- genCCallbackPrototype (lcFirst sn') cb cbType (Just on') - genCallbackWrapperFactory (lcFirst sn') cbType + genCallbackWrapperFactory (lcFirst sn') 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 + genCallbackWrapper (lcFirst sn') cb cbType (Just on') -- Wrapper for connecting functions to the signal -- We can connect to a signal either before the default handler runs @@ -459,10 +495,15 @@ -- since if something provides signals it is necessarily a -- GObject. klass <- classConstraint on + + addLanguagePragma "ImplicitParams" + addLanguagePragma "RankNTypes" + let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>" + implicitSelfCBType = "((?self :: a) => " <> cbType <> ")" signatureArgs = if sigDetailed s - then "a -> P.Maybe T.Text -> " <> cbType <> " -> m SignalHandlerId" - else "a -> " <> cbType <> " -> m SignalHandlerId" + then "a -> P.Maybe T.Text -> " <> implicitSelfCBType <> " -> m SignalHandlerId" + else "a -> " <> implicitSelfCBType <> " -> m SignalHandlerId" signature = " :: " <> signatureConstraints <> " " <> signatureArgs onName = "on" <> signalConnectorName afterName = "after" <> signalConnectorName @@ -473,10 +514,14 @@ if sigDetailed s then do line $ onName <> " obj detail cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectBefore" "detail" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectBefore" "detail" "wrapped" else do line $ onName <> " obj cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectBefore" "Nothing" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectBefore" "Nothing" "wrapped" export docSection onName group $ do @@ -485,10 +530,14 @@ if sigDetailed s then do line $ afterName <> " obj detail cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectAfter" "detail" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectAfter" "detail" "wrapped" else do line $ afterName <> " obj cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectAfter" "Nothing" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectAfter" "Nothing" "wrapped" export docSection afterName cppIf CPPOverloading (genSignalInfoInstance on s) @@ -520,7 +569,9 @@ <> hsn <> " callback" , "@" , "" - , detailedDoc ] + , detailedDoc + , "" + , selfDoc] detailedDoc :: Text detailedDoc = if not (sigDetailed s) @@ -531,6 +582,12 @@ <> "::detail@” instead." ] + selfDoc :: Text + selfDoc = T.unlines [ + "By default the object invoking the signal is not passed to the callback." + , "If you need to access it, you can use the implit @?self@ parameter." + , "Note that this requires activating the @ImplicitParams@ GHC extension." + ] -- | Generate the code for connecting the given signal. This assumes -- that it lives inside a @do@ block. @@ -538,9 +595,11 @@ -> Text -- ^ Callback type -> Text -- ^ SignalConnectBefore or SignalConnectAfter -> Text -- ^ Detail + -> Text -- ^ Name of variable holding the callback -> CodeGen e () -genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail = do - cb' <- genWrappedCallback cb "cb" cbType True +genSignalConnector (Signal {sigName = sn, sigCallable = cb}) + cbType when detail cbName = do + cb' <- genWrappedCallback cb cbName cbType True let cb'' = prime cb' line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb' line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -26,11 +26,15 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (upperName, lowerName, underscoresToCamelCase, qualifiedSymbol, callbackHaskellToForeign, - callbackWrapperAllocator) + callbackWrapperAllocator, + haddockAttrAnchor, moduleLocation, + hackageModuleLink, + normalizedAPIName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -254,24 +258,27 @@ <> ") (" <> nullPtr <> " :: " <> fType <> ")" -- | Return whether the given type corresponds to a callback that does --- not throw exceptions. See [Note: Callables that throw] for the --- reason why we do not try to wrap callbacks that throw exceptions. -isRegularCallback :: Type -> CodeGen e Bool +-- not throw exceptions. If it is, return the callback itself. See +-- [Note: Callables that throw] for the reason why we do not try to +-- wrap callbacks that throw exceptions. +isRegularCallback :: Type -> CodeGen e (Maybe Callback) isRegularCallback t@(TInterface _) = do api <- getAPI t case api of - APICallback (Callback {cbCallable = callable}) -> - return (not $ callableThrows callable) - _ -> return False -isRegularCallback _ = return False + APICallback callback@(Callback {cbCallable = callable}) -> + if callableThrows callable + then return Nothing + else return (Just callback) + _ -> return Nothing +isRegularCallback _ = return Nothing -- | The types accepted by the allocating set function -- 'Data.GI.Base.Attributes.(:&=)'. fieldTransferTypeConstraint :: Type -> CodeGen e Text fieldTransferTypeConstraint t = do isPtr <- typeIsPtr t - isRegularCallback <- isRegularCallback t - inType <- if isPtr && not isRegularCallback + maybeRegularCallback <- isRegularCallback t + inType <- if isPtr && not (isJust maybeRegularCallback) then typeShow <$> foreignType t else typeShow <$> isoHaskellType t return $ "(~)" <> if T.any (== ' ') inType @@ -294,15 +301,16 @@ -- | Generate the field transfer function, which marshals Haskell -- values to types that we can set, even if we need to allocate memory. genFieldTransfer :: Text -> Type -> CodeGen e () -genFieldTransfer var t@(TInterface tn@(Name _ n)) = do - isRegularCallback <- isRegularCallback t - if isRegularCallback - then do - wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn - maker <- qualifiedSymbol (callbackWrapperAllocator n) tn +genFieldTransfer var t@(TInterface tn) = do + maybeRegularCallback <- isRegularCallback t + case maybeRegularCallback of + Just callback -> do + let Name _ name' = normalizedAPIName (APICallback callback) tn + wrapper <- qualifiedSymbol (callbackHaskellToForeign name') tn + maker <- qualifiedSymbol (callbackWrapperAllocator name') tn line $ maker <> " " <> parenthesize (wrapper <> " Nothing " <> var) - else line $ "return " <> var + Nothing -> line $ "return " <> var genFieldTransfer var _ = line $ "return " <> var -- | Haskell name for the field @@ -334,6 +342,12 @@ transferType <- fieldTransferType (fieldType field) transferConstraint <- fieldTransferTypeConstraint (fieldType field) + api <- findAPIByName owner + hackageLink <- hackageModuleLink owner + let qualifiedAttrName = dotModulePath (moduleLocation owner api) + <> "." <> labelName field + attrInfoURL = hackageLink <> "#" <> haddockAttrAnchor <> labelName field + line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do @@ -366,6 +380,11 @@ line $ "attrTransfer _ v = do" indent $ genFieldTransfer "v" (fieldType field) else line $ "attrTransfer = undefined" + line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\"" + line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\"" + line $ "})" blank @@ -439,7 +458,7 @@ line $ "instance O.HasAttributeList " <> name' line $ "type instance O.AttributeList " <> name' <> " = " <> attrListName line $ "type " <> attrListName <> " = ('[ " <> - T.intercalate ", " (catMaybes attrs) <> "] :: [(Symbol, *)])" + T.intercalate ", " (catMaybes attrs) <> "] :: [(Symbol, DK.Type)])" -- | Generate a constructor for a zero-filled struct/union of the given -- type, using the boxed (or GLib, for unboxed types) allocator. @@ -449,8 +468,8 @@ let builder = "newZero" <> name tsize = tshow size - writeHaddock DocBeforeSymbol ("Construct a `" <> name <> - "` struct initialized to zero.") + writeHaddock DocBeforeSymbol ("Construct a t'" <> name <> + "' struct initialized to zero.") line $ builder <> " :: MonadIO m => m " <> name line $ builder <> " = liftIO $ " <> @@ -496,7 +515,7 @@ genBoxedGValueInstance :: Name -> Text -> CodeGen e () genBoxedGValueInstance n get_type_fn = do let name' = upperName n - doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." + doc = "Convert t'" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." writeHaddock DocBeforeSymbol doc diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs --- a/lib/Data/GI/CodeGen/SymbolNaming.hs +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -31,8 +31,11 @@ , normalizedAPIName , hackageModuleLink + , haddockSignalAnchor + , haddockAttrAnchor ) where +import qualified Data.Char as C #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -114,14 +117,22 @@ 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. +-- | Turn the given `Name` into CamelCase, starting with a lowercase +-- letter. The resulting identifier will be qualified by the namespace +-- if necessary. -- -- === __Examples__ -- >>> lowerName (Name "Gtk" "main_quit") -- "mainQuit" +-- +-- >>> lowerName (Name "NM" "80211Test") +-- "nM80211Test" lowerName :: Name -> Text -lowerName (Name _ s) = lowerSymbol s +lowerName (Name ns s) = + if not . C.isAlpha $ T.head (sanitize s) then + lowerSymbol (ns <> s) + else + lowerSymbol s -- | Turn the given identifier into camelCase, starting with a -- lowercase letter. @@ -134,13 +145,22 @@ "" -> error "empty name!!" n -> lcFirst n --- | Turn the given `Name` into CamelCase, starting with a capital letter. +-- | Turn the given `Name` into CamelCase, starting with a capital +-- letter. The resulting identifier will be qualified by the namespace +-- if necessary. -- -- === __Examples__ -- >>> upperName (Name "Foo" "bar_baz") -- "BarBaz" +-- +-- >>> upperName (Name "NM" "80211ApFlags") +-- "NM80211ApFlags" upperName :: Name -> Text -upperName (Name _ s) = underscoresToCamelCase (sanitize s) +upperName (Name ns s) = + if not . C.isAlpha $ T.head (sanitize s) then + underscoresToCamelCase (sanitize (ns <> s)) + else + 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 @@ -268,9 +288,11 @@ -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text -signalHaskellName sn = let (w:ws) = T.split (== '-') sn - in w <> T.concat (map ucFirst ws) - +signalHaskellName sn = case T.split (== '-') sn of + [] -> "" -- Won't happen due to the + -- definition of T.split, but GHC + -- does not know this. + w:ws -> w <> T.concat (map ucFirst ws) -- | Return a link to the hackage package for the given name. Note -- that the generated link will only be valid if the name belongs to @@ -284,3 +306,10 @@ return $ "https://hackage.haskell.org/package/" <> pkg <> "/docs/" <> location <> ".html" +-- | Prefix in Haddock for the signal anchor. +haddockSignalAnchor :: Text +haddockSignalAnchor = "g:signal:" + +-- | Prefix in Haddock for the attribute anchor. +haddockAttrAnchor :: Text +haddockAttrAnchor = "g:attr:" diff --git a/lib/Data/GI/GIR/Arg.hs b/lib/Data/GI/GIR/Arg.hs --- a/lib/Data/GI/GIR/Arg.hs +++ b/lib/Data/GI/GIR/Arg.hs @@ -4,6 +4,7 @@ , Scope(..) , parseArg , parseTransfer + , parseTransferString ) where #if !MIN_VERSION_base(4,11,0) @@ -13,7 +14,7 @@ import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser -import Data.GI.GIR.Type (parseType) +import Data.GI.GIR.Type (parseType, queryElementCType) data Direction = DirectionIn | DirectionOut @@ -24,6 +25,7 @@ | ScopeTypeCall | ScopeTypeAsync | ScopeTypeNotified + | ScopeTypeForever deriving (Show, Eq, Ord) data Arg = Arg { @@ -31,6 +33,7 @@ -- escaped name valid in Haskell code, use -- `GI.SymbolNaming.escapedArgName`. argType :: Type, + argCType :: Maybe Text, direction :: Direction, mayBeNull :: Bool, argDoc :: Documentation, @@ -38,20 +41,26 @@ argClosure :: Int, argDestroy :: Int, argCallerAllocates :: Bool, + argCallbackUserData :: Bool, + -- ^ Whether the argument is an "user-data" argument for a callback. transfer :: Transfer } deriving (Show, Eq, Ord) -parseTransfer :: Parser Transfer -parseTransfer = getAttr "transfer-ownership" >>= \case +parseTransferString :: Text -> Parser Transfer +parseTransferString transfer = case transfer of "none" -> return TransferNothing "container" -> return TransferContainer "full" -> return TransferEverything t -> parseError $ "Unknown transfer type \"" <> t <> "\"" +parseTransfer :: Parser Transfer +parseTransfer = getAttr "transfer-ownership" >>= parseTransferString + parseScope :: Text -> Parser Scope parseScope "call" = return ScopeTypeCall parseScope "async" = return ScopeTypeAsync parseScope "notified" = return ScopeTypeNotified +parseScope "forever" = return ScopeTypeForever parseScope s = parseError $ "Unknown scope type \"" <> s <> "\"" parseDirection :: Text -> Parser Direction @@ -76,10 +85,16 @@ then nullable || allowNone else nullable callerAllocates <- optionalAttr "caller-allocates" False parseBool + -- There is no annotation for this one yet, see + -- https://gitlab.gnome.org/GNOME/gobject-introspection/-/issues/450 + -- We will use some heuristics later for setting this field. + let callbackUserData = False t <- parseType + maybeCType <- queryElementCType doc <- parseDocumentation return $ Arg { argCName = name , argType = t + , argCType = maybeCType , argDoc = doc , direction = d , mayBeNull = mayBeNull @@ -87,5 +102,6 @@ , argClosure = closure , argDestroy = destroy , argCallerAllocates = callerAllocates + , argCallbackUserData = callbackUserData , transfer = ownership } diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs --- a/lib/Data/GI/GIR/BasicTypes.hs +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -46,6 +46,17 @@ | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr + | TShort -- ^ gshort + | TUShort -- ^ gushort + | TSize -- ^ gsize + | TSSize -- ^ gssize + | Ttime_t -- ^ time_t + | Toff_t -- ^ off_t + | Tdev_t -- ^ dev_t + | Tgid_t -- ^ gid_t + | Tpid_t -- ^ pid_t + | Tsocklen_t -- ^ socklen_t + | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection diff --git a/lib/Data/GI/GIR/Constant.hs b/lib/Data/GI/GIR/Constant.hs --- a/lib/Data/GI/GIR/Constant.hs +++ b/lib/Data/GI/GIR/Constant.hs @@ -7,7 +7,7 @@ import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type) -import Data.GI.GIR.Type (parseType, parseCType) +import Data.GI.GIR.Type (parseType) import Data.GI.GIR.Parser -- | Info about a constant. @@ -26,7 +26,12 @@ deprecated <- parseDeprecation value <- getAttr "value" t <- parseType - ctype <- parseCType + -- This contains the C name for the constant. The C gir generator + -- call this "c:type", while the vala gir generator calls it + -- "c:identifier", so try both. + ctype <- queryAttrWithNamespace CGIRNS "type" >>= \case + Just i -> return i + Nothing -> getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs --- a/lib/Data/GI/GIR/Field.hs +++ b/lib/Data/GI/GIR/Field.hs @@ -51,7 +51,7 @@ -- Sometimes fields marked as not introspectable contain invalid -- introspection info. We are lenient in these cases with parsing -- errors, and simply ignore the fields. - flip catchError (\e -> if (not introspectable) && private + flip catchError (\e -> if not introspectable then return Nothing else throwError e) $ do (t, isPtr, callback) <- diff --git a/lib/Data/GI/GIR/Property.hs b/lib/Data/GI/GIR/Property.hs --- a/lib/Data/GI/GIR/Property.hs +++ b/lib/Data/GI/GIR/Property.hs @@ -9,8 +9,8 @@ import Data.Monoid ((<>)) #endif -import Data.GI.GIR.Arg (parseTransfer) -import Data.GI.GIR.BasicTypes (Transfer, Type) +import Data.GI.GIR.Arg (parseTransferString) +import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseType) @@ -26,6 +26,8 @@ propFlags :: [PropertyFlag], propReadNullable :: Maybe Bool, propWriteNullable :: Maybe Bool, + propSetter :: Maybe Text, + propGetter :: Maybe Text, propTransfer :: Transfer, propDoc :: Documentation, propDeprecated :: Maybe DeprecationInfo @@ -35,11 +37,13 @@ parseProperty = do name <- getAttr "name" t <- parseType - transfer <- parseTransfer + transfer <- optionalAttr "transfer-ownership" TransferNothing parseTransferString deprecated <- parseDeprecation readable <- optionalAttr "readable" True parseBool writable <- optionalAttr "writable" False parseBool construct <- optionalAttr "construct" False parseBool + setter <- queryAttr "setter" + getter <- queryAttr "getter" constructOnly <- optionalAttr "construct-only" False parseBool maybeNullable <- optionalAttr "nullable" Nothing (\t -> Just <$> parseBool t) let flags = (if readable then [PropertyReadable] else []) @@ -56,4 +60,6 @@ , propDoc = doc , propReadNullable = maybeNullable , propWriteNullable = maybeNullable + , propSetter = setter + , propGetter = getter } diff --git a/lib/Data/GI/GIR/Repository.hs b/lib/Data/GI/GIR/Repository.hs --- a/lib/Data/GI/GIR/Repository.hs +++ b/lib/Data/GI/GIR/Repository.hs @@ -49,8 +49,13 @@ then reverse acc : go ys [] else go ys (y : acc) +-- | Return the paths where to look for gir files. girDataDirs :: IO [FilePath] -girDataDirs = getSystemDataDirs "gir-1.0" +girDataDirs = do + sys <- getSystemDataDirs "gir-1.0" + -- See https://github.com/haskell-gi/haskell-gi/issues/390 + let macOS = ["/opt/homebrew/share/gir-1.0"] + return (sys ++ macOS) -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type @@ -8,15 +9,14 @@ , parseOptionalType ) where +#include "HsBaseConfig.h" + import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T -import Foreign.Storable (sizeOf) -import Foreign.C (CShort, CUShort, CSize) -import System.Posix.Types (CSsize) import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Parser @@ -47,24 +47,17 @@ nameToBasicType "filename" = Just TFileName nameToBasicType "gintptr" = Just TIntPtr nameToBasicType "guintptr" = Just TUIntPtr -nameToBasicType "gshort" = case sizeOf (0 :: CShort) of - 2 -> Just TInt16 - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected short size: " ++ show n -nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of - 2 -> Just TUInt16 - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected ushort size: " ++ show n -nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected ssize length: " ++ show n -nameToBasicType "gsize" = case sizeOf (0 :: CSize) of - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected size length: " ++ show n +nameToBasicType "gshort" = Just TShort +nameToBasicType "gushort" = Just TUShort +nameToBasicType "gssize" = Just TSSize +nameToBasicType "gsize" = Just TSize +nameToBasicType "time_t" = Just Ttime_t +nameToBasicType "off_t" = Just Toff_t +nameToBasicType "dev_t" = Just Tdev_t +nameToBasicType "gid_t" = Just Tgid_t +nameToBasicType "pid_t" = Just Tpid_t +nameToBasicType "socklen_t" = Just Tsocklen_t +nameToBasicType "uid_t" = Just Tuid_t nameToBasicType _ = Nothing -- | The different array types. @@ -94,6 +87,7 @@ -- | A hash table. parseHashTable :: Parser Type parseHashTable = parseTypeElements >>= \case + [] -> return $ TGHash (TBasicType TPtr) (TBasicType TPtr) [Just key, Just value] -> return $ TGHash key value other -> parseError $ "Unsupported hash type: " <> T.pack (show other) @@ -121,6 +115,8 @@ parseFundamentalType "GLib" "Variant" = return TVariant parseFundamentalType "GObject" "ParamSpec" = return TParamSpec parseFundamentalType "GObject" "Value" = return TGValue +-- Used by vala, see https://github.com/haskell-gi/haskell-gi/issues/453 +parseFundamentalType "GLib" "ObjectPath" = return (TBasicType TUTF8) parseFundamentalType "GObject" "Closure" = parseClosure -- A TInterface type (basically, everything that is not of a known type). parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n)