haskell-gi 0.21.5 → 0.26.17
raw patch · 51 files changed
Files
- ChangeLog.md +133/−0
- DocTests.hs +10/−13
- LICENSE +14/−0
- Setup.hs +6/−3
- haskell-gi.cabal +28/−26
- lib/Data/GI/CodeGen/API.hs +175/−74
- lib/Data/GI/CodeGen/Cabal.hs +0/−183
- lib/Data/GI/CodeGen/CabalHooks.hs +220/−40
- lib/Data/GI/CodeGen/Callable.hs +154/−112
- lib/Data/GI/CodeGen/Code.hs +255/−103
- lib/Data/GI/CodeGen/CodeGen.hs +277/−182
- lib/Data/GI/CodeGen/Config.hs +8/−1
- lib/Data/GI/CodeGen/Constant.hs +28/−16
- lib/Data/GI/CodeGen/Conversions.hs +0/−994
- lib/Data/GI/CodeGen/Conversions.hsc +1157/−0
- lib/Data/GI/CodeGen/CtoHaskellMap.hs +112/−50
- lib/Data/GI/CodeGen/EnumFlags.hs +46/−12
- lib/Data/GI/CodeGen/Fixups.hs +177/−5
- lib/Data/GI/CodeGen/GObject.hs +7/−5
- lib/Data/GI/CodeGen/GtkDoc.hs +650/−156
- lib/Data/GI/CodeGen/Haddock.hs +161/−77
- lib/Data/GI/CodeGen/Inheritance.hs +20/−20
- lib/Data/GI/CodeGen/LibGIRepository.hs +62/−25
- lib/Data/GI/CodeGen/ModulePath.hs +2/−0
- lib/Data/GI/CodeGen/OverloadedLabels.hs +0/−95
- lib/Data/GI/CodeGen/OverloadedMethods.hs +121/−30
- lib/Data/GI/CodeGen/OverloadedSignals.hs +9/−80
- lib/Data/GI/CodeGen/Overrides.hs +26/−9
- lib/Data/GI/CodeGen/PkgConfig.hs +3/−2
- lib/Data/GI/CodeGen/ProjectInfo.hs +28/−7
- lib/Data/GI/CodeGen/Properties.hs +193/−60
- lib/Data/GI/CodeGen/Signal.hs +227/−100
- lib/Data/GI/CodeGen/Struct.hs +210/−54
- lib/Data/GI/CodeGen/SymbolNaming.hs +105/−27
- lib/Data/GI/CodeGen/Transfer.hs +26/−9
- lib/Data/GI/CodeGen/Type.hs +2/−0
- lib/Data/GI/CodeGen/Util.hs +38/−4
- lib/Data/GI/GIR/Arg.hs +28/−4
- lib/Data/GI/GIR/BasicTypes.hs +13/−0
- lib/Data/GI/GIR/Callable.hs +14/−1
- lib/Data/GI/GIR/Constant.hs +7/−2
- lib/Data/GI/GIR/Field.hs +16/−5
- lib/Data/GI/GIR/Function.hs +1/−0
- lib/Data/GI/GIR/Method.hs +1/−0
- lib/Data/GI/GIR/Object.hs +57/−1
- lib/Data/GI/GIR/Parser.hs +3/−4
- lib/Data/GI/GIR/Property.hs +14/−6
- lib/Data/GI/GIR/Repository.hs +6/−1
- lib/Data/GI/GIR/Signal.hs +3/−0
- lib/Data/GI/GIR/Struct.hs +3/−0
- lib/Data/GI/GIR/Type.hs +39/−33
ChangeLog.md view
@@ -1,3 +1,136 @@+### 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.++### 0.23.0+++ gobjectType now does not require a proxy argument, it needs to be used with TypeApplications instead.+++ Annotated signals are supported: `on widget (signal ::: "detail")`.+++ Safe coercions to parent types supported, with `asA`.+++ Support for GObject subclassing, and registering custom properties.+++ Use TypeApplications in `AttrInfo` implementation, and inherited methods implementation.+++ Add an allocating setting operator `(:&=)`.+++ Support for exporting class structs.+++ IsGValue instances for GObjects and boxed objects.++### 0.22.6+++ Fix generated IsX typeclasses for non-GObject interfaces.++### 0.22.5+++ Add support for inheriting overloading info.++### 0.22.4+++ Do not generate bindings for struct/union fields pointing to private/class structs, which we do not bind.++### 0.22.3+++ Sometimes struct fields marked as not introspectable contain invalid introspection info. We are lenient in these cases with parsing errors, and simply ignore the fields.+ ### 0.21.5 + Add support for callback-valued properties.
DocTests.hs view
@@ -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] ""
LICENSE view
@@ -1,3 +1,17 @@+The haskell-gi library and included works are provided under the terms of the+GNU Library General Public License (LGPL) version 2.1 with the following+exception:++Static linking of applications or any other source to the haskell-gi library+does not constitute a modified or derivative work and does not require the+author(s) to provide source code for said work, to link against the shared+haskell-gi libraries, or to link their applications against a user-supplied+version of haskell-gi. If you link applications to a modified version of+haskell-gi, then the changes to haskell-gi must be provided under the terms of+the LGPL.++----------------------------------------------------------------------------+ GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999
Setup.hs view
@@ -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"
haskell-gi.cabal view
@@ -1,60 +1,60 @@ name: haskell-gi-version: 0.21.5+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 (garetxe@gmail.com)+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 == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1-cabal-version: >=1.8+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.7 && < 5,- haskell-gi-base == 0.21.*,+ build-depends: base >= 4.11 && < 5,+ haskell-gi-base >= 0.26.9 && <0.27, Cabal >= 1.24,- attoparsec == 0.13.*,+ attoparsec >= 0.13, containers, directory, filepath, mtl >= 2.2, transformers >= 0.3, pretty-show,+ ansi-terminal >= 0.10, process, safe, bytestring, xdg-basedir,- xml-conduit >= 1.3.0,+ xml-conduit >= 1.3, regex-tdfa >= 1.2, text >= 1.0 - if !impl(ghc >= 8.0)- build-depends: semigroups == 0.18.*-- extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings- ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing-- if impl(ghc >= 8.0)- ghc-options: -Wcompat+ default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings+ 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,@@ -81,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,@@ -100,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,@@ -115,10 +113,14 @@ other-modules: Paths_haskell_gi + autogen-modules: Paths_haskell_gi+ test-suite doctests type: exitcode-stdio-1.0- ghc-options: -threaded+ default-language: Haskell2010+ ghc-options: -threaded -Wall main-is: DocTests.hs build-depends: base , process , doctest >= 0.8+ , haskell-gi >= 0.26.10
lib/Data/GI/CodeGen/API.hs view
@@ -58,11 +58,14 @@ import Control.Applicative ((<$>)) #endif -import Control.Monad ((>=>), foldM, forM, forM_)+import Control.Monad ((>=>), foldM, forM, when) import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (mapMaybe, catMaybes)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif+ import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text)@@ -104,11 +107,12 @@ import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem)-import Data.GI.CodeGen.LibGIRepository (girRequire, FieldInfo(..),+import Data.GI.CodeGen.LibGIRepository (girRequire, Typelib, FieldInfo(..), girStructFieldInfo, girUnionFieldInfo,- girLoadGType)+ girLoadGType, girIsSymbolResolvable) import Data.GI.CodeGen.GType (gtypeIsBoxed) import Data.GI.CodeGen.Type (Type)+import Data.GI.CodeGen.Util (printWarning, terror, tshow) data GIRInfo = GIRInfo { girPCPackages :: [Text],@@ -150,12 +154,15 @@ -- | 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 -- the given selector. deriving (Show) +-- | An element in the exposed API data API = APIConst Constant | APIFunction Function@@ -191,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 =@@ -259,7 +267,7 @@ | S.null requested = return loaded | otherwise = do let (name, version) = S.elemAt 0 requested- doc <- fixupGIRDocument rules <$>+ doc <- overrideGIRDocument rules <$> readGiRepository verbose name (Just version) extraPaths let newLoaded = M.insert (name, version) doc loaded loadedSet = S.fromList (M.keys newLoaded)@@ -272,11 +280,11 @@ -> Text -- ^ name -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search- -> [GIRRule] -- ^ fixups+ -> [GIRRule] -- ^ overrides -> IO (Document, M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies) loadGIRFile verbose name version extraPaths rules = do- doc <- fixupGIRDocument rules <$>+ doc <- overrideGIRDocument rules <$> readGiRepository verbose name version extraPaths deps <- loadDependencies verbose (documentListIncludes doc) M.empty extraPaths rules@@ -311,37 +319,34 @@ Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err Right docGIR -> return docGIR --- | Load and parse a GIR file, including its dependencies.-loadGIRInfo :: Bool -- ^ verbose- -> Text -- ^ name- -> Maybe Text -- ^ version- -> [FilePath] -- ^ extra paths to search- -> [GIRRule] -- ^ fixups- -> IO (GIRInfo,- [GIRInfo]) -- ^ (parsed doc, parsed deps)-loadGIRInfo verbose name version extraPaths rules = do- (doc, deps) <- loadGIRFile verbose name version extraPaths rules- let aliases = M.unions (map documentListAliases (doc : M.elems deps))- parsedDoc = toGIRInfo (parseGIRDocument aliases doc)- parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)- case combineErrors parsedDoc parsedDeps of- Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err- Right (docGIR, depsGIR) -> do- if girNSName docGIR == name- then do- forM_ (docGIR : depsGIR) $ \info ->- girRequire (girNSName info) (girNSVersion info)- (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR- return (fixedDoc, fixedDeps)- else error . T.unpack $ "Got unexpected namespace \""- <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."- where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]- -> Either Text (GIRInfo, [GIRInfo])- combineErrors parsedDoc parsedDeps = do- doc <- parsedDoc- deps <- sequence parsedDeps- return (doc, deps)+-- | Fixup parsed GIRInfos: some of the required information is not+-- found in the GIR files themselves, or does not accurately reflect+-- the content in the dynamic library itself, but this can be+-- corrected by checking the typelib.+fixupGIRInfos :: Bool -> M.Map Text Typelib -> GIRInfo -> [GIRInfo]+ -> IO (GIRInfo, [GIRInfo])+fixupGIRInfos verbose typelibMap doc deps =+ (fixup (fixupInterface typelibMap ctypes) >=>+ fixup (fixupStruct typelibMap) >=>+ fixup fixupUnion >=>+ fixup (fixupMissingSymbols verbose typelibMap)+ ) (doc, deps)+ where fixup :: ((Name, API) -> IO (Name, API))+ -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])+ fixup fixer (doc, deps) = do+ fixedDoc <- fixAPIs fixer doc+ fixedDeps <- mapM (fixAPIs fixer) deps+ return (fixedDoc, fixedDeps) + fixAPIs :: ((Name, API) -> IO (Name, API))+ -> GIRInfo -> IO GIRInfo+ fixAPIs fixer info = do+ fixedAPIs <- mapM fixer (girAPIs info)+ return $ info {girAPIs = fixedAPIs}++ ctypes :: M.Map Text Name+ ctypes = M.unions (map girCTypes (doc:deps))+ foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType) -- | List the prerequisites for a 'GType' corresponding to an interface.@@ -358,19 +363,22 @@ -- | The list of prerequisites in GIR files is not always -- accurate. Instead of relying on this, we instantiate the 'GType' -- associated to the interface, and listing the interfaces from there.-fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do+fixupInterface :: M.Map Text Typelib -> M.Map Text Name -> (Name, API)+ -> IO (Name, API)+fixupInterface typelibMap csymbolMap (n@(Name ns _), APIInterface iface) = do prereqs <- case ifTypeInit iface of Nothing -> return [] Just ti -> do- gtype <- girLoadGType ns ti+ gtype <- case M.lookup ns typelibMap of+ Just typelib -> girLoadGType typelib ti+ Nothing -> error $ "fi: Typelib for " ++ show ns ++ " not loaded." prereqGTypes <- gtypeInterfaceListPrereqs gtype forM prereqGTypes $ \p -> do case M.lookup p csymbolMap of Just pn -> return pn Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n return (n, APIInterface (iface {ifPrerequisites = prereqs}))-fixupInterface _ (n, api) = return (n, api)+fixupInterface _ _ (n, api) = return (n, api) -- | There is not enough info in the GIR files to determine whether a -- struct is boxed. We find out by instantiating the 'GType'@@ -378,23 +386,27 @@ -- descends from the boxed GType. Similarly, the size of the struct -- and offset of the fields is hard to compute from the GIR data, we -- simply reuse the machinery in libgirepository.-fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupStruct _ (n, APIStruct s) = do- fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s+fixupStruct :: M.Map Text Typelib -> (Name, API)+ -> IO (Name, API)+fixupStruct typelibMap (n, APIStruct s) = do+ fixed <- (fixupStructIsBoxed typelibMap n >=> fixupStructSizeAndOffsets n) s return (n, APIStruct fixed) fixupStruct _ api = return api -- | Find out whether the struct is boxed.-fixupStructIsBoxed :: Name -> Struct -> IO Struct+fixupStructIsBoxed :: M.Map Text Typelib -> Name -> Struct -> IO Struct -- The type for "GVariant" is marked as "intern", we wrap -- this one natively.-fixupStructIsBoxed (Name "GLib" "Variant") s =+fixupStructIsBoxed _ (Name "GLib" "Variant") s = return (s {structIsBoxed = False})-fixupStructIsBoxed (Name ns _) s = do+fixupStructIsBoxed typelibMap (Name ns _) s = do isBoxed <- case structTypeInit s of Nothing -> return False Just ti -> do- gtype <- girLoadGType ns ti+ gtype <- case M.lookup ns typelibMap of+ Just typelib -> girLoadGType typelib ti+ Nothing -> error $ "fsib: Typelib for " ++ show ns ++ " not loaded."+ return (gtypeIsBoxed gtype) return (s {structIsBoxed = isBoxed}) @@ -407,11 +419,11 @@ , structFields = map (fixupField infoMap) (structFields s)}) -- | Same thing for unions.-fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupUnion _ (n, APIUnion u) = do+fixupUnion :: (Name, API) -> IO (Name, API)+fixupUnion (n, APIUnion u) = do fixed <- (fixupUnionSizeAndOffsets n) u return (n, APIUnion fixed)-fixupUnion _ api = return api+fixupUnion api = return api -- | Like 'fixupStructSizeAndOffset' above. fixupUnionSizeAndOffsets :: Name -> Union -> IO Union@@ -428,43 +440,115 @@ ++ show (fieldName f) Just o -> fieldInfoOffset o } --- | Fixup parsed GIRInfos: some of the required information is not--- found in the GIR files themselves, but can be obtained by--- instantiating the required GTypes from the installed libraries.-fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])-fixupGIRInfos doc deps = (fixup fixupInterface >=>- fixup fixupStruct >=>- fixup fixupUnion) (doc, deps)- where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))- -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])- fixup fixer (doc, deps) = do- fixedDoc <- fixAPIs fixer doc- fixedDeps <- mapM (fixAPIs fixer) deps- return (fixedDoc, fixedDeps)+-- | Some of the symbols listed in the introspection data are not+-- present in the dynamic library itself. Generating bindings for+-- these will sometimes lead to linker errors, so here we check that+-- every symbol listed in the bindings is actually present.+fixupMissingSymbols :: Bool -> M.Map Text Typelib -> (Name, API)+ -> IO (Name, API)+fixupMissingSymbols verbose typelibMap (n, APIStruct s) = do+ fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+ (structMethods s) verbose+ return (n, APIStruct (s {structMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIUnion u) = do+ fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+ (unionMethods u) verbose+ return (n, APIUnion (u {unionMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIObject o) = do+ fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+ (objMethods o) verbose+ return (n, APIObject (o {objMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIInterface i) = do+ fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+ (ifMethods i) verbose+ return (n, APIInterface (i {ifMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIFunction f) =+ fixupFunctionSymbols typelibMap (n, f) verbose+fixupMissingSymbols _ _ (n, api) = return (n, api) - fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo- fixAPIs fixer info = do- fixedAPIs <- mapM (fixer ctypes) (girAPIs info)- return $ info {girAPIs = fixedAPIs}+-- | Resolve the typelib owning the given name, erroring out if the+-- typelib is not known.+resolveTypelib :: Name -> M.Map Text Typelib -> Typelib+resolveTypelib n typelibMap = case M.lookup (namespace n) typelibMap of+ Nothing -> terror $ "Could not find typelib for “" <> namespace n <> "”."+ Just typelib -> typelib - ctypes :: M.Map Text Name- ctypes = M.unions (map girCTypes (doc:deps))+-- | Mark whether the methods can be resolved in the given typelib.+fixupMethodMissingSymbols :: Typelib -> [Method] -> Bool -> IO [Method]+fixupMethodMissingSymbols typelib methods verbose = mapM check methods+ where check :: Method -> IO Method+ check method@Method{methodCallable = callable} = do+ resolvable <- girIsSymbolResolvable typelib (methodSymbol method)+ when (verbose && not resolvable) $+ printWarning $ "Could not resolve the callable “"+ <> methodSymbol method+ <> "” in the “" <> tshow typelib+ <> "” typelib, ignoring."+ let callable' = callable{callableResolvable = Just resolvable}+ return $ method{methodCallable = callable'} +-- | Check that the symbol the function refers to is actually present+-- in the dynamic library.+fixupFunctionSymbols :: M.Map Text Typelib -> (Name, Function) -> Bool+ -> IO (Name, API)+fixupFunctionSymbols typelibMap (n, f) verbose = do+ let typelib = resolveTypelib n typelibMap+ resolvable <- girIsSymbolResolvable typelib (fnSymbol f)+ when (verbose && not resolvable) $+ printWarning $ "Could not resolve the function “" <> fnSymbol f+ <> "” in the “" <> tshow typelib <> "” typelib, ignoring."+ let callable' = (fnCallable f){callableResolvable = Just resolvable}+ return (n, APIFunction (f {fnCallable = callable'}))++-- | Load and parse a GIR file, including its dependencies.+loadGIRInfo :: Bool -- ^ verbose+ -> Text -- ^ name+ -> Maybe Text -- ^ version+ -> [FilePath] -- ^ extra paths to search+ -> [GIRRule] -- ^ fixups+ -> IO (GIRInfo, [GIRInfo])+ -- ^ (parsed doc, parsed deps)+loadGIRInfo verbose name version extraPaths rules = do+ (doc, deps) <- loadGIRFile verbose name version extraPaths rules+ let aliases = M.unions (map documentListAliases (doc : M.elems deps))+ parsedDoc = toGIRInfo (parseGIRDocument aliases doc)+ parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)+ case combineErrors parsedDoc parsedDeps of+ Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err+ Right (docGIR, depsGIR) -> do+ if girNSName docGIR == name+ then do+ typelibMap <- M.fromList <$> (forM (docGIR : depsGIR) $ \info -> do+ typelib <- girRequire (girNSName info) (girNSVersion info)+ return (girNSName info, typelib))+ (fixedDoc, fixedDeps) <- fixupGIRInfos verbose typelibMap docGIR depsGIR+ return (fixedDoc, fixedDeps)+ else error . T.unpack $ "Got unexpected namespace \""+ <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."+ where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]+ -> Either Text (GIRInfo, [GIRInfo])+ combineErrors parsedDoc parsedDeps = do+ doc <- parsedDoc+ deps <- sequence parsedDeps+ return (doc, deps)+ -- | Given a XML document containing GIR data, apply the given overrides.-fixupGIRDocument :: [GIRRule] -> XML.Document -> XML.Document-fixupGIRDocument rules doc =- doc {XML.documentRoot = fixupGIR rules (XML.documentRoot doc)}+overrideGIRDocument :: [GIRRule] -> XML.Document -> XML.Document+overrideGIRDocument rules doc =+ doc {XML.documentRoot = overrideGIR rules (XML.documentRoot doc)} -- | Looks for the given path in the given subelements of the given -- element. If the path is empty apply the corresponding rule, -- otherwise return the element ummodified.-fixupGIR :: [GIRRule] -> XML.Element -> XML.Element-fixupGIR rules elem =+overrideGIR :: [GIRRule] -> XML.Element -> XML.Element+overrideGIR rules elem = elem {XML.elementNodes = mapMaybe (\e -> foldM applyGIRRule e rules) (XML.elementNodes elem)} 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) =@@ -486,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
− lib/Data/GI/CodeGen/Cabal.hs
@@ -1,183 +0,0 @@-module Data.GI.CodeGen.Cabal- ( genCabalProject- , cabalConfig- , setupHs- , tryPkgConfig- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Monad (forM_)-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-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"
lib/Data/GI/CodeGen/CabalHooks.hs view
@@ -1,7 +1,10 @@ -- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks- ( setupHaskellGIBinding+ ( setupBinding+ , setupCompatWrapper+ , configureDryRun+ , TaggedOverride(..) ) where import qualified Distribution.ModuleName as MN@@ -12,81 +15,258 @@ import Distribution.PackageDescription import Data.GI.CodeGen.API (loadGIRInfo)-import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree)+import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree,+ ModuleInfo, transitiveModuleDeps) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath) import Data.GI.CodeGen.ModulePath (toModulePath)-import Data.GI.CodeGen.Overrides (parseOverridesFile, girFixups,+import Data.GI.CodeGen.Overrides (parseOverrides, girFixups, filterAPIsAndDeps)-import Data.GI.CodeGen.Util (ucFirst)+import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst, splitOn) -import Control.Monad (when, void)+import System.Directory (createDirectoryIfMissing)+import System.FilePath (joinPath, takeDirectory, (</>)) +import Control.Monad (forM)+ import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import System.Directory (doesFileExist)-import System.FilePath ((</>), (<.>))- type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +-- | Included overrides file.+data TaggedOverride =+ TaggedOverride { overrideTag :: Text+ -- ^ Tag for the override, for error reporting purposes.+ , overrideText :: Text+ }++-- | 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 pkgName pkgVersion verbosity overrides = do+ setupTypelibSearchPath []++ parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do+ parseOverrides ovText >>= \case+ Left err -> error $ "Error when parsing overrides file \""+ <> T.unpack tag <> "\":"+ <> T.unpack err+ Right ovs -> return ovs++ let ovs = mconcat parsed++ (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs)+ 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}++ return $ genCode cfg allAPIs (toModulePath name) (genModule apis)++-- | Write a module containing information about the configuration for+-- the package.+genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride ->+ [Text] -> IO ()+genConfigModule outputDir modName maybeGiven modules = do+ let fname = joinPath [ fromMaybe "" outputDir+ , "GI"+ , T.unpack (ucFirst modName)+ , "Config.hs" ]+ dirname = takeDirectory fname++ createDirectoryIfMissing True dirname++ utf8WriteFile fname $ T.unlines+ [ "{-# LANGUAGE OverloadedStrings #-}"+ , "-- | Build time configuration used during code generation."+ , "module GI." <> ucFirst modName <> ".Config ( overrides, modules ) where"+ , ""+ , "import qualified Data.Text as T"+ , "import Data.Text (Text)"+ , ""+ , "-- | Overrides used when generating these bindings."+ , "overrides :: Text"+ , "overrides = T.unlines"+ , formatList (overrides maybeGiven)+ , ""+ , "-- | Modules in this package"+ , "modules :: [Text]"+ , "modules = " <>+ formatList (("GI." <> ucFirst modName <> ".Config") : modules)+ ]++ 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 overrides outputDir+confCodeGenHook name version pkgName pkgVersion verbosity+ overridesFile inheritedOverrides outputDir defaultConfHook (gpd, hbi) flags = do- setupTypelibSearchPath [] - ovs <- case overrides of- Nothing -> return mempty- Just fname -> parseOverridesFile fname >>= \case- Left err -> error $ "Error when parsing overrides file: "- ++ T.unpack err- Right ovs -> return ovs-- (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs)- let (apis, deps) = filterAPIsAndDeps ovs gir girDeps- allAPIs = M.union apis deps- cfg = Config {modName = name,- verbose = verbosity,- overrides = ovs}+ givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile - let m = genCode cfg allAPIs (toModulePath name) (genModule apis)+ let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs+ m <- genModuleCode name version pkgName pkgVersion verbosity ovs - let em' = map (MN.fromString . T.unpack) (listModuleTree m)- ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'}- cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'}+ let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config"+ em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m)+ 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'} - alreadyDone <- doesFileExist (fromMaybe "" outputDir- </> "GI" </> T.unpack (ucFirst name) <.> "hs")- when (not alreadyDone) $ do- void $ writeModuleTree verbosity outputDir m+ modules <- writeModuleTree verbosity outputDir m + 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 :: 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 pkgName pkgVersion verbose overridesFile overrides outputDir = defaultMainWithHooks (simpleUserHooks {- confHook = confCodeGenHook name version verbose- overridesFile outputDir+ 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 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 pkgName pkgVersion False ovs++ return (("GI." <> ucFirst name <> ".Config") : listModuleTree m,+ transitiveModuleDeps m)
lib/Data/GI/CodeGen/Callable.hs view
@@ -3,7 +3,6 @@ ( genCCallableWrapper , genDynamicCallableWrapper , ForeignSymbol(..)- , ExposeClosures(..) , hOutType , skipRetVal@@ -20,14 +19,13 @@ , inArgInterfaces ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif import Control.Monad (forM, forM_, when, void) import Data.Bool (bool)-import Data.List (nub, (\\))+import Data.List (nub) import Data.Maybe (isJust)+#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import Data.Tuple (swap) import qualified Data.Map as Map import qualified Data.Text as T@@ -46,11 +44,6 @@ import Text.Show.Pretty (ppShow) --- | Whether to expose closures and the associated destroy notify--- handlers in the Haskell wrapper.-data ExposeClosures = WithClosures- | WithoutClosures- hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep hOutType callable outArgs = do hReturnType <- case returnType callable of@@ -75,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@@ -103,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@@ -115,24 +108,24 @@ -- 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 --- Given the list of arguments returns the list of constraints and the+-- | Given the list of arguments returns the list of constraints and the -- list of types in the signature.-inArgInterfaces :: [Arg] -> ExcCodeGen ([Text], [Text])-inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs- where- consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text])- consAndTypes _ [] = return ([], [])- consAndTypes letters (arg:args) = do- (ls, t, cons) <- argumentType letters $ argType arg- t' <- wrapMaybe arg >>= bool (return t)- (return $ "Maybe (" <> t <> ")")- (restCons, restTypes) <- consAndTypes ls args- return (cons <> restCons, t' : restTypes)+inArgInterfaces :: [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text])+inArgInterfaces args expose = do+ resetTypeVariableScope+ go args+ where go [] = return ([], [])+ go (arg:args) = do+ (t, cons) <- argumentType (argType arg) expose+ t' <- wrapMaybe arg >>= bool (return t)+ (return $ "Maybe (" <> t <> ")")+ (restCons, restTypes) <- go args+ return (cons <> restCons, t' : restTypes) -- Given a callable, return a list of (array, length) pairs, where in -- each pair "length" is the argument holding the length of the@@ -277,8 +270,8 @@ -- Marshall the haskell arguments into their corresponding C -- equivalents. omitted gives a list of DirectionIn arguments that -- should be ignored, as they will be dealt with separately.-prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen Text-prepareArgForCall omitted arg = do+prepareArgForCall :: [Arg] -> Arg -> ExposeClosures -> ExcCodeGen Text+prepareArgForCall omitted arg expose = do callback <- findAPI (argType arg) >>= \case Just (APICallback c) -> return (Just c) _ -> return Nothing@@ -293,7 +286,7 @@ Just c -> if callableThrows (cbCallable c) -- See [Note: Callables that throw] then return (escapedArgName arg)- else prepareInCallback arg c+ else prepareInCallback arg c expose Nothing -> prepareInArg arg DirectionInout -> prepareInoutArg arg DirectionOut -> prepareOutArg arg@@ -305,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@@ -317,17 +313,18 @@ return maybeName) -- | Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> Callback -> CodeGen Text-prepareInCallback arg (Callback {cbCallable = cb}) = 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- drop <- if callableHasClosures cb+ let Name _ n = normalizedAPIName (APICallback callback) tn+ drop <- if callableHasClosures cb && expose == WithoutClosures then Just <$> qualifiedSymbol (callbackDropClosures n) tn else return Nothing wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn@@ -366,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"@@ -393,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@@ -425,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.@@ -446,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@@ -460,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 @@ -534,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@@ -545,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 =@@ -570,13 +588,16 @@ 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 -> ExcCodeGen ()-formatHSignature callable symbol = do- sig <- callableSignature callable symbol+formatHSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen ()+formatHSignature callable symbol expose = do+ sig <- callableSignature callable symbol expose indent $ do let constraints = "B.CallStack.HasCallStack" : signatureConstraints sig line $ "(" <> T.intercalate ", " constraints <> ") =>"@@ -605,13 +626,14 @@ -- | The Haskell signature for the given callable. It returns a tuple -- ([constraints], [(type, argname)]).-callableSignature :: Callable -> ForeignSymbol -> ExcCodeGen Signature-callableSignature callable symbol = do+callableSignature :: Callable -> ForeignSymbol -> ExposeClosures+ -> ExcCodeGen Signature+callableSignature callable symbol expose = do let (hInArgs, _) = callableHInArgs callable (case symbol of KnownForeignSymbol _ -> WithoutClosures DynamicForeignSymbol _ -> WithClosures)- (argConstraints, types) <- inArgInterfaces hInArgs+ (argConstraints, types) <- inArgInterfaces hInArgs expose let constraints = ("MonadIO m" : argConstraints) outType <- hOutType callable (callableHOutArgs callable) return $ Signature {@@ -634,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) @@ -750,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 -> ""@@ -768,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@@ -790,23 +813,24 @@ hOutArgs = callableHOutArgs callable line $ name <> " ::"- formatHSignature callable symbol+ formatHSignature callable symbol expose let argNames = case symbol of KnownForeignSymbol _ -> map escapedArgName hInArgs DynamicForeignSymbol _ -> funPtr : map escapedArgName hInArgs line $ name <> " " <> T.intercalate " " argNames <> " = liftIO $ do"- indent (genWrapperBody n symbol callable hInArgs hOutArgs omitted)+ indent (genWrapperBody n symbol callable hInArgs hOutArgs omitted expose) return name -- | Generate the body of the Haskell wrapper for the given foreign symbol. genWrapperBody :: Name -> ForeignSymbol -> Callable -> [Arg] -> [Arg] -> [Arg] ->+ ExposeClosures -> ExcCodeGen ()-genWrapperBody n symbol callable hInArgs hOutArgs omitted = do+genWrapperBody n symbol callable hInArgs hOutArgs omitted expose = do readInArrayLengths n callable hInArgs inArgNames <- forM (args callable) $ \arg ->- prepareArgForCall omitted arg+ prepareArgForCall omitted arg expose -- Map from argument names to names passed to the C function let nameMap = Map.fromList $ flip zip inArgNames $ map escapedArgName $ args callable@@ -861,7 +885,8 @@ fixupDir a = case argType a of TCArray _ _ l _ -> if argCallerAllocates a && l > -1- then a {direction = DirectionInout}+ then a { direction = DirectionInout+ , transfer = TransferEverything } else a _ -> a @@ -894,40 +919,57 @@ } -- | Some debug info for the callable.-genCallableDebugInfo :: Callable -> CodeGen ()+genCallableDebugInfo :: Callable -> CodeGen e () genCallableDebugInfo callable = group $ do- line $ "-- Args : " <> (tshow $ args callable)- line $ "-- Lengths : " <> (tshow $ arrayLengths callable)- line $ "-- returnType : " <> (tshow $ returnType callable)+ commentShow "Args" (args callable)+ commentShow "Lengths" (arrayLengths callable)+ commentShow "returnType" (returnType callable) line $ "-- throws : " <> (tshow $ callableThrows callable) line $ "-- Skip return : " <> (tshow $ skipReturn callable) when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $ do line "-- XXX return value ignored, but it is not a boolean." line "-- This may be a memory leak?"+ 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+ [] -> []+ (f:rest) -> "-- " <> prefix <> ": " <> f :+ map (("-- " <> padding) <>) rest+ in mapM_ line padded -- | Generate a wrapper for a known C symbol. genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen ()-genCCallableWrapper n cSymbol callable = do- genCallableDebugInfo callable+genCCallableWrapper n cSymbol callable+ | callableResolvable callable == Nothing =+ -- If we reach this point there is some internal error.+ terror ("Resolvability of “" <> cSymbol <> "” unkown.")+ | callableResolvable callable == Just False =+ badIntroError ("Could not resolve the symbol “" <> cSymbol+ <> "” in the “" <> namespace n+ <> "” namespace, ignoring.")+ | otherwise = do+ genCallableDebugInfo callable - let callable' = fixupCallerAllocates callable+ let callable' = fixupCallerAllocates callable - hSymbol <- mkForeignImport cSymbol callable'+ hSymbol <- mkForeignImport cSymbol callable' - blank+ blank - deprecatedPragma (lowerName n) (callableDeprecated callable)- writeDocumentation DocBeforeSymbol (callableDocumentation callable)- void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'- WithoutClosures)+ deprecatedPragma (lowerName n) (callableDeprecated callable)+ writeDocumentation DocBeforeSymbol (callableDocumentation callable)+ void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'+ WithoutClosures) -- | For callbacks we do not need to keep track of which arguments are -- closures. forgetClosures :: Callable -> Callable forgetClosures c = c {args = map forgetClosure (args c)} where forgetClosure :: Arg -> Arg- forgetClosure arg = arg {argClosure = -1}+ forgetClosure arg = arg {argClosure = -1,+ argCallbackUserData = False} -- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell -- function that will invoke its first argument, which should be a
lib/Data/GI/CodeGen/Code.hs view
@@ -3,10 +3,9 @@ ( Code , ModuleInfo(moduleCode, sectionDocs) , ModuleFlag(..)- , BaseCodeGen , CodeGen , ExcCodeGen- , CGError(..)+ , CGError , genCode , evalCodeGen @@ -24,7 +23,7 @@ , recurseWithAPIs , handleCGExc- , describeCGError+ , printCGError , notImplementedError , badIntroError , missingInfoError@@ -35,15 +34,20 @@ , line , blank , group+ , comment , cppIf , CPPGuard(..) , hsBoot , submodule , setLanguagePragmas+ , addLanguagePragma , setGHCOptions , setModuleFlags , setModuleMinBase + , getFreshTypeVariable+ , resetTypeVariableScope+ , exportModule , exportDecl , export@@ -51,6 +55,7 @@ , NamedSection(..) , addSectionFormattedDocs+ , prependSectionFormattedDocs , findAPI , getAPI@@ -66,12 +71,17 @@ 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 import qualified Data.Map.Strict as M import Data.Sequence (ViewL ((:<)), viewl, (|>)) import qualified Data.Sequence as Seq@@ -82,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) @@ -120,6 +132,7 @@ = Line Text -- ^ A single line, indented to current indentation. | Indent Code -- ^ Indented region. | Group Code -- ^ A grouped set of lines+ | Comment [Text] -- ^ A (possibly multi line) comment | IncreaseIndent -- ^ Increase the indentation for the rest -- of the lines in the group. | CPPBlock CPPConditional Code -- ^ A block of code guarded by the@@ -131,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) @@ -233,33 +247,33 @@ data CGState = CGState { cgsCPPConditionals :: [CPPConditional] -- ^ Active CPP conditionals, -- outermost condition first.+ , cgsNextAvailableTyvar :: NamedTyvar -- ^ Next unused type+ -- variable. } +-- | The name for a type variable.+data NamedTyvar = SingleCharTyvar Char+ -- ^ A single variable type variable: 'a', 'b', etc...+ | IndexedTyvar Text Integer+ -- ^ An indexed type variable: 'a17', 'key1', ...+ -- | Clean slate for `CGState`. emptyCGState :: CGState-emptyCGState = CGState {- cgsCPPConditionals = []- }+emptyCGState = CGState { cgsCPPConditionals = []+ , 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)@@ -277,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@@ -296,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@@ -345,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@@ -359,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@@ -378,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@@ -405,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@@ -415,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,@@ -424,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@@ -444,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.@@ -460,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)@@ -481,12 +495,14 @@ maximum (moduleMinBase minfo : map minBaseVersion (M.elems $ submodules minfo)) --- | Give a friendly textual description of the error for presenting--- to the user.-describeCGError :: CGError -> Text-describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e-describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e-describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow e+-- | Print, as a comment, a friendly textual description of the error.+printCGError :: CGError -> CodeGen e ()+printCGError (CGErrorNotImplemented e) = do+ comment $ "Not implemented: " <> e+printCGError (CGErrorBadIntrospectionInfo e) =+ comment $ "Bad introspection data: " <> e+printCGError (CGErrorMissingInfo e) =+ comment $ "Missing info: " <> e notImplementedError :: Text -> ExcCodeGen a notImplementedError s = throwError $ CGErrorNotImplemented s@@ -497,19 +513,41 @@ missingInfoError :: Text -> ExcCodeGen a missingInfoError s = throwError $ CGErrorMissingInfo s -findAPI :: Type -> CodeGen (Maybe API)-findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")+-- | Get a type variable unused in the current scope.+getFreshTypeVariable :: CodeGen e Text+getFreshTypeVariable = do+ (cgs@(CGState{cgsNextAvailableTyvar = available}), s) <- get+ let (tyvar, next) =+ case available of+ SingleCharTyvar char -> case char of+ 'z' -> ("z", IndexedTyvar "a" 0)+ -- 'm' is reserved for the MonadIO constraint in signatures+ 'm' -> ("n", SingleCharTyvar 'o')+ c -> (T.singleton c, SingleCharTyvar (toEnum $ fromEnum c + 1))+ IndexedTyvar root index -> (root <> tshow index,+ IndexedTyvar root (index+1))+ put (cgs {cgsNextAvailableTyvar = next}, s)+ return tyvar++-- | Introduce a new scope for type variable naming: the next fresh+-- variable will be called 'a'.+resetTypeVariableScope :: CodeGen e ()+resetTypeVariableScope =+ modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s))++-- | Try to find the API associated with a given type, if known.+findAPI :: HasCallStack => Type -> CodeGen 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@@ -518,25 +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 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)@@ -544,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)@@ -556,26 +598,30 @@ 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) blank return x where addConditional :: CGState -> CGState- addConditional cgs = CGState {cgsCPPConditionals = CPPIf cond :- cgsCPPConditionals cgs}+ addConditional cgs = cgs {cgsCPPConditionals = CPPIf cond :+ cgsCPPConditionals cgs} -- | 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 CPPOverloading = cppIfBlock "ENABLE_OVERLOADING"+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 <>@@ -586,50 +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 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")@@ -645,17 +703,29 @@ genCode n (viewl rest) genCode n (Group (Code seq) :< rest) = genCode n (viewl seq) <> genCode n (viewl rest)+ genCode n (Comment [] :< rest) = genCode n (viewl rest)+ genCode n (Comment [s] :< rest) =+ B.fromText (paddedLine n ("-- " <> s)) <> genCode n (viewl rest)+ genCode n (Comment (l:ls):< rest) =+ B.fromText ("{- " <> l <> "\n" <>+ paddedLines (n+1) ls <> "-}\n") <> genCode n (viewl rest) genCode n (CPPBlock cond (Code seq) :< rest) = let (condBegin, condEnd) = cppCondFormat cond in B.fromText condBegin <> genCode n (viewl seq) <> B.fromText condEnd <> genCode n (viewl rest) genCode n (IncreaseIndent :< rest) = genCode (n+1) (viewl rest) --- | Pad a line to the given number of leading spaces, and add a--- newline at the end.+-- | Pad a line to the given number of leading tabs (with one tab+-- equal to four spaces), and add a newline at the end. paddedLine :: Int -> Text -> Text paddedLine n s = T.replicate (n * 4) " " <> s <> "\n" +-- | Pad a set of lines to the given number of leading tabs (with one+-- tab equal to four spaces), and add a newline at the end of each+-- line.+paddedLines :: Int -> [Text] -> Text+paddedLines n ls = mconcat $ map (paddedLine n) ls+ -- | Put a (padded) comma at the end of the text. comma :: Text -> Text comma s = padTo 40 s <> ","@@ -721,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)@@ -746,7 +824,7 @@ " #" <> anchor <> "#" Nothing -> subsectionTitle subsec , case subsectionDoc subsec of- Just text -> "{- | " <> text <> "\n-}"+ Just text -> formatHaddockComment text Nothing -> "" , ( T.concat . map (formatExport exportSymbol)@@ -754,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@@ -789,10 +872,10 @@ -- | Generate some convenience CPP macros. cppMacros :: Text-cppMacros = T.unlines ["#define ENABLE_OVERLOADING (MIN_VERSION_haskell_gi_overloading(1,0,0) \\"- -- Haddocks look better without overloading- , " && !defined(__HADDOCK_VERSION__))"- ]+cppMacros = T.unlines+ ["#if (MIN_VERSION_haskell_gi_overloading(1,0,0) && !defined(__HADDOCK_VERSION__))"+ , "#define ENABLE_OVERLOADING"+ , "#endif"] -- | Standard fields for every module. standardFields :: Text@@ -802,10 +885,18 @@ -- | The haddock header for the module, including optionally a description. moduleHaddock :: Maybe Text -> Text-moduleHaddock Nothing = T.unlines ["{- |", standardFields <> "-}"]-moduleHaddock (Just description) = T.unlines ["{- |", standardFields,- description, "-}"]+moduleHaddock Nothing = formatHaddockComment $ standardFields+moduleHaddock (Just description) =+ formatHaddockComment $ T.unlines [standardFields, description] +-- | Format the comment with the module documentation.+formatHaddockComment :: Text -> Text+formatHaddockComment doc = let lines = case T.lines doc of+ [] -> []+ (first:rest) -> ("-- | " <> first) :+ map ("-- " <>) rest+ in T.unlines lines+ -- | Generic module prelude. We reexport all of the submodules. modulePrelude :: M.Map HaddockSection Text -> Text -> [Export] -> [Text] -> Text modulePrelude _ name [] [] = "module " <> name <> " () where\n"@@ -831,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@@ -852,16 +942,31 @@ , "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" , "import qualified Data.GI.Base.CallStack as B.CallStack"+ , "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 Foreign.Ptr as FP"+ , "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@@ -870,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@@ -888,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@@ -900,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 =@@ -916,11 +1060,19 @@ -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules. writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]-writeModuleTree verbose dirPrefix minfo = do- submodulePaths <- concat <$> forM (M.elems (submodules minfo))- (writeModuleTree verbose dirPrefix)- writeModuleInfo verbose dirPrefix minfo- return $ (dotWithPrefix (modulePath minfo) : submodulePaths)+writeModuleTree verbose dirPrefix root = doWriteModuleTree root++ where+ doWriteModuleTree :: ModuleInfo -> IO [Text]+ doWriteModuleTree minfo = do+ submodulePaths <- concat <$> forM (M.elems (submodules minfo)) doWriteModuleTree+ writeModuleInfo verbose dirPrefix minfo treeMap+ return $ (dotWithPrefix (modulePath minfo) : submodulePaths)++ treeMap = M.fromList (gatherSubmodules root)+ gatherSubmodules :: ModuleInfo -> [(ModulePath, ModuleInfo)]+ gatherSubmodules minfo = (modulePath minfo, minfo) :+ concatMap gatherSubmodules (M.elems $ submodules minfo) -- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk.
lib/Data/GI/CodeGen/CodeGen.hs view
@@ -4,14 +4,12 @@ , genModule ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Traversable (traverse)-#endif import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub) import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe)+#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text)@@ -22,7 +20,9 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,- detectGObject)+ detectGObject, dropDuplicatedFields,+ checkClosureDestructors, fixSymbolNaming,+ fixClosures, fixCallbackUserData) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation, writeHaddock,@@ -37,63 +37,58 @@ 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)+ 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) -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) $ group $ do- line $ "-- function " <> symbol- handleCGExc (\e -> line ("-- XXX Could not generate function "- <> symbol- <> "\n-- Error was : " <> describeCGError e))+ line $ "-- function " <> name n+ handleCGExc (\e -> do+ line ("-- XXX Could not generate function "+ <> name n+ <> "\n")+ printCGError e) (do genCCallableWrapper n symbol callable export (NamedSubsection MethodSection $ lowerName n) (lowerName n) ) -genBoxedObject :: Name -> Text -> CodeGen ()-genBoxedObject n typeInit = do- let name' = upperName n-- group $ do- line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>- typeInit <> " :: "- indent $ line "IO GType"+-- | Create the newtype wrapping the ManagedPtr for the given type.+genNewtype :: Text -> CodeGen e ()+genNewtype name' = do group $ do- line $ "instance BoxedObject " <> name' <> " where"- indent $ line $ "boxedType _ = c_" <> typeInit+ bline $ "newtype " <> name' <> " = " <> name' <> " (SP.ManagedPtr " <> name' <> ")"+ indent $ line $ "deriving (Eq)" - hsBoot $ line $ "instance BoxedObject " <> name' <> " where"+ group $ do+ 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+ 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) @@ -103,40 +98,34 @@ isFunction <- symbolFromFunction (methodSymbol f) if not isFunction then handleCGExc- (\e -> line ("-- XXX Could not generate method "- <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e) >>- return Nothing)+ (\e -> do line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn)+ printCGError e+ return Nothing) (genMethod n f >> return (Just (n, f))) 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+ 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) @@ -146,16 +135,15 @@ isFunction <- symbolFromFunction (methodSymbol f) if not isFunction then handleCGExc- (\e -> line ("-- XXX Could not generate method "- <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e)- >> return Nothing)+ (\e -> do line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn)+ printCGError e+ return Nothing) (genMethod n f >> return (Just (n, f))) 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@@ -166,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)}@@ -191,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@@ -232,129 +222,187 @@ export (NamedSubsection MethodSection $ lowerName mn) (lowerName mn') cppIf CPPOverloading $- genMethodInfo cn (m {methodCallable = c''})+ genMethodInfo cn (m {methodCallable = c''}) --- Type casting with type checking-genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()-genGObjectCasts n cn_ parents = do+-- | 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.+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 t'" <> name' <> "' to and from t'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." - group $ do- line $ "foreign import ccall \"" <> cn_ <> "\""- indent $ line $ "c_" <> cn_ <> " :: IO GType"+ writeHaddock DocBeforeSymbol doc group $ do- bline $ "instance GObject " <> name' <> " where"+ bline $ "instance B.GValue.IsGValue (Maybe " <> name' <> ") where" indent $ group $ do- line $ "gobjectType _ = c_" <> cn_+ 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 <- " <> 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, 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 <- 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 B.Types.TypedObject " <> name' <> " where"+ indent $ do+ line $ "glibType = " <> get_type_fn++ when isGO $ group $ do+ bline $ "instance B.Types.GObject " <> name'+ className <- classConstraint n group $ do exportDecl className writeHaddock DocBeforeSymbol (classDoc name') - bline $ "class GObject o => " <> className <> " o"- line $ "#if MIN_VERSION_base(4,9,0)"- line $ "instance {-# OVERLAPPABLE #-} (GObject a, O.UnknownAncestorError "- <> name' <> " a) =>"- line $ " " <> className <> " a"- line $ "#endif"- bline $ "instance " <> className <> " " <> name'- forM_ parents $ \parent -> do- pcls <- classConstraint parent- line $ "instance " <> pcls <> " " <> name'+ -- Create the IsX constraint. We cannot simply say+ --+ -- > type IsX o = (GObject o, ...)+ --+ -- 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 = 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++ 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' <> ")"- 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 ->- handleCGExc- (line . (T.concat ["-- XXX Could not generate signal ", name', "::"- , sigName s- , "\n", "-- Error was : "] <>) . describeCGError)- (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 -> line ("-- XXX Could not generate method "- <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError 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' <> ")"+ genNewtype name' exportDecl (name' <> "(..)") addSectionDocumentation ToplevelSection (ifDocumentation iface) - noName name'-- forM_ (ifSignals iface) $ \s -> handleCGExc- (line . (T.concat ["-- XXX Could not generate signal ", name', "::"- , sigName s- , "\n", "-- Error was : "] <>) . describeCGError)- (genSignal s n)-- cppIf CPPOverloading $- genInterfaceSignals n iface- isGO <- apiIsGObject n (APIInterface iface) if isGO then do@@ -362,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 $@@ -371,39 +420,56 @@ 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' <> "'.") - bline $ "class ManagedPtrNewtype a => " <> cls <> " a"- line $ "instance " <> cls <> " " <> name'+ -- Create the IsX constraint. We cannot simply say+ --+ -- > type IsX o = (ManagedPtrNewtype o, O.IsDescendantOf X o)+ --+ -- 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 = "(ManagedPtrNewtype o, O.IsDescendantOf " <> name' <> " o)"+ bline $ "class " <> constraints <> " => " <> cls <> " o"+ bline $ "instance " <> constraints <> " => " <> cls <> " o"+ genWrappedPtr n (ifAllocationInfo iface) 0 when (not . null . ifProperties $ iface) $ group $ do- line $ "-- XXX Skipping property generation for non-GObject interface"+ 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 isFunction <- symbolFromFunction (methodSymbol f) unless isFunction $ handleCGExc- (\e -> line ("-- XXX Could not generate method "- <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e)- >> (cppIf CPPOverloading $- genUnsupportedMethodInfo n f))+ (\e -> do comment ("XXX Could not generate method "+ <> name' <> "::" <> name mn)+ printCGError e+ 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@@ -413,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@@ -425,38 +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- $ 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).@@ -465,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
lib/Data/GI/CodeGen/Config.hs view
@@ -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.
lib/Data/GI/CodeGen/Constant.hs view
@@ -2,11 +2,9 @@ ( genConstant ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import Data.GI.CodeGen.API@@ -15,7 +13,7 @@ import Data.GI.CodeGen.Haddock (deprecatedPragma, writeDocumentation, RelativeDocPosition(..)) import Data.GI.CodeGen.Type-import Data.GI.CodeGen.Util (tshow)+import Data.GI.CodeGen.Util (tshow, ucFirst) -- | Data for a bidrectional pattern synonym. It is either a simple -- one of the form "pattern Name = value :: Type" or an explicit one@@ -31,26 +29,29 @@ type PSView = Text type PSExpression = Text -writePattern :: Text -> PatternSynonym -> CodeGen ()+writePattern :: Text -> PatternSynonym -> CodeGen e () writePattern name (SimpleSynonym value t) = line $- "pattern " <> name <> " = " <> value <> " :: " <> t+ "pattern " <> ucFirst name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do -- Supported only on ghc >= 7.10 setModuleMinBase Base48- line $ "pattern " <> name <> " <- (" <> view <> " -> "+ line $ "pattern " <> ucFirst name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where" indent $ line $- name <> " = " <> expression <> " " <> value <> " :: " <> t+ 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) - handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)+ handleCGExc (\e -> do+ line $ "-- XXX: Could not generate constant"+ printCGError e+ ) (do writeDocumentation DocBeforeSymbol (constantDocumentation c) assignValue name (constantType c) (constantValue c)- export ToplevelSection ("pattern " <> name))+ export ToplevelSection ("pattern " <> ucFirst name)) -- | Assign to the given name the given constant value, in a way that -- can be assigned to the corresponding Haskell type.@@ -92,10 +93,10 @@ showBasicType TUInt32 i = return i showBasicType TInt64 i = return i showBasicType TUInt64 i = return i-showBasicType TBoolean "0" = return "False"-showBasicType TBoolean "false" = return "False"-showBasicType TBoolean "1" = return "True"-showBasicType TBoolean "true" = return "True"+showBasicType TBoolean "0" = return "P.False"+showBasicType TBoolean "false" = return "P.False"+showBasicType TBoolean "1" = return "P.True"+showBasicType TBoolean "true" = return "P.True" showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\"" showBasicType TFloat f = return f showBasicType TDouble d = return d@@ -105,5 +106,16 @@ showBasicType TGType gtype = return $ "GType " <> gtype showBasicType TIntPtr ptr = return ptr showBasicType TUIntPtr ptr = return ptr+showBasicType TShort s = return s+showBasicType TUShort u = return u+showBasicType TSSize s = return s+showBasicType TSize s = return s+showBasicType Ttime_t t = return t+showBasicType Toff_t o = return o+showBasicType Tdev_t d = return d+showBasicType Tgid_t g = return g+showBasicType Tpid_t p = return p+showBasicType Tsocklen_t l = return l+showBasicType Tuid_t u = return u -- We take care of this one separately above showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer"
− lib/Data/GI/CodeGen/Conversions.hs
@@ -1,994 +0,0 @@-{-# LANGUAGE PatternGuards, DeriveFunctor #-}--module Data.GI.CodeGen.Conversions- ( convert- , genConversion- , unpackCArray- , computeArrayLength-- , callableHasClosures-- , hToF- , fToH- , transientToH- , haskellType- , isoHaskellType- , foreignType-- , argumentType- , 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)-import Data.Monoid ((<>))-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"--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- | 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"--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- | 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."---- | 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 :: [Char] -> Type -> CodeGen ([Char], Text, [Text])-argumentType [] _ = error "out of letters"-argumentType letters (TGList a) = do- (ls, name, constraints) <- argumentType letters a- return (ls, "[" <> name <> "]", constraints)-argumentType letters (TGSList a) = do- (ls, name, constraints) <- argumentType letters a- return (ls, "[" <> name <> "]", constraints)-argumentType letters@(l:ls) t = 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- return (ls, T.singleton l, [cls <> " " <> T.singleton l])- Just (APIObject _) -> do- isGO <- isGObject t- if isGO- then do cls <- typeConstraint t- return (ls, T.singleton l, [cls <> " " <> T.singleton l])- else return (letters, s, [])- Just (APICallback cb) ->- -- See [Note: Callables that throw]- if callableThrows (cbCallable cb)- then do- ft <- typeShow <$> foreignType t- return (letters, ft, [])- else- return (letters, s, [])- _ -> return (letters, 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 (TInterface (Name "GObject" "Closure")) = return $ "Closure" `con` []-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.-isoHaskellType :: Type -> CodeGen TypeRep-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 (TInterface (Name "GObject" "Closure")) =- return $ ptr $ "Closure" `con` []-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 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
+ lib/Data/GI/CodeGen/Conversions.hsc view
@@ -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 <glib-object.h>++#if !MIN_VERSION_base(4,13,0)+import Data.Monoid ((<>))+#endif++import Control.Monad (when)+import Data.Maybe (isJust)+import Data.Text (Text)+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
lib/Data/GI/CodeGen/CtoHaskellMap.hs view
@@ -6,31 +6,38 @@ ) where import qualified Data.Map as M+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T-import Data.String (IsString(..)) -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(..))-import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.))-import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName)-import Data.GI.CodeGen.Util (ucFirst)+ Function(..), Method(..), Struct(..), Union(..),+ 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 = IdentifierLink Text+data Hyperlink = ValueIdentifier Text+ -- ^ An identifier at the value level: functions, data+ -- constructors, ...+ | TypeIdentifier Text+ -- ^ An identifier at the type level. | ModuleLink Text- | ModuleLinkWithAnchor Text Text+ -- ^ Link to a module.+ | ModuleLinkWithAnchor (Maybe Text) Text Text+ -- ^ Link to an anchor inside a given module, with an+ -- optional label. deriving (Show, Eq) --- Just for convenience-instance IsString Hyperlink where- fromString = IdentifierLink . T.pack- -- | Given a set of APIs, build a `Map` that given a Text -- corresponding to a certain C identifier returns the corresponding -- Haskell element in the bindings. For instance, `gtk_widget_show`@@ -50,64 +57,115 @@ extractRefs (n, APIObject o) = objectRefs n o builtins :: [(CRef, Hyperlink)]- builtins = [(TypeRef "gboolean", "Bool"),- (ConstantRef "TRUE", "True"),- (ConstantRef "FALSE", "False"),- (TypeRef "GError", "GError"),- (TypeRef "GType", "GType"),- (TypeRef "GVariant", "GVariant"),- (ConstantRef "NULL", "Nothing")]+ builtins = [(CTypeRef "gboolean", TypeIdentifier "P.Bool"),+ (ConstantRef "TRUE", ValueIdentifier "P.True"),+ (ConstantRef "FALSE", ValueIdentifier "P.False"),+ (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 absolute location of the module where the given `API`--- lives.-location :: Name -> API -> ModulePath-location n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api+-- | Obtain the fully qualified symbol pointing to a value.+fullyQualifiedValue :: Name -> API -> Text -> Hyperlink+fullyQualifiedValue n api symbol =+ ValueIdentifier $ dotModulePath (moduleLocation n api) <> "." <> symbol --- | Obtain the fully qualified symbol.-fullyQualified :: Name -> API -> Text -> Hyperlink-fullyQualified n api symbol =- IdentifierLink $ dotModulePath (location n api) <> "." <> symbol+-- | Obtain the fully qualified symbol pointing to a type.+fullyQualifiedType :: Name -> API -> Text -> Hyperlink+fullyQualifiedType 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),- fullyQualified n (APIConst c) $ name n),- (TypeRef (constantCType c),- fullyQualified 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),- fullyQualified 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), fullyQualified n api $ upperName n) :- map memberToRef (enumMembers e)- where memberToRef :: EnumerationMember -> (CRef, Hyperlink)- memberToRef em = (ConstantRef (enumMemberCId em),- fullyQualified n api $ upperName $+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})---- | Given an optional C type and the API constructor construct the--- list of associated refs.-maybeCType :: Name -> API -> Maybe Text -> [(CRef, Hyperlink)]-maybeCType _ _ Nothing = []-maybeCType n api (Just ctype) = [(TypeRef ctype,- fullyQualified n api (upperName n))]+ 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 = map methodRef methods- where methodRef :: Method -> (CRef, Hyperlink)- methodRef m@(Method {methodName = mn}) =+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 (FunctionRef (methodSymbol m),- fullyQualified 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@(Name _ owner) api maybeCName signals = concatMap signalRef signals+ where signalRef :: Signal -> [(CRef, Hyperlink)]+ signalRef (Signal {sigName = sn}) =+ let mod = dotModulePath (moduleLocation n api)+ sn' = signalHaskellName sn+ ownerCName = case maybeCName of+ Just cname -> cname+ Nothing -> let Name ns owner = n+ in ucFirst ns <> owner+ 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) = [(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)] callbackRefs n cb = maybeCType n (APICallback cb) (cbCType cb)@@ -126,8 +184,12 @@ ifaceRefs :: Name -> Interface -> [(CRef, Hyperlink)] ifaceRefs n i = maybeCType n (APIInterface i) (ifCType i) <> methodRefs n (APIInterface i) (ifMethods i)+ <> signalRefs n (APIInterface i) (ifCType i) (ifSignals i)+ <> propRefs n (APIInterface i) (ifCType i) (ifProperties i) -- | Extract the C references in an object. objectRefs :: Name -> Object -> [(CRef, Hyperlink)] objectRefs n o = maybeCType n (APIObject o) (objCType o) <> methodRefs n (APIObject o) (objMethods o)+ <> signalRefs n (APIObject o) (objCType o) (objSignals o)+ <> propRefs n (APIObject o) (objCType o) (objProperties o)
lib/Data/GI/CodeGen/EnumFlags.hs view
@@ -5,8 +5,11 @@ ) where import Control.Monad (when, forM_)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text)+import qualified Data.Set as S import Foreign.C (CUInt) import Foreign.Storable (sizeOf)@@ -18,6 +21,19 @@ import Data.GI.CodeGen.SymbolNaming (upperName) import Data.GI.CodeGen.Util (tshow) +-- | Given a list of named enum members, filter out those that have+-- the same value as a previous entry in the list.+dropDuplicated :: [(Text, EnumerationMember)] -> [(Text, EnumerationMember)]+dropDuplicated namedMembers = go namedMembers enumMemberValue S.empty+ where go :: Ord c => [(a, b)] -> (b->c) -> S.Set c -> [(a, b)]+ go [] _ _ = []+ go ((n, m) : rest) f seen =+ if S.member (f m) seen+ -- already seen, discard+ then go rest f seen+ else (n,m) : go rest f (S.insert (f m) seen)++ genEnumOrFlags :: HaddockSection -> Name -> Enumeration -> ExcCodeGen () genEnumOrFlags docSection n@(Name ns name) e = do -- Conversion functions expect enums and flags to map to CUInt,@@ -61,7 +77,7 @@ line $ "fromEnum (Another" <> name' <> " k) = k" blank indent $ do- forM_ members' $ \(n, m) ->+ forM_ (dropDuplicated members') $ \(n, m) -> line $ "toEnum " <> tshow (enumMemberValue m) <> " = " <> n line $ "toEnum k = Another" <> name' <> " k" @@ -71,49 +87,67 @@ 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 let docSection = NamedSubsection EnumSection (upperName n)- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)+ handleCGExc (\e -> do+ line $ "-- XXX Code Generation error"+ printCGError e) (do genEnumOrFlags docSection n enum case enumTypeInit enum of 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 let docSection = NamedSubsection FlagSection (upperName n)- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)+ handleCGExc (\e -> do+ line "-- XXX Code generation error"+ printCGError e) (do genEnumOrFlags docSection n enum @@ -125,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"
lib/Data/GI/CodeGen/Fixups.hs view
@@ -3,12 +3,23 @@ ( dropMovedItems , guessPropertyNullability , 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".@@ -50,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.@@ -69,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.@@ -95,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 ->@@ -130,3 +143,162 @@ gobject : ifPrerequisites iface})) else (n, APIInterface iface) detectGObject api = api++-- | Drop any fields whose name coincides with that of a previous+-- element. Note that this function keeps ordering.+dropDuplicatedEnumFields :: Enumeration -> Enumeration+dropDuplicatedEnumFields enum =+ enum{enumMembers = dropDuplicates S.empty (enumMembers enum)}+ where dropDuplicates :: S.Set T.Text -> [EnumerationMember] -> [EnumerationMember]+ dropDuplicates _ [] = []+ dropDuplicates previous (m:ms) =+ if enumMemberName m `S.member` previous+ then dropDuplicates previous ms+ else m : dropDuplicates (S.insert (enumMemberName m) previous) ms++-- | Some libraries include duplicated flags by mistake, drop those.+dropDuplicatedFields :: (Name, API) -> (Name, API)+dropDuplicatedFields (n, APIFlags (Flags enum)) =+ (n, APIFlags (Flags $ dropDuplicatedEnumFields enum))+dropDuplicatedFields (n, api) = (n, api)++-- | Sometimes arguments are marked as being a user_data destructor,+-- but there is no associated user_data argument. In this case we drop+-- the annotation.+checkClosureDestructors :: (Name, API) -> (Name, API)+checkClosureDestructors (n, APIObject o) =+ (n, APIObject (o {objMethods = checkMethodDestructors (objMethods o)}))+checkClosureDestructors (n, APIInterface i) =+ (n, APIInterface (i {ifMethods = checkMethodDestructors (ifMethods i)}))+checkClosureDestructors (n, APIStruct s) =+ (n, APIStruct (s {structMethods = checkMethodDestructors (structMethods s)}))+checkClosureDestructors (n, APIUnion u) =+ (n, APIUnion (u {unionMethods = checkMethodDestructors (unionMethods u)}))+checkClosureDestructors (n, APIFunction f) =+ (n, APIFunction (f {fnCallable = checkCallableDestructors (fnCallable f)}))+checkClosureDestructors (n, api) = (n, api)++checkMethodDestructors :: [Method] -> [Method]+checkMethodDestructors = map checkMethod+ where checkMethod :: Method -> Method+ checkMethod m = m {methodCallable =+ checkCallableDestructors (methodCallable m)}++-- | 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+checkCallableDestructors c = c {args = map checkArg (args c)}+ where checkArg :: Arg -> Arg+ 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
lib/Data/GI/CodeGen/GObject.hs view
@@ -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"
lib/Data/GI/CodeGen/GtkDoc.hs view
@@ -6,8 +6,10 @@ , Token(..) , Language(..) , Link(..)- , ListItem(..) , CRef(..)+ , DocSymbolName(..)+ , docName+ , resolveDocSymbol ) where import Prelude hiding (takeWhile)@@ -15,21 +17,33 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif-import Data.Monoid ((<>)) 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 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) -- | A parsed gtk-doc token. data Token = Literal Text+ | Comment Text | Verbatim Text | 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)@@ -39,28 +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- | PropertyRef Text Text+ | SignalRef DocSymbolName Text+ | OldSignalRef Text Text+ | LocalSignalRef 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) @@ -71,7 +96,7 @@ -- GtkDoc [] -- -- >>> parseGtkDoc "func()"--- GtkDoc [SymbolRef (FunctionRef "func")]+-- GtkDoc [SymbolRef (OldFunctionRef "func")] -- -- >>> parseGtkDoc "literal" -- GtkDoc [Literal "literal"]@@ -80,51 +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 (OldFunctionRef "gtk_button_activate"),Literal "."]+-- -- >>> parseGtkDoc "The signal ##%#GtkButton::activate is related to gtk_button_activate()."--- GtkDoc [Literal "The signal ##%",SymbolRef (SignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."]+-- GtkDoc [Literal "The signal ##%",SymbolRef (OldSignalRef "GtkButton" "activate"),Literal " is related to ",SymbolRef (OldFunctionRef "gtk_button_activate"),Literal "."] -- -- >>> parseGtkDoc "# A section\n\n## and a subsection ##\n" -- GtkDoc [SectionHeader 1 (GtkDoc [Literal "A section"]),Literal "\n",SectionHeader 2 (GtkDoc [Literal "and a subsection "])] -- -- >>> parseGtkDoc "Compact list:\n- First item\n- Second item"--- GtkDoc [Literal "Compact list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]]+-- GtkDoc [Literal "Compact list:\n",UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] -- -- >>> parseGtkDoc "Spaced list:\n\n- First item\n\n- Second item"--- GtkDoc [Literal "Spaced list:\n",List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []]]+-- GtkDoc [Literal "Spaced list:\n\n",UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]] -- -- >>> parseGtkDoc "List with urls:\n- [test](http://test)\n- "--- GtkDoc [Literal "List with urls:\n",List [ListItem (GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})]) [],ListItem (GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]) []]]+-- GtkDoc [Literal "List with urls:\n",UnnumberedList [GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})],GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]]] parseGtkDoc :: Text -> GtkDoc-parseGtkDoc raw =+parseGtkDoc doc = rawParseGtkDoc (T.cons startOfString doc)++-- | Like `parseGtkDoc`, but it does not annotate beginning of lines.+rawParseGtkDoc :: Text -> GtkDoc+rawParseGtkDoc raw = case parseOnly (parseTokens <* endOfInput) raw of Left e ->- error $ "gtk-doc parsing failed with error \"" <> e- <> "\" on the input \"" <> T.unpack raw <> "\""- Right tks -> GtkDoc . coalesceLiterals- . restoreSHPreNewlines . restoreListPreNewline $ tks+ terror $ "gtk-doc parsing failed with error \"" <> T.pack e+ <> "\" on the input \"" <>+ T.replace (T.singleton startOfString) "" raw <> "\""+ Right tks -> GtkDoc . coalesceLiterals . removeSOS $ tks --- | `parseSectionHeader` eats the newline before the section header,--- but `parseInitialSectionHeader` does not, since it only matches at--- the beginning of the text. This restores the newlines eaten by--- `parseSectionHeader`, so a `SectionHeader` returned by the parser--- can always be assumed /not/ to have an implicit starting newline.-restoreSHPreNewlines :: [Token] -> [Token]-restoreSHPreNewlines [] = []-restoreSHPreNewlines (i : rest) = i : restoreNewlines rest- where restoreNewlines :: [Token] -> [Token]- restoreNewlines [] = []- restoreNewlines (s@(SectionHeader _ _) : rest) =- Literal "\n" : s : restoreNewlines rest- restoreNewlines (x : rest) = x : restoreNewlines rest+-- | A character indicating the start of the string, to simplify the+-- GtkDoc parser (part of the syntax is sensitive to the start of+-- lines, which we can represent as any character after '\n' or SOS).+startOfString :: Char+startOfString = '\x98' -- Unicode Start Of String (SOS) --- | `parseList` eats the newline before the list, restore it.-restoreListPreNewline :: [Token] -> [Token]-restoreListPreNewline [] = []-restoreListPreNewline (l@(List _) : rest) =- Literal "\n" : l : restoreListPreNewline rest-restoreListPreNewline (x : rest) = x : restoreListPreNewline rest+-- | Remove the SOS marker from the input. Since this only appears at+-- the beginning of the text, we only need to worry about replacing it+-- in the first token, and only if it's a literal.+removeSOS :: [Token] -> [Token]+removeSOS [] = []+removeSOS (Literal l : rest) =+ if l == T.singleton startOfString+ then rest+ else Literal (T.replace (T.singleton startOfString) "" l) : rest+removeSOS (other : rest) = other : rest -- | Accumulate consecutive literals into a single literal. coalesceLiterals :: [Token] -> [Token]@@ -146,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@@ -166,119 +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 property name, of the form+-- | 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]+parseLocalSignal = do+ _ <- string "::"+ signal <- signalOrPropName+ return [SymbolRef (LocalSignalRef signal)]++-- | 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 reference to a virtual method, of the form+-- | Parse a property name in the new style:+-- > [property@Namespace.Object:property-name]+--+-- === __Examples__+-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.ProgressBar:show-text]"+-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "ProgressBar") "show-text")]+-- >>> parseOnly (parseNewProperty <* endOfInput) "[property@Gtk.Editable:width-chars]"+-- Right [SymbolRef (PropertyRef (AbsoluteName "Gtk" "Editable") "width-chars")]+parseNewProperty :: Parser [Token]+parseNewProperty = do+ _ <- string "[property@"+ ns <- takeWhile1 (\c -> isAscii c && isAlpha c)+ _ <- char '.'+ n <- parseCIdent+ _ <- char ':'+ property <- takeWhile1 (\c -> (isAscii c && isAlpha c) || c == '-')+ _ <- char ']'+ return [SymbolRef (PropertyRef (AbsoluteName ns n) property)]++-- | Parse a property+parseProperty :: Parser [Token]+parseProperty = parseOldProperty <|> parseNewProperty++-- | Parse an xml comment, of the form+-- > <!-- comment -->+-- Note that this function keeps spaces.+--+-- === __Examples__+-- >>> parseOnly (parseComment <* endOfInput) "<!-- comment -->"+-- Right [Comment " comment "]+parseComment :: Parser [Token]+parseComment = do+ comment <- string "<!--" *> manyTill anyChar (string "-->")+ return [Comment $ T.pack comment]++-- | 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.@@ -288,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@@ -338,6 +578,8 @@ special '[' = True special '!' = True special '\n' = True+special ':' = True+special '-' = True special c = isCIdent c -- | Parse a verbatim string, of the form@@ -345,51 +587,93 @@ -- -- === __Examples__ -- >>> parseOnly (parseVerbatim <* endOfInput) "`Example quote!`"--- Right (Verbatim "Example quote!")-parseVerbatim :: Parser Token+-- Right [Verbatim "Example quote!"]+parseVerbatim :: Parser [Token] parseVerbatim = do _ <- char '`' v <- takeWhile1 (/= '`') _ <- char '`'- return $ Verbatim v+ return [Verbatim v] -- | Parse a URL in Markdown syntax, of the form -- > [name](url) -- -- === __Examples__ -- >>> parseOnly (parseUrl <* endOfInput) "[haskell](http://haskell.org)"--- Right (ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"}))-parseUrl :: Parser Token+-- Right [ExternalLink (Link {linkName = "haskell", linkAddress = "http://haskell.org"})]+parseUrl :: Parser [Token] parseUrl = do _ <- char '[' name <- takeWhile1 (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')'- return $ ExternalLink $ Link {linkName = name, linkAddress = address}+ return [ExternalLink $ Link {linkName = name, linkAddress = address}] -- | Parse an image reference, of the form -- >  -- -- === __Examples__ -- >>> parseOnly (parseImage <* endOfInput) ""--- Right (Image (Link {linkName = "", linkAddress = "diagram.png"}))-parseImage :: Parser Token+-- Right [Image (Link {linkName = "", linkAddress = "diagram.png"})]+parseImage :: Parser [Token] parseImage = do _ <- string "![" name <- takeWhile (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')'- return $ Image $ Link {linkName = name, linkAddress = address}+ return [Image $ Link {linkName = name, linkAddress = address}] -- | Parse a code block embedded in the documentation.-parseCodeBlock :: Parser Token-parseCodeBlock = do+parseCodeBlock :: Parser [Token]+parseCodeBlock = parseOldStyleCodeBlock <|> parseNewStyleCodeBlock++-- | Parse a new style code block, of the form+-- > ```c+-- > some c code+-- > ```+--+-- === __Examples__+-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```c\nThis is C code\n```"+-- Right [CodeBlock (Just (Language "c")) "This is C code"]+--+-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```\nThis is langless\n```"+-- Right [CodeBlock Nothing "This is langless"]+--+-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```py\n This has space in front\n ```"+-- Right [CodeBlock (Just (Language "py")) " This has space in front"]+--+-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```c\n new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);\n ```"+-- Right [CodeBlock (Just (Language "c")) " new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);"]+parseNewStyleCodeBlock :: Parser [Token]+parseNewStyleCodeBlock = do+ _ <- takeWhile isHorizontalSpace+ _ <- string "```"+ lang <- T.strip <$> takeWhile (/= '\n')+ _ <- char '\n'+ let maybeLang = if T.null lang then Nothing+ else Just lang+ code <- T.pack <$> manyTill anyChar (string "\n" >>+ takeWhile isHorizontalSpace >>+ string "```")+ return [CodeBlock (Language <$> maybeLang) code]++-- | Parse an old style code block, of the form+-- > |[<!-- language="C" --> code ]|+--+-- === __Examples__+-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|"+-- Right [CodeBlock Nothing "this is code"]+--+-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[<!-- language=\"C\"-->this is C code]|"+-- Right [CodeBlock (Just (Language "C")) "this is C code"]+parseOldStyleCodeBlock :: Parser [Token]+parseOldStyleCodeBlock = do _ <- string "|[" lang <- (Just <$> parseLanguage) <|> return Nothing code <- T.pack <$> manyTill anyChar (string "]|")- return $ CodeBlock lang code+ return [CodeBlock lang code] -- | Parse the language of a code block, specified as a comment. parseLanguage :: Parser Language@@ -403,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@@ -415,39 +718,230 @@ -- -- === __Examples__ -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "### Hello! ###\n"--- Right (SectionHeader 3 (GtkDoc [Literal "Hello! "]))+-- Right [SectionHeader 3 (GtkDoc [Literal "Hello! "])] -- -- >>> parseOnly (parseInitialSectionHeader <* endOfInput) "# Hello!\n"--- Right (SectionHeader 1 (GtkDoc [Literal "Hello!"]))-parseInitialSectionHeader :: Parser Token+-- Right [SectionHeader 1 (GtkDoc [Literal "Hello!"])]+parseInitialSectionHeader :: Parser [Token] parseInitialSectionHeader = do hashes <- takeWhile1 (== '#') _ <- many1 space heading <- takeWhile1 (notInClass "#\n") _ <- (string hashes >> char '\n') <|> (char '\n')- return $ SectionHeader (T.length hashes) (parseGtkDoc heading)+ return [SectionHeader (T.length hashes) (parseGtkDoc heading)] --- | Parse a list header. Note that the newline before the start of--- the list is "eaten" by this parser, but is restored later by--- `parseGtkDoc`.------ === __Examples__--- >>> parseOnly (parseList <* endOfInput) "\n- First item\n- Second item"--- Right (List [ListItem (GtkDoc [Literal "First item"]) [],ListItem (GtkDoc [Literal "Second item"]) []])------ >>> parseOnly (parseList <* endOfInput) "\n\n- Two line\n item\n\n- Second item,\n also two lines"--- Right (List [ListItem (GtkDoc [Literal "Two line"]) [GtkDoc [Literal "item"]],ListItem (GtkDoc [Literal "Second item,"]) [GtkDoc [Literal "also two lines"]]])-parseList :: Parser Token-parseList = do- items <- many1 parseListItem- return $ List items- where parseListItem :: Parser ListItem- parseListItem = do- _ <- char '\n'- _ <- string "\n- " <|> string "- "- first <- takeWhile1 (/= '\n')- rest <- many' parseLine- return $ ListItem (parseGtkDoc first) (map parseGtkDoc rest)+{- | Parse an unnumbered list. - parseLine :: Parser Text- parseLine = string "\n " >> takeWhile1 (/= '\n')+=== __Examples__+>>> :{+parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+T.cons startOfString+"- First item",+"- Second item"+]+:}+Right [UnnumberedList [GtkDoc [Literal "First item"],GtkDoc [Literal "Second item"]]]++>>> :{+parseOnly (parseUnnumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+"",+"",+"- Two line",+" item",+"",+"- Second item,",+" with three lines",+" of text."+]+:}+Right [Literal "\n\n",UnnumberedList [GtkDoc [Literal "Two line\nitem"],GtkDoc [Literal "Second item,\nwith three lines\nof text."]]]+-}+parseUnnumberedList :: Parser [Token]+parseUnnumberedList = do+ (initialNewlines, entries) <- parseList (string "- ") T.length+ return $ initialNewlines <> [UnnumberedList (map snd entries)]++{- | Parse a numbered list header.++=== __Examples__+>>> :{+parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+T.cons startOfString+"1. First item,",+" written in two lines",+"",+"2. Second item,",+" also in two lines"+]+:}+Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nalso in two lines"])]]++>>> :{+parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+T.cons startOfString+"1. First item,",+" written in two lines",+"2. Second item,",+" now in three lines,",+" written compactly"+]+:}+Right [NumberedList [("1",GtkDoc [Literal "First item,\nwritten in two lines"]),("2",GtkDoc [Literal "Second item,\nnow in three lines,\nwritten compactly"])]]++>>> :{+parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+T.cons startOfString+"9. This is a list entry with two lines,",+" with the second line in its own line.",+"10. If the label width changes,",+" the indentation of the second line should also be adjusted.",+"",+"11. You can optionally include an empty line between entries",+" without stopping the list.",+"",+" This also applies within list entries, this is still part of",+" entry 11.",+"12. But you don't have to."+]+:}+Right [NumberedList [("9",GtkDoc [Literal "This is a list entry with two lines,\nwith the second line in its own line."]),("10",GtkDoc [Literal "If the label width changes,\nthe indentation of the second line should also be adjusted."]),("11",GtkDoc [Literal "You can optionally include an empty line between entries\nwithout stopping the list.\n\nThis also applies within list entries, this is still part of\nentry 11."]),("12",GtkDoc [Literal "But you don't have to."])]]++>>> :{+parseGtkDoc $ T.stripEnd $ T.unlines [+"1. A list with a single element",+"",+"And this is text not in the list, so we use parseGtkDoc."+]+:}+GtkDoc [NumberedList [("1",GtkDoc [Literal "A list with a single element"])],Literal "\n\nAnd this is text not in the list, so we use parseGtkDoc."]++>>> :{+parseOnly (parseNumberedList <* endOfInput) $ T.stripEnd $ T.unlines [+T.cons startOfString+"1. An example of a list in lenient mode,",+"where we don't require indenting this second line.",+"",+"2. In this mode entries can be optionally separated by an empty line.",+"3. But they don't need to"+]+:}+Right [NumberedList [("1",GtkDoc [Literal "An example of a list in lenient mode,\nwhere we don't require indenting this second line."]),("2",GtkDoc [Literal "In this mode entries can be optionally separated by an empty line."]),("3",GtkDoc [Literal "But they don't need to"])]]+-}+parseNumberedList :: Parser [Token]+parseNumberedList = do+ (initialNewlines, list) <- parseList (do idx <- takeWhile1 isDigit+ _ <- string ". "+ return idx)+ (\label -> T.length label + 2)+ return $ initialNewlines <> [NumberedList list]++{- | The indent parsing mode. In strict mode we require that all the+ text in the lines is indented relative to the label, as in the+ following example:++ 1. The first line,+ and the second line++ In this mode we allow empty lines in the entry.+ 2. This is the second entry.++ In lenient mode we drop this restriction, so the following is valid:+ 1. The first line,+ and the second line+ In this mode we _do not_ allow empty lines in the entry.+ 2. This is the second entry.+-}+data IndentParsingMode = Lenient | Strict+ deriving (Eq)++{- | Parse an unnumbered or numbered list. See 'parseNumberedList' and+ 'parseUnnumberedList' for examples.+-}+parseList :: Parser Text -> (Text -> Int) ->+ Parser ([Token], [(Text, GtkDoc)])+parseList labelParser indent =+ doParseList Lenient <|> doParseList Strict+ where+ doParseList :: IndentParsingMode ->+ Parser ([Token], [(Text, GtkDoc)])+ doParseList mode = do+ -- Consume the initial newlines before parseListItem does, so we can+ -- restore the initial newlines after. We impose that there is at+ -- least a newline (or Start of String symbol) before the start of+ -- the list.+ initialNewlines <- parseInitialNewlines+ (initialSpace, first) <-+ parseListItem (takeWhile isHorizontalSpace) (pure ())+ -- We allow either one or zero empty lines between entries.+ let newlineParser = (string "\n\n" <|> string "\n") >> pure ()+ rest <- map snd <$>+ many' (parseListItem (string initialSpace) newlineParser)+ -- Validate the resulting entries, and assemble them into GtkDoc.+ validated <- forM (first : rest) $ \(label, (firstLine, otherLines)) -> do+ validate label otherLines+ return (label,+ parseGtkDoc $ T.strip $ T.unlines $ firstLine : otherLines)++ return (initialNewlines, validated)++ where+ parseListItem :: Parser Text -> Parser () ->+ Parser (Text, (Text, (Text, [Text])))+ parseListItem parseInitialSpace startingNewlines = do+ startingNewlines+ initialSpace <- parseInitialSpace+ label <- labelParser+ first <- takeWhile (/= '\n')+ let padding = case mode of+ Strict -> initialSpace <> T.replicate (indent label) " "+ Lenient -> initialSpace+ paddingParser = string padding++ rest <- many' (parseLine paddingParser)++ return (initialSpace, (label, (first, rest)))++ parseLine :: Parser Text -> Parser Text+ parseLine paddingParser = do+ emptyLines <- case mode of+ -- We do not allow empty lines in entries in the lenient+ -- indent parser, while the strict indent one allows one+ -- at most.+ Strict -> option "" emptyLine+ Lenient -> pure ""+ _ <- char '\n' >> paddingParser+ contents <- takeWhile1 (/= '\n')+ when (startsWith labelParser contents) $+ fail "Line starting with a label"+ return $ emptyLines <> contents++ emptyLine = do+ _ <- char '\n'+ maybeNext <- peekChar+ guard $ maybeNext == Nothing || maybeNext == Just '\n'+ return ("\n" :: Text)++ startsWith :: Parser a -> Text -> Bool+ startsWith p l = isRight $ parseOnly p l++ validate :: Text -> [Text] -> Parser ()+ validate _ [] = pure ()+ validate label lines = case mode of+ Strict -> pure ()+ Lenient -> do+ let extraIndent = string $ T.replicate (indent label) " "++ -- If every line has extra padding we are most likely in+ -- the wrong mode too.+ when (all (startsWith extraIndent) lines) $+ fail "All lines have extra indent"++-- | Turn an ordinary `Name` into a `DocSymbolName`+docName :: Name -> DocSymbolName+docName (Name ns n) = AbsoluteName ns n++-- | Return a `Name` from a potentially relative `DocSymbolName`,+-- using the provided default namespace if the name is relative.+resolveDocSymbol :: DocSymbolName -> Text -> Name+resolveDocSymbol (AbsoluteName ns n) _ = Name ns n+resolveDocSymbol (RelativeName n) defaultNS = Name defaultNS n
lib/Data/GI/CodeGen/Haddock.hs view
@@ -10,16 +10,20 @@ , addSectionDocumentation ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif+#if !MIN_VERSION_base(4,13,0) import Control.Monad (mapM_, unless)+#else+import Control.Monad (unless)+#endif import qualified Data.Map as M+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import qualified Data.Text as T 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(..))@@ -29,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)+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 @^@.@@ -44,72 +50,131 @@ -- 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", "foo()")]--- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")])--- "'foo()'"+-- >>> formatHaddock M.empty "" "Test" (GtkDoc [Literal "This is a **bold** world!"])+-- "This is a __bold__ world!" --+-- >>> let c2h = M.fromList [(OldFunctionRef "foo", ValueIdentifier "foo")]+-- >>> formatHaddock c2h "" "Test" (GtkDoc [SymbolRef (OldFunctionRef "foo")])+-- "'foo'"+-- -- >>> let onlineDocs = "http://wiki.haskell.org"--- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")])+-- >>> formatHaddock M.empty onlineDocs "Test" (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")]) -- "<http://wiki.haskell.org/GObjectIntrospection GI>" ----- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]])--- "\n* <<a/test.png test>>\n"-formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text-formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc+-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [UnnumberedList [GtkDoc [Image (Link "test" "test.png")]]])+-- "* <<a/test.png test>>\n"+--+-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [NumberedList [("1", GtkDoc [Literal "Hi!"]), ("2", GtkDoc [Literal "Second and very long, so split\n line."])]])+-- "1. Hi!\n\n2. Second and very long, so split\n line.\n\n"+formatHaddock :: M.Map CRef Hyperlink -> Text -> Text -> GtkDoc -> Text+formatHaddock c2h docBase defaultNS (GtkDoc tokens) = T.concat $ map formatToken tokens where formatToken :: Token -> Text- formatToken (Literal l) = escape l+ formatToken (Literal l) = escape (convertBold l)+ formatToken (Comment _) = "" formatToken (Verbatim v) = "@" <> escape v <> "@" formatToken (CodeBlock l c) = formatCodeBlock l c formatToken (ExternalLink l) = formatLink l docBase formatToken (Image l) = formatImage l docBase- formatToken (SectionHeader l h) = formatSectionHeader c2h docBase l h- formatToken (List l) = formatList c2h docBase l- formatToken (SymbolRef (ParamRef p)) = "/@" <> lowerSymbol p <> "@/"+ 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 _) = error $ "Should not be reached"-formatUnknownCRef c2h (SignalRef owner signal) =- case M.lookup (TypeRef owner) c2h of+ -- 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 <> "](#" <> 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 <> "/@" -- | Format a `Hyperlink` into plain `Text`. formatHyperlink :: Hyperlink -> Text-formatHyperlink (IdentifierLink t) = "'" <> t <> "'"+formatHyperlink (TypeIdentifier t) = "t'" <> t <> "'"+formatHyperlink (ValueIdentifier t) = "'" <> t <> "'" formatHyperlink (ModuleLink m) = "\"" <> m <> "\""-formatHyperlink (ModuleLinkWithAnchor m a) = "\"" <> m <> "#" <> a <> "\""+formatHyperlink (ModuleLinkWithAnchor mLabel m a) =+ case mLabel of+ Nothing -> "\"" <> m <> "#" <> a <> "\""+ Just label -> "[" <> label <> "](\"" <> m <> "#" <> a <> "\")" -- | Format a code block in a specified language. 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@@ -143,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__@@ -179,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@@ -190,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 -> []@@ -208,75 +294,73 @@ -- | 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- line $ case pos of- DocBeforeSymbol -> "{- |"- DocAfterSymbol -> "{- ^" c2h <- getC2HMap docBase <- getDocBase- let haddock = formatDocumentation c2h docBase doc- mapM_ line (T.lines haddock)- line "-}"+ 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 -> "|" DocAfterSymbol -> "^"- in if T.any (== '\n') haddock- then do- line $ "{- " <> marker- mapM_ line (T.lines haddock)- line $ "-}"- else line $ "-- " <> marker <> " " <> haddock+ lines = case T.lines haddock of+ [] -> []+ (first:rest) -> ("-- " <> marker <> " " <> first) : map ("-- " <>) rest+ 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- line $ "{- ^ /@" <> lowerSymbol (argCName arg) <> "@/: " <>- formatHaddock c2h docBase (parseGtkDoc raw) <> " -}"+ defaultNS <- modName <$> config+ let haddock = "/@" <> lowerSymbol (argCName arg) <> "@/: " <>+ 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')/"] else [] let fullInfo = T.intercalate " " (returnValInfo ++ throwsInfo) unless (T.null fullInfo) $- line $ "{- ^ " <> fullInfo <> " -}"+ 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
lib/Data/GI/CodeGen/Inheritance.hs view
@@ -9,17 +9,17 @@ , instanceTree ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif import Control.Monad (foldM, when) import qualified Data.Map as M+#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import Data.GI.CodeGen.API import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line) import Data.GI.CodeGen.Util (tshow)+import Data.GI.CodeGen.Fixups (dropMovedItems) -- | Find the parent of a given object when building the -- instanceTree. For the purposes of the binding we do not need to@@ -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,15 +67,15 @@ -- (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 api of- APIInterface iface -> return $ map ((,) n) (ifInheritables iface)- APIObject object -> return $ map ((,) n) (objInheritables object)+ case dropMovedItems api of+ Just (APIInterface iface) -> return $ map ((,) n) (ifInheritables iface)+ 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
lib/Data/GI/CodeGen/LibGIRepository.hs view
@@ -1,20 +1,27 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, DataKinds #-} -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository ( girRequire+ , Typelib , setupTypelibSearchPath , FieldInfo(..) , girStructFieldInfo , girUnionFieldInfo , girLoadGType+ , girIsSymbolResolvable ) where #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, when, (>=>))+import Control.Monad (forM, (>=>)) import qualified Data.Map as M+import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T @@ -26,18 +33,27 @@ 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) -- | Wrapper for 'GIBaseInfo' newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo) --- | Wrapper for 'GITypelib'-newtype Typelib = Typelib (Ptr Typelib)+-- | Wrapper for 'GITypelib', remembering the originating namespace+-- and version.+data Typelib = Typelib { typelibNamespace :: Text+ , typelibVersion :: Text+ , _typelibPtr :: Ptr Typelib+ } +instance Show Typelib where+ show t = T.unpack (typelibNamespace t) ++ "-" ++ T.unpack (typelibVersion t)+ -- | Extra info about a field in a struct or union which is not easily -- determined from the GIR file. (And which we determine by using -- libgirepository.)@@ -45,11 +61,19 @@ 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 () -- | Add the given directory to the typelib search path, this is a@@ -82,10 +106,11 @@ withTextCString ns $ \cns -> withTextCString version $ \cversion -> do typelib <- checkGError (g_irepository_require nullPtr cns cversion 0)- (error $ "Could not load typelib for "- ++ show ns ++ " version "- ++ show version)- return (Typelib typelib)+ (\gerror -> error $ "Could not load typelib for "+ ++ show ns ++ " version "+ ++ show version ++ ".\n"+ ++ "Error was: " ++ show gerror)+ return (Typelib ns version typelib) foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name :: Ptr () -> CString -> CString -> IO (Ptr BaseInfo)@@ -154,28 +179,40 @@ foreign import ccall "g_typelib_symbol" g_typelib_symbol :: Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt --- | Load a symbol from the dynamic library associated to the given namespace.-girSymbol :: forall a. Text -> Text -> IO (FunPtr a)-girSymbol ns symbol = do- typelib <- withTextCString ns $ \cns ->- checkGError (g_irepository_require nullPtr cns nullPtr 0)- (error $ "Could not load typelib " ++ show ns)+-- | Try to load a symbol from the dynamic library associated to the+-- given typelib.+girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a))+girLookupSymbol (Typelib _ _ typelib) symbol = do funPtrPtr <- allocMem :: IO (Ptr (FunPtr a)) result <- withTextCString symbol $ \csymbol -> g_typelib_symbol typelib csymbol funPtrPtr- when (result /= 1) $- error ("Could not resolve symbol " ++ show symbol ++ " in namespace "- ++ show ns) funPtr <- peek funPtrPtr freeMem funPtrPtr- return funPtr+ if result /= 1+ then return Nothing+ else return (Just funPtr) +-- | Load a symbol from the dynamic library associated to the given+-- typelib. If the symbol does not exist this will raise an error.+girSymbol :: Typelib -> Text -> IO (FunPtr a)+girSymbol typelib@(Typelib ns version _) symbol = do+ maybeSymbol <- girLookupSymbol typelib symbol+ case maybeSymbol of+ Just funPtr -> return funPtr+ Nothing -> error ("Could not resolve symbol " ++ show symbol ++ " in namespace "+ ++ show (ns <> "-" <> version))+ type GTypeInit = IO CGType foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit --- | Load a GType given the namespace where it lives and the type init+-- | Load a GType given the `Typelib` where it lives and the type init -- function.-girLoadGType :: Text -> Text -> IO GType-girLoadGType ns typeInit = do- funPtr <- girSymbol ns typeInit- GType <$> gtypeInit funPtr+girLoadGType :: Typelib -> Text -> IO GType+girLoadGType typelib typeInit =+ GType <$> (girSymbol typelib typeInit >>= gtypeInit)++-- | Check whether a symbol is present in the dynamical liberary.+girIsSymbolResolvable :: Typelib -> Text -> IO Bool+girIsSymbolResolvable typelib symbol = do+ maybeSymbol <- girLookupSymbol typelib symbol+ return (isJust maybeSymbol)
lib/Data/GI/CodeGen/ModulePath.hs view
@@ -7,7 +7,9 @@ , dotModulePath ) where +#if !MIN_VERSION_base(4,13,0) import Data.Monoid (Monoid(..), (<>))+#endif import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Semigroup as Sem
− lib/Data/GI/CodeGen/OverloadedLabels.hs
@@ -1,95 +0,0 @@-module Data.GI.CodeGen.OverloadedLabels- ( genOverloadedLabels- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Data.Maybe (isNothing)-import Data.Monoid ((<>))-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
lib/Data/GI/CodeGen/OverloadedMethods.hs view
@@ -5,47 +5,69 @@ ) where import Control.Monad (forM, forM_, when)+#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.API+import Data.GI.CodeGen.Conversions (ExposeClosures(..)) 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) => O.IsLabelProxy t ("+ <> "O.OverloadedMethod info " <> n <> " p) => OL.IsLabel t (" <> n <> " -> p) where"- indent $ line $ "fromLabelProxy _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"+ line $ "#if MIN_VERSION_base(4,10,0)"+ indent $ line $ "fromLabel = O.overloadedMethod @info"+ line $ "#else"+ 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 $ "#if MIN_VERSION_base(4,9,0)" line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "- <> "O.MethodInfo info " <> n <> " p) => O.IsLabel t ("- <> n <> " -> p) where"+ <> "O.OverloadedMethodInfo info " <> n <> ") => "+ <> "OL.IsLabel t (O.MethodProxy info "+ <> n <> ") where" line $ "#if MIN_VERSION_base(4,10,0)"- indent $ line $ "fromLabel = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"+ indent $ line $ "fromLabel = O.MethodProxy" line $ "#else"- indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"- line $ "#endif"+ 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@@ -58,13 +80,17 @@ return ((lowerName . methodName) method, mi) group $ do let resolver = "Resolve" <> name <> "Method"- 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 @@ -74,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)- sig <- callableSignature callable (KnownForeignSymbol undefined)+ 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.MethodResolutionFailed \""- <> 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
lib/Data/GI/CodeGen/OverloadedSignals.hs view
@@ -1,102 +1,32 @@ 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 ((<>))-import Data.Text (Text)+#endif import qualified Data.Text as T-import qualified Data.Set as S import Data.GI.CodeGen.API import Data.GI.CodeGen.Code import Data.GI.CodeGen.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import Data.GI.CodeGen.GObject (apiIsGObject)-import Data.GI.CodeGen.Signal (signalHaskellName, genSignalConnector) import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase,- qualifiedSymbol)-import Data.GI.CodeGen.Util (lcFirst, ucFirst)---- 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 $ "#if MIN_VERSION_base(4,8,0)"- line $ "pattern " <> camelName <>- " :: SignalProxy object (ResolveSignal \""- <> lcFirst camelName <> "\" object)"- line $ "pattern " <> camelName <> " = SignalProxy"- line $ "#else"- line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. "- <> "info ~ ResolveSignal \"" <> lcFirst camelName- <> "\" object => SignalProxy object info"- line $ "#endif"- exportDecl $ "pattern " <> camelName---- | Qualified name for the "(sigName, info)" tag for a given signal.-signalInfoName :: Name -> Signal -> CodeGen Text-signalInfoName n signal = do- let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal- <> "SignalInfo"- qualifiedSymbol infoName n---- | Generate the given signal instance for the given API object.-genInstance :: Name -> Signal -> CodeGen ()-genInstance owner signal = group $ do- let name = upperName owner- let sn = (ucFirst . signalHaskellName . sigName) signal- si <- signalInfoName owner signal- bline $ "data " <> si- line $ "instance SignalInfo " <> si <> " where"- indent $ do- let signalConnectorName = name <> sn- cbHaskellType = signalConnectorName <> "Callback"- line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType- line $ "connectSignal _ obj cb connectMode = do"- indent $ genSignalConnector signal cbHaskellType "connectMode"- export (NamedSubsection SignalSection $ lcFirst sn) si+ signalInfoName)+import Data.GI.CodeGen.Util (lcFirst) -- | 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) when isGO $ do- mapM_ (genInstance n) (objSignals o) infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal@@ -106,13 +36,12 @@ 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- mapM_ (genInstance n) (ifSignals iface) infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal@@ -122,4 +51,4 @@ let signalListType = name <> "SignalList" line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ "- <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"+ <> T.intercalate ", " infos <> "] :: [(Symbol, DK.Type)])"
lib/Data/GI/CodeGen/Overrides.hs view
@@ -2,7 +2,7 @@ module Data.GI.CodeGen.Overrides ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups, onlineDocsMap)- , parseOverridesFile+ , parseOverrides , filterAPIsAndDeps ) where @@ -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)@@ -132,12 +135,11 @@ -- encode this in a monad. type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a --- | Parse the given overrides file, filling in the configuration as+-- | Parse the given overrides, filling in the configuration as -- needed. In case the parsing fails we return a description of the -- error instead.-parseOverridesFile :: FilePath -> IO (Either Text Overrides)-parseOverridesFile fname = do- overrides <- utf8ReadFile fname+parseOverrides :: Text -> IO (Either Text Overrides)+parseOverrides overrides = do runExceptT $ flip evalStateT emptyParserState $ execWriterT $ mapM (parseOneLine . T.strip) (T.lines overrides) @@ -164,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) =@@ -262,6 +266,17 @@ "\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 () parseAdd (T.words -> [path, name]) = do@@ -394,10 +409,12 @@ -- | Parse the given overrides file, and merge into the given context. parseInclude :: Text -> Parser ()-parseInclude fname = liftIO (parseOverridesFile $ T.unpack fname) >>= \case- Left err -> throwError ("Error when parsing included '"- <> fname <> "': " <> err)- Right ovs -> tell ovs+parseInclude fname = do+ includeText <- liftIO $ utf8ReadFile (T.unpack fname)+ liftIO (parseOverrides includeText) >>= \case+ Left err -> throwError ("Error when parsing included '"+ <> fname <> "': " <> err)+ Right ovs -> tell ovs -- | Filter a set of named objects based on a lookup list of names to -- ignore.
lib/Data/GI/CodeGen/PkgConfig.hs view
@@ -4,9 +4,10 @@ ) where import Control.Monad (when)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid (First(..), (<>))-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (mconcat)+#else+import Data.Monoid (First(..)) #endif import qualified Data.Map.Strict as M import qualified Data.Text as T
lib/Data/GI/CodeGen/ProjectInfo.hs view
@@ -14,6 +14,9 @@ , standardDeps ) where +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T (unlines) @@ -21,10 +24,10 @@ 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 (garetxe@gmail.com)"+maintainers = "Iñaki García Etxebarria" license :: Text license = "LGPL-2.1"@@ -36,12 +39,13 @@ "OverloadedStrings", "NegativeLiterals", "ConstraintKinds", "TypeFamilies", "MultiParamTypeClasses", "KindSignatures", "FlexibleInstances", "UndecidableInstances", "DataKinds",- "FlexibleContexts"]+ "FlexibleContexts", "UndecidableSuperClasses",+ "TypeOperators"] -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default. otherExtensions :: [Text]-otherExtensions = ["PatternSynonyms", "ViewPatterns"]+otherExtensions = ["PatternSynonyms", "ViewPatterns", "TypeApplications"] -- | Default options for GHC when compiling generated code. ghcOptions :: [Text]@@ -59,15 +63,32 @@ 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. category :: Text category = "Bindings" -licenseText :: Text-licenseText = T.unlines+staticLinkingException :: Text -> Text+staticLinkingException name = T.unlines+ ["The " <> name <> " library and included works are provided under the terms of the"+ ,"GNU Library General Public License (LGPL) version 2.1 with the following"+ ,"exception:"+ ,""+ ,"Static linking of applications or any other source to the " <> name <> " library"+ ,"does not constitute a modified or derivative work and does not require"+ ,"the author(s) to provide source code for said work, to link against the"+ ,"shared " <> name <> " libraries, or to link their applications against a"+ ,"user-supplied version of " <> name <> ". If you link applications to a modified"+ ,"version of " <> name <> ", then the changes to " <> name <> " must be provided under the"+ ,"terms of the LGPL."+ ,""+ ,"----------------------------------------------------------------------------"+ ,""]++licenseText :: Text -> Text+licenseText name = staticLinkingException name <> T.unlines [" GNU LESSER GENERAL PUBLIC LICENSE" ," Version 2.1, February 1999" ,""
lib/Data/GI/CodeGen/Properties.hs view
@@ -8,7 +8,9 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when, unless)+#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@@ -23,14 +25,18 @@ import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)-import Data.GI.CodeGen.SymbolNaming (lowerName, upperName,- classConstraint, typeConstraint,+import Data.GI.CodeGen.ModulePath (dotModulePath)+import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint, hyphensToCamelCase, qualifiedSymbol,- callbackDynamicWrapper)+ typeConstraint, callbackDynamicWrapper,+ callbackHaskellToForeign,+ 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"@@ -39,6 +45,9 @@ TGHash _ _ -> return "Hash" TVariant -> return "Variant" 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: " ++@@ -68,34 +77,126 @@ 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 e Text+propSetTypeConstraint (TGClosure Nothing) =+ return $ "(~) " <> parenthesize (typeShow ("GClosure" `con` [con0 "()"]))+propSetTypeConstraint t = do+ isGO <- isGObject t+ if isGO+ then typeConstraint t+ else do+ isCallback <- typeIsCallback t+ hInType <- if isCallback+ then typeShow <$> foreignType t+ else typeShow <$> haskellType t+ return $ "(~) " <> if T.any (== ' ') hInType+ then parenthesize hInType+ else hInType++-- | The constraint for transferring the given type into a property.+propTransferTypeConstraint :: Type -> CodeGen e Text+propTransferTypeConstraint t = do+ isGO <- isGObject t+ if isGO+ then typeConstraint t+ else do+ hInType <- typeShow <$> isoHaskellType t+ return $ "(~) " <> if T.any (== ' ') hInType+ then parenthesize hInType+ else hInType++-- | The type of the return value of @attrTransfer@ for the given+-- type.+propTransferType :: Type -> CodeGen e Text+propTransferType (TGClosure Nothing) =+ return $ typeShow ("GClosure" `con` [con0 "()"])+propTransferType t = do+ isCallback <- typeIsCallback t+ if isCallback+ then typeShow <$> foreignType t+ else typeShow <$> haskellType t++-- | 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 e ()+genPropTransfer var (TGClosure Nothing) = line $ "return " <> var+genPropTransfer var t = do+ isGO <- isGObject t+ if isGO+ then do+ ht <- typeShow <$> haskellType t+ line $ "unsafeCastTo " <> ht <> " " <> var+ else case t of+ TInterface tn@(Name _ n) -> do+ isCallback <- typeIsCallback t+ if not isCallback+ then line $ "return " <> var+ else do+ -- Callbacks need to be wrapped+ wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn+ maker <- qualifiedSymbol (callbackWrapperAllocator n) tn+ line $ maker <> " " <>+ parenthesize (wrapper <> " Nothing " <> var)+ _ -> line $ "return " <> var+ -- | 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) if isCallback then do ftype <- foreignType (propType prop) return ([], typeShow ftype) else do- (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop+ (t,constraints) <- argumentType (propType prop) WithoutClosures return (constraints, t) -- | Generate documentation for the given setter.@@ -109,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)@@ -120,11 +221,14 @@ writeHaddock DocBeforeSymbol (setterDoc n prop) line $ setter <> " :: (" <> T.intercalate ", " constraints' <> ") => o -> " <> t <> " -> m ()"- line $ setter <> " obj val = liftIO $ 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.@@ -137,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@@ -151,8 +255,8 @@ returnType = typeShow $ "m" `con` [outType] getProp = if isNullable && not isMaybe then "checkUnexpectedNothing \"" <> getter- <> "\" $ getObjectProperty" <> tStr- else "getObjectProperty" <> tStr+ <> "\" $ B.Properties.getObjectProperty" <> tStr+ else "B.Properties.getObjectProperty" <> tStr -- Some property getters require in addition a constructor, which -- will convert the foreign value to the wrapped Haskell one. constructorArg <-@@ -167,33 +271,36 @@ 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 isNullable <- typeIsNullable (propType prop) isCallback <- typeIsCallback (propType prop) cls <- classConstraint n- let constraints' = (cls <> " o") : constraints+ let constraints' = (cls <> " o") : "MIO.MonadIO m" : constraints pconstraints = parenthesize (T.intercalate ", " constraints') <> " => " writeHaddock DocBeforeSymbol (constructorDoc prop) line $ constructor <> " :: " <> pconstraints- <> t <> " -> IO (GValueConstruct o)"- line $ constructor <> " val = constructObjectProperty" <> tStr+ <> t <> " -> m (GValueConstruct o)"+ 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 "\" (Just val)"- else "\" val"+ then "\" (P.Just " <> val' <> ")"+ else "\" " <> val' export docSection constructor -- | Generate documentation for the given setter.@@ -206,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"]@@ -219,7 +326,7 @@ else "(Nothing :: " <> nothingType <> ")" line $ clear <> " :: (" <> T.intercalate ", " constraints <> ") => o -> m ()"- line $ clear <> " obj = liftIO $ setObjectProperty" <> tStr+ line $ clear <> " obj = liftIO $ B.Properties.setObjectProperty" <> tStr <> " obj \"" <> propName prop <> "\" " <> nothing export docSection clear @@ -230,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.@@ -242,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@@ -254,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"@@ -262,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"@@ -272,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 &&@@ -332,18 +440,16 @@ cppIf CPPOverloading $ do cls <- classConstraint owner inConstraint <- if writable || constructOnly- then do- inIsGO <- isGObject (propType prop)- isCallback <- typeIsCallback (propType prop)- hInType <- if isCallback- then typeShow <$> foreignType (propType prop)- else typeShow <$> haskellType (propType prop)- if inIsGO- then typeConstraint (propType prop)- else return $ "(~) " <> if T.any (== ' ') hInType- then parenthesize hInType- else hInType+ then propSetTypeConstraint (propType prop) else return "(~) ()"+ transferConstraint <- if writable || constructOnly+ then propTransferTypeConstraint (propType prop)+ else return "(~) ()"+ transferType <- if writable || constructOnly+ then propTransferType (propType prop)+ else return "()"+ let puttable = readable && writable && inConstraint == ("(~) " <> outType)+ let allowedOps = (if writable then ["'AttrSet", "'AttrConstruct"] else [])@@ -356,38 +462,63 @@ <> (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 line $ "type AttrAllowedOps " <> it <> " = '[ " <> T.intercalate ", " allowedOps <> "]"+ line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls line $ "type AttrSetTypeConstraint " <> it <> " = " <> inConstraint- line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls+ line $ "type AttrTransferTypeConstraint " <> it+ <> " = " <> transferConstraint+ line $ "type AttrTransferType " <> it <> " = " <> transferType line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "type AttrOrigin " <> it <> " = " <> name- line $ "attrGet _ = " <> getter- line $ "attrSet _ = " <> setter- line $ "attrConstruct _ = " <> constructor- line $ "attrClear _ = " <> clear+ 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 let cName = (hyphensToCamelCase . propName) prop docSection = NamedSubsection PropertySection (lcFirst cName) export docSection it- line $ "data " <> it+ bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <> " = '[]" line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrTransferTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrTransferType " <> it <> " = ()" line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()" line $ "type AttrGetType " <> it <> " = ()" line $ "type AttrLabel " <> it <> " = \"\""@@ -396,8 +527,9 @@ line $ "attrSet = undefined" line $ "attrConstruct = undefined" 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 @@ -405,7 +537,8 @@ handleCGExc (\err -> do line $ "-- XXX Generation of property \"" <> propName prop <> "\" of object \""- <> name <> "\" failed: " <> describeCGError err+ <> name <> "\" failed."+ printCGError err cppIf CPPOverloading (genPlaceholderProperty n prop)) (genOneProperty n prop) @@ -414,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@@ -422,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
lib/Data/GI/CodeGen/Signal.hs view
@@ -1,17 +1,15 @@ module Data.GI.CodeGen.Signal ( genSignal- , genSignalConnector , genCallback , signalHaskellName ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif 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 import Data.Bool (bool) import qualified Data.Text as T import Data.Text (Text)@@ -21,7 +19,7 @@ import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (hOutType, wrapMaybe, fixupCallerAllocates,- genDynamicCallableWrapper, ExposeClosures(..),+ genDynamicCallableWrapper, callableHInArgs, callableHOutArgs) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions@@ -29,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@@ -39,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@@ -53,7 +52,7 @@ line $ "type " <> name' <> " =" indent $ do forM_ inArgsWithArrows $ \(arrow, arg) -> do- ht <- haskellType (argType arg)+ ht <- isoHaskellType (argType arg) isMaybe <- wrapMaybe arg let formattedType = if isMaybe then typeShow (maybeT ht)@@ -67,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 =@@ -82,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@@ -112,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 `"@@ -127,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@@ -143,29 +150,33 @@ 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 group $ do- line $ closure <> " :: " <> callback <> " -> IO Closure"- line $ closure <> " cb = do"+ line $ closure <> " :: MonadIO m => " <> callback <> " -> m (GClosure "+ <> 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- <> " >>= newCClosure"+ <> " >>= B.GClosure.newGClosure" where closureDoc :: Text- closureDoc = "Wrap the callback into a `Closure`."+ 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@@ -179,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.@@ -212,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@@ -242,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@@ -268,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'@@ -296,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@@ -311,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 ()@@ -323,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@@ -331,31 +356,32 @@ 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'- line $ "-- -> " <> tshow (fixupCallerAllocates cb)+ line $ "{- " <> T.pack (ppShow cb') <> "\n-}" if skipReturn cb then group $ do line $ "-- XXX Skipping callback " <> name'- line $ "-- Callbacks skipping return unsupported :\n"- <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb)+ line $ "{- Callbacks skipping return unsupported :\n"+ <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb') <> "-}" else do- let cb' = fixupCallerAllocates cb-- handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "- <> name' <>- "\n-- Error was : " <> describeCGError e)) $ do- typeSynonym <- genCCallbackPrototype name' cb' name' False+ handleCGExc (\e -> do+ line $ "-- XXX Could not generate callback wrapper for "+ <> name'+ printCGError e) $ do+ 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,16 +405,63 @@ 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 --- | 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)+-- | Generate the given signal instance for the given API object.+genSignalInfoInstance :: Name -> Signal -> CodeGen e ()+genSignalInfoInstance owner signal = group $ do+ api <- findAPIByName owner+ let name = upperName owner+ 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"+ indent $ do+ let signalConnectorName = name <> sn+ cbHaskellType = signalConnectorName <> "Callback"+ line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType+ line $ "connectSignal obj cb connectMode detail = do"+ 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 -genSignal :: Signal -> Name -> ExcCodeGen ()-genSignal s@(Signal { sigName = sn, sigCallable = cb }) on = do+-- | Write some simple debug message when signal generation fails, and+-- generate a placeholder SignalInfo instance.+processSignalError :: Signal -> Name -> CGError -> CodeGen e ()+processSignalError signal owner err = do+ let qualifiedSignalName = upperName owner <> "::" <> sigName signal+ sn = (ucFirst . signalHaskellName . sigName) signal+ line $ T.concat ["-- XXX Could not generate signal "+ , qualifiedSignalName+ , "\n", "-- Error was : "]+ printCGError err++ -- Generate a placeholder SignalInfo instance that raises a type+ -- error when one attempts to use it.+ cppIf CPPOverloading $ group $ do+ si <- signalInfoName owner signal+ bline $ "data " <> si+ line $ "instance SignalInfo " <> si <> " where"+ indent $ do+ line $ "type HaskellCallbackType " <> si <>+ " = B.Signals.SignalCodeGenError \"" <> qualifiedSignalName <> "\""+ line $ "connectSignal = undefined"+ export (NamedSubsection SignalSection $ lcFirst sn) si++-- | Generate a wrapper for a signal.+genSignal :: Signal -> Name -> CodeGen e ()+genSignal s@(Signal { sigName = sn, sigCallable = cb }) on =+ handleCGExc (processSignalError s on) $ do let on' = upperName on line $ "-- signal " <> on' <> "::" <> sn@@ -400,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@@ -423,8 +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) =>"- signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"+ implicitSelfCBType = "((?self :: a) => " <> cbType <> ")"+ signatureArgs = if sigDetailed s+ then "a -> P.Maybe T.Text -> " <> implicitSelfCBType <> " -> m SignalHandlerId"+ else "a -> " <> implicitSelfCBType <> " -> m SignalHandlerId" signature = " :: " <> signatureConstraints <> " " <> signatureArgs onName = "on" <> signalConnectorName afterName = "after" <> signalConnectorName@@ -432,48 +511,96 @@ group $ do writeHaddock DocBeforeSymbol onDoc line $ onName <> signature- line $ onName <> " obj cb = liftIO $ do"- indent $ genSignalConnector s cbType "SignalConnectBefore"+ if sigDetailed s+ then do+ line $ onName <> " obj detail cb = liftIO $ do"+ 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 $ do+ line $ "let wrapped self = let ?self = self in cb"+ genSignalConnector s cbType "SignalConnectBefore" "Nothing" "wrapped" export docSection onName group $ do writeHaddock DocBeforeSymbol afterDoc line $ afterName <> signature- line $ afterName <> " obj cb = liftIO $ do"- indent $ genSignalConnector s cbType "SignalConnectAfter"+ if sigDetailed s+ then do+ line $ afterName <> " obj detail cb = liftIO $ do"+ 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 $ do+ line $ "let wrapped self = let ?self = self in cb"+ genSignalConnector s cbType "SignalConnectAfter" "Nothing" "wrapped" export docSection afterName + cppIf CPPOverloading (genSignalInfoInstance on s)+ where onDoc :: Text- onDoc = T.unlines [- "Connect a signal handler for the “@" <> sn <>- "@” signal, to be run before the default handler."+ onDoc = let hsn = signalHaskellName sn+ in T.unlines [+ "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <>+ ") signal, to be run before the default handler." , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.on' " <> lowerName on <> " #"- <> lcFirst (hyphensToCamelCase sn) <> " callback"- , "@" ]+ <> hsn <> " callback"+ , "@"+ , ""+ , detailedDoc ] afterDoc :: Text- afterDoc = T.unlines [- "Connect a signal handler for the “@" <> sn <>- "@” signal, to be run after the default handler."+ afterDoc = let hsn = signalHaskellName sn+ in T.unlines [+ "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <>+ ") signal, to be run after the default handler." , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to" , "" , "@" , "'Data.GI.Base.Signals.after' " <> lowerName on <> " #"- <> lcFirst (hyphensToCamelCase sn) <> " callback"- , "@" ]+ <> hsn <> " callback"+ , "@"+ , ""+ , detailedDoc+ , ""+ , selfDoc] + detailedDoc :: Text+ detailedDoc = if not (sigDetailed s)+ then ""+ else T.unlines [+ "This signal admits a optional parameter @detail@."+ , "If it's not @Nothing@, we will connect to “@" <> sn+ <> "::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. genSignalConnector :: Signal -> Text -- ^ Callback type -> Text -- ^ SignalConnectBefore or SignalConnectAfter- -> CodeGen ()-genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when = do- cb' <- genWrappedCallback cb "cb" cbType True+ -> Text -- ^ Detail+ -> 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+ <> " " <> detail
lib/Data/GI/CodeGen/Struct.hs view
@@ -5,6 +5,7 @@ , extractCallbacksInStruct , fixAPIStructs , ignoreStruct+ , genBoxed , genWrappedPtr ) where @@ -14,7 +15,9 @@ import Control.Monad (forM, when) import Data.Maybe (mapMaybe, isJust, catMaybes)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T @@ -23,15 +26,36 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol))-import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.ModulePath (dotModulePath)+import Data.GI.CodeGen.SymbolNaming (upperName, lowerName,+ underscoresToCamelCase,+ qualifiedSymbol,+ callbackHaskellToForeign,+ callbackWrapperAllocator,+ haddockAttrAnchor, moduleLocation,+ hackageModuleLink,+ normalizedAPIName)+ import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util -- | Whether (not) to generate bindings for the given struct. ignoreStruct :: Name -> Struct -> Bool-ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) ||- "Private" `T.isSuffixOf` name+ignoreStruct (Name _ name) s = (isJust (gtypeStructFor s) ||+ "Private" `T.isSuffixOf` name) &&+ (not $ structForceVisible s) +-- | Whether the given type corresponds to an ignored struct.+isIgnoredStructType :: Type -> CodeGen e Bool+isIgnoredStructType t =+ case t of+ TInterface n -> do+ api <- getAPI t+ case api of+ APIStruct s -> return (ignoreStruct n s)+ _ -> return False+ _ -> return False+ -- | Canonical name for the type of a callback type embedded in a -- struct field. fieldCallbackType :: Text -> Field -> Text@@ -77,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@@ -233,6 +257,62 @@ line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field) <> ") (" <> nullPtr <> " :: " <> fType <> ")" +-- | Return whether the given type corresponds to a callback that does+-- 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@(Callback {cbCallable = callable}) ->+ if callableThrows callable+ then return Nothing+ else return (Just callback)+ _ -> return Nothing+isRegularCallback _ = return Nothing++-- | The types accepted by the allocating set function+-- 'Data.GI.Base.Attributes.(:&=)'.+fieldTransferTypeConstraint :: Type -> CodeGen e Text+fieldTransferTypeConstraint t = do+ isPtr <- typeIsPtr t+ maybeRegularCallback <- isRegularCallback t+ inType <- if isPtr && not (isJust maybeRegularCallback)+ then typeShow <$> foreignType t+ else typeShow <$> isoHaskellType t+ return $ "(~)" <> if T.any (== ' ') inType+ then parenthesize inType+ else inType++-- | 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 e Text+fieldTransferType t = do+ isPtr <- typeIsPtr t+ inType <- if isPtr+ then typeShow <$> foreignType t+ else typeShow <$> haskellType t+ return $ if T.any (== ' ') inType+ then parenthesize inType+ else inType++-- | Generate the field transfer function, which marshals Haskell+-- values to types that we can set, even if we need to allocate memory.+genFieldTransfer :: Text -> Type -> CodeGen e ()+genFieldTransfer var t@(TInterface tn) = 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)+ Nothing -> line $ "return " <> var+genFieldTransfer var _ = line $ "return " <> var+ -- | Haskell name for the field fName :: Field -> Text fName = underscoresToCamelCase . fieldName@@ -259,10 +339,19 @@ inType <- if isPtr then typeShow <$> foreignType (fieldType field) else typeShow <$> haskellType (fieldType field)+ 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+ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on line $ "type AttrAllowedOps " <> it <> if embedded then " = '[ 'AttrGet]"@@ -273,18 +362,29 @@ <> if T.any (== ' ') inType then parenthesize inType else inType- line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on+ line $ "type AttrTransferTypeConstraint " <> it <> " = " <> transferConstraint+ line $ "type AttrTransferType " <> it <> " = " <> transferType line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> fieldName field <> "\"" line $ "type AttrOrigin " <> it <> " = " <> on- line $ "attrGet _ = " <> fieldGetter owner field- line $ "attrSet _ = " <> if not embedded+ line $ "attrGet = " <> fieldGetter owner field+ line $ "attrSet = " <> if not embedded then fieldSetter owner field else "undefined" line $ "attrConstruct = undefined"- line $ "attrClear _ = " <> if not embedded && isPtr+ line $ "attrClear = " <> if not embedded && isPtr then fieldClear owner field else "undefined"+ if not embedded+ then do+ 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 @@ -297,12 +397,20 @@ return $ "'(\"" <> labelName field <> "\", " <> it <> ")" +-- | Build code for a single field. buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text) buildFieldAttributes n field | not (fieldVisible field) = return Nothing | privateType (fieldType field) = return Nothing | otherwise = group $ do + -- We don't generate bindings for private and class structs, so+ -- do not generate bindings for fields pointing to class structs+ -- either.+ ignored <- isIgnoredStructType (fieldType field)+ when ignored $+ notImplementedError "Field type is an unsupported struct type"+ nullPtr <- nullPtrForType (fieldType field) embedded <- isEmbedded field@@ -330,15 +438,17 @@ docSection = NamedSubsection PropertySection $ lcFirst $ fName field -genStructOrUnionFields :: Name -> [Field] -> CodeGen ()+-- | Generate code for the given list of fields.+genStructOrUnionFields :: Name -> [Field] -> CodeGen e () genStructOrUnionFields n fields = do let name' = upperName n attrs <- forM fields $ \field ->- handleCGExc (\e -> line ("-- XXX Skipped attribute for \"" <> name' <>- ":" <> fieldName field <> "\" :: " <>- describeCGError e) >>- return Nothing)+ handleCGExc (\e -> do+ line ("-- XXX Skipped attribute for \"" <> name' <>+ ":" <> fieldName field <> "\"")+ printCGError e+ return Nothing) (buildFieldAttributes n field) blank@@ -348,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@@ -381,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
lib/Data/GI/CodeGen/SymbolNaming.hs view
@@ -3,11 +3,11 @@ ( lowerName , lowerSymbol , upperName- , noName , escapedArgName , classConstraint , typeConstraint+ , safeCast , hyphensToCamelCase , underscoresToCamelCase@@ -21,30 +21,47 @@ , callbackHaskellToForeignWithClosures , callbackClosureGenerator + , signalHaskellName+ , 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 import Data.Text (Text) 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 @@ -100,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.@@ -120,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@@ -142,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__@@ -199,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@@ -235,3 +278,38 @@ | "set_" `T.isPrefixOf` s = s <> "_" | "get_" `T.isPrefixOf` s = s <> "_" | otherwise = s++-- | Qualified name for the "(sigName, info)" tag for a given signal.+signalInfoName :: Name -> Signal -> CodeGen e Text+signalInfoName n signal = do+ let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal+ <> "SignalInfo"+ qualifiedSymbol infoName n++-- | Return the name for the signal in Haskell CamelCase conventions.+signalHaskellName :: Text -> Text+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:"
lib/Data/GI/CodeGen/Transfer.hs view
@@ -11,7 +11,9 @@ #endif import Control.Monad (when)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import Data.GI.CodeGen.API@@ -41,13 +43,15 @@ basicFreeFn (TGHash _ _) = Just "unrefGHashTable" basicFreeFn (TError) = Nothing basicFreeFn (TVariant) = Nothing+basicFreeFn (TGValue) = Nothing basicFreeFn (TParamSpec) = Nothing+basicFreeFn (TGClosure _) = Nothing -- Basic free primitives in the case that an error occured. This is -- 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@@ -59,6 +63,14 @@ 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"+ else Nothing basicFreeFnOnError t@(TInterface _) transfer = do api <- findAPI t case api of@@ -107,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 []@@ -216,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,@@ -225,15 +237,20 @@ -- transfer semantics of the callable). freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text] freeInArg arg label len = do- -- Arguments that we alloc ourselves do not need to be freed, they- -- will always be soaked up by the wrapPtr constructor, or they will- -- be DirectionIn.- if not (argCallerAllocates arg)- then case direction arg of+ -- Arguments that we alloc ourselves do not always need to be freed,+ -- they will sometimes be soaked up by the wrapPtr constructor, or+ -- they will be DirectionIn.+ if willWrap arg+ then return []+ else case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label DirectionInout -> freeOut label- else return []++ -- Whether memory ownership of the pointer passed in to the function+ -- will be assumed by the C->Haskell wrapper.+ where willWrap :: Arg -> Bool+ willWrap = argCallerAllocates -- | Same thing as freeInArg, but called in case the call to C didn't -- succeed. We thus free everything we allocated in preparation for
lib/Data/GI/CodeGen/Type.hs view
@@ -19,7 +19,9 @@ , maybeT ) where +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import qualified Data.Text as T import Data.Text (Text)
lib/Data/GI/CodeGen/Util.hs view
@@ -17,16 +17,25 @@ , utf8WriteFile , splitOn++ , printWarning ) where +import GHC.Stack (HasCallStack)++#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import Data.Char (toLower, toUpper) import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO +import qualified System.Console.ANSI as A+import System.IO (stderr, hFlush) padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " "@@ -44,10 +53,6 @@ tshow :: Show a => a -> Text tshow = T.pack . show --- | Throw an error with the given `Text`.-terror :: Text -> a-terror = error . T.unpack- -- | Capitalize the first character of the given string. ucFirst :: Text -> Text ucFirst "" = ""@@ -90,3 +95,32 @@ -- | Write the given `Text` into an UTF-8 encoded file. utf8WriteFile :: FilePath -> T.Text -> IO () utf8WriteFile fname text = B.writeFile fname (TE.encodeUtf8 text)++-- | Print a (colored) warning message to stderr+printWarning :: Text -> IO ()+printWarning warning = do+ inColour <- A.hSupportsANSIColor stderr+ if not inColour+ then TIO.hPutStrLn stderr warning+ else do+ A.hSetSGR stderr [A.SetConsoleIntensity A.BoldIntensity,+ A.SetColor A.Foreground A.Vivid A.Yellow]+ TIO.hPutStr stderr "Warning: "+ A.hSetSGR stderr [A.SetColor A.Foreground A.Vivid A.White]+ TIO.hPutStrLn stderr warning+ A.hSetSGR stderr [A.Reset]+ hFlush stderr++-- | Throw an error with the given `Text`.+terror :: HasCallStack => Text -> a+terror errMsg =+ let fmt = A.setSGRCode [A.SetConsoleIntensity A.BoldIntensity,+ A.SetColor A.Foreground A.Vivid A.Red]+ ++ "ERROR: "+ ++ A.setSGRCode [A.SetColor A.Foreground A.Vivid A.White]+ ++ T.unpack errMsg+ ++ A.setSGRCode [A.SetConsoleIntensity A.NormalIntensity,+ A.SetColor A.Foreground A.Vivid A.Blue]+ ++ "\nPlease report this at https://github.com/haskell-gi/haskell-gi/issues"+ ++ A.setSGRCode [A.Reset]+ in error fmt
lib/Data/GI/GIR/Arg.hs view
@@ -4,14 +4,17 @@ , Scope(..) , parseArg , parseTransfer+ , parseTransferString ) where +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) 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@@ -22,6 +25,7 @@ | ScopeTypeCall | ScopeTypeAsync | ScopeTypeNotified+ | ScopeTypeForever deriving (Show, Eq, Ord) data Arg = Arg {@@ -29,6 +33,7 @@ -- escaped name valid in Haskell code, use -- `GI.SymbolNaming.escapedArgName`. argType :: Type,+ argCType :: Maybe Text, direction :: Direction, mayBeNull :: Bool, argDoc :: Documentation,@@ -36,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@@ -67,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 }
lib/Data/GI/GIR/BasicTypes.hs view
@@ -46,6 +46,17 @@ | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr+ | TShort -- ^ gshort+ | TUShort -- ^ gushort+ | TSize -- ^ gsize+ | TSSize -- ^ gssize+ | Ttime_t -- ^ time_t+ | Toff_t -- ^ off_t+ | Tdev_t -- ^ dev_t+ | Tgid_t -- ^ gid_t+ | Tpid_t -- ^ pid_t+ | Tsocklen_t -- ^ socklen_t+ | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection@@ -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@@ -63,5 +75,6 @@ | TGList Type -- ^ GList | TGSList Type -- ^ GSList | TGHash Type Type -- ^ GHashTable+ | TGClosure (Maybe Type) -- ^ GClosure containing the given API (if known) | TInterface Name -- ^ A reference to some API in the GIR deriving (Eq, Show, Ord)
lib/Data/GI/GIR/Callable.hs view
@@ -17,7 +17,12 @@ skipReturn :: Bool, callableThrows :: Bool, callableDeprecated :: Maybe DeprecationInfo,- callableDocumentation :: Documentation+ callableDocumentation :: Documentation,+ -- | Whether the symbol for this callable can be resolved in+ -- the dynamical library associated with the current+ -- introspection data. 'Nothing' means that we have not+ -- checked yet.+ callableResolvable :: Maybe Bool } deriving (Show, Eq) parseArgs :: Parser [Arg]@@ -64,4 +69,12 @@ , callableThrows = throws , callableDeprecated = deprecated , callableDocumentation = docs+ -- Some symbols are present in the @.gir@ file, but+ -- they are absent from the library+ -- itself. Generating bindings for such symbols+ -- could then lead to linker errors, so later on we+ -- check whether the callables are actually+ -- resolvable, and adjust the callable info+ -- appropriately.+ , callableResolvable = Nothing }
lib/Data/GI/GIR/Constant.hs view
@@ -7,7 +7,7 @@ import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type)-import Data.GI.GIR.Type (parseType, parseCType)+import Data.GI.GIR.Type (parseType) import Data.GI.GIR.Parser -- | Info about a constant.@@ -26,7 +26,12 @@ deprecated <- parseDeprecation value <- getAttr "value" t <- parseType- ctype <- parseCType+ -- This contains the C name for the constant. The C gir generator+ -- call this "c:type", while the vala gir generator calls it+ -- "c:identifier", so try both.+ ctype <- queryAttrWithNamespace CGIRNS "type" >>= \case+ Just i -> return i+ Nothing -> getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value
lib/Data/GI/GIR/Field.hs view
@@ -5,8 +5,12 @@ , parseFields ) where -import Data.Maybe (isJust)+import Control.Monad.Except (catchError, throwError)++import Data.Maybe (isJust, catMaybes)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text, isSuffixOf) import Data.GI.GIR.BasicTypes (Type(..))@@ -33,7 +37,7 @@ -- non-introspectable fields too (but set fieldVisible = False for -- them), this is necessary since they affect the computation of -- offsets of fields and sizes of containing structs.-parseField :: Parser Field+parseField :: Parser (Maybe Field) parseField = do name <- getAttr "name" deprecated <- parseDeprecation@@ -44,7 +48,13 @@ introspectable <- optionalAttr "introspectable" True parseBool private <- optionalAttr "private" False parseBool doc <- parseDocumentation- (t, isPtr, callback) <-+ -- 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+ then return Nothing+ else throwError e) $ do+ (t, isPtr, callback) <- if introspectable then do callbacks <- parseChildrenWithLocalName "callback" parseCallback@@ -68,7 +78,8 @@ return (t, fmap ("*" `isSuffixOf`) ct, Nothing) [n] -> return (TInterface n, Just True, Nothing) _ -> parseError "Multiple callbacks in field"- return $ Field {++ return $ Just $ Field { fieldName = name , fieldVisible = introspectable && not private , fieldType = t@@ -83,4 +94,4 @@ } parseFields :: Parser [Field]-parseFields = parseAllChildrenWithLocalName "field" parseField+parseFields = catMaybes <$> parseAllChildrenWithLocalName "field" parseField
lib/Data/GI/GIR/Function.hs view
@@ -9,6 +9,7 @@ import Data.GI.GIR.Parser data Function = Function {+ -- | The symbol in the dynlib that this function refers to. fnSymbol :: Text , fnMovedTo :: Maybe Text , fnCallable :: Callable
lib/Data/GI/GIR/Method.hs view
@@ -18,6 +18,7 @@ data Method = Method { methodName :: Name,+ -- | The symbol in the dynlib that this method refers to. methodSymbol :: Text, methodType :: MethodType, methodMovedTo :: Maybe Text,
lib/Data/GI/GIR/Object.hs view
@@ -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
lib/Data/GI/GIR/Parser.hs view
@@ -1,6 +1,7 @@ -- | The Parser monad. module Data.GI.GIR.Parser ( Parser+ , ParseContext(..) , ParseError , parseError @@ -33,14 +34,12 @@ , Documentation ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif- import Control.Monad.Except import Control.Monad.Reader +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Read as TR
lib/Data/GI/GIR/Property.hs view
@@ -5,10 +5,12 @@ ) where import Data.Text (Text)+#if !MIN_VERSION_base(4,11,0) 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) @@ -24,6 +26,8 @@ propFlags :: [PropertyFlag], propReadNullable :: Maybe Bool, propWriteNullable :: Maybe Bool,+ propSetter :: Maybe Text,+ propGetter :: Maybe Text, propTransfer :: Transfer, propDoc :: Documentation, propDeprecated :: Maybe DeprecationInfo@@ -33,12 +37,15 @@ 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 []) <> (if writable then [PropertyWritable] else []) <> (if construct then [PropertyConstruct] else [])@@ -51,7 +58,8 @@ , propTransfer = transfer , propDeprecated = deprecated , propDoc = doc- -- No support in the GIR for nullability info- , propReadNullable = Nothing- , propWriteNullable = Nothing+ , propReadNullable = maybeNullable+ , propWriteNullable = maybeNullable+ , propSetter = setter+ , propGetter = getter }
lib/Data/GI/GIR/Repository.hs view
@@ -49,8 +49,13 @@ then reverse acc : go ys [] else go ys (y : acc) +-- | Return the paths where to look for gir files. girDataDirs :: IO [FilePath]-girDataDirs = getSystemDataDirs "gir-1.0"+girDataDirs = do+ sys <- getSystemDataDirs "gir-1.0"+ -- See https://github.com/haskell-gi/haskell-gi/issues/390+ let macOS = ["/opt/homebrew/share/gir-1.0"]+ return (sys ++ macOS) -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit
lib/Data/GI/GIR/Signal.hs view
@@ -12,12 +12,14 @@ sigName :: Text, sigCallable :: Callable, sigDeprecated :: Maybe DeprecationInfo,+ sigDetailed :: Bool, sigDoc :: Documentation } deriving (Show, Eq) parseSignal :: Parser Signal parseSignal = do n <- getAttr "name"+ detailed <- optionalAttr "detailed" False parseBool deprecated <- parseDeprecation callable <- parseCallable doc <- parseDocumentation@@ -25,5 +27,6 @@ sigName = n , sigCallable = callable , sigDeprecated = deprecated+ , sigDetailed = detailed , sigDoc = doc }
lib/Data/GI/GIR/Struct.hs view
@@ -21,6 +21,7 @@ gtypeStructFor :: Maybe Name, -- https://bugzilla.gnome.org/show_bug.cgi?id=560248 structIsDisguised :: Bool,+ structForceVisible :: Bool, structFields :: [Field], structMethods :: [Method], structDeprecated :: Maybe DeprecationInfo,@@ -38,6 +39,7 @@ typeInit <- queryAttrWithNamespace GLibGIRNS "get-type" maybeCType <- queryCType disguised <- optionalAttr "disguised" False parseBool+ forceVisible <- optionalAttr "haskell-gi-force-visible" False parseBool fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)@@ -51,6 +53,7 @@ , structSize = error ("[size] unfixed struct " ++ show name) , gtypeStructFor = structFor , structIsDisguised = disguised+ , structForceVisible = forceVisible , structFields = fields , structMethods = constructors ++ methods ++ functions , structDeprecated = deprecated
lib/Data/GI/GIR/Type.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type@@ -8,17 +9,14 @@ , parseOptionalType ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif+#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@@ -49,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.@@ -96,10 +87,17 @@ -- | 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) +-- | Parse a `GClosure` declaration.+parseClosure :: Parser Type+parseClosure = queryAttr "closure-type" >>= \case+ Just t -> (TGClosure . Just) <$> parseTypeName t+ Nothing -> return $ TGClosure Nothing+ -- | For GLists and GSLists there is sometimes no information about -- the type of the elements. In these cases we report them as -- pointers.@@ -116,18 +114,16 @@ 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) --- | Parse information on a "type" element. Returns either a `Type`,--- or `Nothing` indicating that the name of the type in the--- introspection data was "none" (associated with @void@ in C).-parseTypeInfo :: Parser (Maybe Type)-parseTypeInfo = do- typeName <- getAttr "name"- if typeName == "none"- then return Nothing- else Just <$> case nameToBasicType typeName of+-- | Parse a type given as a string.+parseTypeName :: Text -> Parser Type+parseTypeName typeName = case nameToBasicType typeName of Just b -> return (TBasicType b) Nothing -> case T.split ('.' ==) typeName of [ns, n] -> parseFundamentalType ns n@@ -136,6 +132,16 @@ parseFundamentalType ns n _ -> parseError $ "Unsupported type form: \"" <> typeName <> "\""++-- | Parse information on a "type" element. Returns either a `Type`,+-- or `Nothing` indicating that the name of the type in the+-- introspection data was "none" (associated with @void@ in C).+parseTypeInfo :: Parser (Maybe Type)+parseTypeInfo = do+ typeName <- getAttr "name"+ if typeName == "none"+ then return Nothing+ else Just <$> parseTypeName typeName -- | Find the children giving the type of the given element. parseTypeElements :: Parser [Maybe Type]