diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,98 @@ +### 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). + ++ Accept docsections in gir files, although they are currently ignored. See [issue 318](https://github.com/haskell-gi/haskell-gi/issues/318). + +### 0.24.4 + ++ Relax bound on ansi-terminal. + +### 0.24.3 + ++ Provide type init functions for GParamSpec types. This solves a puzzling linker error saying that the "intern" symbol could not be resolved, see [issue 297](https://github.com/haskell-gi/haskell-gi/issues/297) and [issue 298](https://github.com/haskell-gi/haskell-gi/issues/298). + +### 0.24.2 + ++ Support for allocating GArrays of known size structs in caller-allocates arguments. + +### 0.24.1 + ++ Add support for delete-attr override, to remove attributes. + ++ Allow (but ignore) destroyers in scope async callbacks. + +### 0.24.0 + ++ Added support for non-GObject objects + +### 0.23.2 + ++ Fix a possible segfault in functions that return an out pointer to a dynamically allocated array, but do not initialize the array if it has zero size. See [#289](https://github.com/haskell-gi/haskell-gi/issues/289) for an example. + ### 0.23.1 + Check whether symbols exist in the dynamic library before trying to generate bindings for them, in order to avoid linker errors. diff --git a/DocTests.hs b/DocTests.hs --- a/DocTests.hs +++ b/DocTests.hs @@ -1,20 +1,17 @@ -import Test.DocTest +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) import System.Process main :: IO () main = do - gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" - doctest $ [ "-XCPP", "-XOverloadedStrings", "-XRankNTypes", "-XLambdaCase" - , "-ilib" - -- For the autogenerated Data.GI.CodeGen.GType (hsc) - , "-idist/build" - , "dist/build/lib/c/enumStorage.o" - ] ++ gobjectIntrospectionLibs ++ - -- The actual modules to test - [ "Data.GI.CodeGen.GtkDoc" - , "Data.GI.CodeGen.ModulePath" - , "Data.GI.CodeGen.SymbolNaming" - , "Data.GI.CodeGen.Haddock" ] + gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" +-- traverse_ putStrLn args -- optionally print arguments + doctest (gobjectIntrospectionLibs ++ args) + where + args = flags ++ pkgs ++ module_sources pkgConfigLibs :: String -> IO [String] pkgConfigLibs pkg = words <$> readProcess "pkg-config" ["--libs", pkg] "" diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,6 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMain +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,33 +1,37 @@ name: haskell-gi -version: 0.23.1 +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: Simple -tested-with: GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.10.1 +build-type: Custom +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 +custom-setup + setup-depends: + base >= 4 && <5, + 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.23.0 && <0.24, + build-depends: base >= 4.11 && < 5, + haskell-gi-base >= 0.26.9 && <0.27, Cabal >= 1.24, attoparsec >= 0.13, containers, @@ -36,7 +40,7 @@ mtl >= 2.2, transformers >= 0.3, pretty-show, - ansi-terminal ^>= 0.10, + ansi-terminal >= 0.10, process, safe, bytestring, @@ -46,13 +50,11 @@ 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 - build-tools: hsc2hs hs-source-dirs: lib exposed-modules: Data.GI.GIR.Alias, Data.GI.GIR.Allocation, @@ -79,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, @@ -98,7 +99,6 @@ Data.GI.CodeGen.LibGIRepository, Data.GI.CodeGen.ModulePath, Data.GI.CodeGen.OverloadedSignals, - Data.GI.CodeGen.OverloadedLabels, Data.GI.CodeGen.OverloadedMethods, Data.GI.CodeGen.Overrides, Data.GI.CodeGen.PkgConfig, @@ -118,10 +118,9 @@ test-suite doctests type: exitcode-stdio-1.0 default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -threaded -Wall main-is: DocTests.hs build-depends: base , process , doctest >= 0.8 - , haskell-gi - , attoparsec + , haskell-gi >= 0.26.10 diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs --- a/lib/Data/GI/CodeGen/API.hs +++ b/lib/Data/GI/CodeGen/API.hs @@ -154,6 +154,8 @@ -- | A rule for modifying the GIR file. data GIRRule = GIRSetAttr (GIRPath, XML.Name) Text -- ^ (Path to element, -- attrName), newValue. + | GIRDeleteAttr GIRPath XML.Name + -- ^ Delete the given attribute | GIRAddNode GIRPath XML.Name -- ^ Add a child node at -- the given selector. | GIRDeleteNode GIRPath -- ^ Delete any nodes matching @@ -196,6 +198,7 @@ "class" -> parse APIObject parseObject "interface" -> parse APIInterface parseInterface "boxed" -> ns -- Unsupported + "docsection" -> ns -- Ignored for now, see https://github.com/haskell-gi/haskell-gi/issues/318 n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting." where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace parse wrapper parser = @@ -544,6 +547,8 @@ where applyGIRRule :: XML.Node -> GIRRule -> Maybe XML.Node applyGIRRule n (GIRSetAttr (path, attr) newVal) = Just $ girSetAttr (path, attr) newVal n + applyGIRRule n (GIRDeleteAttr path attr) = + Just $ girDeleteAttr path attr n applyGIRRule n (GIRAddNode path new) = Just $ girAddNode path new n applyGIRRule n (GIRDeleteNode path) = @@ -565,6 +570,23 @@ (XML.elementNodes elem)}) else n girSetAttr _ _ n = n + +-- | Delete an attribute for the child element specified by the given +-- path, if the attribute exists. +girDeleteAttr :: GIRPath -> XML.Name -> XML.Node -> XML.Node +girDeleteAttr (spec:rest) attr n@(XML.NodeElement elem) = + if specMatch spec n + then case rest of + -- Matched the full path, apply + [] -> XML.NodeElement (elem {XML.elementAttributes = + M.delete attr + (XML.elementAttributes elem)}) + -- Still some selectors to apply + _ -> XML.NodeElement (elem {XML.elementNodes = + map (girDeleteAttr rest attr) + (XML.elementNodes elem)}) + else n +girDeleteAttr _ _ n = n -- | Add the given subnode to any nodes matching the given path girAddNode :: GIRPath -> XML.Name -> XML.Node -> XML.Node diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Cabal.hs +++ /dev/null @@ -1,182 +0,0 @@ -module Data.GI.CodeGen.Cabal - ( genCabalProject - , cabalConfig - , setupHs - , tryPkgConfig - ) where - -import Control.Monad (forM_) -import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import Data.Version (Version(..)) -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Text (Text) -import Text.Read - -import Data.GI.CodeGen.API (GIRInfo(..)) -import Data.GI.CodeGen.Code -import Data.GI.CodeGen.Config (Config(..)) -import Data.GI.CodeGen.Overrides (cabalPkgVersion) -import Data.GI.CodeGen.PkgConfig (pkgConfigGetVersion) -import qualified Data.GI.CodeGen.ProjectInfo as PI -import Data.GI.CodeGen.Util (padTo, tshow) - -import Paths_haskell_gi (version) - -cabalConfig :: Text -cabalConfig = T.unlines ["optimization: False"] - -setupHs :: Text -setupHs = T.unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main = defaultMain"] - -haskellGIAPIVersion :: Int -haskellGIAPIVersion = (head . versionBranch) version - --- | Obtain the minor version. That is, if the given version numbers --- are x.y.z, so branch is [x,y,z], we return y. -minorVersion :: [Int] -> Int -minorVersion (_:y:_) = y -minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." - --- | Obtain the haskell-gi minor version. Notice that we only append --- the minor version here, ignoring revisions. (So if the version is --- x.y.z, we drop the "z" part.) This gives us a mechanism for --- releasing bug-fix releases of haskell-gi without increasing the --- necessary dependency on haskell-gi-base, which only depends on x.y. -haskellGIMinor :: Int -haskellGIMinor = minorVersion (versionBranch version) - -{- | - -If the haskell-gi version is of the form x.y[.z] and the pkgconfig -version of the package being wrapped is a.b.c, this gives something of -the form x.a.b.y. - -This strange seeming-rule is so that the packages that we produce -follow the PVP, assuming that the package being wrapped follows the -usual semantic versioning convention (http://semver.org) that -increases in "a" indicate non-backwards compatible changes, increases -in "b" backwards compatible additions to the API, and increases in "c" -denote API compatible changes (so we do not need to regenerate -bindings for these, at least in principle, so we do not encode them in -the cabal version). - -In order to follow the PVP, then everything we need to do in the -haskell-gi side is to increase x everytime the generated API changes -(for a fixed a.b.c version). - -In any case, if such "strange" package numbers are undesired, or the -wrapped package does not follow semver, it is possible to add an -explicit cabal-pkg-version override. This needs to be maintained by -hand (including in the list of dependencies of packages depending on -this one), so think carefully before using this override! - --} -giModuleVersion :: Int -> Int -> Text -giModuleVersion major minor = - (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor, - haskellGIMinor] - --- | Determine the next version for which the minor of the package has --- been bumped. -giNextMinor :: Int -> Int -> Text -giNextMinor major minor = (T.intercalate "." . map tshow) - [haskellGIAPIVersion, major, minor+1] - --- | Info for a given package. -data PkgInfo = PkgInfo { pkgName :: Text - , pkgMajor :: Int - , pkgMinor :: Int - } deriving Show - --- | Determine the pkg-config name and installed version (major.minor --- only) for a given module, or throw an exception if that fails. -tryPkgConfig :: GIRInfo -> Bool -> M.Map Text Text -> IO (Either Text PkgInfo) -tryPkgConfig gir verbose overridenNames = do - let name = girNSName gir - version = girNSVersion gir - packages = girPCPackages gir - - pkgConfigGetVersion name version packages verbose overridenNames >>= \case - Just (n,v) -> - case readMajorMinor v of - Just (major, minor) -> - return $ Right (PkgInfo { pkgName = n - , pkgMajor = major - , pkgMinor = minor}) - Nothing -> return $ Left $ "Cannot parse version \"" <> v <> - "\" for module " <> name - Nothing -> return $ Left $ - "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <> - "Try adding an override with the proper package name:\n" - <> "pkg-config-name " <> name <> " [matching pkg-config name here]" - --- | Given a string a.b.c..., representing a version number, determine --- the major and minor versions, i.e. "a" and "b". If successful, --- return (a,b). -readMajorMinor :: Text -> Maybe (Int, Int) -readMajorMinor version = - case T.splitOn "." version of - (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b) - _ -> Nothing - --- | Generate the cabal project. -genCabalProject :: (GIRInfo, PkgInfo) -> [(GIRInfo, PkgInfo)] -> - [Text] -> BaseVersion -> CodeGen () -genCabalProject (gir, PkgInfo {pkgName = pcName, pkgMajor = major, - pkgMinor = minor}) - deps exposedModules minBaseVersion = do - cfg <- config - let name = girNSName gir - - line $ "-- Autogenerated, do not edit." - line $ padTo 20 "name:" <> "gi-" <> T.toLower name - - let cabalVersion = fromMaybe (giModuleVersion major minor) - (cabalPkgVersion $ overrides cfg) - line $ padTo 20 "version:" <> cabalVersion - line $ padTo 20 "synopsis:" <> name - <> " bindings" - line $ padTo 20 "description:" <> "Bindings for " <> name - <> ", autogenerated by haskell-gi." - line $ padTo 20 "homepage:" <> PI.homepage - line $ padTo 20 "license:" <> PI.license - line $ padTo 20 "license-file:" <> "LICENSE" - line $ padTo 20 "author:" <> PI.authors - line $ padTo 20 "maintainer:" <> PI.maintainers - line $ padTo 20 "category:" <> PI.category - line $ padTo 20 "build-type:" <> "Simple" - line $ padTo 20 "cabal-version:" <> ">=1.10" - blank - line $ "library" - indent $ do - line $ padTo 20 "default-language:" <> PI.defaultLanguage - line $ padTo 20 "default-extensions:" <> - T.intercalate ", " PI.defaultExtensions - line $ padTo 20 "other-extensions:" <> - T.intercalate ", " PI.otherExtensions - line $ padTo 20 "ghc-options:" <> T.intercalate " " PI.ghcOptions - line $ padTo 20 "exposed-modules:" <> head exposedModules - forM_ (tail exposedModules) $ \mod -> - line $ padTo 20 "" <> mod - line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <> - tshow major <> "." <> tshow minor - line $ "build-depends:" - indent $ do - line $ "haskell-gi-base >= " - <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor - <> " && < " <> tshow (haskellGIAPIVersion + 1) <> "," - forM_ deps $ \(dep, PkgInfo _ depMajor depMinor) -> do - let depName = girNSName dep - line $ "gi-" <> T.toLower depName <> " >= " - <> giModuleVersion depMajor depMinor - <> " && < " - <> giNextMinor depMajor depMinor - <> "," - forM_ PI.standardDeps (line . (<> ",")) - line $ "base >= " <> showBaseVersion minBaseVersion <> " && <5" diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -1,8 +1,8 @@ -- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks - ( setupHaskellGIBinding - , setupBinding + ( setupBinding + , setupCompatWrapper , configureDryRun , TaggedOverride(..) ) where @@ -23,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 @@ -52,10 +52,12 @@ -- | Generate the code for the given module. genModuleCode :: Text -- ^ name -> Text -- ^ version + -> Text -- ^ pkgName + -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> [TaggedOverride] -- ^ Explicit overrides -> IO ModuleInfo -genModuleCode name version verbosity overrides = do +genModuleCode name version pkgName pkgVersion verbosity overrides = do setupTypelibSearchPath [] parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do @@ -71,6 +73,9 @@ let (apis, deps) = filterAPIsAndDeps ovs gir girDeps allAPIs = M.union apis deps cfg = Config {modName = name, + modVersion = version, + ghcPkgName = pkgName, + ghcPkgVersion = pkgVersion, verbose = verbosity, overrides = ovs} @@ -78,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) @@ -91,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)" @@ -99,31 +105,43 @@ , "-- | 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 -> Text -- ^ version + -> Text -- ^ pkgName + -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ other overrides -> Maybe FilePath -- ^ output dir -> ConfHook -- ^ previous `confHook` -> ConfHook -confCodeGenHook name version verbosity overridesFile inheritedOverrides outputDir +confCodeGenHook name version pkgName pkgVersion verbosity + overridesFile inheritedOverrides outputDir defaultConfHook (gpd, hbi) flags = do givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs - m <- genModuleCode name version verbosity ovs + m <- genModuleCode name version pkgName pkgVersion verbosity ovs let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config" em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m) @@ -138,52 +156,117 @@ 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 return (lbi {withOptimization = NoOptimisation}) -- | The entry point for @Setup.hs@ files in bindings. -setupHaskellGIBinding :: Text -- ^ name - -> Text -- ^ version - -> Bool -- ^ verbose - -> Maybe FilePath -- ^ overrides file - -> Maybe FilePath -- ^ output dir - -> IO () -setupHaskellGIBinding name version verbose overridesFile outputDir = - setupBinding name version verbose overridesFile [] outputDir - --- | The entry point for @Setup.hs@ files in bindings. setupBinding :: Text -- ^ name -> Text -- ^ version + -> Text -- ^ pkgName + -> Text -- ^ pkgVersion -> Bool -- ^ verbose -> Maybe FilePath -- ^ overrides file -> [TaggedOverride] -- ^ Explicit overrides -> Maybe FilePath -- ^ output dir -> IO () -setupBinding name version verbose overridesFile overrides outputDir = +setupBinding name version pkgName pkgVersion verbose overridesFile overrides outputDir = defaultMainWithHooks (simpleUserHooks { - confHook = confCodeGenHook name version verbose + confHook = confCodeGenHook name version + pkgName pkgVersion + verbose overridesFile overrides outputDir (confHook simpleUserHooks) }) +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) + }) + -- | Return the list of modules that `setupHaskellGIBinding` would -- create, together with the set of dependencies loaded while -- generating the code. configureDryRun :: Text -- ^ name -> Text -- ^ version + -> Text -- ^ pkgName + -> Text -- ^ pkgVersion -> Maybe FilePath -- ^ Overrides file -> [TaggedOverride] -- ^ Other overrides to load -> IO ([Text], S.Set Text) -configureDryRun name version overridesFile inheritedOverrides = do +configureDryRun name version pkgName pkgVersion overridesFile inheritedOverrides = do givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs - m <- genModuleCode name version False ovs + m <- genModuleCode name version pkgName pkgVersion False ovs return (("GI." <> ucFirst name <> ".Config") : listModuleTree m, transitiveModuleDeps m) diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -68,7 +68,7 @@ -- | Generate a foreign import for the given C symbol. Return the name -- of the corresponding Haskell identifier. -mkForeignImport :: Text -> Callable -> CodeGen Text +mkForeignImport :: Text -> Callable -> CodeGen e Text mkForeignImport cSymbol callable = do line first indent $ do @@ -96,7 +96,7 @@ -- | Make a wrapper for foreign `FunPtr`s of the given type. Return -- the name of the resulting dynamic Haskell wrapper. -mkDynamicImport :: Text -> CodeGen Text +mkDynamicImport :: Text -> CodeGen e Text mkDynamicImport typeSynonym = do line $ "foreign import ccall \"dynamic\" " <> dynamic <> " :: FunPtr " <> typeSynonym <> " -> " <> typeSynonym @@ -108,7 +108,7 @@ -- sanity checking to make sure that the argument is actually nullable -- (a relatively common annotation mistake is to mix up (optional) -- with (nullable)). -wrapMaybe :: Arg -> CodeGen Bool +wrapMaybe :: Arg -> CodeGen e Bool wrapMaybe arg = if mayBeNull arg then typeIsNullable (argType arg) else return False @@ -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 @@ -310,16 +313,17 @@ return maybeName) -- | Callbacks are a fairly special case, we treat them separately. -prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen Text -prepareInCallback arg (Callback {cbCallable = cb}) expose = do +prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen e Text +prepareInCallback arg callback@(Callback {cbCallable = cb}) expose = do let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg (maker, wrapper, drop) <- case argType arg of - TInterface tn@(Name _ n) -> + TInterface tn -> do + let Name _ n = normalizedAPIName (APICallback callback) tn drop <- if callableHasClosures cb && expose == WithoutClosures then Just <$> qualifiedSymbol (callbackDropClosures n) tn else return Nothing @@ -359,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" @@ -386,30 +390,27 @@ prepareInoutArg arg = do name' <- prepareInArg arg ft <- foreignType $ argType arg - allocInfo <- typeAllocInfo (argType arg) - case allocInfo of - Just (TypeAllocInfo isBoxed n) -> do - let allocator = if isBoxed - then "callocBoxedBytes" - else "callocBytes" - wrapMaybe arg >>= bool - (do - name'' <- genConversion (prime name') $ - literal $ M $ allocator <> " " <> tshow n <> - " :: " <> 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 @@ -418,17 +419,21 @@ then do allocInfo <- typeAllocInfo (argType arg) case allocInfo of - Just (TypeAllocInfo isBoxed n) -> do - let allocator = if isBoxed - then "callocBoxedBytes" - else "callocBytes" - genConversion name $ literal $ M $ allocator <> " " <> tshow n <> + Just (TypeAlloc allocator _) -> do + genConversion name $ literal $ M $ allocator <> " :: " <> typeShow (io ft) Nothing -> notImplementedError $ ("Don't know how to allocate \"" <> argCName arg <> "\" of type " <> tshow (argType arg)) - else genConversion name $ literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft) + else do + -- Initialize pointers to NULL to avoid a crash in case the function + -- does not initialize it. + isPtr <- typeIsPtr (argType arg) + let alloc = if isPtr + then "callocMem" + else "allocMem" + genConversion name $ literal $ M $ alloc <> " :: " <> typeShow (io $ ptr ft) -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object. @@ -439,7 +444,7 @@ if fixed > -1 then do unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer - -- Free the memory associated with the array + -- Free the memory associated with the array. freeContainerType transfer t aname undefined return unpacked else do @@ -453,7 +458,7 @@ lname let lname'' = primeLength lname' unpacked <- convert aname $ unpackCArray lname'' t transfer - -- Free the memory associated with the array + -- Free the memory associated with the array. freeContainerType transfer t aname lname'' return unpacked @@ -527,9 +532,9 @@ forM_ closures $ \closure -> case Map.lookup closure m of Nothing -> badIntroError $ "Closure not found! " - <> T.pack (ppShow callable) - <> "\n" <> T.pack (ppShow m) - <> "\n" <> tshow closure + <> "\nClosure: " <> tshow closure + <> "\nc2cm: " <> T.pack (ppShow m) + <> "\ncallable: " <> T.pack (ppShow callable) Just cb -> do let closureName = escapedArgName $ (args callable)!!closure n = escapedArgName cb @@ -538,21 +543,41 @@ Nothing -> badIntroError $ "Cannot find closure name!! " <> T.pack (ppShow callable) <> "\n" <> T.pack (ppShow nameMap) - case argScope cb of - ScopeTypeInvalid -> badIntroError $ "Invalid scope! " + -- Check that the given closure is an actual callback type. + maybeAPI <- findAPI (argType cb) + case maybeAPI of + Just (APICallback _) -> do + case argScope cb of + ScopeTypeInvalid -> badIntroError $ "Invalid scope! " <> T.pack (ppShow callable) - ScopeTypeNotified -> do - line $ "let " <> closureName <> " = castFunPtrToPtr " <> n' - case argDestroy cb of - (-1) -> badIntroError $ - "ScopeTypeNotified without destructor! " - <> T.pack (ppShow callable) - k -> let destroyName = - escapedArgName $ (args callable)!!k in - line $ "let " <> destroyName <> " = safeFreeFunPtrPtr" - ScopeTypeAsync -> - line $ "let " <> closureName <> " = nullPtr" - ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr" + ScopeTypeNotified -> do + line $ "let " <> closureName <> " = castFunPtrToPtr " <> n' + case argDestroy cb of + (-1) -> badIntroError $ + "ScopeTypeNotified without destructor! " + <> T.pack (ppShow callable) + k -> do + let destroyArg = (args callable)!!k + destroyName = escapedArgName destroyArg + destroyFun <- case argType destroyArg of + TInterface (Name "GLib" "DestroyNotify") -> + return "SP.safeFreeFunPtrPtr" + TInterface (Name "GObject" "ClosureNotify") -> + return "SP.safeFreeFunPtrPtr'" + _ -> notImplementedError $ "Unknown destroy type: " <> tshow (argType destroyArg) + line $ "let " <> destroyName <> " = " <> destroyFun + ScopeTypeAsync -> do + line $ "let " <> closureName <> " = nullPtr" + case argDestroy cb of + -- Async callbacks don't really need destroy + -- notifications, as they can always be released + -- at the end of the callback. + (-1) -> return () + 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 () freeCallCallbacks callable nameMap = @@ -563,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 () @@ -628,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) @@ -744,7 +773,7 @@ forM hOutArgs (convertOutArg callable nameMap) -- | Invoke the given C function, taking care of errors. -invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen () +invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen e () invokeCFunction callable symbol argNames = do let returnBind = case returnType callable of Nothing -> "" @@ -762,7 +791,7 @@ <> call <> (T.concat . map (" " <>)) argNames -- | Return the result of the call, possibly including out arguments. -returnResult :: Callable -> Text -> [Text] -> CodeGen () +returnResult :: Callable -> Text -> [Text] -> CodeGen e () returnResult callable result pps = if skipRetVal callable || returnType callable == Nothing then case pps of @@ -890,7 +919,7 @@ } -- | Some debug info for the callable. -genCallableDebugInfo :: Callable -> CodeGen () +genCallableDebugInfo :: Callable -> CodeGen e () genCallableDebugInfo callable = group $ do commentShow "Args" (args callable) @@ -901,7 +930,7 @@ when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $ do line "-- XXX return value ignored, but it is not a boolean." line "-- This may be a memory leak?" - where commentShow :: Show a => Text -> a -> CodeGen () + where commentShow :: Show a => Text -> a -> CodeGen e () commentShow prefix s = let padding = T.replicate (T.length prefix + 2) " " padded = case T.lines (T.pack $ ppShow s) of @@ -939,7 +968,8 @@ forgetClosures :: Callable -> Callable forgetClosures c = c {args = map forgetClosure (args c)} where forgetClosure :: Arg -> Arg - forgetClosure arg = arg {argClosure = -1} + forgetClosure arg = arg {argClosure = -1, + argCallbackUserData = False} -- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell -- function that will invoke its first argument, which should be a diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -3,10 +3,9 @@ ( Code , ModuleInfo(moduleCode, sectionDocs) , ModuleFlag(..) - , BaseCodeGen , CodeGen , ExcCodeGen - , CGError(..) + , CGError , genCode , evalCodeGen @@ -56,6 +55,7 @@ , NamedSection(..) , addSectionFormattedDocs + , prependSectionFormattedDocs , findAPI , getAPI @@ -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 @@ -89,6 +92,8 @@ import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy as LT +import GHC.Stack (HasCallStack) + import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory) @@ -139,6 +144,7 @@ -- | Subsection of the haddock documentation where the export should -- be located, or alternatively the toplevel section. data HaddockSection = ToplevelSection + | Section NamedSection | NamedSubsection NamedSection Text deriving (Show, Eq, Ord) @@ -257,25 +263,17 @@ , cgsNextAvailableTyvar = SingleCharTyvar 'a' } --- | The base type for the code generator monad. -type BaseCodeGen excType a = +-- | The base type for the code generator monad. Generators that +-- cannot throw errors are parametric in the exception type 'excType'. +type CodeGen excType a = ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except excType)) a --- | The code generator monad, for generators that cannot throw --- errors. The fact that they cannot throw errors is encoded in the --- forall, which disallows any operation on the error, except --- discarding it or passing it along without inspecting. This last --- operation is useful in order to allow embedding `CodeGen` --- computations inside `ExcCodeGen` computations, while disallowing --- the opposite embedding without explicit error handling. -type CodeGen a = forall e. BaseCodeGen e a - -- | Code generators that can throw errors. -type ExcCodeGen a = BaseCodeGen CGError a +type ExcCodeGen a = CodeGen CGError a -- | Run a `CodeGen` with given `Config` and initial state, returning -- either the resulting exception, or the result and final module info. -runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) -> +runCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) -> (Either e (a, ModuleInfo)) runCodeGen cg cfg state = dropCGState <$> runExcept (runStateT (runReaderT cg cfg) state) @@ -293,13 +291,13 @@ -- | Run the given code generator using the state and config of an -- ambient CodeGen, but without adding the generated code to -- `moduleCode`, instead returning it explicitly. -recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code) +recurseCG :: CodeGen e a -> CodeGen e (a, Code) recurseCG = recurseWithState id -- | Like `recurseCG`, but we allow for explicitly setting the state -- of the inner code generator. -recurseWithState :: (CGState -> CGState) -> BaseCodeGen e a - -> BaseCodeGen e (a, Code) +recurseWithState :: (CGState -> CGState) -> CodeGen e a + -> CodeGen e (a, Code) recurseWithState cgsSet cg = do cfg <- ask (cgs, oldInfo) <- get @@ -312,7 +310,7 @@ -- | Like `recurseCG`, giving explicitly the set of loaded APIs and C to -- Haskell map for the subgenerator. -recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen () +recurseWithAPIs :: M.Map Name API -> CodeGen e () -> CodeGen e () recurseWithAPIs apis cg = do cfg <- ask (cgs, oldInfo) <- get @@ -361,7 +359,7 @@ -- current module. Note that we do not generate the submodule if the -- code generator generated no code and the module does not have -- submodules. -submodule' :: Text -> BaseCodeGen e () -> BaseCodeGen e () +submodule' :: Text -> CodeGen e () -> CodeGen e () submodule' modName cg = do cfg <- ask (_, oldInfo) <- get @@ -375,13 +373,13 @@ -- | Run the given CodeGen in order to generate a submodule (specified -- an an ordered list) of the current module. -submodule :: ModulePath -> BaseCodeGen e () -> BaseCodeGen e () +submodule :: ModulePath -> CodeGen e () -> CodeGen e () submodule (ModulePath []) cg = cg submodule (ModulePath (m:ms)) cg = submodule' m (submodule (ModulePath ms) cg) -- | Try running the given `action`, and if it fails run `fallback` -- instead. -handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a +handleCGExc :: (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a handleCGExc fallback action = do cfg <- ask @@ -394,25 +392,25 @@ return r -- | Return the currently loaded set of dependencies. -getDeps :: CodeGen Deps +getDeps :: CodeGen e Deps getDeps = moduleDeps . snd <$> get -- | Return the ambient configuration for the code generator. -config :: CodeGen Config +config :: CodeGen e Config config = hConfig <$> ask -- | Return the name of the current module. -currentModule :: CodeGen Text +currentModule :: CodeGen e Text currentModule = do (_, s) <- get return (dotWithPrefix (modulePath s)) -- | Return the list of APIs available to the generator. -getAPIs :: CodeGen (M.Map Name API) +getAPIs :: CodeGen e (M.Map Name API) getAPIs = loadedAPIs <$> ask -- | Return the C -> Haskell available to the generator. -getC2HMap :: CodeGen (M.Map CRef Hyperlink) +getC2HMap :: CodeGen e (M.Map CRef Hyperlink) getC2HMap = c2hMap <$> ask -- | Due to the `forall` in the definition of `CodeGen`, if we want to @@ -421,7 +419,7 @@ -- is perfectly safe, since there is no way to construct a computation -- in the `CodeGen` monad that throws an exception, due to the higher -- rank type. -unwrapCodeGen :: CodeGen a -> CodeGenConfig -> (CGState, ModuleInfo) +unwrapCodeGen :: CodeGen e a -> CodeGenConfig -> (CGState, ModuleInfo) -> (a, ModuleInfo) unwrapCodeGen cg cfg info = case runCodeGen cg cfg info of @@ -431,7 +429,7 @@ -- | Run a code generator, and return the information for the -- generated module together with the return value of the generator. evalCodeGen :: Config -> M.Map Name API -> - ModulePath -> CodeGen a -> (a, ModuleInfo) + ModulePath -> CodeGen e a -> (a, ModuleInfo) evalCodeGen cfg apis mPath cg = let initialInfo = emptyModule mPath cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis, @@ -440,11 +438,11 @@ -- | Like `evalCodeGen`, but discard the resulting output value. genCode :: Config -> M.Map Name API -> - ModulePath -> CodeGen () -> ModuleInfo + ModulePath -> CodeGen e () -> ModuleInfo genCode cfg apis mPath cg = snd $ evalCodeGen cfg apis mPath cg -- | Mark the given dependency as used by the module. -registerNSDependency :: Text -> CodeGen () +registerNSDependency :: Text -> CodeGen e () registerNSDependency name = do deps <- getDeps unless (Set.member name deps) $ do @@ -460,7 +458,7 @@ -- | Given a module name and a symbol in the module (including a -- proper namespace), return a qualified name for the symbol. -qualified :: ModulePath -> Name -> CodeGen Text +qualified :: ModulePath -> Name -> CodeGen e Text qualified mp (Name ns s) = do cfg <- config -- Make sure the module is listed as a dependency. @@ -476,7 +474,7 @@ -- | Import the given module name qualified (as a source import if the -- namespace is the same as the current one), and return the name -- under which the module was imported. -qualifiedImport :: ModulePath -> CodeGen Text +qualifiedImport :: ModulePath -> CodeGen e Text qualifiedImport mp = do modify' $ \(cgs, s) -> (cgs, s {qualifiedImports = Set.insert mp (qualifiedImports s)}) return (qualifiedModuleName mp) @@ -498,7 +496,7 @@ : map minBaseVersion (M.elems $ submodules minfo)) -- | Print, as a comment, a friendly textual description of the error. -printCGError :: CGError -> CodeGen () +printCGError :: CGError -> CodeGen e () printCGError (CGErrorNotImplemented e) = do comment $ "Not implemented: " <> e printCGError (CGErrorBadIntrospectionInfo e) = @@ -516,7 +514,7 @@ missingInfoError s = throwError $ CGErrorMissingInfo s -- | Get a type variable unused in the current scope. -getFreshTypeVariable :: CodeGen Text +getFreshTypeVariable :: CodeGen e Text getFreshTypeVariable = do (cgs@(CGState{cgsNextAvailableTyvar = available}), s) <- get let (tyvar, next) = @@ -533,23 +531,23 @@ -- | Introduce a new scope for type variable naming: the next fresh -- variable will be called 'a'. -resetTypeVariableScope :: CodeGen () +resetTypeVariableScope :: CodeGen e () resetTypeVariableScope = modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s)) -findAPI :: Type -> CodeGen (Maybe API) -findAPI TError = Just <$> findAPIByName (Name "GLib" "Error") +-- | Try to find the API associated with a given type, if known. +findAPI :: HasCallStack => Type -> CodeGen e (Maybe API) findAPI (TInterface n) = Just <$> findAPIByName n findAPI _ = return Nothing -- | Find the API associated with a given type. If the API cannot be -- found this raises an `error`. -getAPI :: Type -> CodeGen API +getAPI :: HasCallStack => Type -> CodeGen e API getAPI t = findAPI t >>= \case Just a -> return a Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".") -findAPIByName :: Name -> CodeGen API +findAPIByName :: HasCallStack => Name -> CodeGen e API findAPIByName n@(Name ns _) = do apis <- getAPIs case M.lookup n apis of @@ -558,29 +556,29 @@ terror $ "couldn't find API description for " <> ns <> "." <> name n -- | Add some code to the current generator. -tellCode :: CodeToken -> CodeGen () +tellCode :: CodeToken -> CodeGen e () tellCode c = modify' (\(cgs, s) -> (cgs, s {moduleCode = moduleCode s <> codeSingleton c})) -- | Print out a (newline-terminated) line. -line :: Text -> CodeGen () +line :: Text -> CodeGen e () line = tellCode . Line -- | Print out the given line both to the normal module, and to the -- HsBoot file. -bline :: Text -> CodeGen () +bline :: Text -> CodeGen e () bline l = hsBoot (line l) >> line l -- | A blank line -blank :: CodeGen () +blank :: CodeGen e () blank = line "" -- | A (possibly multi line) comment, separated by newlines -comment :: Text -> CodeGen () +comment :: Text -> CodeGen e () comment = tellCode . Comment . T.lines -- | Increase the indent level for code generation. -indent :: BaseCodeGen e a -> BaseCodeGen e a +indent :: CodeGen e a -> CodeGen e a indent cg = do (x, code) <- recurseCG cg tellCode (Indent code) @@ -588,11 +586,11 @@ -- | Increase the indentation level for the rest of the lines in the -- current group. -increaseIndent :: CodeGen () +increaseIndent :: CodeGen e () increaseIndent = tellCode IncreaseIndent -- | Group a set of related code. -group :: BaseCodeGen e a -> BaseCodeGen e a +group :: CodeGen e a -> CodeGen e a group cg = do (x, code) <- recurseCG cg tellCode (Group code) @@ -600,7 +598,7 @@ return x -- | Guard a block of code with @#if@. -cppIfBlock :: Text -> BaseCodeGen e a -> BaseCodeGen e a +cppIfBlock :: Text -> CodeGen e a -> CodeGen e a cppIfBlock cond cg = do (x, code) <- recurseWithState addConditional cg tellCode (CPPBlock (CPPIf cond) code) @@ -612,14 +610,18 @@ -- | Possible features to test via CPP. data CPPGuard = CPPOverloading -- ^ Enable overloading + | CPPMinVersion Text (Integer, Integer, Integer) + -- ^ Require a specific version of the given package. -- | Guard a code block with CPP code, such that it is included only -- if the specified feature is enabled. -cppIf :: CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a +cppIf :: CPPGuard -> CodeGen e a -> CodeGen e a cppIf CPPOverloading = cppIfBlock "defined(ENABLE_OVERLOADING)" +cppIf (CPPMinVersion pkg (a,b,c)) = cppIfBlock $ "MIN_VERSION_" <> pkg <> + "(" <> tshow a <> "," <> tshow b <> "," <> tshow c <> ")" -- | Write the given code into the .hs-boot file for the current module. -hsBoot :: BaseCodeGen e a -> BaseCodeGen e a +hsBoot :: CodeGen e a -> CodeGen e a hsBoot cg = do (x, code) <- recurseCG cg modify' (\(cgs, s) -> (cgs, s{bootCode = bootCode s <> @@ -630,56 +632,62 @@ addGuards (cond : conds) c = codeSingleton $ CPPBlock cond (addGuards conds c) -- | Add a export to the current module. -exportPartial :: ([CPPConditional] -> Export) -> CodeGen () +exportPartial :: ([CPPConditional] -> Export) -> CodeGen e () exportPartial partial = modify' $ \(cgs, s) -> (cgs, let e = partial $ cgsCPPConditionals cgs in s{moduleExports = moduleExports s |> e}) -- | Reexport a whole module. -exportModule :: SymbolName -> CodeGen () +exportModule :: SymbolName -> CodeGen e () exportModule m = exportPartial (Export ExportModule m) -- | Add a type declaration-related export. -exportDecl :: SymbolName -> CodeGen () +exportDecl :: SymbolName -> CodeGen e () exportDecl d = exportPartial (Export ExportTypeDecl d) -- | Export a symbol in the given haddock subsection. -export :: HaddockSection -> SymbolName -> CodeGen () +export :: HaddockSection -> SymbolName -> CodeGen e () export s n = exportPartial (Export (ExportSymbol s) n) -- | Set the language pragmas for the current module. -setLanguagePragmas :: [Text] -> CodeGen () +setLanguagePragmas :: [Text] -> CodeGen e () setLanguagePragmas ps = modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps}) -- | Add a language pragma for the current module. -addLanguagePragma :: Text -> CodeGen () +addLanguagePragma :: Text -> CodeGen e () addLanguagePragma p = modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.insert p (modulePragmas s)}) -- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma). -setGHCOptions :: [Text] -> CodeGen () +setGHCOptions :: [Text] -> CodeGen e () setGHCOptions opts = modify' $ \(cgs, s) -> (cgs, s{moduleGHCOpts = Set.fromList opts}) -- | Set the given flags for the module. -setModuleFlags :: [ModuleFlag] -> CodeGen () +setModuleFlags :: [ModuleFlag] -> CodeGen e () setModuleFlags flags = modify' $ \(cgs, s) -> (cgs, s{moduleFlags = Set.fromList flags}) -- | Set the minimum base version supported by the current module. -setModuleMinBase :: BaseVersion -> CodeGen () +setModuleMinBase :: BaseVersion -> CodeGen e () setModuleMinBase v = modify' $ \(cgs, s) -> (cgs, s{moduleMinBase = max v (moduleMinBase s)}) -- | Add documentation for a given section. -addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen () +addSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e () addSectionFormattedDocs section docs = - modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (<>) section - docs (sectionDocs s)}) + modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (flip (<>)) + section docs (sectionDocs s)}) +-- | Prepend documentation at the beginning of a given section. +prependSectionFormattedDocs :: HaddockSection -> Text -> CodeGen e () +prependSectionFormattedDocs section docs = + modify' $ \(cgs, s) -> (cgs, s{sectionDocs = M.insertWith (<>) + section docs (sectionDocs s)}) + -- | Format a CPP conditional. cppCondFormat :: CPPConditional -> (Text, Text) cppCondFormat (CPPIf c) = ("#if " <> c <> "\n", "#endif\n") @@ -783,18 +791,26 @@ mainSectionName FlagSection = "Flags" -- | Format a given section made of subsections. -formatSection :: NamedSection -> [(Subsection, Export)] -> Maybe Text -formatSection section exports = - if null exports +formatSection :: M.Map HaddockSection Text -> NamedSection -> + (Set.Set Export, [(Subsection, Export)]) -> Maybe Text +formatSection docs section (sectionExports, subsectionExports) = + if null subsectionExports && Set.null sectionExports then Nothing - else Just . T.unlines $ [" -- * " <> mainSectionName section + else let docstring = case M.lookup (Section section) docs of + Nothing -> "" + Just s -> formatHaddockComment s + in Just . T.unlines $ [" -- * " <> mainSectionName section + , docstring + , ( T.concat + . map (formatExport exportSymbol) + . Set.toList ) sectionExports , ( T.unlines . map formatSubsection . M.toList ) exportedSubsections] where exportedSubsections :: M.Map Subsection (Set.Set Export) - exportedSubsections = foldr extract M.empty exports + exportedSubsections = foldr extract M.empty subsectionExports extract :: (Subsection, Export) -> M.Map Subsection (Set.Set Export) -> M.Map Subsection (Set.Set Export) @@ -816,18 +832,23 @@ -- | Format the list of exports into grouped sections. formatSubsectionExports :: M.Map HaddockSection Text -> [Export] -> [Maybe Text] -formatSubsectionExports docs exports = map (uncurry formatSection) +formatSubsectionExports docs exports = map (uncurry (formatSection docs)) (M.toAscList collectedExports) - where collectedExports :: M.Map NamedSection [(Subsection, Export)] + where collectedExports :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) collectedExports = foldl classifyExport M.empty exports - classifyExport :: M.Map NamedSection [(Subsection, Export)] -> - Export -> M.Map NamedSection [(Subsection, Export)] + classifyExport :: M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) -> + Export -> + M.Map NamedSection (Set.Set Export, [(Subsection, Export)]) classifyExport m export = - case exportType export of + let join (snew, exnew) (sold, exold) = (Set.union snew sold, + exnew ++ exold) + in case exportType export of ExportSymbol hs@(NamedSubsection ms n) -> let subsec = subsecWithPrefix ms n (M.lookup hs docs) - in M.insertWith (++) ms [(subsec, export)] m + in M.insertWith join ms (Set.empty, [(subsec, export)]) m + ExportSymbol (Section s) -> + M.insertWith join s (Set.singleton export, []) m _ -> m -- | Format the given export list. This is just the inside of the @@ -901,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 @@ -922,9 +942,12 @@ , "import qualified Prelude as P" , "" , "import qualified Data.GI.Base.Attributes as GI.Attributes" + , "import qualified Data.GI.Base.BasicTypes as B.Types" , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr" + , "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" @@ -932,11 +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.OverloadedLabels as OL" + , "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 @@ -945,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 @@ -963,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 @@ -975,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 = @@ -991,11 +1060,19 @@ -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules. writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text] -writeModuleTree verbose dirPrefix minfo = do - submodulePaths <- concat <$> forM (M.elems (submodules minfo)) - (writeModuleTree verbose dirPrefix) - writeModuleInfo verbose dirPrefix minfo - return $ (dotWithPrefix (modulePath minfo) : submodulePaths) +writeModuleTree verbose dirPrefix root = doWriteModuleTree root + + where + doWriteModuleTree :: ModuleInfo -> IO [Text] + doWriteModuleTree minfo = do + submodulePaths <- concat <$> forM (M.elems (submodules minfo)) doWriteModuleTree + writeModuleInfo verbose dirPrefix minfo treeMap + return $ (dotWithPrefix (modulePath minfo) : submodulePaths) + + treeMap = M.fromList (gatherSubmodules root) + gatherSubmodules :: ModuleInfo -> [(ModulePath, ModuleInfo)] + gatherSubmodules minfo = (modulePath minfo, minfo) : + concatMap gatherSubmodules (M.elems $ submodules minfo) -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk. diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -21,7 +21,8 @@ import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability, detectGObject, dropDuplicatedFields, - checkClosureDestructors) + checkClosureDestructors, fixSymbolNaming, + fixClosures, fixCallbackUserData) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation, writeHaddock, @@ -36,17 +37,14 @@ import Data.GI.CodeGen.Signal (genSignal, genCallback) import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct, fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion, - genWrappedPtr) -import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName, - submoduleLocation, lowerName, qualifiedAPI) + genBoxed, genWrappedPtr) +import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, + submoduleLocation, lowerName, qualifiedAPI, + normalizedAPIName, safeCast) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) --- | Standard derived instances for newtypes wrapping @ManagedPtr@s. -newtypeDeriving :: CodeGen () -newtypeDeriving = indent $ line $ "deriving (Eq)" - -genFunction :: Name -> Function -> CodeGen () +genFunction :: Name -> Function -> CodeGen e () genFunction n (Function symbol fnMovedTo callable) = -- Only generate the function if it has not been moved. when (Nothing == fnMovedTo) $ @@ -62,67 +60,35 @@ export (NamedSubsection MethodSection $ lowerName n) (lowerName n) ) --- | Generate the GValue instances for the given GObject. -genBoxedGValueInstance :: Name -> Text -> CodeGen () -genBoxedGValueInstance n get_type_fn = do - let name' = upperName n - doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." - - writeHaddock DocBeforeSymbol doc - +-- | Create the newtype wrapping the ManagedPtr for the given type. +genNewtype :: Text -> CodeGen e () +genNewtype name' = do group $ do - bline $ "instance B.GValue.IsGValue " <> name' <> " where" - indent $ group $ do - line $ "toGValue o = do" - indent $ group $ do - line $ "gtype <- " <> get_type_fn - line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)" - line $ "fromGValue gv = do" - indent $ group $ do - line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")" - line $ "B.ManagedPtr.newBoxed " <> name' <> " ptr" - -genBoxedObject :: Name -> Text -> CodeGen () -genBoxedObject n typeInit = do - let name' = upperName n - get_type_fn = "c_" <> typeInit + bline $ "newtype " <> name' <> " = " <> name' <> " (SP.ManagedPtr " <> name' <> ")" + indent $ line $ "deriving (Eq)" group $ do - line $ "foreign import ccall \"" <> typeInit <> "\" " <> - get_type_fn <> " :: " - indent $ line "IO GType" - group $ do - line $ "instance BoxedObject " <> name' <> " where" - indent $ line $ "boxedType _ = " <> get_type_fn - - genBoxedGValueInstance n get_type_fn - - hsBoot $ line $ "instance BoxedObject " <> name' <> " where" + bline $ "instance SP.ManagedPtrNewtype " <> name' <> " where" + indent $ line $ "toManagedPtr (" <> name' <> " p) = p" -- | Generate wrapper for structures. -genStruct :: Name -> Struct -> CodeGen () +genStruct :: Name -> Struct -> CodeGen e () genStruct n s = unless (ignoreStruct n s) $ do - let name' = upperName n + let Name _ name' = normalizedAPIName (APIStruct s) n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") - let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" - hsBoot decl - decl - newtypeDeriving + genNewtype name' + exportDecl (name' <> ("(..)")) addSectionDocumentation ToplevelSection (structDocumentation s) if structIsBoxed s - then genBoxedObject n (fromJust $ structTypeInit s) + then genBoxed n (fromJust $ structTypeInit s) else genWrappedPtr n (structAllocationInfo s) (structSize s) - exportDecl (name' <> ("(..)")) - -- Generate a builder for a structure filled with zeroes. genZeroStruct n s - noName name' - -- Generate code for fields. genStructOrUnionFields n (structFields s) @@ -140,33 +106,26 @@ else return Nothing -- Overloaded methods - cppIf CPPOverloading $ - genMethodList n (catMaybes methods) + cppIf CPPOverloading (genMethodList n (catMaybes methods)) -- | Generated wrapper for unions. -genUnion :: Name -> Union -> CodeGen () +genUnion :: Name -> Union -> CodeGen e () genUnion n u = do - let name' = upperName n + let Name _ name' = normalizedAPIName (APIUnion u) n writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") - let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" - hsBoot decl - decl - newtypeDeriving + genNewtype name' + exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (unionDocumentation u) if unionIsBoxed u - then genBoxedObject n (fromJust $ unionTypeInit u) + then genBoxed n (fromJust $ unionTypeInit u) else genWrappedPtr n (unionAllocationInfo u) (unionSize u) - exportDecl (name' <> "(..)") - -- Generate a builder for a structure filled with zeroes. genZeroUnion n u - noName name' - -- Generate code for fields. genStructOrUnionFields n (unionFields u) @@ -184,8 +143,7 @@ else return Nothing -- Overloaded methods - cppIf CPPOverloading $ - genMethodList n (catMaybes methods) + cppIf CPPOverloading $ genMethodList n (catMaybes methods) -- | When parsing the GIR file we add the implicit object argument to -- methods of an object. Since we are prepending an argument we need @@ -196,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)} @@ -221,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 @@ -262,44 +222,68 @@ 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. +genGValueGetter :: Text -> Text -> CodeGen e Text +genGValueGetter name' get_value_fn = group $ do + let symb = "gv_get_" <> get_value_fn + line $ "foreign import ccall \"" <> get_value_fn <> "\" " <> symb <> " ::" + indent $ line $ "FP.Ptr B.GValue.GValue -> IO (FP.Ptr " <> name' <> ")" + return symb + +-- | Generate an import for the gvalue setter for the given type. It +-- returns the name of the function on the Haskell side. +genGValueSetter :: Text -> Text -> CodeGen e Text +genGValueSetter name' set_value_fn = group $ do + let symb = "gv_set_" <> set_value_fn + line $ "foreign import ccall \"" <> set_value_fn <> "\" " <> symb <> " ::" + indent $ line $ "FP.Ptr B.GValue.GValue -> FP.Ptr " <> name' <> " -> IO ()" + return symb + -- | Generate the GValue instances for the given GObject. -genGObjectGValueInstance :: Name -> Text -> CodeGen () -genGObjectGValueInstance n get_type_fn = do +genGValueInstance :: Name -> Text -> Text -> Text -> Text -> CodeGen e () +genGValueInstance n get_type_fn newFn get_value_fn set_value_fn = do let name' = upperName n - doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." + doc = "Convert 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 group $ do - bline $ "instance B.GValue.IsGValue " <> name' <> " where" + bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where" indent $ group $ do - line $ "toGValue o = do" - indent $ group $ do - line $ "gtype <- " <> get_type_fn - line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_object)" - line $ "fromGValue gv = do" + line $ "gvalueGType_ = " <> get_type_fn + line $ "gvalueSet_ gv P.Nothing = " <> set_value_fn <> " gv (FP.nullPtr :: FP.Ptr " <> name' <> ")" + line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (" <> set_value_fn <> " gv)" + line $ "gvalueGet_ gv = do" indent $ group $ do - line $ "ptr <- B.GValue.get_object gv :: IO (Ptr " <> name' <> ")" - line $ "B.ManagedPtr.newObject " <> name' <> " ptr" + line $ "ptr <- " <> get_value_fn <> " gv :: IO (FP.Ptr " <> name' <> ")" + line $ "if ptr /= FP.nullPtr" + line $ "then P.Just <$> " <> newFn <> " " <> name' <> " ptr" + line $ "else return P.Nothing" --- Type casting with type checking -genGObjectCasts :: Name -> Text -> [Name] -> CodeGen () -genGObjectCasts n cn_ parents = do +-- | Type casting with type checking, returns the function returning the +-- GType for the oject. +genCasts :: Name -> Text -> [Name] -> CodeGen e Text +genCasts n ti parents = do + isGO <- isGObject (TInterface n) let name' = upperName n - get_type_fn = "c_" <> cn_ - group $ do - line $ "foreign import ccall \"" <> cn_ <> "\"" - indent $ line $ get_type_fn <> " :: IO GType" + get_type_fn <- do + let cn_ = "c_" <> ti + group $ do + line $ "foreign import ccall \"" <> ti <> "\"" + indent $ line $ cn_ <> " :: IO B.Types.GType" + return cn_ group $ do - bline $ "instance GObject " <> name' <> " where" - indent $ group $ do - line $ "gobjectType = " <> get_type_fn + bline $ "instance B.Types.TypedObject " <> name' <> " where" + indent $ do + line $ "glibType = " <> get_type_fn - genGObjectGValueInstance n get_type_fn + when isGO $ group $ do + bline $ "instance B.Types.GObject " <> name' className <- classConstraint n group $ do @@ -313,105 +297,112 @@ -- since we sometimes need to refer to @IsX@ itself, without -- applying it. We instead use the trick of creating a class with -- a universal instance. - let constraints = "(GObject o, O.IsDescendantOf " <> name' <> " o)" + let constraints = if isGO + then "(SP.GObject o, O.IsDescendantOf " <> name' <> " o)" + else "(SP.BoxedPtr o, SP.TypedObject o, O.IsDescendantOf " <> name' <> " o)" bline $ "class " <> constraints <> " => " <> className <> " o" bline $ "instance " <> constraints <> " => " <> className <> " o" blank - qualifiedParents <- mapM qualifiedAPI parents + parentAPIs <- mapM (\n -> getAPI (TInterface n)) parents + qualifiedParents <- mapM (uncurry qualifiedAPI) (zip parentAPIs parents) bline $ "instance O.HasParentTypes " <> name' line $ "type instance O.ParentTypes " <> name' <> " = '[" <> T.intercalate ", " qualifiedParents <> "]" -- Safe downcasting. group $ do - let safeCast = "to" <> name' - exportDecl safeCast + cast <- safeCast n + exportDecl cast writeHaddock DocBeforeSymbol (castDoc name') - line $ safeCast <> " :: (MonadIO m, " <> className <> " o) => o -> m " <> name' - line $ safeCast <> " = liftIO . unsafeCastTo " <> name' + bline $ cast <> " :: (MIO.MonadIO m, " <> className <> " o) => o -> m " <> name' + line $ cast <> " = MIO.liftIO . B.ManagedPtr.unsafeCastTo " <> name' + return get_type_fn + where castDoc :: Text -> Text - castDoc name' = "Cast to `" <> name' <> - "`, for types for which this is known to be safe. " <> - "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 -- of objects, we deal with these separately. -genObject :: Name -> Object -> CodeGen () +genObject :: Name -> Object -> CodeGen e () genObject n o = do - let name' = upperName n + let Name _ name' = normalizedAPIName (APIObject o) n let t = TInterface n isGO <- isGObject t - if not isGO - then line $ "-- APIObject \"" <> name' <> - "\" does not descend from GObject, it will be ignored." - else do - writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") - bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" - newtypeDeriving - exportDecl (name' <> "(..)") + writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") + genNewtype name' + exportDecl (name' <> "(..)") - addSectionDocumentation ToplevelSection (objDocumentation o) + addSectionDocumentation ToplevelSection (objDocumentation o) - -- Type safe casting to parent objects, and implemented interfaces. - parents <- instanceTree n - genGObjectCasts n (objTypeInit o) (parents <> objInterfaces o) + -- Type safe casting to parent objects, and implemented interfaces. + parents <- instanceTree n + get_type_fn <- genCasts n (objTypeInit o) (parents <> objInterfaces o) - noName name' + if isGO + then genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object" + else case (objGetValueFunc o, objSetValueFunc o) of + (Just get_value_fn, Just set_value_fn) -> do + getter <- genGValueGetter name' get_value_fn + setter <- genGValueSetter name' set_value_fn + genGValueInstance n get_type_fn "B.ManagedPtr.newPtr" getter setter + _ -> line $ "--- XXX Missing getter and/or setter, so no GValue instance could be generated." - cppIf CPPOverloading $ - fullObjectMethodList n o >>= genMethodList n + cppIf CPPOverloading $ fullObjectMethodList n o >>= genMethodList n - forM_ (objSignals o) $ \s -> genSignal s n + if isGO + then do + forM_ (objSignals o) $ \s -> genSignal s n - genObjectProperties n o - cppIf CPPOverloading $ - genNamespacedPropLabels n (objProperties o) (objMethods o) - cppIf CPPOverloading $ - genObjectSignals n o + genObjectProperties n o + cppIf CPPOverloading $ + genNamespacedPropLabels n (objProperties o) (objMethods o) + cppIf CPPOverloading $ + genObjectSignals n o + else group $ do + let allocInfo = AllocationInfo { + allocCalloc = AllocationOpUnknown, + allocCopy = case objRefFunc o of + Just ref -> AllocationOp ref + Nothing -> AllocationOpUnknown, + allocFree = case objUnrefFunc o of + Just unref -> AllocationOp unref + Nothing -> AllocationOpUnknown + } + genWrappedPtr n allocInfo 0 - -- Methods - forM_ (objMethods o) $ \f -> do - let mn = methodName f - handleCGExc (\e -> do line ("-- XXX Could not generate method " - <> name' <> "::" <> name mn) - printCGError e - cppIf CPPOverloading $ - genUnsupportedMethodInfo n f) - (genMethod n f) + -- Methods + forM_ (objMethods o) $ \f -> do + let mn = methodName f + handleCGExc (\e -> do line ("-- XXX Could not generate method " + <> name' <> "::" <> name mn) + printCGError e + cppIf CPPOverloading $ + genUnsupportedMethodInfo n f) + (genMethod n f) -genInterface :: Name -> Interface -> CodeGen () +genInterface :: Name -> Interface -> CodeGen e () genInterface n iface = do - let name' = upperName n + let Name _ name' = normalizedAPIName (APIInterface iface) n line $ "-- interface " <> name' <> " " writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.") deprecatedPragma name' $ ifDeprecated iface - bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" - newtypeDeriving + genNewtype name' exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (ifDocumentation iface) - noName name' - - forM_ (ifSignals iface) $ \s -> handleCGExc - (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::" - , sigName s] - printCGError e) - (genSignal s n) - - cppIf CPPOverloading $ - genInterfaceSignals n iface - isGO <- apiIsGObject n (APIInterface iface) if isGO then do @@ -419,7 +410,8 @@ gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface) allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p let uniqueParents = nub (concat allParents) - genGObjectCasts n cn_ uniqueParents + get_type_fn <- genCasts n cn_ uniqueParents + genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object" genInterfaceProperties n iface cppIf CPPOverloading $ @@ -428,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 -- @@ -448,8 +440,7 @@ comment $ "XXX Skipping property generation for non-GObject interface" -- Methods - cppIf CPPOverloading $ - fullInterfaceMethodList n iface >>= genMethodList n + cppIf CPPOverloading $ fullInterfaceMethodList n iface >>= genMethodList n forM_ (ifMethods iface) $ \f -> do let mn = methodName f @@ -462,13 +453,23 @@ cppIf CPPOverloading (genUnsupportedMethodInfo n f)) (genMethod n f) + -- Signals + forM_ (ifSignals iface) $ \s -> handleCGExc + (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::" + , sigName s] + printCGError e) + (genSignal s n) + + cppIf CPPOverloading $ + genInterfaceSignals n iface + -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function -- in the list of APIs. If we find a matching function (without the -- "moved-to" annotation), we don't generate the method. -- -- It may be more expedient to keep a map of symbol -> function. -symbolFromFunction :: Text -> CodeGen Bool +symbolFromFunction :: Text -> CodeGen e Bool symbolFromFunction sym = do apis <- getAPIs return $ any (hasSymbol sym . snd) $ M.toList apis @@ -478,7 +479,7 @@ sym1 == sym2 && movedTo == Nothing hasSymbol _ _ = False -genAPI :: Name -> API -> CodeGen () +genAPI :: Name -> API -> CodeGen e () genAPI n (APIConst c) = genConstant n c genAPI n (APIFunction f) = genFunction n f genAPI n (APIEnum e) = genEnum n e @@ -490,45 +491,41 @@ genAPI n (APIInterface i) = genInterface n i -- | Generate the code for a given API in the corresponding module. -genAPIModule :: Name -> API -> CodeGen () +genAPIModule :: Name -> API -> CodeGen e () genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api -genModule' :: M.Map Name API -> CodeGen () +genModule' :: M.Map Name API -> CodeGen e () genModule' apis = do mapM_ (uncurry genAPIModule) - -- We provide these ourselves - $ filter ((`notElem` [ Name "GLib" "Array" - , Name "GLib" "Error" - , Name "GLib" "HashTable" - , Name "GLib" "List" - , Name "GLib" "SList" - , Name "GLib" "Variant" - , Name "GObject" "Value" - , Name "GObject" "Closure"]) . fst) - $ mapMaybe (traverse dropMovedItems) - -- Some callback types are defined inside structs - $ map fixAPIStructs - -- Try to guess nullability of properties when there is no - -- nullability info in the GIR. - $ map guessPropertyNullability - -- Not every interface providing signals or properties is - -- correctly annotated as descending from GObject, fix this. - $ map detectGObject - -- Some APIs contain duplicated fields by mistake, drop - -- the duplicates. - $ map dropDuplicatedFields - -- Make sure that every argument marked as being a - -- destructor for a user_data argument has an associated - -- user_data argument. - $ map checkClosureDestructors - $ M.toList - $ apis + -- We provide these ourselves + $ filter (not . handWritten) + -- Some callback types are defined inside structs + $ map fixAPIStructs + -- Some APIs contain duplicated fields by mistake, drop + -- the duplicates. + $ map dropDuplicatedFields + $ mapMaybe (traverse dropMovedItems) + $ M.toList apis -- Make sure we generate a "Callbacks" module, since it is imported -- by other modules. It is fine if it ends up empty. submodule "Callbacks" (return ()) + where + -- Whether we provide hand-written bindings for the given API, + -- replacing the ones that would be autogenerated from the + -- introspection data. + handWritten :: (Name, API) -> Bool + handWritten (Name "GLib" "Array", _) = True + handWritten (Name "GLib" "Error", _) = True + handWritten (Name "GLib" "HashTable", _) = True + handWritten (Name "GLib" "List", _) = True + handWritten (Name "GLib" "SList", _) = True + handWritten (Name "GLib" "Variant", _) = True + handWritten (Name "GObject" "Value", _) = True + handWritten (Name "GObject" "Closure", _) = True + handWritten _ = False -genModule :: M.Map Name API -> CodeGen () +genModule :: M.Map Name API -> CodeGen e () genModule apis = do -- Reexport Data.GI.Base for convenience (so it does not need to be -- imported separately). @@ -537,9 +534,35 @@ -- Some API symbols are embedded into structures, extract these and -- inject them into the set of APIs loaded and being generated. - let embeddedAPIs = (M.fromList + let embeddedAPIs = (fixAPIs . M.fromList . concatMap extractCallbacksInStruct . M.toList) apis allAPIs <- getAPIs - recurseWithAPIs (M.union allAPIs embeddedAPIs) - (genModule' (M.union apis embeddedAPIs)) + let contextAPIs = M.union (fixAPIs allAPIs) embeddedAPIs + targetAPIs = M.union (fixAPIs apis) embeddedAPIs + + recurseWithAPIs contextAPIs (genModule' targetAPIs) + + where + fixAPIs :: M.Map Name API -> M.Map Name API + fixAPIs apis = M.fromList + -- Try to guess nullability of properties when there is no + -- nullability info in the GIR. + $ map guessPropertyNullability + -- Not every interface providing signals or properties is + -- correctly annotated as descending from GObject, fix this. + $ map detectGObject + -- Make sure that every argument marked as being a + -- 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 + $ M.toList apis diff --git a/lib/Data/GI/CodeGen/Config.hs b/lib/Data/GI/CodeGen/Config.hs --- a/lib/Data/GI/CodeGen/Config.hs +++ b/lib/Data/GI/CodeGen/Config.hs @@ -7,8 +7,15 @@ import Data.GI.CodeGen.Overrides (Overrides) data Config = Config { - -- | Name of the module being generated. + -- | GIR name of the module being generated (Gtk, GObject, ...). modName :: Text, + -- | Version of the GIR API for the package being generated + -- ("3.0", "2.0", ...). + modVersion :: Text, + -- | Haskell package being generated (gi-gtk, gi-gobject, ...). + ghcPkgName :: Text, + -- | Version of the haskell package ("3.0.35", "2.0.21", ...). + ghcPkgVersion :: Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator. diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs --- a/lib/Data/GI/CodeGen/Constant.hs +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -29,7 +29,7 @@ type PSView = Text type PSExpression = Text -writePattern :: Text -> PatternSynonym -> CodeGen () +writePattern :: Text -> PatternSynonym -> CodeGen e () writePattern name (SimpleSynonym value t) = line $ "pattern " <> ucFirst name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do @@ -40,7 +40,7 @@ indent $ line $ ucFirst name <> " = " <> expression <> " " <> value <> " :: " <> t -genConstant :: Name -> Constant -> CodeGen () +genConstant :: Name -> Constant -> CodeGen e () genConstant (Name _ name) c = group $ do setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"] deprecatedPragma name (constantDeprecated c) @@ -106,5 +106,16 @@ showBasicType TGType gtype = return $ "GType " <> gtype showBasicType TIntPtr ptr = return ptr showBasicType TUIntPtr ptr = return ptr +showBasicType TShort s = return s +showBasicType TUShort u = return u +showBasicType TSSize s = return s +showBasicType TSize s = return s +showBasicType Ttime_t t = return t +showBasicType Toff_t o = return o +showBasicType Tdev_t d = return d +showBasicType Tgid_t g = return g +showBasicType Tpid_t p = return p +showBasicType Tsocklen_t l = return l +showBasicType Tuid_t u = return u -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer" diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Conversions.hs +++ /dev/null @@ -1,1059 +0,0 @@ -{-# LANGUAGE PatternGuards, DeriveFunctor #-} - -module Data.GI.CodeGen.Conversions - ( convert - , genConversion - , unpackCArray - , computeArrayLength - - , callableHasClosures - - , hToF - , fToH - , transientToH - , haskellType - , isoHaskellType - , foreignType - - , argumentType - , ExposeClosures(..) - , elementType - , elementMap - , elementTypeAndMap - - , isManaged - , typeIsNullable - , typeIsPtr - , typeIsCallback - , maybeNullConvert - , nullPtrForType - - , typeAllocInfo - , TypeAllocInfo(..) - - , apply - , mapC - , literal - , Constructor(..) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>), pure, Applicative) -#endif -import Control.Monad (when) -import Data.Maybe (isJust) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Exts (IsString(..)) - -import Foreign.C.Types (CInt, CUInt) -import Foreign.Storable (sizeOf) - -import Data.GI.CodeGen.API -import Data.GI.CodeGen.Code -import Data.GI.CodeGen.GObject -import Data.GI.CodeGen.SymbolNaming -import Data.GI.CodeGen.Type -import Data.GI.CodeGen.Util - --- | The free monad. -data Free f r = Free (f (Free f r)) | Pure r - -instance Functor f => Functor (Free f) where - fmap f = go where - go (Pure a) = Pure (f a) - go (Free fa) = Free (go <$> fa) - -instance (Functor f) => Applicative (Free f) where - pure = Pure - Pure a <*> Pure b = Pure $ a b - Pure a <*> Free mb = Free $ fmap a <$> mb - 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 - --- | Lift some command to the Free monad. -liftF :: (Functor f) => f r -> Free f r -liftF command = Free (fmap Pure command) - --- String identifying a constructor in the generated code, which is --- either (by default) a pure function (indicated by the P --- constructor) or a function returning values on a monad (M --- constructor). 'Id' denotes the identity function. -data Constructor = P Text | M Text | Id - deriving (Eq,Show) -instance IsString Constructor where - fromString = P . T.pack - -data FExpr next = Apply Constructor next - | LambdaConvert Text next - | MapC Map Constructor next - | Literal Constructor next - deriving (Show, Functor) - -type Converter = Free FExpr () - --- Different available maps. -data Map = Map | MapFirst | MapSecond - deriving (Show) - --- Naming for the maps. -mapName :: Map -> Text -mapName Map = "map" -mapName MapFirst = "mapFirst" -mapName MapSecond = "mapSecond" - --- Naming for the monadic versions of the maps that we use -monadicMapName :: Map -> Text -monadicMapName Map = "mapM" -monadicMapName MapFirst = "mapFirstA" -monadicMapName MapSecond = "mapSecondA" - -apply :: Constructor -> Converter -apply f = liftF $ Apply f () - -mapC :: Constructor -> Converter -mapC f = liftF $ MapC Map f () - -mapFirst :: Constructor -> Converter -mapFirst f = liftF $ MapC MapFirst f () - -mapSecond :: Constructor -> Converter -mapSecond f = liftF $ MapC MapSecond f () - -literal :: Constructor -> Converter -literal f = liftF $ Literal f () - -lambdaConvert :: Text -> Converter -lambdaConvert c = liftF $ LambdaConvert c () - -genConversion :: Text -> Converter -> CodeGen Text -genConversion l (Pure ()) = return l -genConversion l (Free k) = do - let l' = prime l - case k of - Apply (P f) next -> - do line $ "let " <> l' <> " = " <> f <> " " <> l - genConversion l' next - Apply (M f) next -> - do line $ l' <> " <- " <> f <> " " <> l - genConversion l' next - Apply Id next -> genConversion l next - - MapC m (P f) next -> - do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l - genConversion l' next - MapC m (M f) next -> - do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l - genConversion l' next - MapC _ Id next -> genConversion l next - - LambdaConvert conv next -> - do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do" - increaseIndent - genConversion l' next - - Literal (P f) next -> - do line $ "let " <> l <> " = " <> f - genConversion l next - Literal (M f) next -> - do line $ l <> " <- " <> f - genConversion l next - Literal Id next -> genConversion l next - --- | Given an array, together with its type, return the code for reading --- its length. -computeArrayLength :: Text -> Type -> ExcCodeGen Text -computeArrayLength array (TCArray _ _ _ t) = do - reader <- findReader - return $ "fromIntegral $ " <> reader <> " " <> array - where findReader = case t of - TBasicType TUInt8 -> return "B.length" - TBasicType _ -> return "length" - TInterface _ -> return "length" - TCArray{} -> return "length" - _ -> notImplementedError $ - "Don't know how to compute length of " <> tshow t -computeArrayLength _ t = - notImplementedError $ "computeArrayLength called on non-CArray type " - <> tshow t - -convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text -convert l c = do - c' <- c - genConversion l c' - -hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor -hObjectToF t transfer = - if transfer == TransferEverything - then do - isGO <- isGObject t - if isGO - then return $ M "B.ManagedPtr.disownObject" - else badIntroError "Transferring a non-GObject object" - -- castPtr since we accept any instance of the class associated with - -- the GObject, not just the precise type of the GObject, while the - -- foreign function declaration requires a pointer of the precise - -- type. - else return $ M "unsafeManagedPtrCastPtr" - -hVariantToF :: Transfer -> CodeGen Constructor -hVariantToF transfer = - if transfer == TransferEverything - then return $ M "B.GVariant.disownGVariant" - else return $ M "unsafeManagedPtrGetPtr" - -hParamSpecToF :: Transfer -> CodeGen Constructor -hParamSpecToF transfer = - if transfer == TransferEverything - then return $ M "B.GParamSpec.disownGParamSpec" - else return $ M "unsafeManagedPtrGetPtr" - -hClosureToF :: Transfer -> Maybe Type -> CodeGen 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 - -- closures is always represented as Ptr (GClosure ()), while the - -- corresponding Haskell type is the parametric "GClosure a". - else return $ M "unsafeManagedPtrCastPtr" --- Typed closures -hClosureToF transfer (Just _) = - if transfer == TransferEverything - then return $ M "B.GClosure.disownGClosure" - else return $ M "unsafeManagedPtrGetPtr" - -hBoxedToF :: Transfer -> CodeGen Constructor -hBoxedToF transfer = - if transfer == TransferEverything - then return $ M "B.ManagedPtr.disownBoxed" - else return $ M "unsafeManagedPtrGetPtr" - -hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor -hStructToF s transfer = - if transfer /= TransferEverything || structIsBoxed s then - hBoxedToF transfer - else do - when (structSize s == 0) $ - badIntroError "Transferring a non-boxed struct with unknown size!" - return $ M "unsafeManagedPtrGetPtr" - -hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor -hUnionToF u transfer = - if transfer /= TransferEverything || unionIsBoxed u then - hBoxedToF transfer - else do - when (unionSize u == 0) $ - badIntroError "Transferring a non-boxed union with unknown size!" - return $ M "unsafeManagedPtrGetPtr" - --- Given the Haskell and Foreign types, returns the name of the --- function marshalling between both. -hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer - -> ExcCodeGen Constructor -hToF' t a hType fType transfer - | ( hType == fType ) = return Id - | TError <- t = hBoxedToF transfer - | TVariant <- t = hVariantToF transfer - | TParamSpec <- t = hParamSpecToF transfer - | TGClosure c <- t = hClosureToF transfer c - | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)" - | Just (APIFlags _) <- a = return "gflagsToWord" - | Just (APIObject _) <- a = hObjectToF t transfer - | Just (APIInterface _) <- a = hObjectToF t transfer - | Just (APIStruct s) <- a = hStructToF s transfer - | Just (APIUnion u) <- a = hUnionToF u transfer - -- Converting callback types requires more context, we leave that - -- as a special case to be implemented by the caller. - | Just (APICallback _) <- a = error "Cannot handle callback type here!! " - | TByteArray <- t = return $ M "packGByteArray" - | TCArray True _ _ (TBasicType TUTF8) <- t = - return $ M "packZeroTerminatedUTF8CArray" - | TCArray True _ _ (TBasicType TFileName) <- t = - return $ M "packZeroTerminatedFileNameArray" - | TCArray True _ _ (TBasicType TPtr) <- t = - return $ M "packZeroTerminatedPtrArray" - | TCArray True _ _ (TBasicType TUInt8) <- t = - return $ M "packZeroTerminatedByteString" - | TCArray True _ _ (TBasicType TBoolean) <- t = - return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))" - | TCArray True _ _ (TBasicType TGType) <- t = - return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)" - | TCArray True _ _ (TBasicType _) <- t = - return $ M "packZeroTerminatedStorableArray" - | TCArray False _ _ (TBasicType TUTF8) <- t = - return $ M "packUTF8CArray" - | TCArray False _ _ (TBasicType TFileName) <- t = - return $ M "packFileNameArray" - | TCArray False _ _ (TBasicType TPtr) <- t = - return $ M "packPtrArray" - | TCArray False _ _ (TBasicType TUInt8) <- t = - return $ M "packByteString" - | TCArray False _ _ (TBasicType TBoolean) <- t = - return $ M "(packMapStorableArray (fromIntegral . 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 _) <- t = - return $ M "packStorableArray" - | TCArray{} <- t = notImplementedError $ - "Don't know how to pack C array of type " <> tshow t - | 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)" - ("Float", "CFloat") -> return "realToFrac" - ("Double", "CDouble") -> return "realToFrac" - ("GType", "CGType") -> return "gtypeToCGType" - _ -> notImplementedError $ - "Don't know how to convert " - <> typeShow hType <> " into " - <> typeShow fType <> ".\n" - <> "Internal type: " - <> tshow t - -getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor -getForeignConstructor t transfer = do - a <- findAPI t - hType <- haskellType t - fType <- foreignType t - hToF' t a hType fType transfer - -hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter -hToF_PackedType t packer transfer = do - innerConstructor <- getForeignConstructor t transfer - return $ do - mapC innerConstructor - apply (M packer) - --- | Try to find the `hash` and `equal` functions appropriate for the --- given type, when used as a key in a GHashTable. -hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text) -hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual") -hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") -hashTableKeyMappings t = - notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported." - --- | `GHashTable` tries to fit every type into a pointer, the --- following function tries to find the appropriate --- (destroy,packer,unpacker) for the given type. -hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text) -hashTablePtrPackers (TBasicType TPtr) = - return ("Nothing", "ptrPackPtr", "ptrUnpackPtr") -hashTablePtrPackers (TBasicType TUTF8) = - return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr") -hashTablePtrPackers t = - notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported." - -hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter -hToF_PackGHashTable keys elems = do - -- We will be adding elements to the Hash list with appropriate - -- destructors, so we always want a fresh copy. - keysConstructor <- getForeignConstructor keys TransferEverything - elemsConstructor <- getForeignConstructor elems TransferEverything - (keyHash, keyEqual) <- hashTableKeyMappings keys - (keyDestroy, keyPack, _) <- hashTablePtrPackers keys - (elemDestroy, elemPack, _) <- hashTablePtrPackers elems - return $ do - apply (P "Map.toList") - mapFirst keysConstructor - mapSecond elemsConstructor - mapFirst (P keyPack) - mapSecond (P elemPack) - apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual, - keyDestroy, elemDestroy])) - -hToF :: Type -> Transfer -> ExcCodeGen Converter -hToF (TGList t) transfer = do - isPtr <- typeIsPtr t - when (not isPtr) $ - badIntroError ("'" <> tshow t <> - "' is not a pointer type, cannot pack into a GList.") - hToF_PackedType t "packGList" transfer -hToF (TGSList t) transfer = do - isPtr <- typeIsPtr t - when (not isPtr) $ - badIntroError ("'" <> tshow t <> - "' is not a pointer type, cannot pack into a GSList.") - hToF_PackedType t "packGSList" transfer -hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer -hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer -hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb -hToF (TCArray zt _ _ t@(TCArray{})) transfer = do - let packer = if zt - then "packZeroTerminated" - else "pack" - hToF_PackedType t (packer <> "PtrArray") transfer - -hToF (TCArray zt _ _ t@(TInterface _)) transfer = do - isScalar <- typeIsEnumOrFlag t - let packer = if zt - then "packZeroTerminated" - else "pack" - if isScalar - then hToF_PackedType t (packer <> "StorableArray") transfer - else do - api <- findAPI t - let size = case api of - Just (APIStruct s) -> structSize s - Just (APIUnion u) -> unionSize u - _ -> 0 - if size == 0 || zt - then hToF_PackedType t (packer <> "PtrArray") transfer - else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer - -hToF t transfer = do - a <- findAPI t - hType <- haskellType t - fType <- foreignType t - constructor <- hToF' t a hType fType transfer - return $ apply constructor - -boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor -boxedForeignPtr constructor transfer = return $ - case transfer of - TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor - _ -> M $ parenthesize $ "newBoxed " <> constructor - -suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor -suForeignPtr isBoxed hType transfer = do - let constructor = typeConName hType - if isBoxed then - boxedForeignPtr constructor transfer - else return $ M $ parenthesize $ - case transfer of - TransferEverything -> "wrapPtr " <> constructor - _ -> "newPtr " <> constructor - -structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor -structForeignPtr s = - suForeignPtr (structIsBoxed s) - -unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor -unionForeignPtr u = - suForeignPtr (unionIsBoxed u) - -fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor -fObjectToH t hType transfer = do - let constructor = typeConName hType - isGO <- isGObject t - return $ M $ parenthesize $ - case transfer of - TransferEverything -> - if isGO - then "wrapObject " <> constructor - else "wrapPtr " <> constructor - _ -> - if isGO - then "newObject " <> constructor - else "newPtr " <> constructor - -fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor -fCallbackToH hType TransferNothing = do - let constructor = typeConName hType - return (P (callbackDynamicWrapper constructor)) -fCallbackToH _ transfer = - notImplementedError ("ForeignCallback with unsupported transfer type `" - <> tshow transfer <> "'") - -fVariantToH :: Transfer -> CodeGen Constructor -fVariantToH transfer = - return $ M $ case transfer of - TransferEverything -> "B.GVariant.wrapGVariantPtr" - _ -> "B.GVariant.newGVariantFromPtr" - -fParamSpecToH :: Transfer -> CodeGen Constructor -fParamSpecToH transfer = - return $ M $ case transfer of - TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr" - _ -> "B.GParamSpec.newGParamSpecFromPtr" - -fClosureToH :: Transfer -> Maybe Type -> CodeGen Constructor --- Untyped closures -fClosureToH transfer Nothing = - return $ M $ case transfer of - TransferEverything -> - parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr" - _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr" --- Typed closures -fClosureToH transfer (Just _) = - return $ M $ case transfer of - TransferEverything -> "B.GClosure.wrapGClosurePtr" - _ -> "B.GClosure.newGClosureFromPtr" - -fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer - -> ExcCodeGen Constructor -fToH' t a hType fType transfer - | ( hType == fType ) = return Id - | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)" - | Just (APIFlags _) <- a = return "wordToGFlags" - | TError <- t = boxedForeignPtr "GError" transfer - | TVariant <- t = fVariantToH transfer - | TParamSpec <- t = fParamSpecToH transfer - | TGClosure c <- t = fClosureToH transfer c - | Just (APIStruct s) <- a = structForeignPtr s hType transfer - | Just (APIUnion u) <- a = unionForeignPtr u hType transfer - | Just (APIObject _) <- a = fObjectToH t hType transfer - | Just (APIInterface _) <- a = fObjectToH t hType transfer - | Just (APICallback _) <- a = fCallbackToH hType transfer - | TCArray True _ _ (TBasicType TUTF8) <- t = - return $ M "unpackZeroTerminatedUTF8CArray" - | TCArray True _ _ (TBasicType TFileName) <- t = - return $ M "unpackZeroTerminatedFileNameArray" - | TCArray True _ _ (TBasicType TUInt8) <- t = - return $ M "unpackZeroTerminatedByteString" - | TCArray True _ _ (TBasicType TPtr) <- t = - return $ M "unpackZeroTerminatedPtrArray" - | TCArray True _ _ (TBasicType TBoolean) <- t = - return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))" - | TCArray True _ _ (TBasicType TGType) <- t = - return $ M "(unpackMapZeroTerminatedStorableArray GType)" - | TCArray True _ _ (TBasicType TFloat) <- t = - return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" - | TCArray True _ _ (TBasicType TDouble) <- t = - return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" - | TCArray True _ _ (TBasicType _) <- t = - return $ M "unpackZeroTerminatedStorableArray" - | TCArray{} <- t = notImplementedError $ - "Don't know how to unpack C array of type " <> tshow t - | TByteArray <- t = return $ M "unpackGByteArray" - | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet" - | otherwise = case (typeShow fType, typeShow hType) of - ("CString", "T.Text") -> return $ M "cstringToText" - ("CString", "[Char]") -> return $ M "cstringToString" - ("CInt", "Char") -> return "(chr . fromIntegral)" - ("CInt", "Bool") -> return "(/= 0)" - ("CFloat", "Float") -> return "realToFrac" - ("CDouble", "Double") -> return "realToFrac" - ("CGType", "GType") -> return "GType" - _ -> - notImplementedError $ "Don't know how to convert " - <> typeShow fType <> " into " - <> typeShow hType <> ".\n" - <> "Internal type: " - <> tshow t - -getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor -getHaskellConstructor t transfer = do - a <- findAPI t - hType <- haskellType t - fType <- foreignType t - fToH' t a hType fType transfer - -fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter -fToH_PackedType t unpacker transfer = do - innerConstructor <- getHaskellConstructor t transfer - return $ do - apply (M unpacker) - mapC innerConstructor - -fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter -fToH_UnpackGHashTable keys elems transfer = do - keysConstructor <- getHaskellConstructor keys transfer - (_,_,keysUnpack) <- hashTablePtrPackers keys - elemsConstructor <- getHaskellConstructor elems transfer - (_,_,elemsUnpack) <- hashTablePtrPackers elems - return $ do - apply (M "unpackGHashTable") - mapFirst (P keysUnpack) - mapFirst keysConstructor - mapSecond (P elemsUnpack) - mapSecond elemsConstructor - apply (P "Map.fromList") - -fToH :: Type -> Transfer -> ExcCodeGen Converter -fToH (TGList t) transfer = do - isPtr <- typeIsPtr t - when (not isPtr) $ - badIntroError ("`" <> tshow t <> - "' is not a pointer type, cannot unpack from a GList.") - fToH_PackedType t "unpackGList" transfer -fToH (TGSList t) transfer = do - isPtr <- typeIsPtr t - when (not isPtr) $ - badIntroError ("`" <> tshow t <> - "' is not a pointer type, cannot unpack from a GSList.") - fToH_PackedType t "unpackGSList" transfer -fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer -fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer -fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer --- We cannot unpack arrays without any kind of length info. -fToH t@(TCArray False (-1) (-1) _) _ = - badIntroError ("`" <> tshow t <> - "' is an array type, but contains no length information.") -fToH (TCArray True _ _ t@(TCArray{})) transfer = - fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer -fToH (TCArray True _ _ t@(TInterface _)) transfer = do - isScalar <- typeIsEnumOrFlag t - if isScalar - then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer - else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer - -fToH t transfer = do - a <- findAPI t - hType <- haskellType t - fType <- foreignType t - constructor <- fToH' t a hType fType transfer - return $ apply constructor - --- | Somewhat like `fToH`, but with slightly different borrowing --- semantics: in the case of `TransferNothing` we wrap incoming --- pointers to boxed structs into transient `ManagedPtr`s (every other --- case behaves as `fToH`). These are `ManagedPtr`s for which we do --- not make a copy, and which will be disowned when the function --- exists, instead of making a copy that the GC will collect --- eventually. --- --- This is necessary in order to get the semantics of callbacks and --- signals right: in some cases making a copy of the object does not --- simply increase the refcount, but rather makes a full copy. In this --- cases modification of the original object is not possible, but this --- is sometimes useful, see for example --- --- https://github.com/haskell-gi/haskell-gi/issues/97 --- --- Another situation where making a copy of incoming arguments is --- problematic is when the underlying library is not thread-safe. When --- running under the threaded GHC runtime it can happen that the GC --- runs on a different OS thread than the thread where the object was --- created, and this leads to rather mysterious bugs, see for example --- --- https://github.com/haskell-gi/haskell-gi/issues/96 --- --- This case is particularly nasty, since it affects `onWidgetDraw`, --- which is very common. -transientToH :: Type -> Transfer -> ExcCodeGen Converter -transientToH t@(TInterface _) TransferNothing = do - a <- findAPI t - case a of - Just (APIStruct s) -> if structIsBoxed s - then wrapTransient t - else fToH t TransferNothing - Just (APIUnion u) -> if unionIsBoxed u - then wrapTransient t - else fToH t TransferNothing - _ -> fToH t TransferNothing -transientToH t transfer = fToH t transfer - --- | Wrap the given transient. -wrapTransient :: Type -> CodeGen Converter -wrapTransient t = do - hCon <- typeConName <$> haskellType t - return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon - -unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter -unpackCArray length (TCArray False _ _ t) transfer = - case t of - TBasicType TUTF8 -> return $ apply $ M $ parenthesize $ - "unpackUTF8CArrayWithLength " <> length - TBasicType TFileName -> return $ apply $ M $ parenthesize $ - "unpackFileNameArrayWithLength " <> length - TBasicType TUInt8 -> return $ apply $ M $ parenthesize $ - "unpackByteStringWithLength " <> length - TBasicType TPtr -> return $ apply $ M $ parenthesize $ - "unpackPtrArrayWithLength " <> length - TBasicType TBoolean -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength (/= 0) " <> length - TBasicType TGType -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength GType " <> length - TBasicType TFloat -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength realToFrac " <> length - TBasicType TDouble -> return $ apply $ M $ parenthesize $ - "unpackMapStorableArrayWithLength realToFrac " <> length - TBasicType _ -> return $ apply $ M $ parenthesize $ - "unpackStorableArrayWithLength " <> length - TInterface _ -> do - a <- findAPI t - isScalar <- typeIsEnumOrFlag t - hType <- haskellType t - fType <- foreignType t - innerConstructor <- fToH' t a hType fType transfer - let (boxed, size) = case a of - Just (APIStruct s) -> (structIsBoxed s, structSize s) - Just (APIUnion u) -> (unionIsBoxed u, unionSize u) - _ -> (False, 0) - let unpacker | isScalar = "unpackStorableArrayWithLength" - | (size == 0) = "unpackPtrArrayWithLength" - | boxed = "unpackBoxedArrayWithLength " <> tshow size - | otherwise = "unpackBlockArrayWithLength " <> tshow size - return $ do - apply $ M $ parenthesize $ unpacker <> " " <> length - mapC innerConstructor - _ -> notImplementedError $ - "unpackCArray : Don't know how to unpack C Array of type " <> tshow t - -unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." - --- | Whether to expose closures and the associated destroy notify --- handlers in the Haskell wrapper. -data ExposeClosures = WithClosures - | WithoutClosures - deriving (Eq) - --- | Given a type find the typeclasses the type belongs to, and return --- the representation of the type in the function signature and the --- list of typeclass constraints for the type. -argumentType :: Type -> ExposeClosures -> CodeGen (Text, [Text]) -argumentType (TGList a) expose = do - (name, constraints) <- argumentType a expose - return ("[" <> name <> "]", constraints) -argumentType (TGSList a) expose = do - (name, constraints) <- argumentType a expose - return ("[" <> name <> "]", constraints) -argumentType t expose = do - api <- findAPI t - s <- typeShow <$> haskellType t - case api of - -- Instead of restricting to the actual class, - -- we allow for any object descending from it. - Just (APIInterface _) -> do - cls <- typeConstraint t - l <- getFreshTypeVariable - return (l, [cls <> " " <> l]) - Just (APIObject _) -> do - isGO <- isGObject t - if isGO - then do cls <- typeConstraint t - l <- getFreshTypeVariable - return (l, [cls <> " " <> l]) - else return (s, []) - Just (APICallback cb) -> - -- See [Note: Callables that throw] - if callableThrows (cbCallable cb) - then do - ft <- typeShow <$> foreignType t - return (ft, []) - else - case expose of - WithClosures -> do - s_withClosures <- typeShow <$> isoHaskellType t - return (s_withClosures, []) - WithoutClosures -> - return (s, []) - _ -> return (s, []) - -haskellBasicType :: BasicType -> TypeRep -haskellBasicType TPtr = ptr $ con0 "()" -haskellBasicType TBoolean = con0 "Bool" --- For all the platforms that we support (and those supported by glib) --- we have gint == gint32. Encoding this assumption in the types saves --- conversions. -haskellBasicType TInt = case sizeOf (0 :: CInt) of - 4 -> con0 "Int32" - n -> error ("Unsupported `gint' length: " ++ - show n) -haskellBasicType TUInt = case sizeOf (0 :: CUInt) of - 4 -> con0 "Word32" - n -> error ("Unsupported `guint' length: " ++ - show n) -haskellBasicType TLong = con0 "CLong" -haskellBasicType TULong = con0 "CULong" -haskellBasicType TInt8 = con0 "Int8" -haskellBasicType TUInt8 = con0 "Word8" -haskellBasicType TInt16 = con0 "Int16" -haskellBasicType TUInt16 = con0 "Word16" -haskellBasicType TInt32 = con0 "Int32" -haskellBasicType TUInt32 = con0 "Word32" -haskellBasicType TInt64 = con0 "Int64" -haskellBasicType TUInt64 = con0 "Word64" -haskellBasicType TGType = con0 "GType" -haskellBasicType TUTF8 = con0 "T.Text" -haskellBasicType TFloat = con0 "Float" -haskellBasicType TDouble = con0 "Double" -haskellBasicType TUniChar = con0 "Char" -haskellBasicType TFileName = con0 "[Char]" -haskellBasicType TIntPtr = con0 "CIntPtr" -haskellBasicType TUIntPtr = con0 "CUIntPtr" - --- | This translates GI types to the types used for generated Haskell code. -haskellType :: Type -> CodeGen TypeRep -haskellType (TBasicType bt) = return $ haskellBasicType bt --- There is no great choice in this case, so we simply pass the --- pointer along. This is useful for GdkPixbufNotify, for example. -haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) = - foreignType t -haskellType (TCArray _ _ _ (TBasicType TUInt8)) = - return $ "ByteString" `con` [] -haskellType (TCArray _ _ _ a) = do - inner <- haskellType a - return $ "[]" `con` [inner] -haskellType (TGArray a) = do - inner <- haskellType a - return $ "[]" `con` [inner] -haskellType (TPtrArray a) = do - inner <- haskellType a - return $ "[]" `con` [inner] -haskellType (TByteArray) = return $ "ByteString" `con` [] -haskellType (TGList a) = do - inner <- haskellType a - return $ "[]" `con` [inner] -haskellType (TGSList a) = do - inner <- haskellType a - return $ "[]" `con` [inner] -haskellType (TGHash a b) = do - innerA <- haskellType a - innerB <- haskellType b - return $ "Map.Map" `con` [innerA, innerB] -haskellType TError = return $ "GError" `con` [] -haskellType TVariant = return $ "GVariant" `con` [] -haskellType TParamSpec = return $ "GParamSpec" `con` [] -haskellType (TGClosure (Just inner@(TInterface n))) = do - innerAPI <- getAPI inner - case innerAPI of - APICallback _ -> do - tname <- qualifiedSymbol (callbackCType $ name n) n - return $ "GClosure" `con` [con0 tname] - -- The given inner type does not make sense, so we treat it as an - -- untyped closure. - _ -> haskellType (TGClosure Nothing) -haskellType (TGClosure _) = do - tyvar <- getFreshTypeVariable - return $ "GClosure" `con` [con0 tyvar] -haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` [] -haskellType t@(TInterface n) = do - api <- getAPI t - tname <- qualifiedAPI n - return $ case api of - (APIFlags _) -> "[]" `con` [tname `con` []] - _ -> tname `con` [] - --- | Whether the callable has closure arguments (i.e. "user_data" --- style arguments). -callableHasClosures :: Callable -> Bool -callableHasClosures = any (/= -1) . map argClosure . args - --- | Check whether the given type corresponds to a callback. -typeIsCallback :: Type -> CodeGen Bool -typeIsCallback t@(TInterface _) = do - api <- findAPI t - case api of - Just (APICallback _) -> return True - _ -> return False -typeIsCallback _ = return False - --- | Basically like `haskellType`, but for types which admit a --- "isomorphic" version of the Haskell type distinct from the usual --- Haskell type. Generally the Haskell type we expose is isomorphic --- 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. -isoHaskellType :: Type -> CodeGen TypeRep -isoHaskellType (TGClosure Nothing) = - return $ "GClosure" `con` [con0 "()"] -isoHaskellType t@(TInterface n) = do - api <- findAPI t - case api of - Just (APICallback cb) -> do - tname <- qualifiedAPI n - if callableHasClosures (cbCallable cb) - then return ((callbackHTypeWithClosures tname) `con` []) - else return (tname `con` []) - _ -> haskellType t -isoHaskellType t = haskellType t - --- | Foreign (C) type associated to one of the basic types. -foreignBasicType :: BasicType -> TypeRep -foreignBasicType TBoolean = "CInt" `con` [] -foreignBasicType TUTF8 = "CString" `con` [] -foreignBasicType TFileName = "CString" `con` [] -foreignBasicType TUniChar = "CInt" `con` [] -foreignBasicType TFloat = "CFloat" `con` [] -foreignBasicType TDouble = "CDouble" `con` [] -foreignBasicType TGType = "CGType" `con` [] -foreignBasicType t = haskellBasicType t - --- This translates GI types to the types used in foreign function calls. -foreignType :: Type -> CodeGen TypeRep -foreignType (TBasicType t) = return $ foreignBasicType t -foreignType (TCArray zt _ _ t) = do - api <- findAPI t - let size = case api of - Just (APIStruct s) -> structSize s - Just (APIUnion u) -> unionSize u - _ -> 0 - if size == 0 || zt - then ptr <$> foreignType t - else foreignType t -foreignType (TGArray a) = do - inner <- foreignType a - return $ ptr ("GArray" `con` [inner]) -foreignType (TPtrArray a) = do - inner <- foreignType a - return $ ptr ("GPtrArray" `con` [inner]) -foreignType (TByteArray) = return $ ptr ("GByteArray" `con` []) -foreignType (TGList a) = do - inner <- foreignType a - return $ ptr ("GList" `con` [inner]) -foreignType (TGSList a) = do - inner <- foreignType a - return $ ptr ("GSList" `con` [inner]) -foreignType (TGHash a b) = do - innerA <- foreignType a - innerB <- foreignType b - return $ ptr ("GHashTable" `con` [innerA, innerB]) -foreignType t@TError = ptr <$> haskellType t -foreignType t@TVariant = ptr <$> haskellType t -foreignType t@TParamSpec = ptr <$> haskellType t -foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"]) -foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t -foreignType (TInterface (Name "GObject" "Value")) = - return $ ptr $ "GValue" `con` [] -foreignType t@(TInterface n) = do - api <- getAPI t - let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e)) - ctypeForEnum e = if enumIsSigned e - then "CInt" - else "CUInt" - case api of - APIEnum e -> return $ (ctypeForEnum e) `con` [] - APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` [] - APICallback _ -> do - tname <- qualifiedSymbol (callbackCType $ name n) n - return (funptr $ tname `con` []) - _ -> do - tname <- qualifiedAPI n - return (ptr $ tname `con` []) - --- | Whether the give type corresponds to an enum or flag. -typeIsEnumOrFlag :: Type -> CodeGen Bool -typeIsEnumOrFlag t = do - a <- findAPI t - case a of - Nothing -> return False - (Just (APIEnum _)) -> return True - (Just (APIFlags _)) -> return True - _ -> return False - --- | Information on how to allocate a type. -data TypeAllocInfo = TypeAllocInfo { - typeAllocInfoIsBoxed :: Bool - , typeAllocInfoSize :: Int -- ^ In bytes. - } - --- | Information on how to allocate the given type, if known. -typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo) -typeAllocInfo t = do - api <- findAPI t - case api of - Just (APIStruct s) -> case structSize s of - 0 -> return Nothing - n -> let info = TypeAllocInfo { - typeAllocInfoIsBoxed = structIsBoxed s - , typeAllocInfoSize = n - } - in return (Just info) - _ -> return Nothing - --- | Returns whether the given type corresponds to a `ManagedPtr` --- instance (a thin wrapper over a `ForeignPtr`). -isManaged :: Type -> CodeGen Bool -isManaged TError = return True -isManaged TVariant = return True -isManaged TParamSpec = return True -isManaged (TGClosure _) = return True -isManaged t@(TInterface _) = do - a <- findAPI t - case a of - Just (APIObject _) -> return True - Just (APIInterface _) -> return True - Just (APIStruct _) -> return True - Just (APIUnion _) -> return True - _ -> return False -isManaged _ = return False - --- | Returns whether the given type is represented by a pointer on the --- C side. -typeIsPtr :: Type -> CodeGen Bool -typeIsPtr t = isJust <$> typePtrType t - --- | Distinct types of foreign pointers. -data FFIPtrType = FFIPtr -- ^ Ordinary `Ptr`. - | FFIFunPtr -- ^ `FunPtr`. - --- | For those types represented by pointers on the C side, return the --- type of pointer which represents them on the Haskell FFI. -typePtrType :: Type -> CodeGen (Maybe FFIPtrType) -typePtrType (TBasicType TPtr) = return (Just FFIPtr) -typePtrType (TBasicType TUTF8) = return (Just FFIPtr) -typePtrType (TBasicType TFileName) = return (Just FFIPtr) -typePtrType t = do - ft <- foreignType t - case typeConName ft of - "Ptr" -> return (Just FFIPtr) - "FunPtr" -> return (Just FFIFunPtr) - _ -> return Nothing - --- | If the passed in type is nullable, return the conversion function --- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the --- corresponding `Maybe` type. -maybeNullConvert :: Type -> CodeGen (Maybe Text) -maybeNullConvert (TBasicType TPtr) = return Nothing -maybeNullConvert (TGList _) = return Nothing -maybeNullConvert (TGSList _) = return Nothing -maybeNullConvert t = do - pt <- typePtrType t - case pt of - Just FFIPtr -> return (Just "SP.convertIfNonNull") - Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull") - Nothing -> return Nothing - --- | An appropriate NULL value for the given type, for types which are --- represented by pointers on the C side. -nullPtrForType :: Type -> CodeGen (Maybe Text) -nullPtrForType t = do - pt <- typePtrType t - case pt of - Just FFIPtr -> return (Just "FP.nullPtr") - Just FFIFunPtr -> return (Just "FP.nullFunPtr") - Nothing -> return Nothing - --- | Returns whether the given type should be represented by a --- `Maybe` type on the Haskell side. This applies to all properties --- which have a C representation in terms of pointers, except for --- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers, --- which we just pass through to the Haskell side. Notice that --- introspection annotations can override this. -typeIsNullable :: Type -> CodeGen Bool -typeIsNullable t = isJust <$> maybeNullConvert t - --- | If the given type maps to a list in Haskell, return the type of the --- elements, and the function that maps over them. -elementTypeAndMap :: Type -> Text -> Maybe (Type, Text) --- ByteString -elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing -elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") -elementTypeAndMap (TCArray False (-1) _ t) len = - Just (t, parenthesize $ "mapCArrayWithLength " <> len) -elementTypeAndMap (TCArray False fixed _ t) _ = - Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed) -elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray") -elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray") -elementTypeAndMap (TGList t) _ = Just (t, "mapGList") -elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList") --- GHashTable is treated separately, see Transfer.hs -elementTypeAndMap _ _ = Nothing - --- Return just the element type. -elementType :: Type -> Maybe Type -elementType t = fst <$> elementTypeAndMap t undefined - --- Return just the map. -elementMap :: Type -> Text -> Maybe Text -elementMap t len = snd <$> elementTypeAndMap t len diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -0,0 +1,1157 @@ +{-# LANGUAGE PatternGuards, DeriveFunctor #-} + +module Data.GI.CodeGen.Conversions + ( convert + , genConversion + , unpackCArray + , computeArrayLength + + , callableHasClosures + + , hToF + , fToH + , transientToH + , haskellType + , isoHaskellType + , foreignType + + , argumentType + , ExposeClosures(..) + , elementType + , elementMap + , elementTypeAndMap + + , isManaged + , typeIsNullable + , typeIsPtr + , typeIsCallback + , maybeNullConvert + , nullPtrForType + + , typeAllocInfo + , TypeAllocInfo(..) + + , apply + , mapC + , literal + , Constructor(..) + ) where + +#include + +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif + +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Exts (IsString(..)) + +import Foreign.C.Types (CInt, CUInt) +import Foreign.Storable (sizeOf) + +import Data.GI.CodeGen.API +import Data.GI.CodeGen.Code +import Data.GI.CodeGen.GObject +import Data.GI.CodeGen.SymbolNaming +import Data.GI.CodeGen.Type +import Data.GI.CodeGen.Util + +-- | The free monad. +data Free f r = Free (f (Free f r)) | Pure r + +instance Functor f => Functor (Free f) where + fmap f = go where + go (Pure a) = Pure (f a) + go (Free fa) = Free (go <$> fa) + +instance (Functor f) => Applicative (Free f) where + pure = Pure + Pure a <*> Pure b = Pure $ a b + Pure a <*> Free mb = Free $ fmap a <$> mb + Free ma <*> b = Free $ (<*> b) <$> ma + +instance (Functor f) => Monad (Free f) where + (Free x) >>= f = Free (fmap (>>= f) x) + (Pure r) >>= f = f r + +-- | Lift some command to the Free monad. +liftF :: (Functor f) => f r -> Free f r +liftF command = Free (fmap Pure command) + +-- String identifying a constructor in the generated code, which is +-- either (by default) a pure function (indicated by the P +-- constructor) or a function returning values on a monad (M +-- constructor). 'Id' denotes the identity function. +data Constructor = P Text | M Text | Id + deriving (Eq,Show) +instance IsString Constructor where + fromString = P . T.pack + +data FExpr next = Apply Constructor next + | LambdaConvert Text next + | MapC Map Constructor next + | Literal Constructor next + deriving (Show, Functor) + +type Converter = Free FExpr () + +-- Different available maps. +data Map = Map | MapFirst | MapSecond + deriving (Show) + +-- Naming for the maps. +mapName :: Map -> Text +mapName Map = "map" +mapName MapFirst = "mapFirst" +mapName MapSecond = "mapSecond" + +-- Naming for the monadic versions of the maps that we use +monadicMapName :: Map -> Text +monadicMapName Map = "mapM" +monadicMapName MapFirst = "mapFirstA" +monadicMapName MapSecond = "mapSecondA" + +apply :: Constructor -> Converter +apply f = liftF $ Apply f () + +mapC :: Constructor -> Converter +mapC f = liftF $ MapC Map f () + +mapFirst :: Constructor -> Converter +mapFirst f = liftF $ MapC MapFirst f () + +mapSecond :: Constructor -> Converter +mapSecond f = liftF $ MapC MapSecond f () + +literal :: Constructor -> Converter +literal f = liftF $ Literal f () + +lambdaConvert :: Text -> Converter +lambdaConvert c = liftF $ LambdaConvert c () + +genConversion :: Text -> Converter -> CodeGen e Text +genConversion l (Pure ()) = return l +genConversion l (Free k) = do + let l' = prime l + case k of + Apply (P f) next -> + do line $ "let " <> l' <> " = " <> f <> " " <> l + genConversion l' next + Apply (M f) next -> + do line $ l' <> " <- " <> f <> " " <> l + genConversion l' next + Apply Id next -> genConversion l next + + MapC m (P f) next -> + do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l + genConversion l' next + MapC m (M f) next -> + do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l + genConversion l' next + MapC _ Id next -> genConversion l next + + LambdaConvert conv next -> + do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do" + increaseIndent + genConversion l' next + + Literal (P f) next -> + do line $ "let " <> l <> " = " <> f + genConversion l next + Literal (M f) next -> + do line $ l <> " <- " <> f + genConversion l next + Literal Id next -> genConversion l next + +-- | Given an array, together with its type, return the code for reading +-- its length. +computeArrayLength :: Text -> Type -> ExcCodeGen Text +computeArrayLength array (TCArray _ _ _ t) = do + reader <- findReader + return $ "fromIntegral $ " <> reader <> " " <> array + where findReader = case t of + TBasicType TUInt8 -> return "B.length" + _ -> return "P.length" +computeArrayLength _ t = + notImplementedError $ "computeArrayLength called on non-CArray type " + <> tshow t + +convert :: Text -> CodeGen e Converter -> CodeGen e Text +convert l c = do + c' <- c + genConversion l c' + +hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor +hObjectToF t transfer = + if transfer == TransferEverything + then do + isGO <- isGObject t + if isGO + then return $ M "B.ManagedPtr.disownObject" + else return $ M "B.ManagedPtr.disownManagedPtr" + -- castPtr since we accept any instance of the class associated with + -- the GObject, not just the precise type of the GObject, while the + -- foreign function declaration requires a pointer of the precise + -- type. + else return $ M "unsafeManagedPtrCastPtr" + +hVariantToF :: Transfer -> CodeGen e Constructor +hVariantToF transfer = + if transfer == TransferEverything + then return $ M "B.GVariant.disownGVariant" + else return $ M "unsafeManagedPtrGetPtr" + +hValueToF :: Transfer -> CodeGen e Constructor +hValueToF transfer = + if transfer == TransferEverything + then return $ M "B.GValue.disownGValue" + else return $ M "unsafeManagedPtrGetPtr" + +hParamSpecToF :: Transfer -> CodeGen e Constructor +hParamSpecToF transfer = + if transfer == TransferEverything + then return $ M "B.GParamSpec.disownGParamSpec" + else return $ M "unsafeManagedPtrGetPtr" + +hClosureToF :: Transfer -> Maybe Type -> CodeGen e Constructor +-- Untyped closures +hClosureToF transfer Nothing = + -- 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 _) = + if transfer == TransferEverything + then return $ M "B.GClosure.disownGClosure" + else return $ M "unsafeManagedPtrGetPtr" + +hBoxedToF :: Transfer -> CodeGen e Constructor +hBoxedToF transfer = + if transfer == TransferEverything + then return $ M "B.ManagedPtr.disownBoxed" + else return $ M "unsafeManagedPtrGetPtr" + +hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor +hStructToF s transfer = + if transfer /= TransferEverything || structIsBoxed s then + hBoxedToF transfer + else do + when (structSize s == 0) $ + badIntroError "Transferring a non-boxed struct with unknown size!" + return $ M "unsafeManagedPtrGetPtr" + +hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor +hUnionToF u transfer = + if transfer /= TransferEverything || unionIsBoxed u then + hBoxedToF transfer + else do + when (unionSize u == 0) $ + badIntroError "Transferring a non-boxed union with unknown size!" + return $ M "unsafeManagedPtrGetPtr" + +-- Given the Haskell and Foreign types, returns the name of the +-- function marshalling between both. +hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +hToF' t a hType fType transfer + | ( hType == fType ) = return Id + | TError <- t = hBoxedToF transfer + | TVariant <- t = hVariantToF transfer + | TGValue <- t = hValueToF transfer + | TParamSpec <- t = hParamSpecToF transfer + | TGClosure c <- t = hClosureToF transfer c + | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)" + | Just (APIFlags _) <- a = return "gflagsToWord" + | Just (APIObject _) <- a = hObjectToF t transfer + | Just (APIInterface _) <- a = hObjectToF t transfer + | Just (APIStruct s) <- a = hStructToF s transfer + | Just (APIUnion u) <- a = hUnionToF u transfer + -- Converting callback types requires more context, we leave that + -- as a special case to be implemented by the caller. + | Just (APICallback _) <- a = error "Cannot handle callback type here!! " + | TByteArray <- t = return $ M "packGByteArray" + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "packZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "packZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TPtr) <- t = + return $ M "packZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "packZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "packZeroTerminatedStorableArray" + | TCArray False _ _ (TBasicType TUTF8) <- t = + return $ M "packUTF8CArray" + | TCArray False _ _ (TBasicType TFileName) <- t = + return $ M "packFileNameArray" + | TCArray False _ _ (TBasicType TPtr) <- t = + return $ M "packPtrArray" + | TCArray False _ _ (TBasicType TUInt8) <- t = + return $ M "packByteString" + | TCArray False _ _ (TBasicType TBoolean) <- t = + 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 = + return $ M "B.GValue.packGValueArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to pack C array of type " <> tshow t + | otherwise = case (typeShow hType, typeShow fType) of + ("T.Text", "CString") -> return $ M "textToCString" + ("[Char]", "CString") -> return $ M "stringToCString" + ("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" + _ -> notImplementedError $ + "Don't know how to convert " + <> typeShow hType <> " into " + <> typeShow fType <> ".\n" + <> "Internal type: " + <> tshow t + +getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getForeignConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + hToF' t a hType fType transfer + +hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter +hToF_PackedType t packer transfer = do + innerConstructor <- getForeignConstructor t transfer + return $ do + mapC innerConstructor + apply (M packer) + +-- | Try to find the `hash` and `equal` functions appropriate for the +-- given type, when used as a key in a GHashTable. +hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text) +hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual") +hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") +hashTableKeyMappings t = + notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported." + +-- | `GHashTable` tries to fit every type into a pointer, the +-- following function tries to find the appropriate +-- (destroy,packer,unpacker) for the given type. +hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text) +hashTablePtrPackers (TBasicType TPtr) = + return ("Nothing", "B.GHT.ptrPackPtr", "B.GHT.ptrUnpackPtr") +hashTablePtrPackers (TBasicType TUTF8) = + 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." + +hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter +hToF_PackGHashTable keys elems = do + -- We will be adding elements to the Hash list with appropriate + -- destructors, so we always want a fresh copy. + keysConstructor <- getForeignConstructor keys TransferEverything + elemsConstructor <- getForeignConstructor elems TransferEverything + (keyHash, keyEqual) <- hashTableKeyMappings keys + (keyDestroy, keyPack, _) <- hashTablePtrPackers keys + (elemDestroy, elemPack, _) <- hashTablePtrPackers elems + return $ do + apply (P "Map.toList") + mapFirst keysConstructor + mapSecond elemsConstructor + mapFirst (P keyPack) + mapSecond (P elemPack) + apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual, + keyDestroy, elemDestroy])) + +hToF :: Type -> Transfer -> ExcCodeGen Converter +hToF (TGList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("'" <> tshow t <> + "' is not a pointer type, cannot pack into a GList.") + hToF_PackedType t "packGList" transfer +hToF (TGSList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("'" <> tshow t <> + "' is not a pointer type, cannot pack into a GSList.") + hToF_PackedType t "packGSList" transfer +hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer +hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer +hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb +hToF (TCArray zt _ _ t@(TCArray{})) transfer = do + let packer = if zt + then "packZeroTerminated" + else "pack" + hToF_PackedType t (packer <> "PtrArray") transfer +hToF (TCArray zt _ _ t@(TInterface _)) transfer = do + isScalar <- typeIsEnumOrFlag t + let packer = if zt + then "packZeroTerminated" + else "pack" + if isScalar + then hToF_PackedType t (packer <> "StorableArray") transfer + else do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then hToF_PackedType t (packer <> "PtrArray") transfer + else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer + +hToF t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- hToF' t a hType fType transfer + return $ apply constructor + +boxedForeignPtr :: Text -> Transfer -> CodeGen e Constructor +boxedForeignPtr constructor transfer = return $ + case transfer of + TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor + _ -> M $ parenthesize $ "newBoxed " <> constructor + +suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen e Constructor +suForeignPtr isBoxed hType transfer = do + let constructor = typeConName hType + if isBoxed then + boxedForeignPtr constructor transfer + else return $ M $ parenthesize $ + case transfer of + TransferEverything -> "wrapPtr " <> constructor + _ -> "newPtr " <> constructor + +structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen e Constructor +structForeignPtr s = + suForeignPtr (structIsBoxed s) + +unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen e Constructor +unionForeignPtr u = + suForeignPtr (unionIsBoxed u) + +fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor +fObjectToH t hType transfer = do + let constructor = typeConName hType + isGO <- isGObject t + return $ M $ parenthesize $ + case transfer of + TransferEverything -> + if isGO + then "wrapObject " <> constructor + else "wrapPtr " <> constructor + _ -> + if isGO + then "newObject " <> constructor + else "newPtr " <> constructor + +fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor +fCallbackToH hType TransferNothing = do + let constructor = typeConName hType + return (P (callbackDynamicWrapper constructor)) +fCallbackToH _ transfer = + notImplementedError ("ForeignCallback with unsupported transfer type `" + <> tshow transfer <> "'") + +fVariantToH :: Transfer -> CodeGen e Constructor +fVariantToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GVariant.wrapGVariantPtr" + _ -> "B.GVariant.newGVariantFromPtr" + +fValueToH :: Transfer -> CodeGen e Constructor +fValueToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GValue.wrapGValuePtr" + _ -> "B.GValue.newGValueFromPtr" + +fParamSpecToH :: Transfer -> CodeGen e Constructor +fParamSpecToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr" + _ -> "B.GParamSpec.newGParamSpecFromPtr" + +fClosureToH :: Transfer -> Maybe Type -> CodeGen e Constructor +-- Untyped closures +fClosureToH transfer Nothing = + return $ M $ case transfer of + TransferEverything -> + parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr" + _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr" +-- Typed closures +fClosureToH transfer (Just _) = + return $ M $ case transfer of + TransferEverything -> "B.GClosure.wrapGClosurePtr" + _ -> "B.GClosure.newGClosureFromPtr" + +fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +fToH' t a hType fType transfer + | ( hType == fType ) = return Id + | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)" + | Just (APIFlags _) <- a = return "wordToGFlags" + | TError <- t = boxedForeignPtr "GError" transfer + | TVariant <- t = fVariantToH transfer + | TGValue <- t = fValueToH transfer + | TParamSpec <- t = fParamSpecToH transfer + | TGClosure c <- t = fClosureToH transfer c + | Just (APIStruct s) <- a = structForeignPtr s hType transfer + | Just (APIUnion u) <- a = unionForeignPtr u hType transfer + | Just (APIObject _) <- a = fObjectToH t hType transfer + | Just (APIInterface _) <- a = fObjectToH t hType transfer + | Just (APICallback _) <- a = fCallbackToH hType transfer + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "unpackZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "unpackZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "unpackZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TPtr) <- t = + return $ M "unpackZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray GType)" + | TCArray True _ _ (TBasicType TFloat) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType TDouble) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "unpackZeroTerminatedStorableArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to unpack C array of type " <> tshow t + | TByteArray <- t = return $ M "unpackGByteArray" + | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet" + | otherwise = case (typeShow fType, typeShow hType) of + ("CString", "T.Text") -> return $ M "cstringToText" + ("CString", "[Char]") -> return $ M "cstringToString" + ("CInt", "Char") -> return "(chr . fromIntegral)" + ("CInt", "Bool") -> return "(/= 0)" + ("CFloat", "Float") -> return "realToFrac" + ("CDouble", "Double") -> return "realToFrac" + ("CGType", "GType") -> return "GType" + _ -> + notImplementedError $ "Don't know how to convert " + <> typeShow fType <> " into " + <> typeShow hType <> ".\n" + <> "Internal type: " + <> tshow t + +getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getHaskellConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + fToH' t a hType fType transfer + +fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter +fToH_PackedType t unpacker transfer = do + innerConstructor <- getHaskellConstructor t transfer + return $ do + apply (M unpacker) + mapC innerConstructor + +fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter +fToH_UnpackGHashTable keys elems transfer = do + keysConstructor <- getHaskellConstructor keys transfer + (_,_,keysUnpack) <- hashTablePtrPackers keys + elemsConstructor <- getHaskellConstructor elems transfer + (_,_,elemsUnpack) <- hashTablePtrPackers elems + return $ do + apply (M "unpackGHashTable") + mapFirst (P keysUnpack) + mapFirst keysConstructor + mapSecond (P elemsUnpack) + mapSecond elemsConstructor + apply (P "Map.fromList") + +fToH :: Type -> Transfer -> ExcCodeGen Converter +fToH (TGList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("`" <> tshow t <> + "' is not a pointer type, cannot unpack from a GList.") + fToH_PackedType t "unpackGList" transfer +fToH (TGSList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("`" <> tshow t <> + "' is not a pointer type, cannot unpack from a GSList.") + fToH_PackedType t "unpackGSList" transfer +fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer +fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer +fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer +-- We cannot unpack arrays without any kind of length info. +fToH t@(TCArray False (-1) (-1) _) _ = + badIntroError ("`" <> tshow t <> + "' is an array type, but contains no length information.") +fToH (TCArray True _ _ t@(TCArray{})) transfer = + fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer +fToH (TCArray True _ _ t@(TInterface _)) transfer = do + isScalar <- typeIsEnumOrFlag t + if isScalar + then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer + else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer + +fToH t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- fToH' t a hType fType transfer + return $ apply constructor + +-- | Somewhat like `fToH`, but with slightly different borrowing +-- semantics: in the case of `TransferNothing` we wrap incoming +-- pointers to boxed structs into transient `ManagedPtr`s (every other +-- case behaves as `fToH`). These are `ManagedPtr`s for which we do +-- not make a copy, and which will be disowned when the function +-- exists, instead of making a copy that the GC will collect +-- eventually. +-- +-- This is necessary in order to get the semantics of callbacks and +-- signals right: in some cases making a copy of the object does not +-- simply increase the refcount, but rather makes a full copy. In this +-- cases modification of the original object is not possible, but this +-- is sometimes useful, see for example +-- +-- https://github.com/haskell-gi/haskell-gi/issues/97 +-- +-- Another situation where making a copy of incoming arguments is +-- problematic is when the underlying library is not thread-safe. When +-- running under the threaded GHC runtime it can happen that the GC +-- runs on a different OS thread than the thread where the object was +-- created, and this leads to rather mysterious bugs, see for example +-- +-- https://github.com/haskell-gi/haskell-gi/issues/96 +-- +-- This case is particularly nasty, since it affects `onWidgetDraw`, +-- which is very common. +transientToH :: Type -> Transfer -> ExcCodeGen Converter +transientToH t@(TInterface _) TransferNothing = do + a <- findAPI t + case a of + Just (APIStruct s) -> if structIsBoxed s + then wrapTransient + else fToH t TransferNothing + Just (APIUnion u) -> if unionIsBoxed u + then wrapTransient + else fToH t TransferNothing + _ -> fToH t TransferNothing +transientToH t transfer = fToH t transfer + +-- | Wrap the given transient. +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 + TBasicType TFileName -> return $ apply $ M $ parenthesize $ + "unpackFileNameArrayWithLength " <> length + TBasicType TUInt8 -> return $ apply $ M $ parenthesize $ + "unpackByteStringWithLength " <> length + TBasicType TPtr -> return $ apply $ M $ parenthesize $ + "unpackPtrArrayWithLength " <> length + TBasicType TBoolean -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (/= 0) " <> length + TBasicType TGType -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength GType " <> length + TBasicType TFloat -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " <> length + TBasicType TDouble -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " <> length + TBasicType TUniChar -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (SP.chr . P.fromIntegral) " <> length + TBasicType _ -> return $ apply $ M $ parenthesize $ + "unpackStorableArrayWithLength " <> length + TGValue -> return $ apply $ M $ parenthesize $ + "B.GValue.unpackGValueArrayWithLength " <> length + TInterface _ -> do + a <- findAPI t + isScalar <- typeIsEnumOrFlag t + hType <- haskellType t + fType <- foreignType t + let (boxed, size) = case a of + Just (APIStruct s) -> (structIsBoxed s, structSize s) + Just (APIUnion u) -> (unionIsBoxed u, unionSize u) + _ -> (False, 0) + let unpacker | isScalar = "unpackStorableArrayWithLength" + | (size == 0) = "unpackPtrArrayWithLength" + | boxed = "unpackBoxedArrayWithLength " <> tshow size + | otherwise = "unpackBlockArrayWithLength " <> tshow size + -- We always make a copy of the elements when unpacking + -- boxed types. + let transfer' | boxed = if transfer == TransferContainer + then TransferEverything + else transfer + | otherwise = transfer + innerConstructor <- fToH' t a hType fType transfer' + return $ do + apply $ M $ parenthesize $ unpacker <> " " <> length + mapC innerConstructor + _ -> notImplementedError $ + "unpackCArray : Don't know how to unpack C Array of type " <> tshow t + +unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." + +-- | Whether to expose closures and the associated destroy notify +-- handlers in the Haskell wrapper. +data ExposeClosures = WithClosures + | WithoutClosures + deriving (Eq) + +-- | Given a type find the typeclasses the type belongs to, and return +-- the representation of the type in the function signature and the +-- list of typeclass constraints for the type. +argumentType :: Type -> ExposeClosures -> CodeGen e (Text, [Text]) +argumentType (TGList a) expose = do + (name, constraints) <- argumentType a expose + return ("[" <> name <> "]", constraints) +argumentType (TGSList a) expose = do + (name, constraints) <- argumentType a expose + return ("[" <> name <> "]", constraints) +argumentType t expose = do + api <- findAPI t + s <- typeShow <$> haskellType t + case api of + -- Instead of restricting to the actual class, + -- we allow for any object descending from it. + Just (APIInterface _) -> do + cls <- typeConstraint t + l <- getFreshTypeVariable + return (l, [cls <> " " <> l]) + Just (APIObject _) -> do + cls <- typeConstraint t + l <- getFreshTypeVariable + return (l, [cls <> " " <> l]) + Just (APICallback cb) -> + -- See [Note: Callables that throw] + if callableThrows (cbCallable cb) + then do + ft <- typeShow <$> foreignType t + return (ft, []) + else + case expose of + WithClosures -> do + s_withClosures <- typeShow <$> isoHaskellType t + return (s_withClosures, []) + WithoutClosures -> + return (s, []) + _ -> return (s, []) + +haskellBasicType :: BasicType -> TypeRep +haskellBasicType TPtr = ptr $ con0 "()" +haskellBasicType TBoolean = con0 "Bool" +-- For all the platforms that we support (and those supported by glib) +-- we have gint == gint32. Encoding this assumption in the types saves +-- conversions. +haskellBasicType TInt = case sizeOf (0 :: CInt) of + 4 -> con0 "Int32" + n -> error ("Unsupported `gint' length: " ++ + show n) +haskellBasicType TUInt = case sizeOf (0 :: CUInt) of + 4 -> con0 "Word32" + n -> error ("Unsupported `guint' length: " ++ + show n) +haskellBasicType TLong = con0 "FCT.CLong" +haskellBasicType TULong = con0 "FCT.CULong" +haskellBasicType TInt8 = con0 "Int8" +haskellBasicType TUInt8 = con0 "Word8" +haskellBasicType TInt16 = con0 "Int16" +haskellBasicType TUInt16 = con0 "Word16" +haskellBasicType TInt32 = con0 "Int32" +haskellBasicType TUInt32 = con0 "Word32" +haskellBasicType TInt64 = con0 "Int64" +haskellBasicType TUInt64 = con0 "Word64" +haskellBasicType TGType = con0 "GType" +haskellBasicType TUTF8 = con0 "T.Text" +haskellBasicType TFloat = con0 "Float" +haskellBasicType TDouble = con0 "Double" +haskellBasicType TUniChar = con0 "Char" +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 +-- There is no great choice in this case, so we simply pass the +-- pointer along. This is useful for GdkPixbufNotify, for example. +haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) = + foreignType t +haskellType (TCArray _ _ _ (TBasicType TUInt8)) = + return $ "ByteString" `con` [] +haskellType (TCArray _ _ _ a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TPtrArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TByteArray) = return $ "ByteString" `con` [] +haskellType (TGList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGSList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGHash a b) = do + innerA <- haskellType a + innerB <- haskellType b + return $ "Map.Map" `con` [innerA, innerB] +haskellType TError = return $ "GError" `con` [] +haskellType TVariant = return $ "GVariant" `con` [] +haskellType TParamSpec = return $ "GParamSpec" `con` [] +haskellType (TGClosure (Just inner@(TInterface n))) = do + innerAPI <- getAPI inner + case innerAPI of + APICallback _ -> do + let n' = normalizedAPIName innerAPI n + tname <- qualifiedSymbol (callbackCType $ name n') n + return $ "GClosure" `con` [con0 tname] + -- The given inner type does not make sense, so we treat it as an + -- untyped closure. + _ -> haskellType (TGClosure Nothing) +haskellType (TGClosure _) = do + tyvar <- getFreshTypeVariable + return $ "GClosure" `con` [con0 tyvar] +haskellType TGValue = return $ "GValue" `con` [] +haskellType t@(TInterface n) = do + api <- getAPI t + tname <- qualifiedAPI api n + return $ case api of + (APIFlags _) -> "[]" `con` [tname `con` []] + _ -> tname `con` [] + +-- | Whether the callable has closure arguments (i.e. "user_data" +-- style arguments). +callableHasClosures :: Callable -> Bool +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 +typeIsCallback t@(TInterface _) = do + api <- findAPI t + case api of + Just (APICallback _) -> return True + _ -> return False +typeIsCallback _ = return False + +-- | Basically like `haskellType`, but for types which admit a +-- "isomorphic" version of the Haskell type distinct from the usual +-- Haskell type. Generally the Haskell type we expose is isomorphic +-- 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. +isoHaskellType :: Type -> CodeGen e TypeRep +isoHaskellType (TGClosure Nothing) = + return $ "GClosure" `con` [con0 "()"] +isoHaskellType t@(TInterface n) = do + api <- findAPI t + case api of + Just apiCB@(APICallback cb) -> do + tname <- qualifiedAPI apiCB n + if callableHasClosures (cbCallable cb) + then return ((callbackHTypeWithClosures tname) `con` []) + else return (tname `con` []) + _ -> haskellType t +isoHaskellType t = haskellType t + +-- | Foreign (C) type associated to one of the basic types. +foreignBasicType :: BasicType -> TypeRep +foreignBasicType TBoolean = "CInt" `con` [] +foreignBasicType TUTF8 = "CString" `con` [] +foreignBasicType TFileName = "CString" `con` [] +foreignBasicType TUniChar = "CInt" `con` [] +foreignBasicType TFloat = "CFloat" `con` [] +foreignBasicType TDouble = "CDouble" `con` [] +foreignBasicType TGType = "CGType" `con` [] +foreignBasicType t = haskellBasicType t + +-- This translates GI types to the types used in foreign function calls. +foreignType :: Type -> CodeGen e TypeRep +foreignType (TBasicType t) = return $ foreignBasicType t +foreignType (TCArray _ _ _ TGValue) = return $ ptr ("B.GValue.GValue" `con` []) +foreignType (TCArray zt _ _ t) = do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then ptr <$> foreignType t + else foreignType t +foreignType (TGArray a) = do + inner <- foreignType a + return $ ptr ("GArray" `con` [inner]) +foreignType (TPtrArray a) = do + inner <- foreignType a + return $ ptr ("GPtrArray" `con` [inner]) +foreignType (TByteArray) = return $ ptr ("GByteArray" `con` []) +foreignType (TGList a) = do + inner <- foreignType a + return $ ptr ("GList" `con` [inner]) +foreignType (TGSList a) = do + inner <- foreignType a + return $ ptr ("GSList" `con` [inner]) +foreignType (TGHash a b) = do + innerA <- foreignType a + innerB <- foreignType b + return $ ptr ("GHashTable" `con` [innerA, innerB]) +foreignType t@TError = ptr <$> haskellType t +foreignType t@TVariant = ptr <$> haskellType t +foreignType t@TParamSpec = ptr <$> haskellType t +foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"]) +foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t +foreignType t@(TGValue) = ptr <$> haskellType t +foreignType t@(TInterface n) = do + api <- getAPI t + let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e)) + ctypeForEnum e = if enumIsSigned e + then "CInt" + else "CUInt" + case api of + APIEnum e -> return $ (ctypeForEnum e) `con` [] + APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` [] + APICallback _ -> do + let n' = normalizedAPIName api n + tname <- qualifiedSymbol (callbackCType $ name n') n + return (funptr $ tname `con` []) + _ -> do + tname <- qualifiedAPI api n + return (ptr $ tname `con` []) + +-- | Whether the give type corresponds to an enum or flag. +typeIsEnumOrFlag :: Type -> CodeGen e Bool +typeIsEnumOrFlag t = do + a <- findAPI t + case a of + Nothing -> return False + (Just (APIEnum _)) -> return True + (Just (APIFlags _)) -> return True + _ -> return False + +-- | Information on how to allocate a type: allocator function and +-- size of the struct. +data TypeAllocInfo = TypeAlloc Text Int + +-- | Information on how to allocate the given type, if known. +typeAllocInfo :: Type -> CodeGen e (Maybe TypeAllocInfo) +typeAllocInfo TGValue = + let n = #{size GValue} + in return $ Just $ TypeAlloc ("SP.callocBytes " <> tshow n) n +typeAllocInfo (TGArray t) = do + api <- findAPI t + case api of + Just (APIStruct s) -> case structSize s of + 0 -> return Nothing + n -> let allocator = "B.GArray.allocGArray " <> tshow n + in return $ Just $ TypeAlloc allocator n + _ -> return Nothing +typeAllocInfo t = do + api <- findAPI t + case api of + Just (APIStruct s) -> + case structSize s of + 0 -> return Nothing + n -> let allocator = if structIsBoxed s + then "SP.callocBoxedBytes" + else "SP.callocBytes" + in return $ Just $ TypeAlloc (allocator <> " " <> tshow n) n + _ -> return Nothing + +-- | Returns whether the given type corresponds to a `ManagedPtr` +-- instance (a thin wrapper over a `ForeignPtr`). +isManaged :: Type -> CodeGen e Bool +isManaged TError = return True +isManaged TVariant = return True +isManaged TGValue = return True +isManaged TParamSpec = return True +isManaged (TGClosure _) = return True +isManaged t@(TInterface _) = do + a <- findAPI t + case a of + Just (APIObject _) -> return True + Just (APIInterface _) -> return True + Just (APIStruct _) -> return True + Just (APIUnion _) -> return True + _ -> return False +isManaged _ = return False + +-- | Returns whether the given type is represented by a pointer on the +-- C side. +typeIsPtr :: Type -> CodeGen e Bool +typeIsPtr t = isJust <$> typePtrType t + +-- | Distinct types of foreign pointers. +data FFIPtrType = FFIPtr -- ^ Ordinary `Ptr`. + | FFIFunPtr -- ^ `FunPtr`. + +-- | For those types represented by pointers on the C side, return the +-- type of pointer which represents them on the Haskell FFI. +typePtrType :: Type -> CodeGen e (Maybe FFIPtrType) +typePtrType (TBasicType TPtr) = return (Just FFIPtr) +typePtrType (TBasicType TUTF8) = return (Just FFIPtr) +typePtrType (TBasicType TFileName) = return (Just FFIPtr) +typePtrType t = do + ft <- foreignType t + case typeConName ft of + "Ptr" -> return (Just FFIPtr) + "FunPtr" -> return (Just FFIFunPtr) + _ -> return Nothing + +-- | If the passed in type is nullable, return the conversion function +-- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the +-- corresponding `Maybe` type. +maybeNullConvert :: Type -> CodeGen e (Maybe Text) +maybeNullConvert (TBasicType TPtr) = return Nothing +maybeNullConvert (TGList _) = return Nothing +maybeNullConvert (TGSList _) = return Nothing +maybeNullConvert t = do + pt <- typePtrType t + case pt of + Just FFIPtr -> return (Just "SP.convertIfNonNull") + Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull") + Nothing -> return Nothing + +-- | An appropriate NULL value for the given type, for types which are +-- represented by pointers on the C side. +nullPtrForType :: Type -> CodeGen e (Maybe Text) +nullPtrForType t = do + pt <- typePtrType t + case pt of + Just FFIPtr -> return (Just "FP.nullPtr") + Just FFIFunPtr -> return (Just "FP.nullFunPtr") + Nothing -> return Nothing + +-- | Returns whether the given type should be represented by a +-- `Maybe` type on the Haskell side. This applies to all properties +-- which have a C representation in terms of pointers, except for +-- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers, +-- which we just pass through to the Haskell side. Notice that +-- introspection annotations can override this. +typeIsNullable :: Type -> CodeGen e Bool +typeIsNullable t = isJust <$> maybeNullConvert t + +-- | If the given type maps to a list in Haskell, return the type of the +-- elements, and the function that maps over them. +elementTypeAndMap :: Type -> Text -> Maybe (Type, Text) +-- ByteString +elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing +elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") +elementTypeAndMap (TCArray _ _ _ TGValue) len = + Just (TGValue, parenthesize $ "B.GValue.mapGValueArrayWithLength " <> len) +elementTypeAndMap (TCArray False (-1) _ t) len = + Just (t, parenthesize $ "mapCArrayWithLength " <> len) +elementTypeAndMap (TCArray False fixed _ t) _ = + Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed) +elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray") +elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray") +elementTypeAndMap (TGList t) _ = Just (t, "mapGList") +elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList") +-- GHashTable is treated separately, see Transfer.hs +elementTypeAndMap _ _ = Nothing + +-- Return just the element type. +elementType :: Type -> Maybe Type +elementType t = fst <$> elementTypeAndMap t undefined + +-- Return just the map. +elementMap :: Type -> Text -> Maybe Text +elementMap t len = snd <$> elementTypeAndMap t len diff --git a/lib/Data/GI/CodeGen/CtoHaskellMap.hs b/lib/Data/GI/CodeGen/CtoHaskellMap.hs --- a/lib/Data/GI/CodeGen/CtoHaskellMap.hs +++ b/lib/Data/GI/CodeGen/CtoHaskellMap.hs @@ -6,23 +6,24 @@ ) where import qualified Data.Map as M -import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) +import qualified Data.Text as T -import Data.GI.CodeGen.GtkDoc (CRef(..)) +import Data.GI.CodeGen.GtkDoc (CRef(..), docName) import Data.GI.CodeGen.API (API(..), Name(..), Callback(..), Constant(..), Flags(..), Enumeration(..), EnumerationMember(..), Interface(..), Object(..), Function(..), Method(..), Struct(..), Union(..), - Signal(..)) -import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.)) -import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName, - signalHaskellName) -import Data.GI.CodeGen.Util (ucFirst) + Signal(..), Property(..)) +import Data.GI.CodeGen.ModulePath (dotModulePath) +import Data.GI.CodeGen.SymbolNaming (moduleLocation, lowerName, upperName, + signalHaskellName, haddockSignalAnchor, + haddockAttrAnchor, hyphensToCamelCase) +import Data.GI.CodeGen.Util (ucFirst, lcFirst) -- | Link to an identifier, module, etc. data Hyperlink = ValueIdentifier Text @@ -56,83 +57,114 @@ 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")] - --- | Obtain the absolute location of the module where the given `API` --- lives. -location :: Name -> API -> ModulePath -location n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api + (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 fullyQualifiedValue n api symbol = - ValueIdentifier $ dotModulePath (location n api) <> "." <> symbol + ValueIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol -- | Obtain the fully qualified symbol pointing to a type. fullyQualifiedType :: Name -> API -> Text -> Hyperlink fullyQualifiedType n api symbol = - TypeIdentifier $ dotModulePath (location n api) <> "." <> symbol + TypeIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol -- | Extract the C name of a constant. These are often referred to as -- types, so we allow that too. 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 (location n api) + let mod = dotModulePath (moduleLocation n api) sn' = signalHaskellName sn ownerCName = case maybeCName of Just cname -> cname Nothing -> let Name ns owner = n in ucFirst ns <> owner - in (SignalRef ownerCName sn, - ModuleLinkWithAnchor (Just sn') mod ("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)] @@ -153,9 +185,11 @@ ifaceRefs n i = maybeCType n (APIInterface i) (ifCType i) <> methodRefs n (APIInterface i) (ifMethods i) <> signalRefs n (APIInterface i) (ifCType i) (ifSignals i) + <> propRefs n (APIInterface i) (ifCType i) (ifProperties i) -- | Extract the C references in an object. objectRefs :: Name -> Object -> [(CRef, Hyperlink)] objectRefs n o = maybeCType n (APIObject o) (objCType o) <> methodRefs n (APIObject o) (objMethods o) <> signalRefs n (APIObject o) (objCType o) (objSignals o) + <> propRefs n (APIObject o) (objCType o) (objProperties o) diff --git a/lib/Data/GI/CodeGen/EnumFlags.hs b/lib/Data/GI/CodeGen/EnumFlags.hs --- a/lib/Data/GI/CodeGen/EnumFlags.hs +++ b/lib/Data/GI/CodeGen/EnumFlags.hs @@ -87,19 +87,26 @@ maybe (return ()) (genErrorDomain docSection name') (enumErrorDomain e) -genBoxedEnum :: Name -> Text -> CodeGen () +genBoxedEnum :: Name -> Text -> CodeGen e () genBoxedEnum n typeInit = do let name' = upperName n group $ do + line $ "type instance O.ParentTypes " <> name' <> " = '[]" + bline $ "instance O.HasParentTypes " <> name' + + group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do - bline $ "instance BoxedEnum " <> name' <> " where" - indent $ line $ "boxedEnumType _ = c_" <> typeInit + bline $ "instance B.Types.TypedObject " <> name' <> " where" + indent $ line $ "glibType = c_" <> typeInit -genEnum :: Name -> Enumeration -> CodeGen () + group $ do + bline $ "instance B.Types.BoxedEnum " <> name' + +genEnum :: Name -> Enumeration -> CodeGen e () genEnum n@(Name _ name) enum = do line $ "-- Enum " <> name @@ -112,21 +119,28 @@ Nothing -> return () Just ti -> genBoxedEnum n ti) -genBoxedFlags :: Name -> Text -> CodeGen () +genBoxedFlags :: Name -> Text -> CodeGen e () genBoxedFlags n typeInit = do let name' = upperName n group $ do + line $ "type instance O.ParentTypes " <> name' <> " = '[]" + bline $ "instance O.HasParentTypes " <> name' + + group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do - bline $ "instance BoxedFlags " <> name' <> " where" - indent $ line $ "boxedFlagsType _ = c_" <> typeInit + bline $ "instance B.Types.TypedObject " <> name' <> " where" + indent $ line $ "glibType = c_" <> typeInit + group $ do + bline $ "instance B.Types.BoxedFlags " <> name' + -- | Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass. -genFlags :: Name -> Flags -> CodeGen () +genFlags :: Name -> Flags -> CodeGen e () genFlags n@(Name _ name) (Flags enum) = do line $ "-- Flags " <> name @@ -145,7 +159,7 @@ group $ bline $ "instance IsGFlag " <> name') -- | Support for enums encapsulating error codes. -genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen () +genErrorDomain :: HaddockSection -> Text -> Text -> CodeGen e () genErrorDomain docSection name' domain = do group $ do line $ "instance GErrorClass " <> name' <> " where" diff --git a/lib/Data/GI/CodeGen/Fixups.hs b/lib/Data/GI/CodeGen/Fixups.hs --- a/lib/Data/GI/CodeGen/Fixups.hs +++ b/lib/Data/GI/CodeGen/Fixups.hs @@ -5,15 +5,21 @@ , detectGObject , dropDuplicatedFields , checkClosureDestructors + , fixClosures + , fixCallbackUserData + , fixSymbolNaming ) where -import Data.Maybe (isNothing, isJust) +import Data.Char (generalCategory, GeneralCategory(UppercaseLetter)) +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". @@ -55,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. @@ -74,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. @@ -100,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 -> @@ -176,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 @@ -185,3 +193,112 @@ 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. +fixSymbolNaming :: (Name, API) -> (Name, API) +fixSymbolNaming (n, APIConst c) = (fixConstantName n, APIConst c) +fixSymbolNaming (n, api) = (n, api) + +-- | Make sure that the given name is a valid Haskell identifier in +-- patterns. +-- +-- === __Examples__ +-- >>> fixConstantName (Name "IBus" "0") +-- Name {namespace = "IBus", name = "C'0"} +-- +-- >>> fixConstantName (Name "IBus" "a") +-- Name {namespace = "IBus", name = "C'a"} +-- +-- >>> fixConstantName (Name "IBus" "A") +-- Name {namespace = "IBus", name = "A"} +fixConstantName :: Name -> Name +fixConstantName (Name ns n) + | not (T.null n) && generalCategory (T.head n) /= UppercaseLetter + = Name ns ("C'" <> n) + | otherwise = Name ns n diff --git a/lib/Data/GI/CodeGen/GObject.hs b/lib/Data/GI/CodeGen/GObject.hs --- a/lib/Data/GI/CodeGen/GObject.hs +++ b/lib/Data/GI/CodeGen/GObject.hs @@ -13,12 +13,12 @@ import Data.GI.CodeGen.Type -- Returns whether the given type is a descendant of the given parent. -typeDoParentSearch :: Name -> Type -> CodeGen Bool +typeDoParentSearch :: Name -> Type -> CodeGen e Bool typeDoParentSearch parent (TInterface n) = findAPIByName n >>= apiDoParentSearch parent n typeDoParentSearch _ _ = return False -apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool +apiDoParentSearch :: Name -> Name -> API -> CodeGen e Bool apiDoParentSearch parent n api | parent == n = return True | otherwise = case api of @@ -32,12 +32,14 @@ or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs _ -> return False -isGObject :: Type -> CodeGen Bool +-- | Check whether the given type descends from GObject. +isGObject :: Type -> CodeGen e Bool isGObject = typeDoParentSearch $ Name "GObject" "Object" -- | Check whether the given name descends from GObject. -nameIsGObject :: Name -> CodeGen Bool +nameIsGObject :: Name -> CodeGen e Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n -apiIsGObject :: Name -> API -> CodeGen Bool +-- | Check whether the given API descends from GObject. +apiIsGObject :: Name -> API -> CodeGen e Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object" diff --git a/lib/Data/GI/CodeGen/GtkDoc.hs b/lib/Data/GI/CodeGen/GtkDoc.hs --- a/lib/Data/GI/CodeGen/GtkDoc.hs +++ b/lib/Data/GI/CodeGen/GtkDoc.hs @@ -6,8 +6,10 @@ , Token(..) , Language(..) , Link(..) - , ListItem(..) , CRef(..) + , DocSymbolName(..) + , docName + , resolveDocSymbol ) where import Prelude hiding (takeWhile) @@ -15,13 +17,18 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif +import Control.Applicative ((<|>)) +import Control.Monad (forM, guard, when) +import Data.Either (isRight) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif -import Control.Applicative ((<|>)) +import Data.GI.CodeGen.Util (terror) +import Data.GI.GIR.BasicTypes (Name(Name)) + import Data.Attoparsec.Text -import Data.Char (isAsciiUpper, isAsciiLower, isDigit) +import Data.Char (isAlphaNum, isAlpha, isAscii, isDigit) import qualified Data.Text as T import Data.Text (Text) @@ -32,7 +39,11 @@ | CodeBlock (Maybe Language) Text | ExternalLink Link | Image Link - | List [ListItem] + | UnnumberedList [GtkDoc] + -- ^ An unnumbered list of items. + | NumberedList [(Text, GtkDoc)] + -- ^ A list of numbered list items. The first element in + -- the pair is the index. | SectionHeader Int GtkDoc -- ^ A section header of the given depth. | SymbolRef CRef deriving (Show, Eq) @@ -42,29 +53,39 @@ , linkAddress :: Text } deriving (Show, Eq) --- | An item in a list, given by a list of lines (not including ending --- newlines). The list is always non-empty, so we represent it by the --- first line and then a possibly empty list with the rest of the lines. -data ListItem = ListItem GtkDoc [GtkDoc] - deriving (Show, Eq) - -- | The language for an embedded code block. newtype Language = Language Text deriving (Show, Eq) -- | A reference to some symbol in the API. -data CRef = FunctionRef Text +data CRef = FunctionRef DocSymbolName + | OldFunctionRef Text + | MethodRef DocSymbolName Text | ParamRef Text | ConstantRef Text - | SignalRef Text Text + | SignalRef DocSymbolName Text + | OldSignalRef Text Text | LocalSignalRef Text - | PropertyRef Text Text + | PropertyRef DocSymbolName Text + | OldPropertyRef Text Text | VMethodRef Text Text + | VFuncRef DocSymbolName Text | StructFieldRef Text Text - | TypeRef Text + | EnumMemberRef DocSymbolName Text + | CTypeRef Text + | TypeRef DocSymbolName + deriving (Show, Eq, Ord) + +-- | Reference to a name (of a class, for instance) in the +-- documentation. It can be either relative to the module where the +-- documentation is, of in some other namespace. +data DocSymbolName = RelativeName Text + -- ^ The symbol without a namespace specified + | AbsoluteName Text Text + -- ^ Namespace and symbol deriving (Show, Eq, Ord) --- | A parsed representation of gtk-doc formatted documentation. +-- | A parsed gtk-doc with fully resolved references. newtype GtkDoc = GtkDoc [Token] deriving (Show, Eq) @@ -75,7 +96,7 @@ -- GtkDoc [] -- -- >>> parseGtkDoc "func()" --- GtkDoc [SymbolRef (FunctionRef "func")] +-- GtkDoc [SymbolRef (OldFunctionRef "func")] -- -- >>> parseGtkDoc "literal" -- GtkDoc [Literal "literal"] @@ -84,54 +105,54 @@ -- GtkDoc [Literal "This is a long literal"] -- -- >>> parseGtkDoc "Call foo() for free cookies" --- GtkDoc [Literal "Call ",SymbolRef (FunctionRef "foo"),Literal " for free cookies"] +-- GtkDoc [Literal "Call ",SymbolRef (OldFunctionRef "foo"),Literal " for free cookies"] -- -- >>> parseGtkDoc "The signal ::activate is related to gtk_button_activate()." --- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."] +-- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> parseGtkDoc "The signal ##%#GtkButton::activate is related to gtk_button_activate()." --- GtkDoc [Literal "The signal ##%",SymbolRef (SignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."] +-- GtkDoc [Literal "The signal ##%",SymbolRef (OldSignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> parseGtkDoc "# A section\n\n## and a subsection ##\n" -- GtkDoc [SectionHeader 1 (GtkDoc [Literal "A section"]),Literal "\n",SectionHeader 2 (GtkDoc [Literal "and a subsection "])] -- -- >>> parseGtkDoc "Compact list:\n- First item\n- Second item" --- GtkDoc [Literal "Compact list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]] +-- GtkDoc [Literal "Compact list:\n",UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] -- -- >>> parseGtkDoc "Spaced list:\n\n- First item\n\n- Second item" --- GtkDoc [Literal "Spaced list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]] +-- GtkDoc [Literal "Spaced list:\n\n",UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] -- -- >>> parseGtkDoc "List with urls:\n- [test](http://test)\n- ![](image.png)" --- GtkDoc [Literal "List with urls:\n",List [ListItem (GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})]) [],ListItem (GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]) []]] +-- GtkDoc [Literal "List with urls:\n",UnnumberedList [GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})],GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]]] parseGtkDoc :: Text -> GtkDoc -parseGtkDoc raw = +parseGtkDoc doc = rawParseGtkDoc (T.cons startOfString doc) + +-- | Like `parseGtkDoc`, but it does not annotate beginning of lines. +rawParseGtkDoc :: Text -> GtkDoc +rawParseGtkDoc raw = case parseOnly (parseTokens <* endOfInput) raw of Left e -> - error $ "gtk-doc parsing failed with error \"" <> e - <> "\" on the input \"" <> T.unpack raw <> "\"" - Right tks -> GtkDoc . coalesceLiterals - . restoreSHPreNewlines . restoreListPreNewline $ tks + terror $ "gtk-doc parsing failed with error \"" <> T.pack e + <> "\" on the input \"" <> + T.replace (T.singleton startOfString) "" raw <> "\"" + Right tks -> GtkDoc . coalesceLiterals . removeSOS $ tks --- | `parseSectionHeader` eats the newline before the section header, --- but `parseInitialSectionHeader` does not, since it only matches at --- the beginning of the text. This restores the newlines eaten by --- `parseSectionHeader`, so a `SectionHeader` returned by the parser --- can always be assumed /not/ to have an implicit starting newline. -restoreSHPreNewlines :: [Token] -> [Token] -restoreSHPreNewlines [] = [] -restoreSHPreNewlines (i : rest) = i : restoreNewlines rest - where restoreNewlines :: [Token] -> [Token] - restoreNewlines [] = [] - restoreNewlines (s@(SectionHeader _ _) : rest) = - Literal "\n" : s : restoreNewlines rest - restoreNewlines (x : rest) = x : restoreNewlines rest +-- | A character indicating the start of the string, to simplify the +-- GtkDoc parser (part of the syntax is sensitive to the start of +-- lines, which we can represent as any character after '\n' or SOS). +startOfString :: Char +startOfString = '\x98' -- Unicode Start Of String (SOS) --- | `parseList` eats the newline before the list, restore it. -restoreListPreNewline :: [Token] -> [Token] -restoreListPreNewline [] = [] -restoreListPreNewline (l@(List _) : rest) = - Literal "\n" : l : restoreListPreNewline rest -restoreListPreNewline (x : rest) = x : restoreListPreNewline rest +-- | Remove the SOS marker from the input. Since this only appears at +-- the beginning of the text, we only need to worry about replacing it +-- in the first token, and only if it's a literal. +removeSOS :: [Token] -> [Token] +removeSOS [] = [] +removeSOS (Literal l : rest) = + if l == T.singleton startOfString + then rest + else Literal (T.replace (T.singleton startOfString) "" l) : rest +removeSOS (other : rest) = other : rest -- | Accumulate consecutive literals into a single literal. coalesceLiterals :: [Token] -> [Token] @@ -153,17 +174,20 @@ headerAndTokens = do header <- parseInitialSectionHeader tokens <- justTokens - return (header : tokens) + return (header <> tokens) justTokens :: Parser [Token] - justTokens = many' parseToken + justTokens = concat <$> many' parseToken --- | Parse a single token. +-- | Parse a single token. This can sometimes return more than a +-- single token, when parsing a logical token produces multiple output +-- tokens (for example when keeping the initial structure requires +-- adding together literals and other tokens). -- -- === __Examples__ -- >>> parseOnly (parseToken <* endOfInput) "func()" --- Right (SymbolRef (FunctionRef "func")) -parseToken :: Parser Token +-- Right [SymbolRef (OldFunctionRef "func")] +parseToken :: Parser [Token] parseToken = -- Note that the parsers overlap, so this is not as -- efficient as it could be (if we had combined parsers -- and then branched, so that there is no @@ -173,145 +197,349 @@ -- parser much, and it is the main source of -- backtracking. parseFunctionRef + <|> parseMethod + <|> parseConstructor <|> parseSignal + <|> parseId <|> parseLocalSignal <|> parseProperty <|> parseVMethod <|> parseStructField - <|> parseType + <|> parseClass + <|> parseCType <|> parseConstant + <|> parseEnumMember <|> parseParam <|> parseEscaped - <|> parseVerbatim <|> parseCodeBlock + <|> parseVerbatim <|> parseUrl <|> parseImage <|> parseSectionHeader - <|> parseList + <|> parseUnnumberedList + <|> parseNumberedList <|> parseComment <|> parseBoringLiteral --- | Parse a signal name, of the form +-- | Whether the given character is valid in a C identifier. +isCIdent :: Char -> Bool +isCIdent '_' = True +isCIdent c = isAscii c && isAlphaNum c + +-- | Something that could be a valid C identifier (loosely speaking, +-- we do not need to be too strict here). +parseCIdent :: Parser Text +parseCIdent = takeWhile1 isCIdent + +-- | Parse a function ref +parseFunctionRef :: Parser [Token] +parseFunctionRef = parseOldFunctionRef <|> parseNewFunctionRef + +-- | Parse an unresolved reference to a C symbol in new gtk-doc notation. +parseId :: Parser [Token] +parseId = do + _ <- string "[id@" + ident <- parseCIdent + _ <- char ']' + return [SymbolRef (OldFunctionRef ident)] + +-- | Parse a function ref, given by a valid C identifier followed by +-- '()', for instance 'gtk_widget_show()'. If the identifier is not +-- followed by "()", return it as a literal instead. +-- +-- === __Examples__ +-- >>> parseOnly (parseFunctionRef <* endOfInput) "test_func()" +-- Right [SymbolRef (OldFunctionRef "test_func")] +-- +-- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func" +-- Right [Literal "not_a_func"] +parseOldFunctionRef :: Parser [Token] +parseOldFunctionRef = do + ident <- parseCIdent + option [Literal ident] (string "()" >> + return [SymbolRef (OldFunctionRef ident)]) + +-- | Parse a function name in new style, of the form +-- > [func@Namespace.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseFunctionRef <* endOfInput) "[func@Gtk.init]" +-- Right [SymbolRef (FunctionRef (AbsoluteName "Gtk" "init"))] +parseNewFunctionRef :: Parser [Token] +parseNewFunctionRef = do + _ <- string "[func@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ FunctionRef (AbsoluteName ns n)] + +-- | Parse a method name, of the form +-- > [method@Namespace.Object.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseMethod <* endOfInput) "[method@Gtk.Button.set_child]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Button") "set_child")] +-- +-- >>> parseOnly (parseMethod <* endOfInput) "[func@Gtk.Settings.get_for_display]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Settings") "get_for_display")] +parseMethod :: Parser [Token] +parseMethod = do + _ <- string "[method@" <|> string "[func@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + method <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ MethodRef (AbsoluteName ns n) method] + +-- | Parse a reference to a constructor, of the form +-- > [ctor@Namespace.Object.c_func_name] +-- +-- === __Examples__ +-- >>> parseOnly (parseConstructor <* endOfInput) "[ctor@Gtk.Builder.new_from_file]" +-- Right [SymbolRef (MethodRef (AbsoluteName "Gtk" "Builder") "new_from_file")] +parseConstructor :: Parser [Token] +parseConstructor = do + _ <- string "[ctor@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + method <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ MethodRef (AbsoluteName ns n) method] + +-- | Parse a reference to a type, of the form +-- > [class@Namespace.Name] +-- an interface of the form +-- > [iface@Namespace.Name] +-- or an enumeration type, of the form +-- > [enum@Namespace.Name] +-- +-- === __Examples__ +-- >>> parseOnly (parseClass <* endOfInput) "[class@Gtk.Dialog]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "Dialog"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[iface@Gtk.Editable]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "Editable"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[enum@Gtk.SizeRequestMode]" +-- Right [SymbolRef (TypeRef (AbsoluteName "Gtk" "SizeRequestMode"))] +-- +-- >>> parseOnly (parseClass <* endOfInput) "[struct@GLib.Variant]" +-- Right [SymbolRef (TypeRef (AbsoluteName "GLib" "Variant"))] +parseClass :: Parser [Token] +parseClass = do + _ <- string "[class@" <|> string "[iface@" <|> + string "[enum@" <|> string "[struct@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char ']' + return [SymbolRef $ TypeRef (AbsoluteName ns n)] + +-- | Parse a reference to a member of the enum, of the form +-- > [enum@Gtk.FontRendering.AUTOMATIC] +-- +-- === __Examples__ +-- >>> parseOnly (parseEnumMember <* endOfInput) "[enum@Gtk.FontRendering.AUTOMATIC]" +-- Right [SymbolRef (EnumMemberRef (AbsoluteName "Gtk" "FontRendering") "automatic")] +parseEnumMember :: Parser [Token] +parseEnumMember = do + _ <- string "[enum@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- takeWhile1 isCIdent + _ <- char '.' + member <- takeWhile1 isCIdent + _ <- char ']' + -- Sometimes the references are written in uppercase while the name + -- of the member in the introspection data is written in lowercase, + -- so normalise everything to lowercase. (See the similar annotation + -- in CtoHaskellMap.hs.) + return [SymbolRef $ EnumMemberRef (AbsoluteName ns n) (T.toLower member)] + +parseSignal :: Parser [Token] +parseSignal = parseOldSignal <|> parseNewSignal + +-- | Parse an old style signal name, of the form -- > #Object::signal -- -- === __Examples__ --- >>> parseOnly (parseSignal <* endOfInput) "#GtkButton::activate" --- Right (SymbolRef (SignalRef "GtkButton" "activate")) -parseSignal :: Parser Token -parseSignal = do +-- >>> parseOnly (parseOldSignal <* endOfInput) "#GtkButton::activate" +-- Right [SymbolRef (OldSignalRef "GtkButton" "activate")] +parseOldSignal :: Parser [Token] +parseOldSignal = do _ <- char '#' obj <- parseCIdent _ <- string "::" signal <- signalOrPropName - return (SymbolRef (SignalRef obj signal)) + return [SymbolRef (OldSignalRef obj signal)] +-- | Parse a new style signal ref, of the form +-- > [signal@Namespace.Object::signal-name] +-- +-- === __Examples__ +-- >>> parseOnly (parseNewSignal <* endOfInput) "[signal@Gtk.AboutDialog::activate-link]" +-- Right [SymbolRef (SignalRef (AbsoluteName "Gtk" "AboutDialog") "activate-link")] +parseNewSignal :: Parser [Token] +parseNewSignal = do + _ <- string "[signal@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- string "::" + signal <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') + _ <- char ']' + return [SymbolRef (SignalRef (AbsoluteName ns n) signal)] + -- | Parse a reference to a signal defined in the current module, of the form -- > ::signal -- -- === __Examples__ -- >>> parseOnly (parseLocalSignal <* endOfInput) "::activate" --- Right (SymbolRef (LocalSignalRef "activate")) -parseLocalSignal :: Parser Token +-- Right [SymbolRef (LocalSignalRef "activate")] +parseLocalSignal :: Parser [Token] parseLocalSignal = do _ <- string "::" signal <- signalOrPropName - return (SymbolRef (LocalSignalRef signal)) + return [SymbolRef (LocalSignalRef signal)] --- | Parse a property name, of the form +-- | Parse a property name in the old style, of the form -- > #Object:property -- -- === __Examples__ --- >>> parseOnly (parseProperty <* endOfInput) "#GtkButton:always-show-image" --- Right (SymbolRef (PropertyRef "GtkButton" "always-show-image")) -parseProperty :: Parser Token -parseProperty = do +-- >>> parseOnly (parseOldProperty <* endOfInput) "#GtkButton:always-show-image" +-- Right [SymbolRef (OldPropertyRef "GtkButton" "always-show-image")] +parseOldProperty :: Parser [Token] +parseOldProperty = do _ <- char '#' obj <- parseCIdent _ <- char ':' property <- signalOrPropName - return (SymbolRef (PropertyRef obj property)) + return [SymbolRef (OldPropertyRef obj property)] +-- | Parse a property name in the new style: +-- > [property@Namespace.Object:property-name] +-- +-- === __Examples__ +-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.ProgressBar:show-text]" +-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "ProgressBar") "show-text")] +-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.Editable:width-chars]" +-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "Editable") "width-chars")] +parseNewProperty :: Parser [Token] +parseNewProperty = do + _ <- string "[property@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- char ':' + property <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-') + _ <- char ']' + return [SymbolRef (PropertyRef (AbsoluteName ns n) property)] + +-- | Parse a property +parseProperty :: Parser [Token] +parseProperty = parseOldProperty <|> parseNewProperty + -- | Parse an xml comment, of the form -- > -- Note that this function keeps spaces. -- -- === __Examples__ -- >>> parseOnly (parseComment <* endOfInput) "" --- Right (Comment " comment ") -parseComment :: Parser Token +-- Right [Comment " comment "] +parseComment :: Parser [Token] parseComment = do comment <- string "") - return (Comment $ T.pack comment) + return [Comment $ T.pack comment] --- | Parse a reference to a virtual method, of the form +-- | Parse an old style reference to a virtual method, of the form -- > #Struct.method() -- -- === __Examples__ --- >>> parseOnly (parseVMethod <* endOfInput) "#Foo.bar()" --- Right (SymbolRef (VMethodRef "Foo" "bar")) -parseVMethod :: Parser Token -parseVMethod = do +-- >>> parseOnly (parseOldVMethod <* endOfInput) "#Foo.bar()" +-- Right [SymbolRef (VMethodRef "Foo" "bar")] +parseOldVMethod :: Parser [Token] +parseOldVMethod = do _ <- char '#' obj <- parseCIdent _ <- char '.' method <- parseCIdent _ <- string "()" - return (SymbolRef (VMethodRef obj method)) + return [SymbolRef (VMethodRef obj method)] +-- | Parse a new style reference to a virtual function, of the form +-- > [vfunc@Namespace.Object.vfunc_name] +-- +-- >>> parseOnly (parseVFunc <* endOfInput) "[vfunc@Gtk.Widget.get_request_mode]" +-- Right [SymbolRef (VFuncRef (AbsoluteName "Gtk" "Widget") "get_request_mode")] +parseVFunc :: Parser [Token] +parseVFunc = do + _ <- string "[vfunc@" + ns <- takeWhile1 (\c -> isAscii c && isAlpha c) + _ <- char '.' + n <- parseCIdent + _ <- char '.' + vfunc <- parseCIdent + _ <- char ']' + return [SymbolRef (VFuncRef (AbsoluteName ns n) vfunc)] + +-- | Parse a reference to a virtual method +parseVMethod :: Parser [Token] +parseVMethod = parseOldVMethod <|> parseVFunc + -- | Parse a reference to a struct field, of the form -- > #Struct.field -- -- === __Examples__ -- >>> parseOnly (parseStructField <* endOfInput) "#Foo.bar" --- Right (SymbolRef (StructFieldRef "Foo" "bar")) -parseStructField :: Parser Token +-- Right [SymbolRef (StructFieldRef "Foo" "bar")] +parseStructField :: Parser [Token] parseStructField = do _ <- char '#' obj <- parseCIdent _ <- char '.' field <- parseCIdent - return (SymbolRef (StructFieldRef obj field)) + return [SymbolRef (StructFieldRef obj field)] -- | Parse a reference to a C type, of the form -- > #Type -- -- === __Examples__ --- >>> parseOnly (parseType <* endOfInput) "#Foo" --- Right (SymbolRef (TypeRef "Foo")) -parseType :: Parser Token -parseType = do +-- >>> parseOnly (parseCType <* endOfInput) "#Foo" +-- Right [SymbolRef (CTypeRef "Foo")] +parseCType :: Parser [Token] +parseCType = do _ <- char '#' obj <- parseCIdent - return (SymbolRef (TypeRef obj)) + return [SymbolRef (CTypeRef obj)] -- | Parse a constant, of the form -- > %CONSTANT_NAME -- -- === __Examples__ -- >>> parseOnly (parseConstant <* endOfInput) "%TEST_CONSTANT" --- Right (SymbolRef (ConstantRef "TEST_CONSTANT")) -parseConstant :: Parser Token +-- Right [SymbolRef (ConstantRef "TEST_CONSTANT")] +parseConstant :: Parser [Token] parseConstant = do _ <- char '%' c <- parseCIdent - return (SymbolRef (ConstantRef c)) + return [SymbolRef (ConstantRef c)] -- | Parse a reference to a parameter, of the form -- > @param_name -- -- === __Examples__ -- >>> parseOnly (parseParam <* endOfInput) "@test_param" --- Right (SymbolRef (ParamRef "test_param")) -parseParam :: Parser Token +-- Right [SymbolRef (ParamRef "test_param")] +parseParam :: Parser [Token] parseParam = do _ <- char '@' param <- parseCIdent - return (SymbolRef (ParamRef param)) - --- | Whether the given character is valid in a C identifier. -isCIdent :: Char -> Bool -isCIdent '_' = True -isCIdent c = isDigit c || isAsciiUpper c || isAsciiLower c + return [SymbolRef (ParamRef param)] -- | Name of a signal or property name. Similar to a C identifier, but -- hyphens are allowed too. @@ -321,42 +549,21 @@ isSignalOrPropIdent '-' = True isSignalOrPropIdent c = isCIdent c --- | Something that could be a valid C identifier (loosely speaking, --- we do not need to be too strict here). -parseCIdent :: Parser Text -parseCIdent = takeWhile1 isCIdent - --- | Parse a function ref, given by a valid C identifier followed by --- '()', for instance 'gtk_widget_show()'. If the identifier is not --- followed by "()", return it as a literal instead. --- --- === __Examples__ --- >>> parseOnly (parseFunctionRef <* endOfInput) "test_func()" --- Right (SymbolRef (FunctionRef "test_func")) --- --- >>> parseOnly (parseFunctionRef <* endOfInput) "not_a_func" --- Right (Literal "not_a_func") -parseFunctionRef :: Parser Token -parseFunctionRef = do - ident <- parseCIdent - option (Literal ident) (string "()" >> - return (SymbolRef (FunctionRef ident))) - -- | Parse a escaped special character, i.e. one preceded by '\'. -parseEscaped :: Parser Token +parseEscaped :: Parser [Token] parseEscaped = do _ <- char '\\' c <- satisfy (`elem` ("#@%\\`" :: [Char])) - return $ Literal (T.singleton c) + return [Literal (T.singleton c)] -- | Parse a literal, i.e. anything without a known special -- meaning. Note that this parser always consumes the first character, -- regardless of what it is. -parseBoringLiteral :: Parser Token +parseBoringLiteral :: Parser [Token] parseBoringLiteral = do c <- anyChar boring <- takeWhile (not . special) - return $ Literal (T.cons c boring) + return [Literal (T.cons c boring)] -- | List of special characters from the point of view of the parser -- (in the sense that they may be the beginning of something with a @@ -372,6 +579,7 @@ special '!' = True special '\n' = True special ':' = True +special '-' = True special c = isCIdent c -- | Parse a verbatim string, of the form @@ -379,51 +587,93 @@ -- -- === __Examples__ -- >>> parseOnly (parseVerbatim <* endOfInput) "`Example quote!`" --- Right (Verbatim "Example quote!") -parseVerbatim :: Parser Token +-- Right [Verbatim "Example quote!"] +parseVerbatim :: Parser [Token] parseVerbatim = do _ <- char '`' v <- takeWhile1 (/= '`') _ <- char '`' - return $ Verbatim v + return [Verbatim v] -- | Parse a URL in Markdown syntax, of the form -- > [name](url) -- -- === __Examples__ -- >>> parseOnly (parseUrl <* endOfInput) "[haskell](http://haskell.org)" --- Right (ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"})) -parseUrl :: Parser Token +-- Right [ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"})] +parseUrl :: Parser [Token] parseUrl = do _ <- char '[' name <- takeWhile1 (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')' - return $ ExternalLink $ Link {linkName = name, linkAddress = address} + return [ExternalLink $ Link {linkName = name, linkAddress = address}] -- | Parse an image reference, of the form -- > ![label](url) -- -- === __Examples__ -- >>> parseOnly (parseImage <* endOfInput) "![](diagram.png)" --- Right (Image (Link {linkName = "", linkAddress = "diagram.png"})) -parseImage :: Parser Token +-- Right [Image (Link {linkName = "", linkAddress = "diagram.png"})] +parseImage :: Parser [Token] parseImage = do _ <- string "![" name <- takeWhile (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')' - return $ Image $ Link {linkName = name, linkAddress = address} + return [Image $ Link {linkName = name, linkAddress = address}] -- | Parse a code block embedded in the documentation. -parseCodeBlock :: Parser Token -parseCodeBlock = do +parseCodeBlock :: Parser [Token] +parseCodeBlock = parseOldStyleCodeBlock <|> parseNewStyleCodeBlock + +-- | Parse a new style code block, of the form +-- > ```c +-- > some c code +-- > ``` +-- +-- === __Examples__ +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```c\nThis is C code\n```" +-- Right [CodeBlock (Just (Language "c")) "This is C code"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```\nThis is langless\n```" +-- Right [CodeBlock Nothing "This is langless"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```py\n This has space in front\n ```" +-- Right [CodeBlock (Just (Language "py")) " This has space in front"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```c\n new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);\n ```" +-- Right [CodeBlock (Just (Language "c")) " new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);"] +parseNewStyleCodeBlock :: Parser [Token] +parseNewStyleCodeBlock = do + _ <- takeWhile isHorizontalSpace + _ <- string "```" + lang <- T.strip <$> takeWhile (/= '\n') + _ <- char '\n' + let maybeLang = if T.null lang then Nothing + else Just lang + code <- T.pack <$> manyTill anyChar (string "\n" >> + takeWhile isHorizontalSpace >> + string "```") + return [CodeBlock (Language <$> maybeLang) code] + +-- | Parse an old style code block, of the form +-- > |[ code ]| +-- +-- === __Examples__ +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|" +-- Right [CodeBlock Nothing "this is code"] +-- +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is C code]|" +-- Right [CodeBlock (Just (Language "C")) "this is C code"] +parseOldStyleCodeBlock :: Parser [Token] +parseOldStyleCodeBlock = do _ <- string "|[" lang <- (Just <$> parseLanguage) <|> return Nothing code <- T.pack <$> manyTill anyChar (string "]|") - return $ CodeBlock lang code + return [CodeBlock lang code] -- | Parse the language of a code block, specified as a comment. parseLanguage :: Parser Language @@ -437,11 +687,30 @@ _ <- string "-->" return $ Language lang +-- | Parse at least one newline (or Start of String (SOS)), and keep +-- going while we see newlines. Return either the empty list (for the +-- case that we see a single SOS), or a singleton list with the +-- Literal representing the seen newlines, and removing the SOS. +parseInitialNewlines :: Parser [Token] +parseInitialNewlines = do + initial <- char '\n' <|> char startOfString + let initialString = if initial == '\n' + then "\n" + else "" + others <- T.pack <$> many' (char '\n') + let joint = initialString <> others + if T.null joint + then return [] + else return [Literal joint] + -- | Parse a section header, given by a number of hash symbols, and -- then ordinary text. Note that this parser "eats" the newline before -- and after the section header. -parseSectionHeader :: Parser Token -parseSectionHeader = char '\n' >> parseInitialSectionHeader +parseSectionHeader :: Parser [Token] +parseSectionHeader = do + initialNewlines <- parseInitialNewlines + sectionHeader <- parseInitialSectionHeader + return $ initialNewlines <> sectionHeader -- | Parse a section header at the beginning of the text. I.e. this is -- the same as `parseSectionHeader`, but we do not expect a newline as @@ -449,39 +718,230 @@ -- -- === __Examples__ -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "### Hello! ###\n" --- Right (SectionHeader 3 (GtkDoc [Literal "Hello! "])) +-- Right [SectionHeader 3 (GtkDoc [Literal "Hello! "])] -- -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "# Hello!\n" --- Right (SectionHeader 1 (GtkDoc [Literal "Hello!"])) -parseInitialSectionHeader :: Parser Token +-- Right [SectionHeader 1 (GtkDoc [Literal "Hello!"])] +parseInitialSectionHeader :: Parser [Token] parseInitialSectionHeader = do hashes <- takeWhile1 (== '#') _ <- many1 space heading <- takeWhile1 (notInClass "#\n") _ <- (string hashes >> char '\n') <|> (char '\n') - return $ SectionHeader (T.length hashes) (parseGtkDoc heading) + return [SectionHeader (T.length hashes) (parseGtkDoc heading)] --- | Parse a list header. Note that the newline before the start of --- the list is "eaten" by this parser, but is restored later by --- `parseGtkDoc`. --- --- === __Examples__ --- >>> parseOnly (parseList <* endOfInput) "\n- First item\n- Second item" --- Right (List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]) --- --- >>> parseOnly (parseList <* endOfInput) "\n\n- Two line\n item\n\n- Second item,\n also two lines" --- Right (List [ListItem (GtkDoc [Literal "Two line"]) [GtkDoc [Literal "item"]],ListItem (GtkDoc [Literal "Second item,"]) [GtkDoc [Literal "also two lines"]]]) -parseList :: Parser Token -parseList = do - items <- many1 parseListItem - return $ List items - where parseListItem :: Parser ListItem - parseListItem = do - _ <- char '\n' - _ <- string "\n- " <|> string "- " - first <- takeWhile1 (/= '\n') - rest <- many' parseLine - return $ ListItem (parseGtkDoc first) (map parseGtkDoc rest) +{- | Parse an unnumbered list. - parseLine :: Parser Text - parseLine = string "\n " >> takeWhile1 (/= '\n') +=== __Examples__ +>>> :{ +parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"- First item", +"- Second item" +] +:} +Right [UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] + +>>> :{ +parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +"", +"", +"- Two line", +" item", +"", +"- Second item,", +" with three lines", +" of text." +] +:} +Right [Literal "\n\n",UnnumberedList [GtkDoc [Literal "Two line\nitem"],GtkDoc [Literal "Second item,\nwith three lines\nof text."]]] +-} +parseUnnumberedList :: Parser [Token] +parseUnnumberedList = do + (initialNewlines, entries) <- parseList (string "- ") T.length + return $ initialNewlines <> [UnnumberedList (map snd entries)] + +{- | Parse a numbered list header. + +=== __Examples__ +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. First item,", +" written in two lines", +"", +"2. Second item,", +" also in two lines" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nalso in two lines"])]] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. First item,", +" written in two lines", +"2. Second item,", +" now in three lines,", +" written compactly" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nnow in three lines,\nwritten compactly"])]] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"9. This is a list entry with two lines,", +" with the second line in its own line.", +"10. If the label width changes,", +" the indentation of the second line should also be adjusted.", +"", +"11. You can optionally include an empty line between entries", +" without stopping the list.", +"", +" This also applies within list entries, this is still part of", +" entry 11.", +"12. But you don't have to." +] +:} +Right [NumberedList [("9",GtkDoc [Literal "This is a list entry with two lines,\nwith the second line in its own line."]),("10",GtkDoc [Literal "If the label width changes,\nthe indentation of the second line should also be adjusted."]),("11",GtkDoc [Literal "You can optionally include an empty line between entries\nwithout stopping the list.\n\nThis also applies within list entries, this is still part of\nentry 11."]),("12",GtkDoc [Literal "But you don't have to."])]] + +>>> :{ +parseGtkDoc $ T.stripEnd $ T.unlines [ +"1. A list with a single element", +"", +"And this is text not in the list, so we use parseGtkDoc." +] +:} +GtkDoc [NumberedList [("1",GtkDoc [Literal "A list with a single element"])],Literal "\n\nAnd this is text not in the list, so we use parseGtkDoc."] + +>>> :{ +parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [ +T.cons startOfString +"1. An example of a list in lenient mode,", +"where we don't require indenting this second line.", +"", +"2. In this mode entries can be optionally separated by an empty line.", +"3. But they don't need to" +] +:} +Right [NumberedList [("1",GtkDoc [Literal "An example of a list in lenient mode,\nwhere we don't require indenting this second line."]),("2",GtkDoc [Literal "In this mode entries can be optionally separated by an empty line."]),("3",GtkDoc [Literal "But they don't need to"])]] +-} +parseNumberedList :: Parser [Token] +parseNumberedList = do + (initialNewlines, list) <- parseList (do idx <- takeWhile1 isDigit + _ <- string ". " + return idx) + (\label -> T.length label + 2) + return $ initialNewlines <> [NumberedList list] + +{- | The indent parsing mode. In strict mode we require that all the + text in the lines is indented relative to the label, as in the + following example: + + 1. The first line, + and the second line + + In this mode we allow empty lines in the entry. + 2. This is the second entry. + + In lenient mode we drop this restriction, so the following is valid: + 1. The first line, + and the second line + In this mode we _do not_ allow empty lines in the entry. + 2. This is the second entry. +-} +data IndentParsingMode = Lenient | Strict + deriving (Eq) + +{- | Parse an unnumbered or numbered list. See 'parseNumberedList' and + 'parseUnnumberedList' for examples. +-} +parseList :: Parser Text -> (Text -> Int) -> + Parser ([Token], [(Text, GtkDoc)]) +parseList labelParser indent = + doParseList Lenient <|> doParseList Strict + where + doParseList :: IndentParsingMode -> + Parser ([Token], [(Text, GtkDoc)]) + doParseList mode = do + -- Consume the initial newlines before parseListItem does, so we can + -- restore the initial newlines after. We impose that there is at + -- least a newline (or Start of String symbol) before the start of + -- the list. + initialNewlines <- parseInitialNewlines + (initialSpace, first) <- + parseListItem (takeWhile isHorizontalSpace) (pure ()) + -- We allow either one or zero empty lines between entries. + let newlineParser = (string "\n\n" <|> string "\n") >> pure () + rest <- map snd <$> + many' (parseListItem (string initialSpace) newlineParser) + -- Validate the resulting entries, and assemble them into GtkDoc. + validated <- forM (first : rest) $ \(label, (firstLine, otherLines)) -> do + validate label otherLines + return (label, + parseGtkDoc $ T.strip $ T.unlines $ firstLine : otherLines) + + return (initialNewlines, validated) + + where + parseListItem :: Parser Text -> Parser () -> + Parser (Text, (Text, (Text, [Text]))) + parseListItem parseInitialSpace startingNewlines = do + startingNewlines + initialSpace <- parseInitialSpace + label <- labelParser + first <- takeWhile (/= '\n') + let padding = case mode of + Strict -> initialSpace <> T.replicate (indent label) " " + Lenient -> initialSpace + paddingParser = string padding + + rest <- many' (parseLine paddingParser) + + return (initialSpace, (label, (first, rest))) + + parseLine :: Parser Text -> Parser Text + parseLine paddingParser = do + emptyLines <- case mode of + -- We do not allow empty lines in entries in the lenient + -- indent parser, while the strict indent one allows one + -- at most. + Strict -> option "" emptyLine + Lenient -> pure "" + _ <- char '\n' >> paddingParser + contents <- takeWhile1 (/= '\n') + when (startsWith labelParser contents) $ + fail "Line starting with a label" + return $ emptyLines <> contents + + emptyLine = do + _ <- char '\n' + maybeNext <- peekChar + guard $ maybeNext == Nothing || maybeNext == Just '\n' + return ("\n" :: Text) + + startsWith :: Parser a -> Text -> Bool + startsWith p l = isRight $ parseOnly p l + + validate :: Text -> [Text] -> Parser () + validate _ [] = pure () + validate label lines = case mode of + Strict -> pure () + Lenient -> do + let extraIndent = string $ T.replicate (indent label) " " + + -- If every line has extra padding we are most likely in + -- the wrong mode too. + when (all (startsWith extraIndent) lines) $ + fail "All lines have extra indent" + +-- | Turn an ordinary `Name` into a `DocSymbolName` +docName :: Name -> DocSymbolName +docName (Name ns n) = AbsoluteName ns n + +-- | Return a `Name` from a potentially relative `DocSymbolName`, +-- using the provided default namespace if the name is relative. +resolveDocSymbol :: DocSymbolName -> Text -> Name +resolveDocSymbol (AbsoluteName ns n) _ = Name ns n +resolveDocSymbol (RelativeName n) defaultNS = Name defaultNS n diff --git a/lib/Data/GI/CodeGen/Haddock.hs b/lib/Data/GI/CodeGen/Haddock.hs --- a/lib/Data/GI/CodeGen/Haddock.hs +++ b/lib/Data/GI/CodeGen/Haddock.hs @@ -23,6 +23,7 @@ import Data.Text (Text) import Data.GI.GIR.Arg (Arg(..)) +import Data.GI.GIR.BasicTypes (Name(Name)) import Data.GI.GIR.Callable (Callable(..)) import Data.GI.GIR.Deprecation (DeprecationInfo(..)) import Data.GI.GIR.Documentation (Documentation(..)) @@ -32,9 +33,11 @@ import Data.GI.CodeGen.Config (modName, overrides) import Data.GI.CodeGen.CtoHaskellMap (Hyperlink(..)) import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..), - Link(..), ListItem(..), parseGtkDoc) + Link(..), parseGtkDoc, + DocSymbolName(..), resolveDocSymbol, docName) import Data.GI.CodeGen.Overrides (onlineDocsMap) -import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName) +import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName, + haddockSignalAnchor) -- | Where is the documentation located with respect to the relevant -- symbol, useful for determining whether we want to start with @|@ or @^@. @@ -47,60 +50,111 @@ -- delimiters are not included in the output. -- -- === __Examples__ --- >>> formatHaddock M.empty "" (GtkDoc [Literal "Hello ", Literal "World!"]) +-- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "Hello ", Literal "World!"]) -- "Hello World!" -- --- >>> let c2h = M.fromList [(FunctionRef "foo", ValueIdentifier "foo")] --- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")]) +-- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "This is a **bold** world!"]) +-- "This is a __bold__ world!" +-- +-- >>> let c2h = M.fromList [(OldFunctionRef "foo", ValueIdentifier "foo")] +-- >>> formatHaddock c2h "" "Test" (GtkDoc [SymbolRef (OldFunctionRef "foo")]) -- "'foo'" -- -- >>> let onlineDocs = "http://wiki.haskell.org" --- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) +-- >>> formatHaddock M.empty onlineDocs "Test" (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) -- "" -- --- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]]) --- "\n* <>\n" -formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text -formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [UnnumberedList [GtkDoc [Image (Link "test" "test.png")]]]) +-- "* <>\n" +-- +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [NumberedList [("1", GtkDoc [Literal "Hi!"]), ("2", GtkDoc [Literal "Second and very long, so split\n line."])]]) +-- "1. Hi!\n\n2. Second and very long, so split\n line.\n\n" +formatHaddock :: M.Map CRef Hyperlink -> Text -> Text -> GtkDoc -> Text +formatHaddock c2h docBase defaultNS (GtkDoc tokens) = T.concat $ map formatToken tokens where formatToken :: Token -> Text - formatToken (Literal l) = escape l + formatToken (Literal l) = escape (convertBold l) formatToken (Comment _) = "" formatToken (Verbatim v) = "@" <> escape v <> "@" formatToken (CodeBlock l c) = formatCodeBlock l c formatToken (ExternalLink l) = formatLink l docBase formatToken (Image l) = formatImage l docBase - formatToken (SectionHeader l h) = formatSectionHeader c2h docBase l h - formatToken (List l) = formatList c2h docBase l + formatToken (SectionHeader l h) = + formatSectionHeader c2h docBase defaultNS l h + formatToken (UnnumberedList l) = + formatUnnumberedList c2h docBase defaultNS l + formatToken (NumberedList l) = + formatNumberedList c2h docBase defaultNS l formatToken (SymbolRef cr) = case M.lookup cr c2h of Just hr -> formatHyperlink hr - Nothing -> formatUnknownCRef c2h cr + Nothing -> formatUnknownCRef c2h defaultNS cr --- | Format a `CRef` whose Haskell representation is not known. -formatUnknownCRef :: M.Map CRef Hyperlink -> CRef -> Text -formatUnknownCRef _ (FunctionRef f) = formatCRef $ f <> "()" -formatUnknownCRef _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" -formatUnknownCRef _ (LocalSignalRef s) = + -- Markdown accepts both two underscores and two stars as + -- indicating bold, but Haddock only accepts two underscores. + convertBold :: Text -> Text + convertBold l = T.replace "**" "__" l + +-- | Format a `CRef` whose Haskell representation is not known, using +-- a provided default namespace for relative symbols. +formatUnknownCRef :: M.Map CRef Hyperlink -> Text -> CRef -> Text +formatUnknownCRef _ _ (OldFunctionRef f) = formatCRef $ f <> "()" +formatUnknownCRef _ defaultNS (FunctionRef n) = + formatCRef $ formatDocSymbol n defaultNS +formatUnknownCRef _ _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" +formatUnknownCRef _ _ (LocalSignalRef s) = let sn = signalHaskellName s - in "[" <> sn <> "](#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__ @@ -189,7 +263,7 @@ -- | Get the base url for the online C language documentation for the -- module being currently generated. -getDocBase :: CodeGen Text +getDocBase :: CodeGen e Text getDocBase = do mod <- modName <$> config docsMap <- (onlineDocsMap . overrides) <$> config @@ -200,17 +274,19 @@ -- | Write the deprecation pragma for the given `DeprecationInfo`, if -- not `Nothing`. -deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen () +deprecatedPragma :: Text -> Maybe DeprecationInfo -> CodeGen e () deprecatedPragma _ Nothing = return () deprecatedPragma name (Just info) = do c2h <- getC2HMap 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,25 +294,26 @@ -- | 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 -> "" Just ver -> "\n\n/Since: " <> ver <> "/" -- | Write the given documentation into generated code. -writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen () +writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen e () writeDocumentation pos doc = do c2h <- getC2HMap docBase <- getDocBase - 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. -writeHaddock :: RelativeDocPosition -> Text -> CodeGen () +writeHaddock :: RelativeDocPosition -> Text -> CodeGen e () writeHaddock pos haddock = let marker = case pos of DocBeforeSymbol -> "|" @@ -247,28 +324,30 @@ in mapM_ line lines -- | Write the documentation for the given argument. -writeArgDocumentation :: Arg -> CodeGen () +writeArgDocumentation :: Arg -> CodeGen e () writeArgDocumentation arg = case rawDocText (argDoc arg) of Nothing -> return () 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. -writeReturnDocumentation :: Callable -> Bool -> CodeGen () +writeReturnDocumentation :: Callable -> Bool -> CodeGen e () 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')/"] @@ -278,9 +357,10 @@ writeHaddock DocAfterSymbol fullInfo -- | Add the given text to the documentation for the section being generated. -addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen () +addSectionDocumentation :: HaddockSection -> Documentation -> CodeGen e () addSectionDocumentation section doc = do c2h <- getC2HMap docBase <- getDocBase - let formatted = formatDocumentation c2h docBase doc + defaultNS <- modName <$> config + let formatted = formatDocumentation c2h docBase defaultNS doc addSectionFormattedDocs section formatted diff --git a/lib/Data/GI/CodeGen/Inheritance.hs b/lib/Data/GI/CodeGen/Inheritance.hs --- a/lib/Data/GI/CodeGen/Inheritance.hs +++ b/lib/Data/GI/CodeGen/Inheritance.hs @@ -34,7 +34,7 @@ getParent _ = Nothing -- | Compute the (ordered) list of parents of the current object. -instanceTree :: Name -> CodeGen [Name] +instanceTree :: Name -> CodeGen e [Name] instanceTree n = do api <- findAPIByName n case getParent api of @@ -67,7 +67,7 @@ -- (including those defined by its ancestors and the interfaces it -- implements), together with the name of the interface defining the -- property. -apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)] +apiInheritables :: Inheritable i => Name -> CodeGen e [(Name, i)] apiInheritables n = do api <- findAPIByName n case dropMovedItems api of @@ -75,7 +75,7 @@ Just (APIObject object) -> return $ map ((,) n) (objInheritables object) _ -> error $ "apiInheritables : Unexpected API : " ++ show n -fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)] +fullAPIInheritableList :: Inheritable i => Name -> CodeGen e [(Name, i)] fullAPIInheritableList n = do api <- findAPIByName n case api of @@ -84,14 +84,14 @@ _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n fullObjectInheritableList :: Inheritable i => Name -> Object -> - CodeGen [(Name, i)] + CodeGen e [(Name, i)] fullObjectInheritableList n obj = do iT <- instanceTree n (++) <$> (concat <$> mapM apiInheritables (n : iT)) <*> (concat <$> mapM apiInheritables (objInterfaces obj)) fullInterfaceInheritableList :: Inheritable i => Name -> Interface -> - CodeGen [(Name, i)] + CodeGen e [(Name, i)] fullInterfaceInheritableList n iface = (++) (map ((,) n) (ifInheritables iface)) <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface)) @@ -103,13 +103,13 @@ -- setters/getters that we can call, but they are all isomorphic). If -- they are not isomorphic we print a warning, and choose to use the -- one closest to the leaves of the object hierarchy. -removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) => - Bool -> [(Name, i)] -> CodeGen [(Name, i)] +removeDuplicates :: forall i e. (Eq i, Show i, Inheritable i) => + Bool -> [(Name, i)] -> CodeGen e [(Name, i)] removeDuplicates verbose inheritables = (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables where filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) -> - CodeGen (M.Map Text (Bool, Name, i)) + CodeGen e (M.Map Text (Bool, Name, i)) filterDups m (name, prop) = case M.lookup (iName prop) m of Just (tainted, n, p) @@ -129,36 +129,36 @@ -- | List all properties defined for an object, including those -- defined by its ancestors. -fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)] +fullObjectPropertyList :: Name -> Object -> CodeGen e [(Name, Property)] fullObjectPropertyList n o = fullObjectInheritableList n o >>= removeDuplicates True -- | List all properties defined for an interface, including those -- defined by its prerequisites. -fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)] +fullInterfacePropertyList :: Name -> Interface -> CodeGen e [(Name, Property)] fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>= removeDuplicates True -- | List all signals defined for an object, including those -- defined by its ancestors. -fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)] +fullObjectSignalList :: Name -> Object -> CodeGen e [(Name, Signal)] fullObjectSignalList n o = fullObjectInheritableList n o >>= removeDuplicates True -- | List all signals defined for an interface, including those -- defined by its prerequisites. -fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)] +fullInterfaceSignalList :: Name -> Interface -> CodeGen e [(Name, Signal)] fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>= removeDuplicates True -- | List all methods defined for an object, including those defined -- by its ancestors. -fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)] +fullObjectMethodList :: Name -> Object -> CodeGen e [(Name, Method)] fullObjectMethodList n o = fullObjectInheritableList n o >>= removeDuplicates False -- | List all methods defined for an interface, including those -- defined by its prerequisites. -fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)] +fullInterfaceMethodList :: Name -> Interface -> CodeGen e [(Name, Method)] fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>= removeDuplicates False diff --git a/lib/Data/GI/CodeGen/LibGIRepository.hs b/lib/Data/GI/CodeGen/LibGIRepository.hs --- a/lib/Data/GI/CodeGen/LibGIRepository.hs +++ b/lib/Data/GI/CodeGen/LibGIRepository.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies, DataKinds #-} -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository ( girRequire @@ -14,6 +15,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif import Control.Monad (forM, (>=>)) import qualified Data.Map as M @@ -29,9 +33,11 @@ import System.FilePath (searchPathSeparator) import Data.GI.Base.BasicConversions (withTextCString, cstringToText) -import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType, ManagedPtr) +import Data.GI.Base.BasicTypes (TypedObject(..), GBoxed, + GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) +import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Base.Utils (allocMem, freeMem) import Data.GI.CodeGen.Util (splitOn) @@ -55,10 +61,18 @@ fieldInfoOffset :: Int } +-- | The (empty) set of parent types for `BaseInfo` visible to the +-- Haskell type system. +instance HasParentTypes BaseInfo +type instance ParentTypes BaseInfo = '[] + foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType -instance BoxedObject BaseInfo where - boxedType _ = c_g_base_info_gtype_get_type +instance TypedObject BaseInfo where + glibType = c_g_base_info_gtype_get_type + +-- | `BaseInfo`s are registered as boxed in the GLib type system. +instance GBoxed BaseInfo foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO () diff --git a/lib/Data/GI/CodeGen/OverloadedLabels.hs b/lib/Data/GI/CodeGen/OverloadedLabels.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/OverloadedLabels.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Data.GI.CodeGen.OverloadedLabels - ( genOverloadedLabels - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Data.Maybe (isNothing) -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import Control.Monad (forM_) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T - -import Data.GI.CodeGen.API -import Data.GI.CodeGen.Code -import Data.GI.CodeGen.SymbolNaming -import Data.GI.CodeGen.Util (lcFirst) - --- | A list of all overloadable identifiers in the set of APIs (current --- properties and methods). -findOverloaded :: [(Name, API)] -> CodeGen [Text] -findOverloaded apis = S.toList <$> go apis S.empty - where - go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) - go [] set = return set - go ((_, api):apis) set = - case api of - APIInterface iface -> go apis (scanInterface iface set) - APIObject object -> go apis (scanObject object set) - APIStruct s -> go apis (scanStruct s set) - APIUnion u -> go apis (scanUnion u set) - _ -> go apis set - - scanObject :: Object -> S.Set Text -> S.Set Text - scanObject o set = - let props = (map propToLabel . objProperties) o - methods = (map methodToLabel . filterMethods . objMethods) o - in S.unions [set, S.fromList props, S.fromList methods] - - scanInterface :: Interface -> S.Set Text -> S.Set Text - scanInterface i set = - let props = (map propToLabel . ifProperties) i - methods = (map methodToLabel . filterMethods . ifMethods) i - in S.unions [set, S.fromList props, S.fromList methods] - - scanStruct :: Struct -> S.Set Text -> S.Set Text - scanStruct s set = - let attrs = (map fieldToLabel . filterFields . structFields) s - methods = (map methodToLabel . filterMethods . structMethods) s - in S.unions [set, S.fromList attrs, S.fromList methods] - - scanUnion :: Union -> S.Set Text -> S.Set Text - scanUnion u set = - let attrs = (map fieldToLabel . filterFields . unionFields) u - methods = (map methodToLabel . filterMethods . unionMethods) u - in S.unions [set, S.fromList attrs, S.fromList methods] - - propToLabel :: Property -> Text - propToLabel = lcFirst . hyphensToCamelCase . propName - - methodToLabel :: Method -> Text - methodToLabel = lowerName . methodName - - fieldToLabel :: Field -> Text - fieldToLabel = lcFirst . underscoresToCamelCase . fieldName - - filterMethods :: [Method] -> [Method] - filterMethods = filter (\m -> (isNothing . methodMovedTo) m && - methodType m == OrdinaryMethod) - - filterFields :: [Field] -> [Field] - filterFields = filter (\f -> fieldVisible f && - (not . T.null . fieldName) f) - -genOverloadedLabel :: Text -> CodeGen () -genOverloadedLabel l = group $ do - line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a" - line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \"" - <> l <> "\")" - export ToplevelSection ("_" <> l) - -genOverloadedLabels :: [(Name, API)] -> CodeGen () -genOverloadedLabels allAPIs = do - setLanguagePragmas ["DataKinds", "FlexibleContexts", "CPP"] - setModuleFlags [ImplicitPrelude] - - line $ "import Data.Proxy (Proxy(..))" - line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))" - blank - - labels <- findOverloaded allAPIs - forM_ labels $ \l -> do - genOverloadedLabel l - blank diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -16,23 +16,25 @@ import Data.GI.CodeGen.Callable (callableSignature, Signature(..), ForeignSymbol(..), fixupCallerAllocates) import Data.GI.CodeGen.Code -import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol) +import Data.GI.CodeGen.ModulePath (dotModulePath) +import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol, + moduleLocation, hackageModuleLink) import Data.GI.CodeGen.Util (ucFirst) -- | Qualified name for the info for a given method. -methodInfoName :: Name -> Method -> CodeGen Text +methodInfoName :: Name -> Method -> CodeGen e Text methodInfoName n method = let infoName = upperName n <> (ucFirst . lowerName . methodName) method <> "MethodInfo" in qualifiedSymbol infoName n -- | Appropriate instances so overloaded labels are properly resolved. -genMethodResolver :: Text -> CodeGen () +genMethodResolver :: Text -> CodeGen e () genMethodResolver n = do addLanguagePragma "TypeApplications" group $ do line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " - <> "O.MethodInfo info " <> n <> " p) => OL.IsLabel t (" + <> "O.OverloadedMethod info " <> n <> " p) => OL.IsLabel t (" <> n <> " -> p) where" line $ "#if MIN_VERSION_base(4,10,0)" indent $ line $ "fromLabel = O.overloadedMethod @info" @@ -40,9 +42,32 @@ indent $ line $ "fromLabel _ = O.overloadedMethod @info" line $ "#endif" + -- The circular instance trick is to avoid the liberal coverage + -- condition. We should be using DYSFUNCTIONAL pragmas instead, once + -- those are implemented: + -- https://github.com/ghc-proposals/ghc-proposals/pull/374 + cppIf (CPPMinVersion "base" (4,13,0)) $ group $ do + line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " + <> "O.OverloadedMethod info " <> n <> " p, " + <> "R.HasField t " <> n <> " p) => " + <> "R.HasField t " <> n <> " p where" + indent $ line $ "getField = O.overloadedMethod @info" + + group $ do + line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", " + <> "O.OverloadedMethodInfo info " <> n <> ") => " + <> "OL.IsLabel t (O.MethodProxy info " + <> n <> ") where" + line $ "#if MIN_VERSION_base(4,10,0)" + indent $ line $ "fromLabel = O.MethodProxy" + line $ "#else" + indent $ line $ "fromLabel _ = O.MethodProxy" + line $ "#endif" + -- | Generate the `MethodList` instance given the list of methods for --- the given named type. -genMethodList :: Name -> [(Name, Method)] -> CodeGen () +-- the given named type. Returns a Haddock comment summarizing the +-- list of methods available. +genMethodList :: Name -> [(Name, Method)] -> CodeGen e () genMethodList n methods = do let name = upperName n let filteredMethods = filter isOrdinaryMethod methods @@ -55,14 +80,17 @@ return ((lowerName . methodName) method, mi) group $ do let resolver = "Resolve" <> name <> "Method" - export (NamedSubsection MethodSection "Overloaded methods") resolver - line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where" + export (Section MethodSection) resolver + 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" genMethodResolver name + docs <- methodListDocumentation others gets sets + prependSectionFormattedDocs (Section MethodSection) docs + where isOrdinaryMethod :: (Name, Method) -> Bool isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod @@ -72,40 +100,105 @@ isSet :: (Name, Method) -> Bool isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m +-- | Format a haddock comment with the information about available +-- methods. +methodListDocumentation :: [(Name, Method)] -> [(Name, Method)] + -> [(Name, Method)] -> CodeGen e Text +methodListDocumentation [] [] [] = return "" +methodListDocumentation ordinary getters setters = do + ordinaryFormatted <- formatMethods ordinary + gettersFormatted <- formatMethods getters + settersFormatted <- formatMethods setters + + return $ "\n\n === __Click to display all available methods, including inherited ones__\n" + <> "==== Methods\n" <> ordinaryFormatted + <> "\n==== Getters\n" <> gettersFormatted + <> "\n==== Setters\n" <> settersFormatted + + where formatMethods :: [(Name, Method)] -> CodeGen e Text + formatMethods [] = return "/None/.\n" + formatMethods methods = do + qualifiedMethods <- forM methods $ \(owner, m) -> do + api <- findAPIByName owner + let mn = lowerName (methodName m) + return $ "[" <> mn <> + "](\"" <> dotModulePath (moduleLocation owner api) + <> "#g:method:" <> mn <> "\")" + return $ T.intercalate ", " qualifiedMethods <> ".\n" + +-- | 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 = when (methodType m == OrdinaryMethod) $ 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]) <> ")" - line $ "instance (" <> T.intercalate ", " (sigConstraint : - signatureConstraints sig) - <> ") => O.MethodInfo " <> infoName <> " " <> obj <> " signature where" + + hackageLink <- hackageModuleLink n let mn = methodName m mangled = lowerName (mn {name = name n <> "_" <> name mn}) - indent $ line $ "overloadedMethod = " <> mangled + dbgInfo = dotModulePath (moduleLocation n api) <> "." <> mangled + + group $ do + line $ "instance (" + <> T.intercalate ", " (sigConstraint : signatureConstraints sig) + <> ") => O.OverloadedMethod " <> infoName <> " " <> obj + <> " signature where" + 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 = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> dbgInfo <> "\"," + line $ "O.resolvedSymbolURL = \"" <> + hackageLink <> "#v:" <> mangled <> "\"" + line $ "})" + export (NamedSubsection MethodSection $ lowerName mn) infoName -- | Generate a method info that is not actually callable, but rather -- gives a type error when trying to use it. -genUnsupportedMethodInfo :: Name -> Method -> CodeGen () +genUnsupportedMethodInfo :: Name -> Method -> CodeGen e () genUnsupportedMethodInfo n m = do infoName <- methodInfoName n m line $ "-- XXX: Dummy instance, since code generation failed.\n" <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi." bline $ "data " <> infoName - line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \"" - <> lowerName (methodName m) <> "\" " <> name n - <> ") => O.MethodInfo " <> infoName <> " o p where" - indent $ line $ "overloadedMethod = undefined" + group $ do + line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \"" + <> lowerName (methodName m) <> "\" " <> name n + <> ") => O.OverloadedMethod " <> infoName <> " o p where" + indent $ line $ "overloadedMethod = undefined" + + group $ do + line $ "instance (o ~ O.UnsupportedMethodError \"" + <> lowerName (methodName m) <> "\" " <> name n + <> ") => O.OverloadedMethodInfo " <> infoName <> " o where" + indent $ line $ "overloadedMethodInfo = undefined" + export ToplevelSection infoName diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs --- a/lib/Data/GI/CodeGen/OverloadedSignals.hs +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -1,20 +1,17 @@ module Data.GI.CodeGen.OverloadedSignals ( genObjectSignals , genInterfaceSignals - , genOverloadedSignalConnectors ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM_, when) +import Control.Monad (when) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Set as S import Data.GI.CodeGen.API import Data.GI.CodeGen.Code @@ -24,46 +21,8 @@ signalInfoName) import Data.GI.CodeGen.Util (lcFirst) --- A list of distinct signal names for all GObjects appearing in the --- given list of APIs. -findSignalNames :: [(Name, API)] -> CodeGen [Text] -findSignalNames apis = S.toList <$> go apis S.empty - where - go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) - go [] set = return set - go ((_, api):apis) set = - case api of - APIInterface iface -> - go apis $ insertSignals (ifSignals iface) set - APIObject object -> - go apis $ insertSignals (objSignals object) set - _ -> go apis set - - insertSignals :: [Signal] -> S.Set Text -> S.Set Text - insertSignals props set = foldr (S.insert . sigName) set props - --- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ... -genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen () -genOverloadedSignalConnectors allAPIs = do - setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP", - -- For ghc 7.8 support - "RankNTypes", "ScopedTypeVariables", "TypeFamilies"] - setModuleFlags [ImplicitPrelude] - - line "import Data.GI.Base.Signals (SignalProxy(..))" - line "import Data.GI.Base.Overloading (ResolveSignal)" - blank - signalNames <- findSignalNames allAPIs - forM_ signalNames $ \sn -> group $ do - let camelName = hyphensToCamelCase sn - line $ "pattern " <> camelName <> - " :: SignalProxy object (ResolveSignal \"" - <> lcFirst camelName <> "\" object)" - line $ "pattern " <> camelName <> " = SignalProxy" - exportDecl $ "pattern " <> camelName - -- | Signal instances for (GObject-derived) objects. -genObjectSignals :: Name -> Object -> CodeGen () +genObjectSignals :: Name -> Object -> CodeGen e () genObjectSignals n o = do let name = upperName n isGO <- apiIsGObject n (APIObject o) @@ -77,10 +36,10 @@ 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 () +genInterfaceSignals :: Name -> Interface -> CodeGen e () genInterfaceSignals n iface = do let name = upperName n infos <- fullInterfaceSignalList n iface >>= @@ -92,4 +51,4 @@ let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " - <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" + <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])" diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs --- a/lib/Data/GI/CodeGen/Overrides.hs +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -11,6 +11,9 @@ import Data.Traversable (traverse) #endif +#if MIN_VERSION_base(4,18,0) +import Control.Monad (foldM) +#endif import Control.Monad.Except import Control.Monad.State import Control.Monad.Writer (WriterT, execWriterT, tell) @@ -163,6 +166,8 @@ withFlags $ parseNsVersion s parseOneLine (T.stripPrefix "set-attr " -> Just s) = withFlags $ parseSetAttr s +parseOneLine (T.stripPrefix "delete-attr " -> Just s) = + withFlags $ parseDeleteAttr s parseOneLine (T.stripPrefix "add-node " -> Just s) = withFlags $ parseAdd s parseOneLine (T.stripPrefix "delete-node " -> Just s) = @@ -260,6 +265,17 @@ throwError ("set-attr syntax is of the form\n" <> "\t\"set-attr nodePath attrName newValue\"\n" <> "Got \"set-attr " <> t <> "\" instead.") + +-- | Delete the given attribute +parseDeleteAttr :: Text -> Parser () +parseDeleteAttr (T.words -> [path, attr]) = do + pathSpec <- parsePathSpec path + parsedAttr <- parseXMLName attr + tell $ defaultOverrides {girFixups = [GIRDeleteAttr pathSpec parsedAttr]} +parseDeleteAttr t = + throwError ("delete-attr syntax is of the form\n" <> + "\t\"delete-attr nodePath attrName\"\n" <> + "Got \"delete-attr " <> t <> "\" instead.") -- | Add the given child node to all nodes matching the path. parseAdd :: Text -> Parser () diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -24,7 +24,7 @@ homepage = "https://github.com/haskell-gi/haskell-gi" authors :: Text -authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte" +authors = "Will Thompson and Iñaki García Etxebarria" maintainers :: Text maintainers = "Iñaki García Etxebarria" @@ -39,7 +39,8 @@ "OverloadedStrings", "NegativeLiterals", "ConstraintKinds", "TypeFamilies", "MultiParamTypeClasses", "KindSignatures", "FlexibleInstances", "UndecidableInstances", "DataKinds", - "FlexibleContexts", "UndecidableSuperClasses"] + "FlexibleContexts", "UndecidableSuperClasses", + "TypeOperators"] -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default. @@ -62,7 +63,7 @@ standardDeps :: [Text] standardDeps = ["bytestring >= 0.10 && < 1", "containers >= 0.5 && < 1", - "text >= 1.0 && < 2", + "text >= 1.0 && < 3", "transformers >= 0.4 && < 1"] -- | Under which category in hackage should the generated bindings be listed. diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -25,15 +25,18 @@ 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) + callbackWrapperAllocator, safeCast, + hackageModuleLink, moduleLocation, + haddockAttrAnchor) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util -propTypeStr :: Type -> CodeGen Text +propTypeStr :: Type -> ExcCodeGen Text propTypeStr t = case t of TBasicType TUTF8 -> return "String" TBasicType TFileName -> return "String" @@ -44,6 +47,7 @@ TParamSpec -> return "ParamSpec" TGClosure _ -> return "Closure" TError -> return "GError" + TGValue -> return "GValue" TBasicType TInt -> case sizeOf (0 :: CInt) of 4 -> return "Int32" n -> error ("Unsupported `gint' type length: " ++ @@ -73,25 +77,52 @@ APICallback _ -> return "Callback" APIStruct s -> if structIsBoxed s then return "Boxed" - else error $ "Unboxed struct property : " ++ show t + else notImplementedError $ "Unboxed struct property : " <> tshow t APIUnion u -> if unionIsBoxed u then return "Boxed" - else error $ "Unboxed union property : " ++ show t - APIObject _ -> do + else notImplementedError $ "Unboxed union property : " <> tshow t + APIObject o -> do isGO <- isGObject t if isGO then return "Object" - else error $ "Non-GObject object property : " ++ show t + else case (objGetValueFunc o, objSetValueFunc o) of + (Just _, Just _) -> return "IsGValueInstance" + _ -> notImplementedError $ "Non-GObject object property without known gvalue_set and/or gvalue_get: " <> tshow t APIInterface _ -> do isGO <- isGObject t if isGO then return "Object" - else error $ "Non-GObject interface property : " ++ show t - _ -> error $ "Unknown interface property of type : " ++ show t - _ -> error $ "Don't know how to handle properties of type " ++ show t + else notImplementedError $ "Non-GObject interface property : " <> tshow t + _ -> notImplementedError $ "Unknown interface property of type : " <> tshow t + _ -> notImplementedError $ "Don't know how to handle properties of type " <> tshow t +-- | Some types need casting to a concrete type before we can set or +-- construct properties. For example, for non-GObject object +-- properties we accept any instance of @IsX@ for convenience, but +-- instance resolution of the IsGValueSetter requires a concrete +-- type. The following code implements the cast on the given variable, +-- if needed, and returns the name of the new variable of concrete +-- type. +castProp :: Type -> Text -> CodeGen e Text +castProp t@(TInterface n) val = do + api <- findAPIByName n + case api of + APIObject o -> do + isGO <- isGObject t + if not isGO + then case (objGetValueFunc o, objSetValueFunc o) of + (Just _, Just _) -> do + let val' = prime val + cast <- safeCast n + line $ val' <> " <- " <> cast <> " " <> val + return val' + _ -> return val + else return val + _ -> return val +castProp _ val = return val + -- | The constraint for setting the given type in properties. -propSetTypeConstraint :: Type -> CodeGen Text +propSetTypeConstraint :: Type -> CodeGen e Text propSetTypeConstraint (TGClosure Nothing) = return $ "(~) " <> parenthesize (typeShow ("GClosure" `con` [con0 "()"])) propSetTypeConstraint t = do @@ -108,7 +139,7 @@ else hInType -- | The constraint for transferring the given type into a property. -propTransferTypeConstraint :: Type -> CodeGen Text +propTransferTypeConstraint :: Type -> CodeGen e Text propTransferTypeConstraint t = do isGO <- isGObject t if isGO @@ -121,7 +152,7 @@ -- | The type of the return value of @attrTransfer@ for the given -- type. -propTransferType :: Type -> CodeGen Text +propTransferType :: Type -> CodeGen e Text propTransferType (TGClosure Nothing) = return $ typeShow ("GClosure" `con` [con0 "()"]) propTransferType t = do @@ -133,7 +164,7 @@ -- | Given a value "v" of the given Haskell type, satisfying the -- constraint generated by 'propTransferTypeConstraint', convert it -- (allocating memory is necessary) to the type given by 'propTransferType'. -genPropTransfer :: Text -> Type -> CodeGen () +genPropTransfer :: Text -> Type -> CodeGen e () genPropTransfer var (TGClosure Nothing) = line $ "return " <> var genPropTransfer var t = do isGO <- isGObject t @@ -156,7 +187,7 @@ -- | Given a property, return the set of constraints on the types, and -- the type variables for the object and its value. -attrType :: Property -> CodeGen ([Text], Text) +attrType :: Property -> CodeGen e ([Text], Text) attrType prop = do resetTypeVariableScope isCallback <- typeIsCallback (propType prop) @@ -179,7 +210,7 @@ <> " 'Data.GI.Base.Attributes.:=' value ]" , "@"] -genPropertySetter :: Text -> Name -> HaddockSection -> Property -> CodeGen () +genPropertySetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertySetter setter n docSection prop = group $ do (constraints, t) <- attrType prop isNullable <- typeIsNullable (propType prop) @@ -190,11 +221,14 @@ writeHaddock DocBeforeSymbol (setterDoc n prop) line $ setter <> " :: (" <> T.intercalate ", " constraints' <> ") => o -> " <> t <> " -> m ()" - line $ setter <> " obj val = liftIO $ B.Properties.setObjectProperty" <> tStr - <> " obj \"" <> propName prop - <> if isNullable && (not isCallback) - then "\" (Just val)" - else "\" val" + line $ setter <> " obj val = MIO.liftIO $ do" + indent $ do + val' <- castProp (propType prop) "val" + line $ "B.Properties.setObjectProperty" <> tStr + <> " obj \"" <> propName prop + <> if isNullable && (not isCallback) + then "\" (Just " <> val' <> ")" + else "\" " <> val' export docSection setter -- | Generate documentation for the given getter. @@ -207,7 +241,7 @@ , "'Data.GI.Base.Attributes.get' " <> lowerName n <> " #" <> hPropName prop , "@"] -genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> CodeGen () +genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyGetter getter n docSection prop = group $ do isNullable <- typeIsNullable (propType prop) let isMaybe = isNullable && propReadNullable prop /= Just False @@ -237,17 +271,17 @@ writeHaddock DocBeforeSymbol (getterDoc n prop) line $ getter <> " :: " <> constraints <> " => o -> " <> returnType - line $ getter <> " obj = liftIO $ " <> getProp + line $ getter <> " obj = MIO.liftIO $ " <> getProp <> " obj \"" <> propName prop <> "\"" <> constructorArg export docSection getter -- | 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 -> CodeGen () +genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyConstructor constructor n docSection prop = group $ do (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop @@ -259,11 +293,14 @@ writeHaddock DocBeforeSymbol (constructorDoc prop) line $ constructor <> " :: " <> pconstraints <> t <> " -> m (GValueConstruct o)" - line $ constructor <> " val = MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr + line $ constructor <> " val = MIO.liftIO $ do" + indent $ do + val' <- castProp (propType prop) "val" + line $ "MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr <> " \"" <> propName prop <> if isNullable && (not isCallback) - then "\" (P.Just val)" - else "\" val" + then "\" (P.Just " <> val' <> ")" + else "\" " <> val' export docSection constructor -- | Generate documentation for the given setter. @@ -276,7 +313,7 @@ , "'Data.GI.Base.Attributes.clear'" <> " #" <> hPropName prop , "@"] -genPropertyClear :: Text -> Name -> HaddockSection -> Property -> CodeGen () +genPropertyClear :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen () genPropertyClear clear n docSection prop = group $ do cls <- classConstraint n let constraints = ["MonadIO m", cls <> " o"] @@ -300,7 +337,7 @@ hPropName :: Property -> Text hPropName = lcFirst . hyphensToCamelCase . propName -genObjectProperties :: Name -> Object -> CodeGen () +genObjectProperties :: Name -> Object -> CodeGen e () genObjectProperties n o = do isGO <- apiIsGObject n (APIObject o) -- We do not generate bindings for objects not descending from GObject. @@ -312,7 +349,7 @@ <> "\", " <> pi <> ")") genProperties n (objProperties o) allProps -genInterfaceProperties :: Name -> Interface -> CodeGen () +genInterfaceProperties :: Name -> Interface -> CodeGen e () genInterfaceProperties n iface = do allProps <- fullInterfacePropertyList n iface >>= mapM (\(owner, prop) -> do @@ -324,7 +361,7 @@ -- If the given accesor is available (indicated by available == True), -- generate a fully qualified accesor name, otherwise just return -- "undefined". accessor is "get", "set" or "construct" -accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text +accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen e Text accessorOrUndefined available accessor owner@(Name _ on) cName = if not available then return "undefined" @@ -332,7 +369,7 @@ -- | The name of the type encoding the information for the property of -- the object. -infoType :: Name -> Property -> CodeGen Text +infoType :: Name -> Property -> CodeGen e Text infoType owner prop = let infoType = upperName owner <> (hyphensToCamelCase . propName) prop <> "PropertyInfo" @@ -342,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 && @@ -410,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 []) @@ -422,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 @@ -440,16 +488,24 @@ 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. -genPlaceholderProperty :: Name -> Property -> CodeGen () +genPlaceholderProperty :: Name -> Property -> CodeGen e () genPlaceholderProperty owner prop = do line $ "-- XXX Placeholder" it <- infoType owner prop @@ -473,7 +529,7 @@ line $ "attrClear = undefined" line $ "attrTransfer = undefined" -genProperties :: Name -> [Property] -> [Text] -> CodeGen () +genProperties :: Name -> [Property] -> [Text] -> CodeGen e () genProperties n ownedProps allProps = do let name = upperName n @@ -491,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 @@ -499,12 +555,12 @@ -- name clashes (an example is Auth::is_for_proxy method in libsoup, -- and the corresponding Auth::is-for-proxy property). When there is a -- clash we give priority to the method. -genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen () +genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen e () genNamespacedPropLabels owner props methods = let lName = lcFirst . hyphensToCamelCase . propName in genNamespacedAttrLabels owner (map lName props) methods -genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen () +genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen e () genNamespacedAttrLabels owner attrNames methods = do let name = upperName owner diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -6,7 +6,7 @@ import Control.Monad (forM, forM_, when, unless) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -27,6 +27,7 @@ RelativeDocPosition(..), writeHaddock, writeDocumentation, writeArgDocumentation, writeReturnDocumentation) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type @@ -37,8 +38,8 @@ -- | The prototype of the callback on the Haskell side (what users of -- the binding will see) genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures -> - Documentation -> ExcCodeGen () -genHaskellCallbackPrototype subsec cb htype expose doc = group $ do + Bool -> Documentation -> ExcCodeGen () +genHaskellCallbackPrototype subsec cb htype expose isSignal doc = group $ do let name' = case expose of WithClosures -> callbackHTypeWithClosures htype WithoutClosures -> htype @@ -65,13 +66,14 @@ line $ returnArrow <> typeShow (io ret) writeReturnDocumentation cb False - blank + when (not isSignal) $ do + blank - -- For optional parameters, in case we want to pass Nothing. - export (NamedSubsection SignalSection subsec) ("no" <> name') - writeHaddock DocBeforeSymbol (noCallbackDoc name') - line $ "no" <> name' <> " :: Maybe " <> name' - line $ "no" <> name' <> " = Nothing" + -- For optional parameters, in case we want to pass Nothing. + export (NamedSubsection SignalSection subsec) ("no" <> name') + writeHaddock DocBeforeSymbol (noCallbackDoc name') + line $ "no" <> name' <> " :: Maybe " <> name' + line $ "no" <> name' <> " = Nothing" where noCallbackDoc :: Text -> Text noCallbackDoc typeName = @@ -80,25 +82,31 @@ -- | Generate the type synonym for the prototype of the callback on -- the C side. Returns the name given to the type synonym. -genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen 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 () -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 `" @@ -125,7 +134,7 @@ -- | Wrap the Haskell `cb` callback into a foreign function of the -- right type. Returns the name of the wrapped value. -genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text +genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen e Text genWrappedCallback cb cbArg callback isSignal = do drop <- if callableHasClosures cb then do @@ -141,8 +150,8 @@ return (prime drop) -- | Generator of closures -genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen () -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 -> BaseCodeGen e Text -> BaseCodeGen 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 @@ -241,7 +253,7 @@ line $ "poke " <> name <> " " <> name'' -- | A simple wrapper that drops every closure argument. -genDropClosures :: Text -> Callable -> Text -> CodeGen () +genDropClosures :: Text -> Callable -> Text -> CodeGen e () genDropClosures subsec cb name' = group $ do let dropper = callbackDropClosures name' (inWithClosures, _) = callableHInArgs cb WithClosures @@ -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 @@ -330,9 +356,9 @@ result' <- convert rname $ hToF r (returnTransfer cb) line $ "return " <> result' -genCallback :: Name -> Callback -> CodeGen () -genCallback n (Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do - let name' = upperName n +genCallback :: Name -> Callback -> CodeGen e () +genCallback n callback@(Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do + let Name _ name' = normalizedAPIName (APICallback callback) n cb' = fixupCallerAllocates cb line $ "-- callback " <> name' @@ -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 () +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,12 +426,18 @@ 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. -processSignalError :: Signal -> Name -> CGError -> CodeGen () +processSignalError :: Signal -> Name -> CGError -> CodeGen e () processSignalError signal owner err = do let qualifiedSignalName = upperName owner <> "::" <> sigName signal sn = (ucFirst . signalHaskellName . sigName) signal @@ -422,7 +459,7 @@ export (NamedSubsection SignalSection $ lcFirst sn) si -- | Generate a wrapper for a signal. -genSignal :: Signal -> Name -> CodeGen () +genSignal :: Signal -> Name -> CodeGen e () genSignal s@(Signal { sigName = sn, sigCallable = cb }) on = handleCGExc (processSignalError s on) $ do let on' = upperName on @@ -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 - -> CodeGen () -genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail = do - cb' <- genWrappedCallback cb "cb" cbType True + -> Text -- ^ Name of variable holding the callback + -> CodeGen e () +genSignalConnector (Signal {sigName = sn, sigCallable = cb}) + cbType when detail cbName = do + cb' <- genWrappedCallback cb cbName cbType True let cb'' = prime cb' line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb' line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -5,6 +5,7 @@ , extractCallbacksInStruct , fixAPIStructs , ignoreStruct + , genBoxed , genWrappedPtr ) where @@ -25,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 @@ -41,7 +46,7 @@ (not $ structForceVisible s) -- | Whether the given type corresponds to an ignored struct. -isIgnoredStructType :: Type -> CodeGen Bool +isIgnoredStructType :: Type -> CodeGen e Bool isIgnoredStructType t = case t of TInterface n -> do @@ -96,7 +101,7 @@ -- | The name of the type encoding the information for a field in a -- struct/union. -infoType :: Name -> Field -> CodeGen Text +infoType :: Name -> Field -> CodeGen e Text infoType owner field = do let name = upperName owner let fName = (underscoresToCamelCase . fieldName) field @@ -253,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 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 Text +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 @@ -280,7 +288,7 @@ -- | The type generated by 'Data.GI.Base.attrTransfer' for this -- field. This type should satisfy the -- 'Data.GI.Base.Attributes.AttrSetTypeConstraint' for the type. -fieldTransferType :: Type -> CodeGen Text +fieldTransferType :: Type -> CodeGen e Text fieldTransferType t = do isPtr <- typeIsPtr t inType <- if isPtr @@ -292,16 +300,17 @@ -- | Generate the field transfer function, which marshals Haskell -- values to types that we can set, even if we need to allocate memory. -genFieldTransfer :: Text -> Type -> CodeGen () -genFieldTransfer 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 :: Text -> Type -> CodeGen e () +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 @@ -333,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 @@ -365,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 @@ -419,7 +439,7 @@ docSection = NamedSubsection PropertySection $ lcFirst $ fName field -- | Generate code for the given list of fields. -genStructOrUnionFields :: Name -> [Field] -> CodeGen () +genStructOrUnionFields :: Name -> [Field] -> CodeGen e () genStructOrUnionFields n fields = do let name' = upperName n @@ -438,24 +458,24 @@ 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. -genZeroSU :: Name -> Int -> Bool -> CodeGen () +genZeroSU :: Name -> Int -> Bool -> CodeGen e () genZeroSU n size isBoxed = group $ do let name = upperName n let builder = "newZero" <> name 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 $ " <> if isBoxed then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name - else "wrappedPtrCalloc >>= wrapPtr " <> name + else "boxedPtrCalloc >>= wrapPtr " <> name exportDecl builder blank @@ -471,77 +491,123 @@ line $ "return o" -- | Specialization for structs of `genZeroSU`. -genZeroStruct :: Name -> Struct -> CodeGen () +genZeroStruct :: Name -> Struct -> CodeGen e () genZeroStruct n s = when (allocCalloc (structAllocationInfo s) /= AllocationOp "none" && structSize s /= 0) $ genZeroSU n (structSize s) (structIsBoxed s) -- | Specialization for unions of `genZeroSU`. -genZeroUnion :: Name -> Union -> CodeGen () +genZeroUnion :: Name -> Union -> CodeGen e () genZeroUnion n u = when (allocCalloc (unionAllocationInfo u ) /= AllocationOp "none" && unionSize u /= 0) $ genZeroSU n (unionSize u) (unionIsBoxed u) -- | Construct a import with the given prefix. -prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text +prefixedForeignImport :: Text -> Text -> Text -> CodeGen e Text prefixedForeignImport prefix symbol prototype = group $ do line $ "foreign import ccall \"" <> symbol <> "\" " <> prefix <> symbol <> " :: " <> prototype return (prefix <> symbol) --- | Same as `prefixedForeignImport`, but import a `FunPtr` to the symbol. -prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text -prefixedFunPtrImport prefix symbol prototype = group $ do - line $ "foreign import ccall \"&" <> symbol <> "\" " <> prefix <> symbol - <> " :: FunPtr (" <> prototype <> ")" - return (prefix <> symbol) +-- | Generate a GValue instance for @GBoxed@ objects. +genBoxedGValueInstance :: Name -> Text -> CodeGen e () +genBoxedGValueInstance n get_type_fn = do + let name' = upperName n + doc = "Convert t'" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." --- | Generate the typeclass with information for how to --- allocate/deallocate a given type. -genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () -genWrappedPtr n info size = group $ do + writeHaddock DocBeforeSymbol doc + + group $ do + bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where" + indent $ group $ do + line $ "gvalueGType_ = " <> get_type_fn + line $ "gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.Ptr " <> name' <> ")" + line $ "gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)" + line $ "gvalueGet_ gv = do" + indent $ group $ do + line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")" + line $ "if ptr /= FP.nullPtr" + line $ "then P.Just <$> B.ManagedPtr.newBoxed " <> name' <> " ptr" + line $ "else return P.Nothing" + +-- | Allocation and deallocation for types registered as `GBoxed` in +-- the GLib type system. +genBoxed :: Name -> Text -> CodeGen e () +genBoxed n typeInit = do let name' = upperName n + get_type_fn = "c_" <> typeInit + group $ do + line $ "foreign import ccall \"" <> typeInit <> "\" " <> + get_type_fn <> " :: " + indent $ line "IO GType" + + group $ do + line $ "type instance O.ParentTypes " <> name' <> " = '[]" + bline $ "instance O.HasParentTypes " <> name' + + group $ do + bline $ "instance B.Types.TypedObject " <> name' <> " where" + indent $ line $ "glibType = " <> get_type_fn + + group $ do + bline $ "instance B.Types.GBoxed " <> name' + + genBoxedGValueInstance n get_type_fn + +-- | Generate the typeclass with information for how to +-- allocate/deallocate a given type which is not a `GBoxed`. +genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen e () +genWrappedPtr n info size = group $ do let prefix = \op -> "_" <> name' <> "_" <> op <> "_" when (size == 0 && allocFree info == AllocationOpUnknown) $ line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?" - calloc <- case allocCalloc info of - AllocationOp "none" -> - return ("error \"calloc not permitted for " <> name' <> "\"") - AllocationOp op -> - prefixedForeignImport (prefix "calloc") op "IO (Ptr a)" - AllocationOpUnknown -> - if size > 0 - then return ("callocBytes " <> tshow size) - else return "return nullPtr" - copy <- case allocCopy info of AllocationOp op -> do copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)" - return ("\\p -> withManagedPtr p (" <> copy <> - " >=> wrapPtr " <> name' <> ")") + return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <> + " >=> B.ManagedPtr.wrapPtr " <> name' <> ")") AllocationOpUnknown -> if size > 0 - then return ("\\p -> withManagedPtr p (copyBytes " - <> tshow size <> " >=> wrapPtr " <> name' <> ")") + then return ("\\p -> B.ManagedPtr.withManagedPtr p (copyBytes " + <> tshow size <> + " >=> B.ManagedPtr.wrapPtr " <> name' <> ")") else return "return" free <- case allocFree info of - AllocationOp op -> ("Just " <>) <$> - prefixedFunPtrImport (prefix "free") op "Ptr a -> IO ()" + AllocationOp op -> do + free <- prefixedForeignImport (prefix "free") op "Ptr a -> IO ()" + return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> free AllocationOpUnknown -> if size > 0 - then return "Just ptr_to_g_free" - else return "Nothing" + then return "\\x -> SP.withManagedPtr x SP.freeMem" + else return "\\_x -> return ()" - line $ "instance WrappedPtr " <> name' <> " where" + bline $ "instance BoxedPtr " <> name' <> " where" indent $ do - line $ "wrappedPtrCalloc = " <> calloc - line $ "wrappedPtrCopy = " <> copy - line $ "wrappedPtrFree = " <> free + line $ "boxedPtrCopy = " <> copy + line $ "boxedPtrFree = " <> free - hsBoot $ line $ "instance WrappedPtr " <> name' <> " where" + case allocCalloc info of + AllocationOp "none" -> return () + AllocationOp op -> do + calloc <- prefixedForeignImport (prefix "calloc") op "IO (Ptr a)" + callocInstance calloc + AllocationOpUnknown -> + if size > 0 + then do + let calloc = "callocBytes " <> tshow size + callocInstance calloc + else return () + + where name' = upperName n + + callocInstance :: Text -> CodeGen e () + callocInstance calloc = group $ do + bline $ "instance CallocPtr " <> name' <> " where" + indent $ do + line $ "boxedPtrCalloc = " <> calloc diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs --- a/lib/Data/GI/CodeGen/SymbolNaming.hs +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -3,11 +3,11 @@ ( lowerName , lowerSymbol , upperName - , noName , escapedArgName , classConstraint , typeConstraint + , safeCast , hyphensToCamelCase , underscoresToCamelCase @@ -25,10 +25,17 @@ , signalInfoName , submoduleLocation + , moduleLocation , qualifiedAPI , qualifiedSymbol + , normalizedAPIName + + , hackageModuleLink + , haddockSignalAnchor + , haddockAttrAnchor ) where +import qualified Data.Char as C #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -36,20 +43,25 @@ import qualified Data.Text as T import Data.GI.CodeGen.API -import Data.GI.CodeGen.Code (CodeGen, group, line, exportDecl, - qualified, getAPI) -import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath) +import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI, findAPIByName, config) +import Data.GI.CodeGen.Config (Config(..)) +import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath, dotModulePath) import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified) -- | Return a qualified form of the constraint for the given name -- (which should correspond to a valid `TInterface`). -classConstraint :: Name -> CodeGen Text +classConstraint :: Name -> CodeGen e Text classConstraint n@(Name _ s) = qualifiedSymbol ("Is" <> s) n +-- | Return a qualified form of the function mapping instances of +-- @IsX@ to haskell values of type @X@. +safeCast :: Name -> CodeGen e Text +safeCast n@(Name _ s) = qualifiedSymbol ("to" <> ucFirst s) n + -- | Same as `classConstraint`, but applicable directly to a type. The -- type should be a `TInterface`, otherwise an error will be raised. -typeConstraint :: Type -> CodeGen Text +typeConstraint :: Type -> CodeGen e Text typeConstraint (TInterface n) = classConstraint n typeConstraint t = error $ "Class constraint for non-interface type: " <> show t @@ -105,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. @@ -125,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 @@ -147,30 +176,38 @@ submoduleLocation n (APIStruct _) = "Structs" /. upperName n submoduleLocation n (APIUnion _) = "Unions" /. upperName n +-- | Obtain the absolute location of the module where the given `API` +-- lives. +moduleLocation :: Name -> API -> ModulePath +moduleLocation n api = + ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api + +-- | Construct the Haskell version of the name associated to the given +-- API. +normalizedAPIName :: API -> Name -> Name +normalizedAPIName (APIConst _) (Name ns name) = Name ns (ucFirst name) +normalizedAPIName (APIFunction _) n = n +normalizedAPIName (APICallback _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIEnum _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIFlags _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIInterface _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIObject _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIStruct _) n@(Name ns _) = Name ns (upperName n) +normalizedAPIName (APIUnion _) n@(Name ns _) = Name ns (upperName n) + -- | Return an identifier for the given interface type valid in the current -- module. -qualifiedAPI :: Name -> CodeGen Text -qualifiedAPI n@(Name ns _) = do - api <- getAPI (TInterface n) - qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) n +qualifiedAPI :: API -> Name -> CodeGen e Text +qualifiedAPI api n@(Name ns _) = + let normalized = normalizedAPIName api n + in qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) normalized -- | Construct an identifier for the given symbol in the given API. -qualifiedSymbol :: Text -> Name -> CodeGen Text +qualifiedSymbol :: Text -> Name -> CodeGen e Text qualifiedSymbol s n@(Name ns _) = do api <- getAPI (TInterface n) qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s) --- | Save a bit of typing for optional arguments in the case that we --- want to pass Nothing. -noName :: Text -> CodeGen () -noName name' = group $ do - -- We should use `writeHaddock` here, but it would give rise to a - -- cyclic import. - line $ "-- | A convenience alias for `Nothing` :: `Maybe` `" <> name' <> "`." - line $ "no" <> name' <> " :: Maybe " <> name' - line $ "no" <> name' <> " = Nothing" - exportDecl ("no" <> name') - -- | Turn a hyphen-separated identifier into camel case. -- -- === __Examples__ @@ -204,6 +241,7 @@ -- argument name (and escaping it if not). escapedArgName :: Arg -> Text escapedArgName arg + | argCName arg == "_" = "_'" -- "_" denotes a hole, so we need to escape it | "_" `T.isPrefixOf` argCName arg = argCName arg | otherwise = escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg @@ -242,7 +280,7 @@ | otherwise = s -- | Qualified name for the "(sigName, info)" tag for a given signal. -signalInfoName :: Name -> Signal -> CodeGen Text +signalInfoName :: Name -> Signal -> CodeGen e Text signalInfoName n signal = do let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal <> "SignalInfo" @@ -250,5 +288,28 @@ -- | 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 +-- the binding which is currently being generated. +hackageModuleLink :: Name -> CodeGen e Text +hackageModuleLink n = do + api <- findAPIByName n + cfg <- config + let location = T.replace "." "-" $ dotModulePath (moduleLocation n api) + pkg = ghcPkgName cfg <> "-" <> ghcPkgVersion cfg + return $ "https://hackage.haskell.org/package/" <> pkg <> "/docs/" + <> location <> ".html" + +-- | Prefix in Haddock for the signal anchor. +haddockSignalAnchor :: Text +haddockSignalAnchor = "g:signal:" + +-- | Prefix in Haddock for the attribute anchor. +haddockAttrAnchor :: Text +haddockAttrAnchor = "g:attr:" diff --git a/lib/Data/GI/CodeGen/Transfer.hs b/lib/Data/GI/CodeGen/Transfer.hs --- a/lib/Data/GI/CodeGen/Transfer.hs +++ b/lib/Data/GI/CodeGen/Transfer.hs @@ -43,6 +43,7 @@ basicFreeFn (TGHash _ _) = Just "unrefGHashTable" basicFreeFn (TError) = Nothing basicFreeFn (TVariant) = Nothing +basicFreeFn (TGValue) = Nothing basicFreeFn (TParamSpec) = Nothing basicFreeFn (TGClosure _) = Nothing @@ -50,7 +51,7 @@ -- run in the exception handler, so any type which we ref/allocate -- with the expectation that the called function will consume it (on -- TransferEverything) should be freed here. -basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text) +basicFreeFnOnError :: Type -> Transfer -> CodeGen e (Maybe Text) basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType _) _ = return Nothing @@ -62,6 +63,10 @@ return $ if transfer == TransferEverything then Just "unrefGParamSpec" else Nothing +basicFreeFnOnError TGValue transfer = + return $ if transfer == TransferEverything + then Just "SP.freeMem" + else Nothing basicFreeFnOnError (TGClosure _) transfer = return $ if transfer == TransferEverything then Just "B.GClosure.unrefGClosure" @@ -114,7 +119,7 @@ basicFreeFnOnError (TError) _ = return Nothing -- Free just the container, but not the elements. -freeContainer :: Type -> Text -> CodeGen [Text] +freeContainer :: Type -> Text -> CodeGen e [Text] freeContainer t label = case basicFreeFn t of Nothing -> return [] @@ -223,7 +228,7 @@ <> label freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label] -freeOut :: Text -> CodeGen [Text] +freeOut :: Text -> CodeGen e [Text] freeOut label = return ["freeMem " <> label] -- | Given an input argument to a C callable, and its label in the code, diff --git a/lib/Data/GI/GIR/Arg.hs b/lib/Data/GI/GIR/Arg.hs --- a/lib/Data/GI/GIR/Arg.hs +++ b/lib/Data/GI/GIR/Arg.hs @@ -4,6 +4,7 @@ , Scope(..) , parseArg , parseTransfer + , parseTransferString ) where #if !MIN_VERSION_base(4,11,0) @@ -13,7 +14,7 @@ import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser -import Data.GI.GIR.Type (parseType) +import Data.GI.GIR.Type (parseType, queryElementCType) data Direction = DirectionIn | DirectionOut @@ -24,6 +25,7 @@ | ScopeTypeCall | ScopeTypeAsync | ScopeTypeNotified + | ScopeTypeForever deriving (Show, Eq, Ord) data Arg = Arg { @@ -31,6 +33,7 @@ -- escaped name valid in Haskell code, use -- `GI.SymbolNaming.escapedArgName`. argType :: Type, + argCType :: Maybe Text, direction :: Direction, mayBeNull :: Bool, argDoc :: Documentation, @@ -38,20 +41,26 @@ argClosure :: Int, argDestroy :: Int, argCallerAllocates :: Bool, + argCallbackUserData :: Bool, + -- ^ Whether the argument is an "user-data" argument for a callback. transfer :: Transfer } deriving (Show, Eq, Ord) -parseTransfer :: Parser Transfer -parseTransfer = getAttr "transfer-ownership" >>= \case +parseTransferString :: Text -> Parser Transfer +parseTransferString transfer = case transfer of "none" -> return TransferNothing "container" -> return TransferContainer "full" -> return TransferEverything t -> parseError $ "Unknown transfer type \"" <> t <> "\"" +parseTransfer :: Parser Transfer +parseTransfer = getAttr "transfer-ownership" >>= parseTransferString + parseScope :: Text -> Parser Scope parseScope "call" = return ScopeTypeCall parseScope "async" = return ScopeTypeAsync parseScope "notified" = return ScopeTypeNotified +parseScope "forever" = return ScopeTypeForever parseScope s = parseError $ "Unknown scope type \"" <> s <> "\"" parseDirection :: Text -> Parser Direction @@ -69,17 +78,30 @@ closure <- optionalAttr "closure" (-1) parseIntegral destroy <- optionalAttr "destroy" (-1) parseIntegral nullable <- optionalAttr "nullable" False parseBool + allowNone <- optionalAttr "allow-none" False parseBool + -- "allow-none" is deprecated, but still produced by Vala. Support + -- it for in arguments. + let mayBeNull = if d == DirectionIn + then nullable || allowNone + else nullable callerAllocates <- optionalAttr "caller-allocates" False parseBool + -- 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 = nullable + , mayBeNull = mayBeNull , argScope = scope , argClosure = closure , argDestroy = destroy , argCallerAllocates = callerAllocates + , argCallbackUserData = callbackUserData , transfer = ownership } diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs --- a/lib/Data/GI/GIR/BasicTypes.hs +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -46,6 +46,17 @@ | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr + | TShort -- ^ gshort + | TUShort -- ^ gushort + | TSize -- ^ gsize + | TSSize -- ^ gssize + | Ttime_t -- ^ time_t + | Toff_t -- ^ off_t + | Tdev_t -- ^ dev_t + | Tgid_t -- ^ gid_t + | Tpid_t -- ^ pid_t + | Tsocklen_t -- ^ socklen_t + | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection @@ -54,6 +65,7 @@ = TBasicType BasicType | TError -- ^ GError | TVariant -- ^ GVariant + | TGValue -- ^ GValue | TParamSpec -- ^ GParamSpec | TCArray Bool Int Int Type -- ^ Zero terminated, Array Fixed -- Size, Array Length, Element Type diff --git a/lib/Data/GI/GIR/Constant.hs b/lib/Data/GI/GIR/Constant.hs --- a/lib/Data/GI/GIR/Constant.hs +++ b/lib/Data/GI/GIR/Constant.hs @@ -7,7 +7,7 @@ import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type) -import Data.GI.GIR.Type (parseType, parseCType) +import Data.GI.GIR.Type (parseType) import Data.GI.GIR.Parser -- | Info about a constant. @@ -26,7 +26,12 @@ deprecated <- parseDeprecation value <- getAttr "value" t <- parseType - ctype <- parseCType + -- This contains the C name for the constant. The C gir generator + -- call this "c:type", while the vala gir generator calls it + -- "c:identifier", so try both. + ctype <- queryAttrWithNamespace CGIRNS "type" >>= \case + Just i -> return i + Nothing -> getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs --- a/lib/Data/GI/GIR/Field.hs +++ b/lib/Data/GI/GIR/Field.hs @@ -51,7 +51,7 @@ -- Sometimes fields marked as not introspectable contain invalid -- introspection info. We are lenient in these cases with parsing -- errors, and simply ignore the fields. - flip catchError (\e -> if (not introspectable) && private + flip catchError (\e -> if not introspectable then return Nothing else throwError e) $ do (t, isPtr, callback) <- diff --git a/lib/Data/GI/GIR/Object.hs b/lib/Data/GI/GIR/Object.hs --- a/lib/Data/GI/GIR/Object.hs +++ b/lib/Data/GI/GIR/Object.hs @@ -4,6 +4,10 @@ , parseObject ) where +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif + import Data.Text (Text) import Data.GI.GIR.Method (Method, parseMethod, MethodType(..)) @@ -17,6 +21,10 @@ objTypeInit :: Text, objTypeName :: Text, objCType :: Maybe Text, + objRefFunc :: Maybe Text, + objUnrefFunc :: Maybe Text, + objSetValueFunc :: Maybe Text, + objGetValueFunc :: Maybe Text, objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo, objDocumentation :: Documentation, @@ -36,15 +44,27 @@ parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName) interfaces <- parseChildrenWithLocalName "implements" parseName props <- parseChildrenWithLocalName "property" parseProperty - typeInit <- getAttrWithNamespace GLibGIRNS "get-type" + typeInitFn <- getAttrWithNamespace GLibGIRNS "get-type" + typeInit <- case typeInitFn of + "intern" -> resolveInternalType name + fn -> return fn typeName <- getAttrWithNamespace GLibGIRNS "type-name" signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal + refFunc <- queryAttrWithNamespace GLibGIRNS "ref-func" + unrefFunc <- queryAttrWithNamespace GLibGIRNS "unref-func" + setValueFunc <- queryAttrWithNamespace GLibGIRNS "set-value-func" + getValueFunc <- queryAttrWithNamespace GLibGIRNS "get-value-func" + ctype <- queryCType return (name, Object { objParent = parent , objTypeInit = typeInit , objCType = ctype + , objRefFunc = refFunc + , objUnrefFunc = unrefFunc + , objSetValueFunc = setValueFunc + , objGetValueFunc = getValueFunc , objTypeName = typeName , objInterfaces = interfaces , objDeprecated = deprecated @@ -54,3 +74,39 @@ , objSignals = signals }) +-- | Some basic types do not list a type init function, and instead +-- mention "intern". Provide the explicit numerical value of the GType +-- in these cases. +resolveInternalType :: Name -> Parser Text +resolveInternalType (Name "GObject" p@"ParamSpec") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecBoolean") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecBoxed") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecChar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecDouble") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecEnum") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecFlags") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecFloat") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecGType") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecInt") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecInt64") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecLong") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecObject") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecOverride") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecParam") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecPointer") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecString") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUChar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUInt") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUInt64") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecULong") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUnichar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecVariant") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecValueArray") = pspec_type_init p +resolveInternalType (Name ns n) = + parseError $ "Unknown internal type: " <> ns <> "." <> n <> "\n" + <> "This is a bug, please report at https://github.com/haskell-gi/haskell-gi/issues" + +-- | The name of the function we provide for querying ParamSpec types +-- at runtime. +pspec_type_init :: Text -> Parser Text +pspec_type_init p = return $ "haskell_gi_pspec_type_init_" <> p diff --git a/lib/Data/GI/GIR/Property.hs b/lib/Data/GI/GIR/Property.hs --- a/lib/Data/GI/GIR/Property.hs +++ b/lib/Data/GI/GIR/Property.hs @@ -9,8 +9,8 @@ import Data.Monoid ((<>)) #endif -import Data.GI.GIR.Arg (parseTransfer) -import Data.GI.GIR.BasicTypes (Transfer, Type) +import Data.GI.GIR.Arg (parseTransferString) +import Data.GI.GIR.BasicTypes (Transfer(..), Type) import Data.GI.GIR.Parser import Data.GI.GIR.Type (parseType) @@ -26,6 +26,8 @@ propFlags :: [PropertyFlag], propReadNullable :: Maybe Bool, propWriteNullable :: Maybe Bool, + propSetter :: Maybe Text, + propGetter :: Maybe Text, propTransfer :: Transfer, propDoc :: Documentation, propDeprecated :: Maybe DeprecationInfo @@ -35,11 +37,13 @@ parseProperty = do name <- getAttr "name" t <- parseType - transfer <- parseTransfer + transfer <- optionalAttr "transfer-ownership" TransferNothing parseTransferString deprecated <- parseDeprecation readable <- optionalAttr "readable" True parseBool writable <- optionalAttr "writable" False parseBool construct <- optionalAttr "construct" False parseBool + setter <- queryAttr "setter" + getter <- queryAttr "getter" constructOnly <- optionalAttr "construct-only" False parseBool maybeNullable <- optionalAttr "nullable" Nothing (\t -> Just <$> parseBool t) let flags = (if readable then [PropertyReadable] else []) @@ -56,4 +60,6 @@ , propDoc = doc , propReadNullable = maybeNullable , propWriteNullable = maybeNullable + , propSetter = setter + , propGetter = getter } diff --git a/lib/Data/GI/GIR/Repository.hs b/lib/Data/GI/GIR/Repository.hs --- a/lib/Data/GI/GIR/Repository.hs +++ b/lib/Data/GI/GIR/Repository.hs @@ -49,8 +49,13 @@ then reverse acc : go ys [] else go ys (y : acc) +-- | Return the paths where to look for gir files. girDataDirs :: IO [FilePath] -girDataDirs = getSystemDataDirs "gir-1.0" +girDataDirs = do + sys <- getSystemDataDirs "gir-1.0" + -- See https://github.com/haskell-gi/haskell-gi/issues/390 + let macOS = ["/opt/homebrew/share/gir-1.0"] + return (sys ++ macOS) -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type @@ -8,15 +9,14 @@ , parseOptionalType ) where +#include "HsBaseConfig.h" + import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T -import Foreign.Storable (sizeOf) -import Foreign.C (CShort, CUShort, CSize) -import System.Posix.Types (CSsize) import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Parser @@ -47,24 +47,17 @@ nameToBasicType "filename" = Just TFileName nameToBasicType "gintptr" = Just TIntPtr nameToBasicType "guintptr" = Just TUIntPtr -nameToBasicType "gshort" = case sizeOf (0 :: CShort) of - 2 -> Just TInt16 - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected short size: " ++ show n -nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of - 2 -> Just TUInt16 - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected ushort size: " ++ show n -nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of - 4 -> Just TInt32 - 8 -> Just TInt64 - n -> error $ "Unexpected ssize length: " ++ show n -nameToBasicType "gsize" = case sizeOf (0 :: CSize) of - 4 -> Just TUInt32 - 8 -> Just TUInt64 - n -> error $ "Unexpected size length: " ++ show n +nameToBasicType "gshort" = Just TShort +nameToBasicType "gushort" = Just TUShort +nameToBasicType "gssize" = Just TSSize +nameToBasicType "gsize" = Just TSize +nameToBasicType "time_t" = Just Ttime_t +nameToBasicType "off_t" = Just Toff_t +nameToBasicType "dev_t" = Just Tdev_t +nameToBasicType "gid_t" = Just Tgid_t +nameToBasicType "pid_t" = Just Tpid_t +nameToBasicType "socklen_t" = Just Tsocklen_t +nameToBasicType "uid_t" = Just Tuid_t nameToBasicType _ = Nothing -- | The different array types. @@ -94,6 +87,7 @@ -- | A hash table. parseHashTable :: Parser Type parseHashTable = parseTypeElements >>= \case + [] -> return $ TGHash (TBasicType TPtr) (TBasicType TPtr) [Just key, Just value] -> return $ TGHash key value other -> parseError $ "Unsupported hash type: " <> T.pack (show other) @@ -120,6 +114,9 @@ parseFundamentalType "GLib" "Error" = return TError 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)