haskell-gi 0.25.0 → 0.26.17
raw patch · 28 files changed
Files
- ChangeLog.md +63/−0
- haskell-gi.cabal +12/−17
- lib/Data/GI/CodeGen/Cabal.hs +0/−182
- lib/Data/GI/CodeGen/CabalHooks.hs +93/−13
- lib/Data/GI/CodeGen/Callable.hs +35/−26
- lib/Data/GI/CodeGen/Code.hs +67/−11
- lib/Data/GI/CodeGen/CodeGen.hs +26/−17
- lib/Data/GI/CodeGen/Constant.hs +11/−0
- lib/Data/GI/CodeGen/Conversions.hsc +103/−35
- lib/Data/GI/CodeGen/CtoHaskellMap.hs +70/−31
- lib/Data/GI/CodeGen/Fixups.hs +97/−6
- lib/Data/GI/CodeGen/GtkDoc.hs +623/−163
- lib/Data/GI/CodeGen/Haddock.hs +132/−52
- lib/Data/GI/CodeGen/OverloadedMethods.hs +24/−12
- lib/Data/GI/CodeGen/OverloadedSignals.hs +2/−2
- lib/Data/GI/CodeGen/Overrides.hs +3/−0
- lib/Data/GI/CodeGen/ProjectInfo.hs +4/−3
- lib/Data/GI/CodeGen/Properties.hs +26/−4
- lib/Data/GI/CodeGen/Signal.hs +124/−65
- lib/Data/GI/CodeGen/Struct.hs +40/−21
- lib/Data/GI/CodeGen/SymbolNaming.hs +37/−8
- lib/Data/GI/GIR/Arg.hs +19/−3
- lib/Data/GI/GIR/BasicTypes.hs +11/−0
- lib/Data/GI/GIR/Constant.hs +7/−2
- lib/Data/GI/GIR/Field.hs +1/−1
- lib/Data/GI/GIR/Property.hs +9/−3
- lib/Data/GI/GIR/Repository.hs +6/−1
- lib/Data/GI/GIR/Type.hs +17/−21
ChangeLog.md view
@@ -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).
haskell-gi.cabal view
@@ -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
− lib/Data/GI/CodeGen/Cabal.hs
@@ -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"
lib/Data/GI/CodeGen/CabalHooks.hs view
@@ -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) })
lib/Data/GI/CodeGen/Callable.hs view
@@ -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
lib/Data/GI/CodeGen/Code.hs view
@@ -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.
lib/Data/GI/CodeGen/CodeGen.hs view
@@ -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
lib/Data/GI/CodeGen/Constant.hs view
@@ -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"
lib/Data/GI/CodeGen/Conversions.hsc view
@@ -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 "()"]
lib/Data/GI/CodeGen/CtoHaskellMap.hs view
@@ -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)
lib/Data/GI/CodeGen/Fixups.hs view
@@ -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.
lib/Data/GI/CodeGen/GtkDoc.hs view
@@ -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- "--- 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 -- > <!-- comment --> -- Note that this function keeps spaces. -- -- === __Examples__ -- >>> parseOnly (parseComment <* endOfInput) "<!-- comment -->"--- Right (Comment " comment ")-parseComment :: Parser Token+-- Right [Comment " comment "]+parseComment :: Parser [Token] parseComment = do comment <- string "<!--" *> manyTill anyChar (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 -- >  -- -- === __Examples__ -- >>> parseOnly (parseImage <* endOfInput) ""--- 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+-- > |[<!-- language="C" --> code ]|+--+-- === __Examples__+-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|"+-- Right [CodeBlock Nothing "this is code"]+--+-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[<!-- language=\"C\"-->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
lib/Data/GI/CodeGen/Haddock.hs view
@@ -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")]) -- "<http://wiki.haskell.org/GObjectIntrospection GI>" ----- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]])--- "\n* <<a/test.png test>>\n"-formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text-formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc+-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [UnnumberedList [GtkDoc [Image (Link "test" "test.png")]]])+-- "* <<a/test.png test>>\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
lib/Data/GI/CodeGen/OverloadedMethods.hs view
@@ -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
lib/Data/GI/CodeGen/OverloadedSignals.hs view
@@ -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)])"
lib/Data/GI/CodeGen/Overrides.hs view
@@ -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)
lib/Data/GI/CodeGen/ProjectInfo.hs view
@@ -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.
lib/Data/GI/CodeGen/Properties.hs view
@@ -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
lib/Data/GI/CodeGen/Signal.hs view
@@ -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
lib/Data/GI/CodeGen/Struct.hs view
@@ -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
lib/Data/GI/CodeGen/SymbolNaming.hs view
@@ -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:"
lib/Data/GI/GIR/Arg.hs view
@@ -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 }
lib/Data/GI/GIR/BasicTypes.hs view
@@ -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
lib/Data/GI/GIR/Constant.hs view
@@ -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
lib/Data/GI/GIR/Field.hs view
@@ -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) <-
lib/Data/GI/GIR/Property.hs view
@@ -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 }
lib/Data/GI/GIR/Repository.hs view
@@ -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
lib/Data/GI/GIR/Type.hs view
@@ -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)