diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/DocTests.hs b/DocTests.hs --- a/DocTests.hs +++ b/DocTests.hs @@ -1,20 +1,17 @@ -import Test.DocTest +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) import System.Process main :: IO () main = do - gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" - doctest $ [ "-XCPP", "-XOverloadedStrings", "-XRankNTypes", "-XLambdaCase" - , "-ilib" - -- For the autogenerated Data.GI.CodeGen.GType (hsc) - , "-idist/build" - , "dist/build/lib/c/enumStorage.o" - ] ++ gobjectIntrospectionLibs ++ - -- The actual modules to test - [ "Data.GI.CodeGen.GtkDoc" - , "Data.GI.CodeGen.ModulePath" - , "Data.GI.CodeGen.SymbolNaming" - , "Data.GI.CodeGen.Haddock" ] + gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0" +-- traverse_ putStrLn args -- optionally print arguments + doctest (gobjectIntrospectionLibs ++ args) + where + args = flags ++ pkgs ++ module_sources pkgConfigLibs :: String -> IO [String] pkgConfigLibs pkg = words <$> readProcess "pkg-config" ["--libs", pkg] "" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,6 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMain +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,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 diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs --- a/lib/Data/GI/CodeGen/API.hs +++ b/lib/Data/GI/CodeGen/API.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Cabal.hs +++ /dev/null @@ -1,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" diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -1,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) diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -3,10 +3,9 @@ ( Code , ModuleInfo(moduleCode, sectionDocs) , ModuleFlag(..) - , BaseCodeGen , CodeGen , ExcCodeGen - , CGError(..) + , CGError , genCode , evalCodeGen @@ -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. diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Config.hs b/lib/Data/GI/CodeGen/Config.hs --- a/lib/Data/GI/CodeGen/Config.hs +++ b/lib/Data/GI/CodeGen/Config.hs @@ -7,8 +7,15 @@ import Data.GI.CodeGen.Overrides (Overrides) data Config = Config { - -- | Name of the module being generated. + -- | GIR name of the module being generated (Gtk, GObject, ...). modName :: Text, + -- | Version of the GIR API for the package being generated + -- ("3.0", "2.0", ...). + modVersion :: Text, + -- | Haskell package being generated (gi-gtk, gi-gobject, ...). + ghcPkgName :: Text, + -- | Version of the haskell package ("3.0.35", "2.0.21", ...). + ghcPkgVersion :: Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator. diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs --- a/lib/Data/GI/CodeGen/Constant.hs +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -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" diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/Conversions.hs +++ /dev/null @@ -1,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 diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -0,0 +1,1157 @@ +{-# LANGUAGE PatternGuards, DeriveFunctor #-} + +module Data.GI.CodeGen.Conversions + ( convert + , genConversion + , unpackCArray + , computeArrayLength + + , callableHasClosures + + , hToF + , fToH + , transientToH + , haskellType + , isoHaskellType + , foreignType + + , argumentType + , ExposeClosures(..) + , elementType + , elementMap + , elementTypeAndMap + + , isManaged + , typeIsNullable + , typeIsPtr + , typeIsCallback + , maybeNullConvert + , nullPtrForType + + , typeAllocInfo + , TypeAllocInfo(..) + + , apply + , mapC + , literal + , Constructor(..) + ) where + +#include + +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif + +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Exts (IsString(..)) + +import Foreign.C.Types (CInt, CUInt) +import Foreign.Storable (sizeOf) + +import Data.GI.CodeGen.API +import Data.GI.CodeGen.Code +import Data.GI.CodeGen.GObject +import Data.GI.CodeGen.SymbolNaming +import Data.GI.CodeGen.Type +import Data.GI.CodeGen.Util + +-- | The free monad. +data Free f r = Free (f (Free f r)) | Pure r + +instance Functor f => Functor (Free f) where + fmap f = go where + go (Pure a) = Pure (f a) + go (Free fa) = Free (go <$> fa) + +instance (Functor f) => Applicative (Free f) where + pure = Pure + Pure a <*> Pure b = Pure $ a b + Pure a <*> Free mb = Free $ fmap a <$> mb + Free ma <*> b = Free $ (<*> b) <$> ma + +instance (Functor f) => Monad (Free f) where + (Free x) >>= f = Free (fmap (>>= f) x) + (Pure r) >>= f = f r + +-- | Lift some command to the Free monad. +liftF :: (Functor f) => f r -> Free f r +liftF command = Free (fmap Pure command) + +-- String identifying a constructor in the generated code, which is +-- either (by default) a pure function (indicated by the P +-- constructor) or a function returning values on a monad (M +-- constructor). 'Id' denotes the identity function. +data Constructor = P Text | M Text | Id + deriving (Eq,Show) +instance IsString Constructor where + fromString = P . T.pack + +data FExpr next = Apply Constructor next + | LambdaConvert Text next + | MapC Map Constructor next + | Literal Constructor next + deriving (Show, Functor) + +type Converter = Free FExpr () + +-- Different available maps. +data Map = Map | MapFirst | MapSecond + deriving (Show) + +-- Naming for the maps. +mapName :: Map -> Text +mapName Map = "map" +mapName MapFirst = "mapFirst" +mapName MapSecond = "mapSecond" + +-- Naming for the monadic versions of the maps that we use +monadicMapName :: Map -> Text +monadicMapName Map = "mapM" +monadicMapName MapFirst = "mapFirstA" +monadicMapName MapSecond = "mapSecondA" + +apply :: Constructor -> Converter +apply f = liftF $ Apply f () + +mapC :: Constructor -> Converter +mapC f = liftF $ MapC Map f () + +mapFirst :: Constructor -> Converter +mapFirst f = liftF $ MapC MapFirst f () + +mapSecond :: Constructor -> Converter +mapSecond f = liftF $ MapC MapSecond f () + +literal :: Constructor -> Converter +literal f = liftF $ Literal f () + +lambdaConvert :: Text -> Converter +lambdaConvert c = liftF $ LambdaConvert c () + +genConversion :: Text -> Converter -> CodeGen e Text +genConversion l (Pure ()) = return l +genConversion l (Free k) = do + let l' = prime l + case k of + Apply (P f) next -> + do line $ "let " <> l' <> " = " <> f <> " " <> l + genConversion l' next + Apply (M f) next -> + do line $ l' <> " <- " <> f <> " " <> l + genConversion l' next + Apply Id next -> genConversion l next + + MapC m (P f) next -> + do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l + genConversion l' next + MapC m (M f) next -> + do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l + genConversion l' next + MapC _ Id next -> genConversion l next + + LambdaConvert conv next -> + do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do" + increaseIndent + genConversion l' next + + Literal (P f) next -> + do line $ "let " <> l <> " = " <> f + genConversion l next + Literal (M f) next -> + do line $ l <> " <- " <> f + genConversion l next + Literal Id next -> genConversion l next + +-- | Given an array, together with its type, return the code for reading +-- its length. +computeArrayLength :: Text -> Type -> ExcCodeGen Text +computeArrayLength array (TCArray _ _ _ t) = do + reader <- findReader + return $ "fromIntegral $ " <> reader <> " " <> array + where findReader = case t of + TBasicType TUInt8 -> return "B.length" + _ -> return "P.length" +computeArrayLength _ t = + notImplementedError $ "computeArrayLength called on non-CArray type " + <> tshow t + +convert :: Text -> CodeGen e Converter -> CodeGen e Text +convert l c = do + c' <- c + genConversion l c' + +hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor +hObjectToF t transfer = + if transfer == TransferEverything + then do + isGO <- isGObject t + if isGO + then return $ M "B.ManagedPtr.disownObject" + else return $ M "B.ManagedPtr.disownManagedPtr" + -- castPtr since we accept any instance of the class associated with + -- the GObject, not just the precise type of the GObject, while the + -- foreign function declaration requires a pointer of the precise + -- type. + else return $ M "unsafeManagedPtrCastPtr" + +hVariantToF :: Transfer -> CodeGen e Constructor +hVariantToF transfer = + if transfer == TransferEverything + then return $ M "B.GVariant.disownGVariant" + else return $ M "unsafeManagedPtrGetPtr" + +hValueToF :: Transfer -> CodeGen e Constructor +hValueToF transfer = + if transfer == TransferEverything + then return $ M "B.GValue.disownGValue" + else return $ M "unsafeManagedPtrGetPtr" + +hParamSpecToF :: Transfer -> CodeGen e Constructor +hParamSpecToF transfer = + if transfer == TransferEverything + then return $ M "B.GParamSpec.disownGParamSpec" + else return $ M "unsafeManagedPtrGetPtr" + +hClosureToF :: Transfer -> Maybe Type -> CodeGen e Constructor +-- Untyped closures +hClosureToF transfer Nothing = + -- We cast the pointer here because the foreign type for untyped + -- closures is always represented as Ptr (GClosure ()), while the + -- corresponding Haskell type is the parametric "GClosure a". + if transfer == TransferEverything + then return $ M "FP.castPtr <$> B.GClosure.disownGClosure" + else return $ M "unsafeManagedPtrCastPtr" +-- Typed closures +hClosureToF transfer (Just _) = + if transfer == TransferEverything + then return $ M "B.GClosure.disownGClosure" + else return $ M "unsafeManagedPtrGetPtr" + +hBoxedToF :: Transfer -> CodeGen e Constructor +hBoxedToF transfer = + if transfer == TransferEverything + then return $ M "B.ManagedPtr.disownBoxed" + else return $ M "unsafeManagedPtrGetPtr" + +hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor +hStructToF s transfer = + if transfer /= TransferEverything || structIsBoxed s then + hBoxedToF transfer + else do + when (structSize s == 0) $ + badIntroError "Transferring a non-boxed struct with unknown size!" + return $ M "unsafeManagedPtrGetPtr" + +hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor +hUnionToF u transfer = + if transfer /= TransferEverything || unionIsBoxed u then + hBoxedToF transfer + else do + when (unionSize u == 0) $ + badIntroError "Transferring a non-boxed union with unknown size!" + return $ M "unsafeManagedPtrGetPtr" + +-- Given the Haskell and Foreign types, returns the name of the +-- function marshalling between both. +hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +hToF' t a hType fType transfer + | ( hType == fType ) = return Id + | TError <- t = hBoxedToF transfer + | TVariant <- t = hVariantToF transfer + | TGValue <- t = hValueToF transfer + | TParamSpec <- t = hParamSpecToF transfer + | TGClosure c <- t = hClosureToF transfer c + | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)" + | Just (APIFlags _) <- a = return "gflagsToWord" + | Just (APIObject _) <- a = hObjectToF t transfer + | Just (APIInterface _) <- a = hObjectToF t transfer + | Just (APIStruct s) <- a = hStructToF s transfer + | Just (APIUnion u) <- a = hUnionToF u transfer + -- Converting callback types requires more context, we leave that + -- as a special case to be implemented by the caller. + | Just (APICallback _) <- a = error "Cannot handle callback type here!! " + | TByteArray <- t = return $ M "packGByteArray" + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "packZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "packZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TPtr) <- t = + return $ M "packZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "packZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "packZeroTerminatedStorableArray" + | TCArray False _ _ (TBasicType TUTF8) <- t = + return $ M "packUTF8CArray" + | TCArray False _ _ (TBasicType TFileName) <- t = + return $ M "packFileNameArray" + | TCArray False _ _ (TBasicType TPtr) <- t = + return $ M "packPtrArray" + | TCArray False _ _ (TBasicType TUInt8) <- t = + return $ M "packByteString" + | TCArray False _ _ (TBasicType TBoolean) <- t = + return $ M "(packMapStorableArray (P.fromIntegral . P.fromEnum))" + | TCArray False _ _ (TBasicType TGType) <- t = + return $ M "(packMapStorableArray gtypeToCGType)" + | TCArray False _ _ (TBasicType TFloat) <- t = + return $ M "(packMapStorableArray realToFrac)" + | TCArray False _ _ (TBasicType TDouble) <- t = + return $ M "(packMapStorableArray realToFrac)" + | TCArray False _ _ (TBasicType TUniChar) <- t = + return $ M "(packMapStorableArray (P.fromIntegral . SP.ord))" + | TCArray False _ _ (TBasicType _) <- t = + return $ M "packStorableArray" + | TCArray False _ _ TGValue <- t = + return $ M "B.GValue.packGValueArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to pack C array of type " <> tshow t + | otherwise = case (typeShow hType, typeShow fType) of + ("T.Text", "CString") -> return $ M "textToCString" + ("[Char]", "CString") -> return $ M "stringToCString" + ("Char", "CInt") -> return "(P.fromIntegral . SP.ord)" + ("Bool", "CInt") -> return "(P.fromIntegral . P.fromEnum)" + ("Float", "CFloat") -> return "realToFrac" + ("Double", "CDouble") -> return "realToFrac" + ("GType", "CGType") -> return "gtypeToCGType" + _ -> notImplementedError $ + "Don't know how to convert " + <> typeShow hType <> " into " + <> typeShow fType <> ".\n" + <> "Internal type: " + <> tshow t + +getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getForeignConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + hToF' t a hType fType transfer + +hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter +hToF_PackedType t packer transfer = do + innerConstructor <- getForeignConstructor t transfer + return $ do + mapC innerConstructor + apply (M packer) + +-- | Try to find the `hash` and `equal` functions appropriate for the +-- given type, when used as a key in a GHashTable. +hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text) +hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual") +hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") +hashTableKeyMappings t = + notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported." + +-- | `GHashTable` tries to fit every type into a pointer, the +-- following function tries to find the appropriate +-- (destroy,packer,unpacker) for the given type. +hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text) +hashTablePtrPackers (TBasicType TPtr) = + return ("Nothing", "B.GHT.ptrPackPtr", "B.GHT.ptrUnpackPtr") +hashTablePtrPackers (TBasicType TUTF8) = + return ("(Just ptr_to_g_free)", "B.GHT.cstringPackPtr", "B.GHT.cstringUnpackPtr") +hashTablePtrPackers TGValue = + return ("(Just B.GValue.ptr_to_gvalue_free)", "B.GHT.gvaluePackPtr", + "B.GHT.gvalueUnpackPtr") +hashTablePtrPackers t = + notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported." + +hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter +hToF_PackGHashTable keys elems = do + -- We will be adding elements to the Hash list with appropriate + -- destructors, so we always want a fresh copy. + keysConstructor <- getForeignConstructor keys TransferEverything + elemsConstructor <- getForeignConstructor elems TransferEverything + (keyHash, keyEqual) <- hashTableKeyMappings keys + (keyDestroy, keyPack, _) <- hashTablePtrPackers keys + (elemDestroy, elemPack, _) <- hashTablePtrPackers elems + return $ do + apply (P "Map.toList") + mapFirst keysConstructor + mapSecond elemsConstructor + mapFirst (P keyPack) + mapSecond (P elemPack) + apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual, + keyDestroy, elemDestroy])) + +hToF :: Type -> Transfer -> ExcCodeGen Converter +hToF (TGList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("'" <> tshow t <> + "' is not a pointer type, cannot pack into a GList.") + hToF_PackedType t "packGList" transfer +hToF (TGSList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("'" <> tshow t <> + "' is not a pointer type, cannot pack into a GSList.") + hToF_PackedType t "packGSList" transfer +hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer +hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer +hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb +hToF (TCArray zt _ _ t@(TCArray{})) transfer = do + let packer = if zt + then "packZeroTerminated" + else "pack" + hToF_PackedType t (packer <> "PtrArray") transfer +hToF (TCArray zt _ _ t@(TInterface _)) transfer = do + isScalar <- typeIsEnumOrFlag t + let packer = if zt + then "packZeroTerminated" + else "pack" + if isScalar + then hToF_PackedType t (packer <> "StorableArray") transfer + else do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then hToF_PackedType t (packer <> "PtrArray") transfer + else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer + +hToF t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- hToF' t a hType fType transfer + return $ apply constructor + +boxedForeignPtr :: Text -> Transfer -> CodeGen e Constructor +boxedForeignPtr constructor transfer = return $ + case transfer of + TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor + _ -> M $ parenthesize $ "newBoxed " <> constructor + +suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen e Constructor +suForeignPtr isBoxed hType transfer = do + let constructor = typeConName hType + if isBoxed then + boxedForeignPtr constructor transfer + else return $ M $ parenthesize $ + case transfer of + TransferEverything -> "wrapPtr " <> constructor + _ -> "newPtr " <> constructor + +structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen e Constructor +structForeignPtr s = + suForeignPtr (structIsBoxed s) + +unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen e Constructor +unionForeignPtr u = + suForeignPtr (unionIsBoxed u) + +fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor +fObjectToH t hType transfer = do + let constructor = typeConName hType + isGO <- isGObject t + return $ M $ parenthesize $ + case transfer of + TransferEverything -> + if isGO + then "wrapObject " <> constructor + else "wrapPtr " <> constructor + _ -> + if isGO + then "newObject " <> constructor + else "newPtr " <> constructor + +fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor +fCallbackToH hType TransferNothing = do + let constructor = typeConName hType + return (P (callbackDynamicWrapper constructor)) +fCallbackToH _ transfer = + notImplementedError ("ForeignCallback with unsupported transfer type `" + <> tshow transfer <> "'") + +fVariantToH :: Transfer -> CodeGen e Constructor +fVariantToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GVariant.wrapGVariantPtr" + _ -> "B.GVariant.newGVariantFromPtr" + +fValueToH :: Transfer -> CodeGen e Constructor +fValueToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GValue.wrapGValuePtr" + _ -> "B.GValue.newGValueFromPtr" + +fParamSpecToH :: Transfer -> CodeGen e Constructor +fParamSpecToH transfer = + return $ M $ case transfer of + TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr" + _ -> "B.GParamSpec.newGParamSpecFromPtr" + +fClosureToH :: Transfer -> Maybe Type -> CodeGen e Constructor +-- Untyped closures +fClosureToH transfer Nothing = + return $ M $ case transfer of + TransferEverything -> + parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr" + _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr" +-- Typed closures +fClosureToH transfer (Just _) = + return $ M $ case transfer of + TransferEverything -> "B.GClosure.wrapGClosurePtr" + _ -> "B.GClosure.newGClosureFromPtr" + +fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer + -> ExcCodeGen Constructor +fToH' t a hType fType transfer + | ( hType == fType ) = return Id + | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)" + | Just (APIFlags _) <- a = return "wordToGFlags" + | TError <- t = boxedForeignPtr "GError" transfer + | TVariant <- t = fVariantToH transfer + | TGValue <- t = fValueToH transfer + | TParamSpec <- t = fParamSpecToH transfer + | TGClosure c <- t = fClosureToH transfer c + | Just (APIStruct s) <- a = structForeignPtr s hType transfer + | Just (APIUnion u) <- a = unionForeignPtr u hType transfer + | Just (APIObject _) <- a = fObjectToH t hType transfer + | Just (APIInterface _) <- a = fObjectToH t hType transfer + | Just (APICallback _) <- a = fCallbackToH hType transfer + | TCArray True _ _ (TBasicType TUTF8) <- t = + return $ M "unpackZeroTerminatedUTF8CArray" + | TCArray True _ _ (TBasicType TFileName) <- t = + return $ M "unpackZeroTerminatedFileNameArray" + | TCArray True _ _ (TBasicType TUInt8) <- t = + return $ M "unpackZeroTerminatedByteString" + | TCArray True _ _ (TBasicType TPtr) <- t = + return $ M "unpackZeroTerminatedPtrArray" + | TCArray True _ _ (TBasicType TBoolean) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))" + | TCArray True _ _ (TBasicType TGType) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray GType)" + | TCArray True _ _ (TBasicType TFloat) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType TDouble) <- t = + return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)" + | TCArray True _ _ (TBasicType _) <- t = + return $ M "unpackZeroTerminatedStorableArray" + | TCArray{} <- t = notImplementedError $ + "Don't know how to unpack C array of type " <> tshow t + | TByteArray <- t = return $ M "unpackGByteArray" + | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet" + | otherwise = case (typeShow fType, typeShow hType) of + ("CString", "T.Text") -> return $ M "cstringToText" + ("CString", "[Char]") -> return $ M "cstringToString" + ("CInt", "Char") -> return "(chr . fromIntegral)" + ("CInt", "Bool") -> return "(/= 0)" + ("CFloat", "Float") -> return "realToFrac" + ("CDouble", "Double") -> return "realToFrac" + ("CGType", "GType") -> return "GType" + _ -> + notImplementedError $ "Don't know how to convert " + <> typeShow fType <> " into " + <> typeShow hType <> ".\n" + <> "Internal type: " + <> tshow t + +getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor +getHaskellConstructor t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + fToH' t a hType fType transfer + +fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter +fToH_PackedType t unpacker transfer = do + innerConstructor <- getHaskellConstructor t transfer + return $ do + apply (M unpacker) + mapC innerConstructor + +fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter +fToH_UnpackGHashTable keys elems transfer = do + keysConstructor <- getHaskellConstructor keys transfer + (_,_,keysUnpack) <- hashTablePtrPackers keys + elemsConstructor <- getHaskellConstructor elems transfer + (_,_,elemsUnpack) <- hashTablePtrPackers elems + return $ do + apply (M "unpackGHashTable") + mapFirst (P keysUnpack) + mapFirst keysConstructor + mapSecond (P elemsUnpack) + mapSecond elemsConstructor + apply (P "Map.fromList") + +fToH :: Type -> Transfer -> ExcCodeGen Converter +fToH (TGList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("`" <> tshow t <> + "' is not a pointer type, cannot unpack from a GList.") + fToH_PackedType t "unpackGList" transfer +fToH (TGSList t) transfer = do + isPtr <- typeIsPtr t + when (not isPtr) $ + badIntroError ("`" <> tshow t <> + "' is not a pointer type, cannot unpack from a GSList.") + fToH_PackedType t "unpackGSList" transfer +fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer +fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer +fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer +-- We cannot unpack arrays without any kind of length info. +fToH t@(TCArray False (-1) (-1) _) _ = + badIntroError ("`" <> tshow t <> + "' is an array type, but contains no length information.") +fToH (TCArray True _ _ t@(TCArray{})) transfer = + fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer +fToH (TCArray True _ _ t@(TInterface _)) transfer = do + isScalar <- typeIsEnumOrFlag t + if isScalar + then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer + else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer + +fToH t transfer = do + a <- findAPI t + hType <- haskellType t + fType <- foreignType t + constructor <- fToH' t a hType fType transfer + return $ apply constructor + +-- | Somewhat like `fToH`, but with slightly different borrowing +-- semantics: in the case of `TransferNothing` we wrap incoming +-- pointers to boxed structs into transient `ManagedPtr`s (every other +-- case behaves as `fToH`). These are `ManagedPtr`s for which we do +-- not make a copy, and which will be disowned when the function +-- exists, instead of making a copy that the GC will collect +-- eventually. +-- +-- This is necessary in order to get the semantics of callbacks and +-- signals right: in some cases making a copy of the object does not +-- simply increase the refcount, but rather makes a full copy. In this +-- cases modification of the original object is not possible, but this +-- is sometimes useful, see for example +-- +-- https://github.com/haskell-gi/haskell-gi/issues/97 +-- +-- Another situation where making a copy of incoming arguments is +-- problematic is when the underlying library is not thread-safe. When +-- running under the threaded GHC runtime it can happen that the GC +-- runs on a different OS thread than the thread where the object was +-- created, and this leads to rather mysterious bugs, see for example +-- +-- https://github.com/haskell-gi/haskell-gi/issues/96 +-- +-- This case is particularly nasty, since it affects `onWidgetDraw`, +-- which is very common. +transientToH :: Type -> Transfer -> ExcCodeGen Converter +transientToH t@(TInterface _) TransferNothing = do + a <- findAPI t + case a of + Just (APIStruct s) -> if structIsBoxed s + then wrapTransient + else fToH t TransferNothing + Just (APIUnion u) -> if unionIsBoxed u + then wrapTransient + else fToH t TransferNothing + _ -> fToH t TransferNothing +transientToH t transfer = fToH t transfer + +-- | Wrap the given transient. +wrapTransient :: CodeGen e Converter +wrapTransient = return $ lambdaConvert $ "B.ManagedPtr.withTransient " + +unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter +unpackCArray length (TCArray False _ _ t) transfer = + case t of + TBasicType TUTF8 -> return $ apply $ M $ parenthesize $ + "unpackUTF8CArrayWithLength " <> length + TBasicType TFileName -> return $ apply $ M $ parenthesize $ + "unpackFileNameArrayWithLength " <> length + TBasicType TUInt8 -> return $ apply $ M $ parenthesize $ + "unpackByteStringWithLength " <> length + TBasicType TPtr -> return $ apply $ M $ parenthesize $ + "unpackPtrArrayWithLength " <> length + TBasicType TBoolean -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (/= 0) " <> length + TBasicType TGType -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength GType " <> length + TBasicType TFloat -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " <> length + TBasicType TDouble -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength realToFrac " <> length + TBasicType TUniChar -> return $ apply $ M $ parenthesize $ + "unpackMapStorableArrayWithLength (SP.chr . P.fromIntegral) " <> length + TBasicType _ -> return $ apply $ M $ parenthesize $ + "unpackStorableArrayWithLength " <> length + TGValue -> return $ apply $ M $ parenthesize $ + "B.GValue.unpackGValueArrayWithLength " <> length + TInterface _ -> do + a <- findAPI t + isScalar <- typeIsEnumOrFlag t + hType <- haskellType t + fType <- foreignType t + let (boxed, size) = case a of + Just (APIStruct s) -> (structIsBoxed s, structSize s) + Just (APIUnion u) -> (unionIsBoxed u, unionSize u) + _ -> (False, 0) + let unpacker | isScalar = "unpackStorableArrayWithLength" + | (size == 0) = "unpackPtrArrayWithLength" + | boxed = "unpackBoxedArrayWithLength " <> tshow size + | otherwise = "unpackBlockArrayWithLength " <> tshow size + -- We always make a copy of the elements when unpacking + -- boxed types. + let transfer' | boxed = if transfer == TransferContainer + then TransferEverything + else transfer + | otherwise = transfer + innerConstructor <- fToH' t a hType fType transfer' + return $ do + apply $ M $ parenthesize $ unpacker <> " " <> length + mapC innerConstructor + _ -> notImplementedError $ + "unpackCArray : Don't know how to unpack C Array of type " <> tshow t + +unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." + +-- | Whether to expose closures and the associated destroy notify +-- handlers in the Haskell wrapper. +data ExposeClosures = WithClosures + | WithoutClosures + deriving (Eq) + +-- | Given a type find the typeclasses the type belongs to, and return +-- the representation of the type in the function signature and the +-- list of typeclass constraints for the type. +argumentType :: Type -> ExposeClosures -> CodeGen e (Text, [Text]) +argumentType (TGList a) expose = do + (name, constraints) <- argumentType a expose + return ("[" <> name <> "]", constraints) +argumentType (TGSList a) expose = do + (name, constraints) <- argumentType a expose + return ("[" <> name <> "]", constraints) +argumentType t expose = do + api <- findAPI t + s <- typeShow <$> haskellType t + case api of + -- Instead of restricting to the actual class, + -- we allow for any object descending from it. + Just (APIInterface _) -> do + cls <- typeConstraint t + l <- getFreshTypeVariable + return (l, [cls <> " " <> l]) + Just (APIObject _) -> do + cls <- typeConstraint t + l <- getFreshTypeVariable + return (l, [cls <> " " <> l]) + Just (APICallback cb) -> + -- See [Note: Callables that throw] + if callableThrows (cbCallable cb) + then do + ft <- typeShow <$> foreignType t + return (ft, []) + else + case expose of + WithClosures -> do + s_withClosures <- typeShow <$> isoHaskellType t + return (s_withClosures, []) + WithoutClosures -> + return (s, []) + _ -> return (s, []) + +haskellBasicType :: BasicType -> TypeRep +haskellBasicType TPtr = ptr $ con0 "()" +haskellBasicType TBoolean = con0 "Bool" +-- For all the platforms that we support (and those supported by glib) +-- we have gint == gint32. Encoding this assumption in the types saves +-- conversions. +haskellBasicType TInt = case sizeOf (0 :: CInt) of + 4 -> con0 "Int32" + n -> error ("Unsupported `gint' length: " ++ + show n) +haskellBasicType TUInt = case sizeOf (0 :: CUInt) of + 4 -> con0 "Word32" + n -> error ("Unsupported `guint' length: " ++ + show n) +haskellBasicType TLong = con0 "FCT.CLong" +haskellBasicType TULong = con0 "FCT.CULong" +haskellBasicType TInt8 = con0 "Int8" +haskellBasicType TUInt8 = con0 "Word8" +haskellBasicType TInt16 = con0 "Int16" +haskellBasicType TUInt16 = con0 "Word16" +haskellBasicType TInt32 = con0 "Int32" +haskellBasicType TUInt32 = con0 "Word32" +haskellBasicType TInt64 = con0 "Int64" +haskellBasicType TUInt64 = con0 "Word64" +haskellBasicType TGType = con0 "GType" +haskellBasicType TUTF8 = con0 "T.Text" +haskellBasicType TFloat = con0 "Float" +haskellBasicType TDouble = con0 "Double" +haskellBasicType TUniChar = con0 "Char" +haskellBasicType TFileName = con0 "[Char]" +haskellBasicType TIntPtr = con0 "CIntPtr" +haskellBasicType TUIntPtr = con0 "CUIntPtr" +haskellBasicType TShort = con0 "FCT.CShort" +haskellBasicType TUShort = con0 "FCT.CUShort" +haskellBasicType TSSize = +#if defined(HTYPE_SSIZE_T) + con0 "SPT.CSsize" +#else + int #{size gsize} +#endif +haskellBasicType TSize = con0 "FCT.CSize" +haskellBasicType Ttime_t = con0 "FCT.CTime" +haskellBasicType Toff_t = +#if defined(HTYPE_OFF_T) + con0 "SPT.COff" +#else + -- If the type is not defined there's not much we can do, other than + -- guessing. The values below are correct on Linux amd64. In + -- practice it will hopefully not be much of an issue with newer + -- versions of GHC, since platforms lacking the definition will + -- (hopefully) also not have the relevant types in the available + -- APIs. The same remark applies to the types below. + int 8 +#endif +haskellBasicType Tdev_t = +#if defined(HTYPE_DEV_T) + con0 "SPT.CDev" +#else + uint 8 +#endif +haskellBasicType Tgid_t = +#if defined(HTYPE_GID_T) + con0 "SPT.CGid" +#else + uint 4 +#endif +haskellBasicType Tpid_t = +#if defined(HTYPE_PID_T) + con0 "SPT.CPid" +#else + int 4 +#endif +haskellBasicType Tsocklen_t = +#if defined(HTYPE_SOCKLEN_T) + con0 "SPT.CSocklen" +#else + uint 4 +#endif +haskellBasicType Tuid_t = +#if defined(HTYPE_UID_T) + con0 "SPT.CUid" +#else + uint 4 +#endif + +-- | Return the unsigned int type with the given amount of bytes. +uint :: Int -> TypeRep +uint n = con0 ("DW.Word" <> tshow (n*8)) + +-- | Return the (signed) int type with the given amount of bytes. +int :: Int -> TypeRep +int n = con0 ("DI.Int" <> tshow (n*8)) + +-- | This translates GI types to the types used for generated Haskell code. +haskellType :: Type -> CodeGen e TypeRep +haskellType (TBasicType bt) = return $ haskellBasicType bt +-- There is no great choice in this case, so we simply pass the +-- pointer along. This is useful for GdkPixbufNotify, for example. +haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) = + foreignType t +haskellType (TCArray _ _ _ (TBasicType TUInt8)) = + return $ "ByteString" `con` [] +haskellType (TCArray _ _ _ a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TPtrArray a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TByteArray) = return $ "ByteString" `con` [] +haskellType (TGList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGSList a) = do + inner <- haskellType a + return $ "[]" `con` [inner] +haskellType (TGHash a b) = do + innerA <- haskellType a + innerB <- haskellType b + return $ "Map.Map" `con` [innerA, innerB] +haskellType TError = return $ "GError" `con` [] +haskellType TVariant = return $ "GVariant" `con` [] +haskellType TParamSpec = return $ "GParamSpec" `con` [] +haskellType (TGClosure (Just inner@(TInterface n))) = do + innerAPI <- getAPI inner + case innerAPI of + APICallback _ -> do + let n' = normalizedAPIName innerAPI n + tname <- qualifiedSymbol (callbackCType $ name n') n + return $ "GClosure" `con` [con0 tname] + -- The given inner type does not make sense, so we treat it as an + -- untyped closure. + _ -> haskellType (TGClosure Nothing) +haskellType (TGClosure _) = do + tyvar <- getFreshTypeVariable + return $ "GClosure" `con` [con0 tyvar] +haskellType TGValue = return $ "GValue" `con` [] +haskellType t@(TInterface n) = do + api <- getAPI t + tname <- qualifiedAPI api n + return $ case api of + (APIFlags _) -> "[]" `con` [tname `con` []] + _ -> tname `con` [] + +-- | Whether the callable has closure arguments (i.e. "user_data" +-- style arguments). +callableHasClosures :: Callable -> Bool +callableHasClosures c = or . concatMap checkArg $ args c + where checkArg :: Arg -> [Bool] + checkArg arg = [argClosure arg /= -1, argCallbackUserData arg] + +-- | Check whether the given type corresponds to a callback. +typeIsCallback :: Type -> CodeGen e Bool +typeIsCallback t@(TInterface _) = do + api <- findAPI t + case api of + Just (APICallback _) -> return True + _ -> return False +typeIsCallback _ = return False + +-- | Basically like `haskellType`, but for types which admit a +-- "isomorphic" version of the Haskell type distinct from the usual +-- Haskell type. Generally the Haskell type we expose is isomorphic +-- to the foreign type, but in some cases, such as callbacks with +-- closure arguments, this does not hold, as we omit the closure +-- arguments. This function returns a type which is actually +-- isomorphic. +-- +-- There is another case this function deals with: for convenience +-- untyped `TGClosure` types have a type variable on the Haskell side +-- when they are arguments to functions, but we do not want this when +-- they appear as arguments to callbacks/signals, or return types of +-- properties, as it would force the type synonym/type family to +-- depend on the type variable. +isoHaskellType :: Type -> CodeGen e TypeRep +isoHaskellType (TGClosure Nothing) = + return $ "GClosure" `con` [con0 "()"] +isoHaskellType t@(TInterface n) = do + api <- findAPI t + case api of + Just apiCB@(APICallback cb) -> do + tname <- qualifiedAPI apiCB n + if callableHasClosures (cbCallable cb) + then return ((callbackHTypeWithClosures tname) `con` []) + else return (tname `con` []) + _ -> haskellType t +isoHaskellType t = haskellType t + +-- | Foreign (C) type associated to one of the basic types. +foreignBasicType :: BasicType -> TypeRep +foreignBasicType TBoolean = "CInt" `con` [] +foreignBasicType TUTF8 = "CString" `con` [] +foreignBasicType TFileName = "CString" `con` [] +foreignBasicType TUniChar = "CInt" `con` [] +foreignBasicType TFloat = "CFloat" `con` [] +foreignBasicType TDouble = "CDouble" `con` [] +foreignBasicType TGType = "CGType" `con` [] +foreignBasicType t = haskellBasicType t + +-- This translates GI types to the types used in foreign function calls. +foreignType :: Type -> CodeGen e TypeRep +foreignType (TBasicType t) = return $ foreignBasicType t +foreignType (TCArray _ _ _ TGValue) = return $ ptr ("B.GValue.GValue" `con` []) +foreignType (TCArray zt _ _ t) = do + api <- findAPI t + let size = case api of + Just (APIStruct s) -> structSize s + Just (APIUnion u) -> unionSize u + _ -> 0 + if size == 0 || zt + then ptr <$> foreignType t + else foreignType t +foreignType (TGArray a) = do + inner <- foreignType a + return $ ptr ("GArray" `con` [inner]) +foreignType (TPtrArray a) = do + inner <- foreignType a + return $ ptr ("GPtrArray" `con` [inner]) +foreignType (TByteArray) = return $ ptr ("GByteArray" `con` []) +foreignType (TGList a) = do + inner <- foreignType a + return $ ptr ("GList" `con` [inner]) +foreignType (TGSList a) = do + inner <- foreignType a + return $ ptr ("GSList" `con` [inner]) +foreignType (TGHash a b) = do + innerA <- foreignType a + innerB <- foreignType b + return $ ptr ("GHashTable" `con` [innerA, innerB]) +foreignType t@TError = ptr <$> haskellType t +foreignType t@TVariant = ptr <$> haskellType t +foreignType t@TParamSpec = ptr <$> haskellType t +foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"]) +foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t +foreignType t@(TGValue) = ptr <$> haskellType t +foreignType t@(TInterface n) = do + api <- getAPI t + let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e)) + ctypeForEnum e = if enumIsSigned e + then "CInt" + else "CUInt" + case api of + APIEnum e -> return $ (ctypeForEnum e) `con` [] + APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` [] + APICallback _ -> do + let n' = normalizedAPIName api n + tname <- qualifiedSymbol (callbackCType $ name n') n + return (funptr $ tname `con` []) + _ -> do + tname <- qualifiedAPI api n + return (ptr $ tname `con` []) + +-- | Whether the give type corresponds to an enum or flag. +typeIsEnumOrFlag :: Type -> CodeGen e Bool +typeIsEnumOrFlag t = do + a <- findAPI t + case a of + Nothing -> return False + (Just (APIEnum _)) -> return True + (Just (APIFlags _)) -> return True + _ -> return False + +-- | Information on how to allocate a type: allocator function and +-- size of the struct. +data TypeAllocInfo = TypeAlloc Text Int + +-- | Information on how to allocate the given type, if known. +typeAllocInfo :: Type -> CodeGen e (Maybe TypeAllocInfo) +typeAllocInfo TGValue = + let n = #{size GValue} + in return $ Just $ TypeAlloc ("SP.callocBytes " <> tshow n) n +typeAllocInfo (TGArray t) = do + api <- findAPI t + case api of + Just (APIStruct s) -> case structSize s of + 0 -> return Nothing + n -> let allocator = "B.GArray.allocGArray " <> tshow n + in return $ Just $ TypeAlloc allocator n + _ -> return Nothing +typeAllocInfo t = do + api <- findAPI t + case api of + Just (APIStruct s) -> + case structSize s of + 0 -> return Nothing + n -> let allocator = if structIsBoxed s + then "SP.callocBoxedBytes" + else "SP.callocBytes" + in return $ Just $ TypeAlloc (allocator <> " " <> tshow n) n + _ -> return Nothing + +-- | Returns whether the given type corresponds to a `ManagedPtr` +-- instance (a thin wrapper over a `ForeignPtr`). +isManaged :: Type -> CodeGen e Bool +isManaged TError = return True +isManaged TVariant = return True +isManaged TGValue = return True +isManaged TParamSpec = return True +isManaged (TGClosure _) = return True +isManaged t@(TInterface _) = do + a <- findAPI t + case a of + Just (APIObject _) -> return True + Just (APIInterface _) -> return True + Just (APIStruct _) -> return True + Just (APIUnion _) -> return True + _ -> return False +isManaged _ = return False + +-- | Returns whether the given type is represented by a pointer on the +-- C side. +typeIsPtr :: Type -> CodeGen e Bool +typeIsPtr t = isJust <$> typePtrType t + +-- | Distinct types of foreign pointers. +data FFIPtrType = FFIPtr -- ^ Ordinary `Ptr`. + | FFIFunPtr -- ^ `FunPtr`. + +-- | For those types represented by pointers on the C side, return the +-- type of pointer which represents them on the Haskell FFI. +typePtrType :: Type -> CodeGen e (Maybe FFIPtrType) +typePtrType (TBasicType TPtr) = return (Just FFIPtr) +typePtrType (TBasicType TUTF8) = return (Just FFIPtr) +typePtrType (TBasicType TFileName) = return (Just FFIPtr) +typePtrType t = do + ft <- foreignType t + case typeConName ft of + "Ptr" -> return (Just FFIPtr) + "FunPtr" -> return (Just FFIFunPtr) + _ -> return Nothing + +-- | If the passed in type is nullable, return the conversion function +-- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the +-- corresponding `Maybe` type. +maybeNullConvert :: Type -> CodeGen e (Maybe Text) +maybeNullConvert (TBasicType TPtr) = return Nothing +maybeNullConvert (TGList _) = return Nothing +maybeNullConvert (TGSList _) = return Nothing +maybeNullConvert t = do + pt <- typePtrType t + case pt of + Just FFIPtr -> return (Just "SP.convertIfNonNull") + Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull") + Nothing -> return Nothing + +-- | An appropriate NULL value for the given type, for types which are +-- represented by pointers on the C side. +nullPtrForType :: Type -> CodeGen e (Maybe Text) +nullPtrForType t = do + pt <- typePtrType t + case pt of + Just FFIPtr -> return (Just "FP.nullPtr") + Just FFIFunPtr -> return (Just "FP.nullFunPtr") + Nothing -> return Nothing + +-- | Returns whether the given type should be represented by a +-- `Maybe` type on the Haskell side. This applies to all properties +-- which have a C representation in terms of pointers, except for +-- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers, +-- which we just pass through to the Haskell side. Notice that +-- introspection annotations can override this. +typeIsNullable :: Type -> CodeGen e Bool +typeIsNullable t = isJust <$> maybeNullConvert t + +-- | If the given type maps to a list in Haskell, return the type of the +-- elements, and the function that maps over them. +elementTypeAndMap :: Type -> Text -> Maybe (Type, Text) +-- ByteString +elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing +elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") +elementTypeAndMap (TCArray _ _ _ TGValue) len = + Just (TGValue, parenthesize $ "B.GValue.mapGValueArrayWithLength " <> len) +elementTypeAndMap (TCArray False (-1) _ t) len = + Just (t, parenthesize $ "mapCArrayWithLength " <> len) +elementTypeAndMap (TCArray False fixed _ t) _ = + Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed) +elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray") +elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray") +elementTypeAndMap (TGList t) _ = Just (t, "mapGList") +elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList") +-- GHashTable is treated separately, see Transfer.hs +elementTypeAndMap _ _ = Nothing + +-- Return just the element type. +elementType :: Type -> Maybe Type +elementType t = fst <$> elementTypeAndMap t undefined + +-- Return just the map. +elementMap :: Type -> Text -> Maybe Text +elementMap t len = snd <$> elementTypeAndMap t len diff --git a/lib/Data/GI/CodeGen/CtoHaskellMap.hs b/lib/Data/GI/CodeGen/CtoHaskellMap.hs --- a/lib/Data/GI/CodeGen/CtoHaskellMap.hs +++ b/lib/Data/GI/CodeGen/CtoHaskellMap.hs @@ -6,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) diff --git a/lib/Data/GI/CodeGen/EnumFlags.hs b/lib/Data/GI/CodeGen/EnumFlags.hs --- a/lib/Data/GI/CodeGen/EnumFlags.hs +++ b/lib/Data/GI/CodeGen/EnumFlags.hs @@ -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" diff --git a/lib/Data/GI/CodeGen/Fixups.hs b/lib/Data/GI/CodeGen/Fixups.hs --- a/lib/Data/GI/CodeGen/Fixups.hs +++ b/lib/Data/GI/CodeGen/Fixups.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/GObject.hs b/lib/Data/GI/CodeGen/GObject.hs --- a/lib/Data/GI/CodeGen/GObject.hs +++ b/lib/Data/GI/CodeGen/GObject.hs @@ -13,12 +13,12 @@ import Data.GI.CodeGen.Type -- Returns whether the given type is a descendant of the given parent. -typeDoParentSearch :: Name -> Type -> CodeGen Bool +typeDoParentSearch :: Name -> Type -> CodeGen e Bool typeDoParentSearch parent (TInterface n) = findAPIByName n >>= apiDoParentSearch parent n typeDoParentSearch _ _ = return False -apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool +apiDoParentSearch :: Name -> Name -> API -> CodeGen e Bool apiDoParentSearch parent n api | parent == n = return True | otherwise = case api of @@ -32,12 +32,14 @@ or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs _ -> return False -isGObject :: Type -> CodeGen Bool +-- | Check whether the given type descends from GObject. +isGObject :: Type -> CodeGen e Bool isGObject = typeDoParentSearch $ Name "GObject" "Object" -- | Check whether the given name descends from GObject. -nameIsGObject :: Name -> CodeGen Bool +nameIsGObject :: Name -> CodeGen e Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n -apiIsGObject :: Name -> API -> CodeGen Bool +-- | Check whether the given API descends from GObject. +apiIsGObject :: Name -> API -> CodeGen e Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object" diff --git a/lib/Data/GI/CodeGen/GtkDoc.hs b/lib/Data/GI/CodeGen/GtkDoc.hs --- a/lib/Data/GI/CodeGen/GtkDoc.hs +++ b/lib/Data/GI/CodeGen/GtkDoc.hs @@ -6,8 +6,10 @@ , Token(..) , Language(..) , Link(..) - , ListItem(..) , CRef(..) + , DocSymbolName(..) + , docName + , resolveDocSymbol ) where import Prelude hiding (takeWhile) @@ -15,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- ![](image.png)" --- GtkDoc [Literal "List with urls:\n",List [ListItem (GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})]) [],ListItem (GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]) []]] +-- GtkDoc [Literal "List with urls:\n",UnnumberedList [GtkDoc [ExternalLink (Link {linkName = "test", linkAddress = "http://test"})],GtkDoc [Image (Link {linkName = "", linkAddress = "image.png"})]]] parseGtkDoc :: Text -> GtkDoc -parseGtkDoc raw = +parseGtkDoc doc = rawParseGtkDoc (T.cons startOfString doc) + +-- | Like `parseGtkDoc`, but it does not annotate beginning of lines. +rawParseGtkDoc :: Text -> GtkDoc +rawParseGtkDoc raw = case parseOnly (parseTokens <* endOfInput) raw of Left e -> - error $ "gtk-doc parsing failed with error \"" <> e - <> "\" on the input \"" <> T.unpack raw <> "\"" - Right tks -> GtkDoc . coalesceLiterals - . restoreSHPreNewlines . restoreListPreNewline $ tks + terror $ "gtk-doc parsing failed with error \"" <> T.pack e + <> "\" on the input \"" <> + T.replace (T.singleton startOfString) "" raw <> "\"" + Right tks -> GtkDoc . coalesceLiterals . removeSOS $ tks --- | `parseSectionHeader` eats the newline before the section header, --- but `parseInitialSectionHeader` does not, since it only matches at --- the beginning of the text. This restores the newlines eaten by --- `parseSectionHeader`, so a `SectionHeader` returned by the parser --- can always be assumed /not/ to have an implicit starting newline. -restoreSHPreNewlines :: [Token] -> [Token] -restoreSHPreNewlines [] = [] -restoreSHPreNewlines (i : rest) = i : restoreNewlines rest - where restoreNewlines :: [Token] -> [Token] - restoreNewlines [] = [] - restoreNewlines (s@(SectionHeader _ _) : rest) = - Literal "\n" : s : restoreNewlines rest - restoreNewlines (x : rest) = x : restoreNewlines rest +-- | A character indicating the start of the string, to simplify the +-- GtkDoc parser (part of the syntax is sensitive to the start of +-- lines, which we can represent as any character after '\n' or SOS). +startOfString :: Char +startOfString = '\x98' -- Unicode Start Of String (SOS) --- | `parseList` eats the newline before the list, restore it. -restoreListPreNewline :: [Token] -> [Token] -restoreListPreNewline [] = [] -restoreListPreNewline (l@(List _) : rest) = - Literal "\n" : l : restoreListPreNewline rest -restoreListPreNewline (x : rest) = x : restoreListPreNewline rest +-- | Remove the SOS marker from the input. Since this only appears at +-- the beginning of the text, we only need to worry about replacing it +-- in the first token, and only if it's a literal. +removeSOS :: [Token] -> [Token] +removeSOS [] = [] +removeSOS (Literal l : rest) = + if l == T.singleton startOfString + then rest + else Literal (T.replace (T.singleton startOfString) "" l) : rest +removeSOS (other : rest) = other : rest -- | Accumulate consecutive literals into a single literal. coalesceLiterals :: [Token] -> [Token] @@ -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 +-- > +-- Note that this function keeps spaces. +-- +-- === __Examples__ +-- >>> parseOnly (parseComment <* endOfInput) "" +-- Right [Comment " comment "] +parseComment :: Parser [Token] +parseComment = do + comment <- 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 -- > ![label](url) -- -- === __Examples__ -- >>> parseOnly (parseImage <* endOfInput) "![](diagram.png)" --- Right (Image (Link {linkName = "", linkAddress = "diagram.png"})) -parseImage :: Parser Token +-- Right [Image (Link {linkName = "", linkAddress = "diagram.png"})] +parseImage :: Parser [Token] parseImage = do _ <- string "![" name <- takeWhile (/= ']') _ <- string "](" address <- takeWhile1 (/= ')') _ <- char ')' - return $ Image $ Link {linkName = name, linkAddress = address} + return [Image $ Link {linkName = name, linkAddress = address}] -- | Parse a code block embedded in the documentation. -parseCodeBlock :: Parser Token -parseCodeBlock = do +parseCodeBlock :: Parser [Token] +parseCodeBlock = parseOldStyleCodeBlock <|> parseNewStyleCodeBlock + +-- | Parse a new style code block, of the form +-- > ```c +-- > some c code +-- > ``` +-- +-- === __Examples__ +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```c\nThis is C code\n```" +-- Right [CodeBlock (Just (Language "c")) "This is C code"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) "```\nThis is langless\n```" +-- Right [CodeBlock Nothing "This is langless"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```py\n This has space in front\n ```" +-- Right [CodeBlock (Just (Language "py")) " This has space in front"] +-- +-- >>> parseOnly (parseNewStyleCodeBlock <* endOfInput) " ```c\n new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);\n ```" +-- Right [CodeBlock (Just (Language "c")) " new_type_id = g_type_register_dynamic (parent_type_id,\n \"TypeName\",\n new_type_plugin,\n type_flags);"] +parseNewStyleCodeBlock :: Parser [Token] +parseNewStyleCodeBlock = do + _ <- takeWhile isHorizontalSpace + _ <- string "```" + lang <- T.strip <$> takeWhile (/= '\n') + _ <- char '\n' + let maybeLang = if T.null lang then Nothing + else Just lang + code <- T.pack <$> manyTill anyChar (string "\n" >> + takeWhile isHorizontalSpace >> + string "```") + return [CodeBlock (Language <$> maybeLang) code] + +-- | Parse an old style code block, of the form +-- > |[ code ]| +-- +-- === __Examples__ +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is code]|" +-- Right [CodeBlock Nothing "this is code"] +-- +-- >>> parseOnly (parseOldStyleCodeBlock <* endOfInput) "|[this is C code]|" +-- Right [CodeBlock (Just (Language "C")) "this is C code"] +parseOldStyleCodeBlock :: Parser [Token] +parseOldStyleCodeBlock = do _ <- string "|[" lang <- (Just <$> parseLanguage) <|> return Nothing code <- T.pack <$> manyTill anyChar (string "]|") - return $ CodeBlock lang code + return [CodeBlock lang code] -- | Parse the language of a code block, specified as a comment. parseLanguage :: Parser Language @@ -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 diff --git a/lib/Data/GI/CodeGen/Haddock.hs b/lib/Data/GI/CodeGen/Haddock.hs --- a/lib/Data/GI/CodeGen/Haddock.hs +++ b/lib/Data/GI/CodeGen/Haddock.hs @@ -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")]) -- "" -- --- >>> formatHaddock M.empty "a" (GtkDoc [List [ListItem (GtkDoc [Image (Link "test" "test.png")]) []]]) --- "\n* <>\n" -formatHaddock :: M.Map CRef Hyperlink -> Text -> GtkDoc -> Text -formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [UnnumberedList [GtkDoc [Image (Link "test" "test.png")]]]) +-- "* <>\n" +-- +-- >>> formatHaddock M.empty "a" "Test" (GtkDoc [NumberedList [("1", GtkDoc [Literal "Hi!"]), ("2", GtkDoc [Literal "Second and very long, so split\n line."])]]) +-- "1. Hi!\n\n2. Second and very long, so split\n line.\n\n" +formatHaddock :: M.Map CRef Hyperlink -> Text -> Text -> GtkDoc -> Text +formatHaddock c2h docBase defaultNS (GtkDoc tokens) = T.concat $ map formatToken tokens where formatToken :: Token -> Text - formatToken (Literal l) = escape l + formatToken (Literal l) = escape (convertBold l) + formatToken (Comment _) = "" formatToken (Verbatim v) = "@" <> escape v <> "@" formatToken (CodeBlock l c) = formatCodeBlock l c formatToken (ExternalLink l) = formatLink l docBase formatToken (Image l) = formatImage l docBase - formatToken (SectionHeader l h) = formatSectionHeader c2h docBase l h - formatToken (List l) = formatList c2h docBase l - formatToken (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 diff --git a/lib/Data/GI/CodeGen/Inheritance.hs b/lib/Data/GI/CodeGen/Inheritance.hs --- a/lib/Data/GI/CodeGen/Inheritance.hs +++ b/lib/Data/GI/CodeGen/Inheritance.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/LibGIRepository.hs b/lib/Data/GI/CodeGen/LibGIRepository.hs --- a/lib/Data/GI/CodeGen/LibGIRepository.hs +++ b/lib/Data/GI/CodeGen/LibGIRepository.hs @@ -1,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) diff --git a/lib/Data/GI/CodeGen/ModulePath.hs b/lib/Data/GI/CodeGen/ModulePath.hs --- a/lib/Data/GI/CodeGen/ModulePath.hs +++ b/lib/Data/GI/CodeGen/ModulePath.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedLabels.hs b/lib/Data/GI/CodeGen/OverloadedLabels.hs deleted file mode 100644 --- a/lib/Data/GI/CodeGen/OverloadedLabels.hs +++ /dev/null @@ -1,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 diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs --- a/lib/Data/GI/CodeGen/OverloadedSignals.hs +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -1,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)])" diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs --- a/lib/Data/GI/CodeGen/Overrides.hs +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -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. diff --git a/lib/Data/GI/CodeGen/PkgConfig.hs b/lib/Data/GI/CodeGen/PkgConfig.hs --- a/lib/Data/GI/CodeGen/PkgConfig.hs +++ b/lib/Data/GI/CodeGen/PkgConfig.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -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" ,"" diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -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 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 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 diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -5,6 +5,7 @@ , extractCallbacksInStruct , fixAPIStructs , ignoreStruct + , genBoxed , genWrappedPtr ) where @@ -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 diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs --- a/lib/Data/GI/CodeGen/SymbolNaming.hs +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -3,11 +3,11 @@ ( lowerName , lowerSymbol , upperName - , noName , escapedArgName , classConstraint , typeConstraint + , safeCast , hyphensToCamelCase , underscoresToCamelCase @@ -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:" diff --git a/lib/Data/GI/CodeGen/Transfer.hs b/lib/Data/GI/CodeGen/Transfer.hs --- a/lib/Data/GI/CodeGen/Transfer.hs +++ b/lib/Data/GI/CodeGen/Transfer.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Type.hs b/lib/Data/GI/CodeGen/Type.hs --- a/lib/Data/GI/CodeGen/Type.hs +++ b/lib/Data/GI/CodeGen/Type.hs @@ -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) diff --git a/lib/Data/GI/CodeGen/Util.hs b/lib/Data/GI/CodeGen/Util.hs --- a/lib/Data/GI/CodeGen/Util.hs +++ b/lib/Data/GI/CodeGen/Util.hs @@ -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 diff --git a/lib/Data/GI/GIR/Arg.hs b/lib/Data/GI/GIR/Arg.hs --- a/lib/Data/GI/GIR/Arg.hs +++ b/lib/Data/GI/GIR/Arg.hs @@ -4,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 } diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs --- a/lib/Data/GI/GIR/BasicTypes.hs +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -46,6 +46,17 @@ | TPtr -- ^ gpointer | TIntPtr -- ^ gintptr | TUIntPtr -- ^ guintptr + | TShort -- ^ gshort + | TUShort -- ^ gushort + | TSize -- ^ gsize + | TSSize -- ^ gssize + | Ttime_t -- ^ time_t + | Toff_t -- ^ off_t + | Tdev_t -- ^ dev_t + | Tgid_t -- ^ gid_t + | Tpid_t -- ^ pid_t + | Tsocklen_t -- ^ socklen_t + | Tuid_t -- ^ uid_t deriving (Eq, Show, Ord) -- | This type represents the types found in GObject Introspection @@ -54,6 +65,7 @@ = TBasicType BasicType | TError -- ^ GError | TVariant -- ^ GVariant + | TGValue -- ^ GValue | TParamSpec -- ^ GParamSpec | TCArray Bool Int Int Type -- ^ Zero terminated, Array Fixed -- Size, Array Length, Element Type @@ -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) diff --git a/lib/Data/GI/GIR/Callable.hs b/lib/Data/GI/GIR/Callable.hs --- a/lib/Data/GI/GIR/Callable.hs +++ b/lib/Data/GI/GIR/Callable.hs @@ -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 } diff --git a/lib/Data/GI/GIR/Constant.hs b/lib/Data/GI/GIR/Constant.hs --- a/lib/Data/GI/GIR/Constant.hs +++ b/lib/Data/GI/GIR/Constant.hs @@ -7,7 +7,7 @@ import Data.Text (Text) import Data.GI.GIR.BasicTypes (Type) -import Data.GI.GIR.Type (parseType, parseCType) +import Data.GI.GIR.Type (parseType) import Data.GI.GIR.Parser -- | Info about a constant. @@ -26,7 +26,12 @@ deprecated <- parseDeprecation value <- getAttr "value" t <- parseType - ctype <- parseCType + -- This contains the C name for the constant. The C gir generator + -- call this "c:type", while the vala gir generator calls it + -- "c:identifier", so try both. + ctype <- queryAttrWithNamespace CGIRNS "type" >>= \case + Just i -> return i + Nothing -> getAttrWithNamespace CGIRNS "identifier" doc <- parseDocumentation return (name, Constant { constantType = t , constantValue = value diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs --- a/lib/Data/GI/GIR/Field.hs +++ b/lib/Data/GI/GIR/Field.hs @@ -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 diff --git a/lib/Data/GI/GIR/Function.hs b/lib/Data/GI/GIR/Function.hs --- a/lib/Data/GI/GIR/Function.hs +++ b/lib/Data/GI/GIR/Function.hs @@ -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 diff --git a/lib/Data/GI/GIR/Method.hs b/lib/Data/GI/GIR/Method.hs --- a/lib/Data/GI/GIR/Method.hs +++ b/lib/Data/GI/GIR/Method.hs @@ -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, diff --git a/lib/Data/GI/GIR/Object.hs b/lib/Data/GI/GIR/Object.hs --- a/lib/Data/GI/GIR/Object.hs +++ b/lib/Data/GI/GIR/Object.hs @@ -4,6 +4,10 @@ , parseObject ) where +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif + import Data.Text (Text) import Data.GI.GIR.Method (Method, parseMethod, MethodType(..)) @@ -17,6 +21,10 @@ objTypeInit :: Text, objTypeName :: Text, objCType :: Maybe Text, + objRefFunc :: Maybe Text, + objUnrefFunc :: Maybe Text, + objSetValueFunc :: Maybe Text, + objGetValueFunc :: Maybe Text, objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo, objDocumentation :: Documentation, @@ -36,15 +44,27 @@ parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName) interfaces <- parseChildrenWithLocalName "implements" parseName props <- parseChildrenWithLocalName "property" parseProperty - typeInit <- getAttrWithNamespace GLibGIRNS "get-type" + typeInitFn <- getAttrWithNamespace GLibGIRNS "get-type" + typeInit <- case typeInitFn of + "intern" -> resolveInternalType name + fn -> return fn typeName <- getAttrWithNamespace GLibGIRNS "type-name" signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal + refFunc <- queryAttrWithNamespace GLibGIRNS "ref-func" + unrefFunc <- queryAttrWithNamespace GLibGIRNS "unref-func" + setValueFunc <- queryAttrWithNamespace GLibGIRNS "set-value-func" + getValueFunc <- queryAttrWithNamespace GLibGIRNS "get-value-func" + ctype <- queryCType return (name, Object { objParent = parent , objTypeInit = typeInit , objCType = ctype + , objRefFunc = refFunc + , objUnrefFunc = unrefFunc + , objSetValueFunc = setValueFunc + , objGetValueFunc = getValueFunc , objTypeName = typeName , objInterfaces = interfaces , objDeprecated = deprecated @@ -54,3 +74,39 @@ , objSignals = signals }) +-- | Some basic types do not list a type init function, and instead +-- mention "intern". Provide the explicit numerical value of the GType +-- in these cases. +resolveInternalType :: Name -> Parser Text +resolveInternalType (Name "GObject" p@"ParamSpec") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecBoolean") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecBoxed") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecChar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecDouble") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecEnum") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecFlags") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecFloat") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecGType") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecInt") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecInt64") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecLong") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecObject") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecOverride") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecParam") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecPointer") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecString") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUChar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUInt") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUInt64") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecULong") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecUnichar") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecVariant") = pspec_type_init p +resolveInternalType (Name "GObject" p@"ParamSpecValueArray") = pspec_type_init p +resolveInternalType (Name ns n) = + parseError $ "Unknown internal type: " <> ns <> "." <> n <> "\n" + <> "This is a bug, please report at https://github.com/haskell-gi/haskell-gi/issues" + +-- | The name of the function we provide for querying ParamSpec types +-- at runtime. +pspec_type_init :: Text -> Parser Text +pspec_type_init p = return $ "haskell_gi_pspec_type_init_" <> p diff --git a/lib/Data/GI/GIR/Parser.hs b/lib/Data/GI/GIR/Parser.hs --- a/lib/Data/GI/GIR/Parser.hs +++ b/lib/Data/GI/GIR/Parser.hs @@ -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 diff --git a/lib/Data/GI/GIR/Property.hs b/lib/Data/GI/GIR/Property.hs --- a/lib/Data/GI/GIR/Property.hs +++ b/lib/Data/GI/GIR/Property.hs @@ -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 } diff --git a/lib/Data/GI/GIR/Repository.hs b/lib/Data/GI/GIR/Repository.hs --- a/lib/Data/GI/GIR/Repository.hs +++ b/lib/Data/GI/GIR/Repository.hs @@ -49,8 +49,13 @@ then reverse acc : go ys [] else go ys (y : acc) +-- | Return the paths where to look for gir files. girDataDirs :: IO [FilePath] -girDataDirs = getSystemDataDirs "gir-1.0" +girDataDirs = do + sys <- getSystemDataDirs "gir-1.0" + -- See https://github.com/haskell-gi/haskell-gi/issues/390 + let macOS = ["/opt/homebrew/share/gir-1.0"] + return (sys ++ macOS) -- | Construct the GIR search path, possibly looking into the -- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit diff --git a/lib/Data/GI/GIR/Signal.hs b/lib/Data/GI/GIR/Signal.hs --- a/lib/Data/GI/GIR/Signal.hs +++ b/lib/Data/GI/GIR/Signal.hs @@ -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 } diff --git a/lib/Data/GI/GIR/Struct.hs b/lib/Data/GI/GIR/Struct.hs --- a/lib/Data/GI/GIR/Struct.hs +++ b/lib/Data/GI/GIR/Struct.hs @@ -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 diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, PatternGuards #-} -- | Parsing type information from GIR files. module Data.GI.GIR.Type @@ -8,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]