diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,27 @@ +### 0.26.0 + ++ Support for 'HasField' methods, which allows the syntax 'widget.show' or 'widget.add child' for invoking methods using the new [RecordDotSyntax](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0282-record-dot-syntax.rst) in ghc 9.2. + ++ And an implicit '?self' parameter for callbacks, for accessing the calling object. See [issue 346](https://github.com/haskell-gi/haskell-gi/issues/346) where this is necessary in practice in gtk4 to use event controllers. + ++ Add an 'After' attribute to connect to signals after the default handler on constructors/setters using attribute syntax, similar to [On](https://hackage.haskell.org/package/haskell-gi-base/docs/Data-GI-Base-Attributes.html#t:AttrOp). + ++ Add [resolveSignal](https://hackage.haskell.org/package/haskell-gi-base-0.26.0/docs/Data-GI-Base-Signals.html#v:resolveSignal) for showing what an overloaded signal resolves to: `resolveSignal button #notify` will output [GI.GObject.Objects.Object.Object::notify](https://hackage.haskell.org/package/gi-gobject-2.0.27/docs/GI-GObject-Objects-Object.html#g:signal:notify). + +### 0.25.0 + ++ Support non-GObject object attributes. + ++ Support for ghc 9.0.1. + ++ Improvements in the generated Haddocks. + ++ Remove the command line version of the bindings generator. + ++ Remove support for non-IsLabel overloading. + ++ Add [resolveMethod](https://hackage.haskell.org/package/haskell-gi-base-0.25.0/docs/Data-GI-Base-Overloading.html#v:resolveMethod) for showing what an overloaded method resolves to: `resolveMethod #show widget` will output `GI.Gtk.Objects.Widget.widgetShow`. + ### 0.24.5 + Fix an accidental double free for GValues, see [issue 320](https://github.com/haskell-gi/haskell-gi/issues/320). diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.25.0 +version: 0.26.0 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. @@ -7,14 +7,12 @@ license: LGPL-2.1 -- or above license-file: LICENSE -author: Will Thompson, - Iñaki García Etxebarria, - Jonas Platte -maintainer: Iñaki García Etxebarria (inaki@blueleaf.cc) +author: Will Thompson and Iñaki García Etxebarria +maintainer: Iñaki García Etxebarria (github@the.blueleaf.cc) stability: Experimental category: Development build-type: Custom -tested-with: GHC == 8.8.1, GHC == 8.10.1 +tested-with: GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.2.1 cabal-version: 2.0 extra-source-files: ChangeLog.md @@ -23,7 +21,7 @@ setup-depends: base >= 4 && <5, Cabal, - cabal-doctest >= 1 && <1.1 + cabal-doctest >= 1 source-repository head type: git @@ -32,8 +30,8 @@ Library default-language: Haskell2010 pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 - build-depends: base >= 4.9 && < 5, - haskell-gi-base >= 0.25.0 && <0.26, + build-depends: base >= 4.11 && < 5, + haskell-gi-base >= 0.26.0 && <0.27, Cabal >= 1.24, attoparsec >= 0.13, containers, @@ -52,9 +50,7 @@ text >= 1.0 default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings - ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing - - ghc-options: -Wcompat + ghc-options: -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing -Wcompat c-sources: lib/c/enumStorage.c build-tool-depends: hsc2hs:hsc2hs 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 @@ -952,6 +952,7 @@ , "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.ByteString.Char8 as B" , "import qualified Data.Map as Map" diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc --- a/lib/Data/GI/CodeGen/Conversions.hsc +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -74,7 +74,6 @@ Free ma <*> b = Free $ (<*> b) <$> ma instance (Functor f) => Monad (Free f) where - return = Pure (Free x) >>= f = Free (fmap (>>= f) x) (Pure r) >>= f = f r @@ -649,19 +648,17 @@ a <- findAPI t case a of Just (APIStruct s) -> if structIsBoxed s - then wrapTransient t + then wrapTransient else fToH t TransferNothing Just (APIUnion u) -> if unionIsBoxed u - then wrapTransient t + then wrapTransient else fToH t TransferNothing _ -> fToH t TransferNothing transientToH t transfer = fToH t transfer -- | Wrap the given transient. -wrapTransient :: Type -> CodeGen e Converter -wrapTransient t = do - hCon <- typeConName <$> haskellType t - return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon +wrapTransient :: CodeGen e Converter +wrapTransient = return $ lambdaConvert $ "B.ManagedPtr.withTransient " unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter unpackCArray length (TCArray False _ _ t) transfer = 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 @@ -21,7 +21,7 @@ Signal(..)) import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (moduleLocation, lowerName, upperName, - signalHaskellName) + signalHaskellName, haddockSignalAnchor) import Data.GI.CodeGen.Util (ucFirst) -- | Link to an identifier, module, etc. @@ -120,7 +120,7 @@ Nothing -> let Name ns owner = n in ucFirst ns <> owner in (SignalRef ownerCName sn, - ModuleLinkWithAnchor (Just sn') mod ("g:signal:" <> sn')) + ModuleLinkWithAnchor (Just sn') mod (haddockSignalAnchor <> sn')) -- | Given an optional C type and the API constructor construct the -- list of associated refs. 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 @@ -34,7 +34,8 @@ import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..), Link(..), ListItem(..), parseGtkDoc) import Data.GI.CodeGen.Overrides (onlineDocsMap) -import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName) +import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName, + haddockSignalAnchor) -- | Where is the documentation located with respect to the relevant -- symbol, useful for determining whether we want to start with @|@ or @^@. @@ -81,7 +82,7 @@ formatUnknownCRef _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" formatUnknownCRef _ (LocalSignalRef s) = let sn = signalHaskellName s - in "[" <> sn <> "](#g:signal:" <> sn <> ")" + in "[" <> sn <> "](#" <> haddockSignalAnchor <> sn <> ")" formatUnknownCRef c2h (SignalRef owner signal) = case M.lookup (TypeRef owner) c2h of Nothing -> formatCRef $ owner <> "::" <> signal 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 @@ -136,11 +136,11 @@ let callable = 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]) <> ")" @@ -160,12 +160,12 @@ line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj <> " where" indent $ do - line $ "overloadedMethodInfo = O.MethodInfo {" + line $ "overloadedMethodInfo = P.Just (O.ResolvedSymbolInfo {" indent $ do - line $ "O.overloadedMethodName = \"" <> dbgInfo <> "\"," - line $ "O.overloadedMethodURL = \"" <> + line $ "O.resolvedSymbolName = \"" <> dbgInfo <> "\"," + line $ "O.resolvedSymbolURL = \"" <> hackageLink <> "#v:" <> mangled <> "\"" - line $ "}" + line $ "})" export (NamedSubsection MethodSection $ lowerName mn) infoName diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -24,7 +24,7 @@ homepage = "https://github.com/haskell-gi/haskell-gi" authors :: Text -authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte" +authors = "Will Thompson and Iñaki García Etxebarria" maintainers :: Text maintainers = "Iñaki García Etxebarria" diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -25,11 +25,14 @@ import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint, hyphensToCamelCase, qualifiedSymbol, typeConstraint, callbackDynamicWrapper, callbackHaskellToForeign, - callbackWrapperAllocator, safeCast) + callbackWrapperAllocator, safeCast, + hackageModuleLink, moduleLocation, + haddockAttrAnchor) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -376,7 +379,8 @@ genOneProperty owner prop = do let name = upperName owner cName = (hyphensToCamelCase . propName) prop - docSection = NamedSubsection PropertySection (lcFirst cName) + lcAttr = lcFirst cName + docSection = NamedSubsection PropertySection lcAttr pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags && @@ -458,6 +462,11 @@ 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 @@ -480,6 +489,11 @@ 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. diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -6,7 +6,7 @@ import Control.Monad (forM, forM_, when, unless) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif @@ -27,6 +27,7 @@ RelativeDocPosition(..), writeHaddock, writeDocumentation, writeArgDocumentation, writeReturnDocumentation) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type @@ -37,8 +38,8 @@ -- | The prototype of the callback on the Haskell side (what users of -- the binding will see) genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures -> - Documentation -> ExcCodeGen () -genHaskellCallbackPrototype subsec cb htype expose doc = group $ do + Bool -> Documentation -> ExcCodeGen () +genHaskellCallbackPrototype subsec cb htype expose isSignal doc = group $ do let name' = case expose of WithClosures -> callbackHTypeWithClosures htype WithoutClosures -> htype @@ -65,13 +66,14 @@ line $ returnArrow <> typeShow (io ret) writeReturnDocumentation cb False - blank + when (not isSignal) $ do + blank - -- For optional parameters, in case we want to pass Nothing. - export (NamedSubsection SignalSection subsec) ("no" <> name') - writeHaddock DocBeforeSymbol (noCallbackDoc name') - line $ "no" <> name' <> " :: Maybe " <> name' - line $ "no" <> name' <> " = Nothing" + -- For optional parameters, in case we want to pass Nothing. + export (NamedSubsection SignalSection subsec) ("no" <> name') + writeHaddock DocBeforeSymbol (noCallbackDoc name') + line $ "no" <> name' <> " :: Maybe " <> name' + line $ "no" <> name' <> " = Nothing" where noCallbackDoc :: Text -> Text noCallbackDoc typeName = @@ -80,16 +82,21 @@ -- | Generate the type synonym for the prototype of the callback on -- the C side. Returns the name given to the type synonym. -genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen e Text -genCCallbackPrototype subsec cb name' isSignal = group $ do +genCCallbackPrototype :: Text -> Callable -> Text -> + Maybe Text -> CodeGen e Text +genCCallbackPrototype subsec cb name' maybeOwner = group $ do let ctypeName = callbackCType name' + isSignal = isJust maybeOwner - export (NamedSubsection SignalSection subsec) ctypeName - writeHaddock DocBeforeSymbol ccallbackDoc + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) ctypeName + writeHaddock DocBeforeSymbol ccallbackDoc line $ "type " <> ctypeName <> " =" indent $ do - when isSignal $ line $ withComment "Ptr () ->" "object" + maybe (return ()) + (\owner -> line $ withComment ("Ptr " <> owner <> " ->") "object") + maybeOwner forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg let ht' = if direction arg /= DirectionIn @@ -98,7 +105,7 @@ line $ typeShow ht' <> " ->" when (callableThrows cb) $ line "Ptr (Ptr GError) ->" - when isSignal $ line $ withComment "Ptr () ->" "user_data" + when (isJust maybeOwner) $ line $ withComment "Ptr () ->" "user_data" ret <- io <$> case returnType cb of Nothing -> return $ con0 "()" Just t -> foreignType t @@ -110,14 +117,15 @@ ccallbackDoc = "Type for the callback on the (unwrapped) C side." -- | Generator for wrappers callable from C -genCallbackWrapperFactory :: Text -> Text -> CodeGen e () -genCallbackWrapperFactory subsec name' = group $ do +genCallbackWrapperFactory :: Text -> Text -> Bool -> CodeGen e () +genCallbackWrapperFactory subsec name' isSignal = group $ do let factoryName = callbackWrapperAllocator name' writeHaddock DocBeforeSymbol factoryDoc line "foreign import ccall \"wrapper\"" indent $ line $ factoryName <> " :: " <> callbackCType name' <> " -> IO (FunPtr " <> callbackCType name' <> ")" - export (NamedSubsection SignalSection subsec) factoryName + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) factoryName where factoryDoc :: Text factoryDoc = "Generate a function pointer callable from C code, from a `" @@ -141,8 +149,8 @@ return (prime drop) -- | Generator of closures -genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen e () -genClosure subsec cb callback name isSignal = group $ do +genClosure :: Text -> Callable -> Text -> Text -> CodeGen e () +genClosure subsec cb callback name = group $ do let closure = callbackClosureGenerator name export (NamedSubsection SignalSection subsec) closure writeHaddock DocBeforeSymbol closureDoc @@ -151,7 +159,7 @@ <> callbackCType callback <> ")" line $ closure <> " cb = liftIO $ do" indent $ do - wrapped <- genWrappedCallback cb "cb" callback isSignal + wrapped <- genWrappedCallback cb "cb" callback False line $ callbackWrapperAllocator callback <> " " <> wrapped <> " >>= B.GClosure.newGClosure" where @@ -267,24 +275,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 -> ExcCodeGen () +genCallbackWrapper subsec cb name' maybeOwner = group $ do let wrapperName = callbackHaskellToForeign name' (hInArgs, _) = callableHInArgs cb WithClosures hOutArgs = callableHOutArgs cb wrapperDoc = "Wrap a `" <> name' <> "` into a `" <> callbackCType name' <> "`." + isSignal = isJust maybeOwner - export (NamedSubsection SignalSection subsec) wrapperName - writeHaddock DocBeforeSymbol wrapperDoc + when (not isSignal) $ do + export (NamedSubsection SignalSection subsec) wrapperName + writeHaddock DocBeforeSymbol wrapperDoc group $ do - line $ wrapperName <> " ::" + line $ wrapperName <> " :: " indent $ do if isSignal - then do - line $ name' <> " ->" - else do + then line $ "GObject a => (a -> " <> name' <> ") ->" + else do line $ "Maybe (Ptr (FunPtr " <> callbackCType name' <> ")) ->" let hType = if callableHasClosures cb then callbackHTypeWithClosures name' @@ -295,8 +305,8 @@ 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 hInNames <- forM hInArgs (prepareArgForCall cb) @@ -310,11 +320,18 @@ [] -> "" [r] -> r <> " <- " _ -> mkTuple returnVars <> " <- " - line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames) + if isSignal + then line $ returnBind + <> "B.ManagedPtr.withTransient" + <> " gi'selfPtr $ \\gi'self -> " + <> "gi'cb (Coerce.coerce gi'self) " + <> T.concat (map (" " <>) hInNames) + else line $ returnBind <> "gi'cb " <> T.concat (map (" " <>) hInNames) + forM_ hOutArgs saveOutArg - unless isSignal $ line "maybeReleaseFunPtr funptrptr" + unless isSignal $ line "maybeReleaseFunPtr gi'funptrptr" case returnType cb of Nothing -> return () @@ -322,7 +339,7 @@ nullableReturnType <- typeIsNullable r if returnMayBeNull cb && nullableReturnType then do - line "maybeM nullPtr result $ \\result' -> do" + line "maybeM FP.nullPtr result $ \\result' -> do" indent $ unwrapped "result'" else unwrapped "result" where @@ -348,14 +365,14 @@ line $ "-- XXX Could not generate callback wrapper for " <> name' printCGError e) $ do - typeSynonym <- genCCallbackPrototype name' cb' name' False + typeSynonym <- genCCallbackPrototype name' cb' name' Nothing dynamic <- genDynamicCallableWrapper n typeSynonym cb export (NamedSubsection SignalSection name') dynamic - genCallbackWrapperFactory name' name' + genCallbackWrapperFactory name' name' False deprecatedPragma name' (callableDeprecated cb') - genHaskellCallbackPrototype name' cb' name' WithoutClosures cbDoc + genHaskellCallbackPrototype name' cb' name' WithoutClosures False cbDoc when (callableHasClosures cb') $ do - genHaskellCallbackPrototype name' cb' name' WithClosures cbDoc + genHaskellCallbackPrototype name' cb' name' WithClosures False cbDoc genDropClosures name' cb' name' if callableThrows cb' then do @@ -379,14 +396,19 @@ line $ "-- No Haskell->C wrapper generated since the function throws." blank else do - genClosure name' cb' name' name' False - genCallbackWrapper name' cb' name' False + genClosure name' cb' name' name' + genCallbackWrapper name' cb' name' Nothing -- | Generate the given signal instance for the given API object. genSignalInfoInstance :: Name -> Signal -> CodeGen e () genSignalInfoInstance owner signal = group $ do + api <- findAPIByName owner let name = upperName owner - let sn = (ucFirst . signalHaskellName . sigName) signal + sn = (ucFirst . signalHaskellName . sigName) signal + lcSignal = lcFirst sn + qualifiedSignalName = dotModulePath (moduleLocation owner api) + <> "::" <> sigName signal + hackageLink <- hackageModuleLink owner si <- signalInfoName owner signal bline $ "data " <> si line $ "instance SignalInfo " <> si <> " where" @@ -395,8 +417,14 @@ cbHaskellType = signalConnectorName <> "Callback" line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType line $ "connectSignal obj cb connectMode detail = do" - indent $ genSignalConnector signal cbHaskellType "connectMode" "detail" - export (NamedSubsection SignalSection $ lcFirst sn) si + indent $ do + genSignalConnector signal cbHaskellType "connectMode" "detail" "cb" + line $ "dbgSignalInfo = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> qualifiedSignalName <> "\"" + line $ ", O.resolvedSymbolURL = \"" <> hackageLink <> "#" + <> haddockSignalAnchor <> lcSignal <> "\"})" + export (NamedSubsection SignalSection $ lcSignal) si -- | Write some simple debug message when signal generation fails, and -- generate a placeholder SignalInfo instance. @@ -436,19 +464,18 @@ deprecatedPragma cbType (callableDeprecated cb) - genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures (sigDoc s) + genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures True (sigDoc s) - _ <- genCCallbackPrototype (lcFirst sn') cb cbType True + _ <- genCCallbackPrototype (lcFirst sn') cb cbType (Just on') - genCallbackWrapperFactory (lcFirst sn') cbType + genCallbackWrapperFactory (lcFirst sn') cbType True if callableThrows cb then do line $ "-- No Haskell->C wrapper generated since the function throws." blank else do - genClosure (lcFirst sn') cb cbType signalConnectorName True - genCallbackWrapper (lcFirst sn') cb cbType True + genCallbackWrapper (lcFirst sn') cb cbType (Just on') -- Wrapper for connecting functions to the signal -- We can connect to a signal either before the default handler runs @@ -459,10 +486,15 @@ -- since if something provides signals it is necessarily a -- GObject. klass <- classConstraint on + + addLanguagePragma "ImplicitParams" + addLanguagePragma "RankNTypes" + let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>" + implicitSelfCBType = "((?self :: a) => " <> cbType <> ")" signatureArgs = if sigDetailed s - then "a -> P.Maybe T.Text -> " <> cbType <> " -> m SignalHandlerId" - else "a -> " <> cbType <> " -> m SignalHandlerId" + then "a -> P.Maybe T.Text -> " <> implicitSelfCBType <> " -> m SignalHandlerId" + else "a -> " <> implicitSelfCBType <> " -> m SignalHandlerId" signature = " :: " <> signatureConstraints <> " " <> signatureArgs onName = "on" <> signalConnectorName afterName = "after" <> signalConnectorName @@ -473,10 +505,14 @@ if sigDetailed s then do line $ onName <> " obj detail cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectBefore" "detail" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectBefore" "detail" "wrapped" else do line $ onName <> " obj cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectBefore" "Nothing" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectBefore" "Nothing" "wrapped" export docSection onName group $ do @@ -485,10 +521,14 @@ if sigDetailed s then do line $ afterName <> " obj detail cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectAfter" "detail" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectAfter" "detail" "wrapped" else do line $ afterName <> " obj cb = liftIO $ do" - indent $ genSignalConnector s cbType "SignalConnectAfter" "Nothing" + indent $ do + line $ "let wrapped self = let ?self = self in cb" + genSignalConnector s cbType "SignalConnectAfter" "Nothing" "wrapped" export docSection afterName cppIf CPPOverloading (genSignalInfoInstance on s) @@ -520,7 +560,9 @@ <> hsn <> " callback" , "@" , "" - , detailedDoc ] + , detailedDoc + , "" + , selfDoc] detailedDoc :: Text detailedDoc = if not (sigDetailed s) @@ -531,6 +573,12 @@ <> "::detail@” instead." ] + selfDoc :: Text + selfDoc = T.unlines [ + "By default the object invoking the signal is not passed to the callback." + , "If you need to access it, you can use the implit @?self@ parameter." + , "Note that this requires activating the @ImplicitParams@ GHC extension." + ] -- | Generate the code for connecting the given signal. This assumes -- that it lives inside a @do@ block. @@ -538,9 +586,11 @@ -> Text -- ^ Callback type -> Text -- ^ SignalConnectBefore or SignalConnectAfter -> Text -- ^ Detail + -> Text -- ^ Name of variable holding the callback -> CodeGen e () -genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail = do - cb' <- genWrappedCallback cb "cb" cbType True +genSignalConnector (Signal {sigName = sn, sigCallable = cb}) + cbType when detail cbName = do + cb' <- genWrappedCallback cb cbName cbType True let cb'' = prime cb' line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb' line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -26,11 +26,14 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock, RelativeDocPosition(DocBeforeSymbol)) +import Data.GI.CodeGen.ModulePath (dotModulePath) import Data.GI.CodeGen.SymbolNaming (upperName, lowerName, underscoresToCamelCase, qualifiedSymbol, callbackHaskellToForeign, - callbackWrapperAllocator) + callbackWrapperAllocator, + haddockAttrAnchor, moduleLocation, + hackageModuleLink) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -334,6 +337,12 @@ transferType <- fieldTransferType (fieldType field) transferConstraint <- fieldTransferTypeConstraint (fieldType field) + api <- findAPIByName owner + hackageLink <- hackageModuleLink owner + let qualifiedAttrName = dotModulePath (moduleLocation owner api) + <> "." <> labelName field + attrInfoURL = hackageLink <> "#" <> haddockAttrAnchor <> labelName field + line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do @@ -366,6 +375,11 @@ line $ "attrTransfer _ v = do" indent $ genFieldTransfer "v" (fieldType field) else line $ "attrTransfer = undefined" + line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {" + indent $ do + line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\"" + line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\"" + line $ "})" blank diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs --- a/lib/Data/GI/CodeGen/SymbolNaming.hs +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -31,6 +31,8 @@ , normalizedAPIName , hackageModuleLink + , haddockSignalAnchor + , haddockAttrAnchor ) where #if !MIN_VERSION_base(4,11,0) @@ -268,9 +270,11 @@ -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text -signalHaskellName sn = let (w:ws) = T.split (== '-') sn - in w <> T.concat (map ucFirst ws) - +signalHaskellName sn = case T.split (== '-') sn of + [] -> "" -- Won't happen due to the + -- definition of T.split, but GHC + -- does not know this. + w:ws -> w <> T.concat (map ucFirst ws) -- | Return a link to the hackage package for the given name. Note -- that the generated link will only be valid if the name belongs to @@ -284,3 +288,10 @@ return $ "https://hackage.haskell.org/package/" <> pkg <> "/docs/" <> location <> ".html" +-- | Prefix in Haddock for the signal anchor. +haddockSignalAnchor :: Text +haddockSignalAnchor = "g:signal:" + +-- | Prefix in Haddock for the attribute anchor. +haddockAttrAnchor :: Text +haddockAttrAnchor = "g:attr:" diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -94,6 +94,7 @@ -- | A hash table. parseHashTable :: Parser Type parseHashTable = parseTypeElements >>= \case + [] -> return $ TGHash (TBasicType TPtr) (TBasicType TPtr) [Just key, Just value] -> return $ TGHash key value other -> parseError $ "Unsupported hash type: " <> T.pack (show other)