haskell-gi 0.22.6 → 0.23.0

raw patch · 37 files changed

+734/−298 lines, 37 filesdep +haskell-gidep ~attoparsecdep ~haskell-gi-basedep ~xml-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-gi

Dependency ranges changed: attoparsec, haskell-gi-base, xml-conduit

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• haskell-gi.cabal +12/−7
• lib/Data/GI/CodeGen/API.hs +2/−0
• lib/Data/GI/CodeGen/Cabal.hs +2/−3
• lib/Data/GI/CodeGen/CabalHooks.hs +6/−1
• lib/Data/GI/CodeGen/Callable.hs +37/−33
• lib/Data/GI/CodeGen/Code.hs +27/−9
• lib/Data/GI/CodeGen/CodeGen.hs +68/−16
• lib/Data/GI/CodeGen/Constant.hs +11/−13
• lib/Data/GI/CodeGen/Conversions.hs +35/−45
• lib/Data/GI/CodeGen/CtoHaskellMap.hs +61/−34
• lib/Data/GI/CodeGen/EnumFlags.hs +2/−0
• lib/Data/GI/CodeGen/Fixups.hs +35/−0
• lib/Data/GI/CodeGen/GtkDoc.hs +34/−0
• lib/Data/GI/CodeGen/Haddock.hs +29/−25
• lib/Data/GI/CodeGen/Inheritance.hs +6/−6
• lib/Data/GI/CodeGen/LibGIRepository.hs +4/−3
• lib/Data/GI/CodeGen/ModulePath.hs +2/−0
• lib/Data/GI/CodeGen/OverloadedLabels.hs +2/−0
• lib/Data/GI/CodeGen/OverloadedMethods.hs +11/−6
• lib/Data/GI/CodeGen/OverloadedSignals.hs +4/−28
• lib/Data/GI/CodeGen/PkgConfig.hs +3/−2
• lib/Data/GI/CodeGen/ProjectInfo.hs +4/−2
• lib/Data/GI/CodeGen/Properties.hs +96/−11
• lib/Data/GI/CodeGen/Signal.hs +93/−28
• lib/Data/GI/CodeGen/Struct.hs +80/−11
• lib/Data/GI/CodeGen/SymbolNaming.hs +17/−0
• lib/Data/GI/CodeGen/Transfer.hs +13/−6
• lib/Data/GI/CodeGen/Type.hs +2/−0
• lib/Data/GI/CodeGen/Util.hs +2/−1
• lib/Data/GI/GIR/Arg.hs +2/−0
• lib/Data/GI/GIR/Field.hs +2/−0
• lib/Data/GI/GIR/Parser.hs +2/−4
• lib/Data/GI/GIR/Property.hs +2/−0
• lib/Data/GI/GIR/Signal.hs +3/−0
• lib/Data/GI/GIR/Struct.hs +3/−0
• lib/Data/GI/GIR/Type.hs +2/−4

@@ -1,3 +1,21 @@+### 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.

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.22.6+version:             0.23.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.@@ -14,8 +14,8 @@ 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+tested-with:         GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1+cabal-version:       2.0  extra-source-files: ChangeLog.md @@ -24,11 +24,12 @@   location: git://github.com/haskell-gi/haskell-gi.git  Library+  default-language:    Haskell2010   pkgconfig-depends:   gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32   build-depends:       base >= 4.9 && < 5,-                       haskell-gi-base == 0.22.*,+                       haskell-gi-base >= 0.23.0 && <0.24,                        Cabal >= 1.24,-                       attoparsec == 0.13.*,+                       attoparsec >= 0.13,                        containers,                        directory,                        filepath,@@ -39,11 +40,11 @@                        safe,                        bytestring,                        xdg-basedir,-                       xml-conduit >= 1.3.0,+                       xml-conduit >= 1.3,                        regex-tdfa >= 1.2,                        text >= 1.0 -  extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings+  default-extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings   ghc-options:         -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing    ghc-options: -Wcompat@@ -111,10 +112,14 @@    other-modules:       Paths_haskell_gi +  autogen-modules:     Paths_haskell_gi+ test-suite doctests   type:          exitcode-stdio-1.0+  default-language: Haskell2010   ghc-options:   -threaded   main-is:       DocTests.hs   build-depends: base                , process                , doctest >= 0.8+               , haskell-gi

@@ -62,7 +62,9 @@ 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)

@@ -5,12 +5,11 @@     , tryPkgConfig     ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif import Control.Monad (forM_) import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T

@@ -32,7 +32,9 @@  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@@ -88,11 +90,13 @@    utf8WriteFile fname $ T.unlines     [ "{-# LANGUAGE OverloadedStrings #-}"+    , "-- | Build time configuration used during code generation."     , "module GI." <> ucFirst modName <> ".Config ( overrides ) where"     , ""     , "import qualified Data.Text as T"     , "import Data.Text (Text)"     , ""+    , "-- | Overrides used when generating these bindings."     , "overrides :: Text"     , "overrides = T.unlines"     , " [ " <> T.intercalate "\n , " (quoteOverrides maybeGiven) <> "]"@@ -181,4 +185,5 @@   let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs   m <- genModuleCode name version False ovs -  return (listModuleTree m, transitiveModuleDeps m)+  return (("GI." <> ucFirst name <> ".Config") : listModuleTree m,+           transitiveModuleDeps m)

@@ -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.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@@ -120,15 +113,15 @@                 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 args = do+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)+          (t, cons) <- argumentType (argType arg) expose           t' <- wrapMaybe arg >>= bool (return t)             (return $ "Maybe (" <> t <> ")")           (restCons, restTypes) <- go args@@ -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@@ -317,8 +310,8 @@                 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 Text+prepareInCallback arg (Callback {cbCallable = cb}) expose = do   let name = escapedArgName arg       ptrName = "ptr" <> name       scope = argScope arg@@ -327,7 +320,7 @@       case argType arg of         TInterface tn@(Name _ n) ->             do-              drop <- if callableHasClosures cb+              drop <- if callableHasClosures cb && expose == WithoutClosures                       then Just <$> qualifiedSymbol (callbackDropClosures n) tn                       else return Nothing               wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn@@ -574,9 +567,9 @@             line $ "safeFreeFunPtr $ castFunPtrToPtr " <> 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 +598,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 {@@ -790,23 +784,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 +856,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 @@ -897,14 +893,22 @@ genCallableDebugInfo :: Callable -> CodeGen () 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 ()+        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 ()

@@ -40,6 +40,7 @@     , hsBoot     , submodule     , setLanguagePragmas+    , addLanguagePragma     , setGHCOptions     , setModuleFlags     , setModuleMinBase@@ -74,7 +75,9 @@ import Control.Monad.Except import qualified Data.Foldable as F import Data.Maybe (fromMaybe, catMaybes)+#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@@ -605,7 +608,7 @@ -- | 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 CPPOverloading = cppIfBlock "defined(ENABLE_OVERLOADING)"  -- | Write the given code into the .hs-boot file for the current module. hsBoot :: BaseCodeGen e a -> BaseCodeGen e a@@ -642,6 +645,12 @@ setLanguagePragmas ps =     modify' $ \(cgs, s) -> (cgs, s{modulePragmas = Set.fromList ps}) +-- | Add a language pragma for the current module.+addLanguagePragma :: Text -> CodeGen ()+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 opts =@@ -779,7 +788,7 @@                                                    " #" <> anchor <> "#"                                     Nothing -> subsectionTitle subsec                     , case subsectionDoc subsec of-                        Just text -> "{- | " <> text  <> "\n-}"+                        Just text -> formatHaddockComment text                         Nothing -> ""                     , ( T.concat                       . map (formatExport exportSymbol)@@ -822,10 +831,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@@ -835,10 +844,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"@@ -893,6 +910,7 @@                 , "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 Data.Text as T"                 , "import qualified Data.ByteString.Char8 as B"                 , "import qualified Data.Map as Map"

@@ -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,8 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,-                               detectGObject, dropDuplicatedFields)+                               detectGObject, dropDuplicatedFields,+                               checkClosureDestructors) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation,                                 writeHaddock,@@ -43,6 +42,10 @@ import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) +-- | Standard derived instances for newtypes wrapping @ManagedPtr@s.+newtypeDeriving :: CodeGen ()+newtypeDeriving = indent $ line $ "deriving (Eq)"+ genFunction :: Name -> Function -> CodeGen () genFunction n (Function symbol fnMovedTo callable) =     -- Only generate the function if it has not been moved.@@ -57,18 +60,41 @@                           export (NamedSubsection MethodSection $ lowerName n) (lowerName n)                         ) +-- | Generate the GValue instances for the given GObject.+genBoxedGValueInstance :: Name -> Text -> CodeGen ()+genBoxedGValueInstance n get_type_fn = do+  let name' = upperName n+      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."++  writeHaddock DocBeforeSymbol doc++  group $ do+    bline $ "instance B.GValue.IsGValue " <> name' <> " where"+    indent $ group $ do+      line $ "toGValue o = do"+      indent $ group $ do+        line $ "gtype <- " <> get_type_fn+        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"+      line $ "fromGValue gv = do"+      indent $ group $ do+        line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")"+        line $ "B.ManagedPtr.newBoxed " <> name' <> " ptr"+ genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do   let name' = upperName n+      get_type_fn = "c_" <> typeInit    group $ do-    line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>-            typeInit <> " :: "+    line $ "foreign import ccall \"" <> typeInit <> "\" " <>+            get_type_fn <> " :: "     indent $ line "IO GType"   group $ do        line $ "instance BoxedObject " <> name' <> " where"-       indent $ line $ "boxedType _ = c_" <> typeInit+       indent $ line $ "boxedType _ = " <> get_type_fn +  genBoxedGValueInstance n get_type_fn+   hsBoot $ line $ "instance BoxedObject " <> name' <> " where"  -- | Generate wrapper for structures.@@ -80,6 +106,7 @@    let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"    hsBoot decl    decl+   newtypeDeriving     addSectionDocumentation ToplevelSection (structDocumentation s) @@ -123,6 +150,7 @@   let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"   hsBoot decl   decl+  newtypeDeriving    addSectionDocumentation ToplevelSection (unionDocumentation u) @@ -234,20 +262,43 @@     cppIf CPPOverloading $          genMethodInfo cn (m {methodCallable = c''}) +-- | Generate the GValue instances for the given GObject.+genGObjectGValueInstance :: Name -> Text -> CodeGen ()+genGObjectGValueInstance n get_type_fn = do+  let name' = upperName n+      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."++  writeHaddock DocBeforeSymbol doc++  group $ do+    bline $ "instance B.GValue.IsGValue " <> name' <> " where"+    indent $ group $ do+      line $ "toGValue o = do"+      indent $ group $ do+        line $ "gtype <- " <> get_type_fn+        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_object)"+      line $ "fromGValue gv = do"+      indent $ group $ do+        line $ "ptr <- B.GValue.get_object gv :: IO (Ptr " <> name' <> ")"+        line $ "B.ManagedPtr.newObject " <> name' <> " ptr"+ -- Type casting with type checking genGObjectCasts :: Name -> Text -> [Name] -> CodeGen () genGObjectCasts n cn_ parents = do   let name' = upperName n+      get_type_fn = "c_" <> cn_    group $ do     line $ "foreign import ccall \"" <> cn_ <> "\""-    indent $ line $ "c_" <> cn_ <> " :: IO GType"+    indent $ line $ get_type_fn <> " :: IO GType"    group $ do     bline $ "instance GObject " <> name' <> " where"     indent $ group $ do-            line $ "gobjectType = c_" <> cn_+            line $ "gobjectType = " <> get_type_fn +  genGObjectGValueInstance n get_type_fn+   className <- classConstraint n   group $ do     exportDecl className@@ -303,6 +354,7 @@   else do     writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")     bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"+    newtypeDeriving     exportDecl (name' <> "(..)")      addSectionDocumentation ToplevelSection (objDocumentation o)@@ -316,12 +368,7 @@     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)+    forM_ (objSignals o) $ \s -> genSignal s n      genObjectProperties n o     cppIf CPPOverloading $@@ -347,6 +394,7 @@   writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")   deprecatedPragma name' $ ifDeprecated iface   bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"+  newtypeDeriving   exportDecl (name' <> "(..)")    addSectionDocumentation ToplevelSection (ifDocumentation iface)@@ -468,6 +516,10 @@             -- Some APIs contain duplicated fields by mistake, drop             -- the duplicates.           $ map dropDuplicatedFields+            -- Make sure that every argument marked as being a+            -- destructor for a user_data argument has an associated+            -- user_data argument.+          $ map checkClosureDestructors           $ M.toList           $ apis 

@@ -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@@ -33,14 +31,14 @@  writePattern :: Text -> PatternSynonym -> CodeGen () 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 _ name) c = group $ do@@ -50,7 +48,7 @@   handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError 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 +90,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

@@ -13,11 +13,10 @@     , transientToH     , haskellType     , isoHaskellType-    , inboundHaskellType-    , haskellTypeConstraint     , foreignType      , argumentType+    , ExposeClosures(..)     , elementType     , elementMap     , elementTypeAndMap@@ -43,7 +42,9 @@ #endif import Control.Monad (when) import Data.Maybe (isJust)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T import GHC.Exts (IsString(..))@@ -694,17 +695,23 @@  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 -> CodeGen (Text, [Text])-argumentType (TGList a) = do-  (name, constraints) <- argumentType a+argumentType :: Type -> ExposeClosures -> CodeGen (Text, [Text])+argumentType (TGList a) expose = do+  (name, constraints) <- argumentType a expose   return ("[" <> name <> "]", constraints)-argumentType (TGSList a) = do-  (name, constraints) <- argumentType a+argumentType (TGSList a) expose = do+  (name, constraints) <- argumentType a expose   return ("[" <> name <> "]", constraints)-argumentType t = do+argumentType t expose = do   api <- findAPI t   s <- typeShow <$> haskellType t   case api of@@ -728,7 +735,12 @@         ft <- typeShow <$> foreignType t         return (ft, [])       else-        return (s, [])+        case expose of+          WithClosures -> do+            s_withClosures <- typeShow <$> isoHaskellType t+            return (s_withClosures, [])+          WithoutClosures ->+            return (s, [])     _ -> return (s, [])  haskellBasicType :: BasicType -> TypeRep@@ -816,36 +828,6 @@              (APIFlags _) -> "[]" `con` [tname `con` []]              _ -> tname `con` [] --- | 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. Note that for--- types which are not untyped `TGClosure` this is equivalent to--- `isoHaskellType`.-inboundHaskellType :: Type -> CodeGen TypeRep-inboundHaskellType (TGClosure Nothing) =-  return $ "GClosure" `con` [con0 "()"]-inboundHaskellType t = isoHaskellType t---- | The constraint for setting the given type in properties.-haskellTypeConstraint :: Type -> CodeGen Text-haskellTypeConstraint (TGClosure Nothing) =-  return $ "(~) " <> parenthesize (typeShow ("GClosure" `con` [con0 "()"]))-haskellTypeConstraint 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-- -- | Whether the callable has closure arguments (i.e. "user_data" -- style arguments). callableHasClosures :: Callable -> Bool@@ -860,13 +842,21 @@     _ -> 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.+-- | Basically like `haskellType`, but for types which admit a+-- "isomorphic" version of the Haskell type distinct from the usual+-- Haskell type.  Generally the Haskell type we expose is isomorphic+-- to the foreign type, but in some cases, such as callbacks with+-- closure arguments, this does not hold, as we omit the closure+-- arguments. This function returns a type which is actually+-- isomorphic. There is another case this function deals with: for+-- convenience untyped `TGClosure` types have a type variable on the+-- Haskell side when they are arguments to functions, but we do not+-- want this when they appear as arguments to callbacks/signals, or+-- return types of properties, as it would force the type synonym/type+-- family to depend on the type variable. isoHaskellType :: Type -> CodeGen TypeRep+isoHaskellType (TGClosure Nothing) =+  return $ "GClosure" `con` [con0 "()"] isoHaskellType t@(TInterface n) = do   api <- findAPI t   case api of

@@ -6,31 +6,36 @@   ) 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.API (API(..), Name(..), Callback(..),                             Constant(..), Flags(..),                             Enumeration(..), EnumerationMember(..),                             Interface(..), Object(..),-                            Function(..), Method(..), Struct(..), Union(..))+                            Function(..), Method(..), Struct(..), Union(..),+                            Signal(..)) import Data.GI.CodeGen.ModulePath (ModulePath, dotModulePath, (/.))-import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName)+import Data.GI.CodeGen.SymbolNaming (submoduleLocation, lowerName, upperName,+                                     signalHaskellName) import Data.GI.CodeGen.Util (ucFirst)  -- | 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,54 +55,53 @@         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 = [(TypeRef "gboolean", TypeIdentifier "P.Bool"),+                    (ConstantRef "TRUE", ValueIdentifier "P.True"),+                    (ConstantRef "FALSE", ValueIdentifier "P.False"),+                    (TypeRef "GError", TypeIdentifier "GError"),+                    (TypeRef "GType", TypeIdentifier "GType"),+                    (TypeRef "GVariant", TypeIdentifier "GVariant"),+                    (ConstantRef "NULL", ValueIdentifier "P.Nothing")]  -- | Obtain the absolute location of the module where the given `API` -- lives. location :: Name -> API -> ModulePath location n api = ("GI" /. ucFirst (namespace n)) <> submoduleLocation n api --- | 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 value.+fullyQualifiedValue :: Name -> API -> Text -> Hyperlink+fullyQualifiedValue n api symbol =+  ValueIdentifier $ 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 (location 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),+                  fullyQualifiedValue n (APIConst c) $ name n),                  (TypeRef (constantCType c),-                  fullyQualified n (APIConst c) $ name n)]+                  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)]+                 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) :+enumRefs api n e = (TypeRef (enumCType e),+                    fullyQualifiedType n api $ upperName n) :                    map memberToRef (enumMembers e)   where memberToRef :: EnumerationMember -> (CRef, Hyperlink)         memberToRef em = (ConstantRef (enumMemberCId em),-                          fullyQualified n api $ upperName $+                          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))]- -- | Refs to the methods for a given owner. methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)] methodRefs n api methods = map methodRef methods@@ -106,8 +110,29 @@           -- Method name namespaced by the owner.           let mn' = mn {name = name n <> "_" <> name mn}           in (FunctionRef (methodSymbol m),-              fullyQualified n api $ lowerName mn')+              fullyQualifiedValue n api $ lowerName mn') +-- | Refs to the signals for a given owner.+signalRefs :: Name -> API -> Maybe Text -> [Signal] -> [(CRef, Hyperlink)]+signalRefs n api maybeCName signals = map signalRef signals+  where signalRef :: Signal -> (CRef, Hyperlink)+        signalRef (Signal {sigName = sn}) =+          let mod = dotModulePath (location n api)+              sn' = signalHaskellName sn+              ownerCName = case maybeCName of+                Just cname -> cname+                Nothing -> let Name ns owner = n+                           in ucFirst ns <> owner+          in (SignalRef ownerCName sn,+              ModuleLinkWithAnchor (Just sn') mod ("signal:" <> sn'))++-- | Given an optional C type and the API constructor construct the+-- list of associated refs.+maybeCType :: Name -> API -> Maybe Text -> [(CRef, Hyperlink)]+maybeCType _ _ Nothing = []+maybeCType n api (Just ctype) = [(TypeRef ctype,+                                  fullyQualifiedType n api (upperName n))]+ -- | Extract the C name of a callback. callbackRefs :: Name -> Callback -> [(CRef, Hyperlink)] callbackRefs n cb = maybeCType n (APICallback cb) (cbCType cb)@@ -126,8 +151,10 @@ 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)  -- | 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)

@@ -5,7 +5,9 @@     ) 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 

@@ -4,10 +4,13 @@     , guessPropertyNullability     , detectGObject     , dropDuplicatedFields+    , checkClosureDestructors     ) where  import Data.Maybe (isNothing, isJust)+#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import qualified Data.Set as S import qualified Data.Text as T @@ -150,3 +153,35 @@ 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 a 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

@@ -15,7 +15,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*)) #endif+#if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))+#endif import Control.Applicative ((<|>))  import Data.Attoparsec.Text@@ -25,6 +27,7 @@  -- | A parsed gtk-doc token. data Token = Literal Text+           | Comment Text            | Verbatim Text            | CodeBlock (Maybe Language) Text            | ExternalLink Link@@ -54,6 +57,7 @@           | ParamRef Text           | ConstantRef Text           | SignalRef Text Text+          | LocalSignalRef Text           | PropertyRef Text Text           | VMethodRef Text Text           | StructFieldRef Text Text@@ -82,6 +86,9 @@ -- >>> parseGtkDoc "Call foo() for free cookies" -- GtkDoc [Literal "Call ",SymbolRef (FunctionRef "foo"),Literal " for free cookies"] --+-- >>> parseGtkDoc "The signal ::activate is related to gtk_button_activate()."+-- GtkDoc [Literal "The signal ",SymbolRef (LocalSignalRef "activate"),Literal " is related to ",SymbolRef (FunctionRef "gtk_button_activate"),Literal "."]+-- -- >>> 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 "."] --@@ -167,6 +174,7 @@              -- backtracking.                  parseFunctionRef              <|> parseSignal+             <|> parseLocalSignal              <|> parseProperty              <|> parseVMethod              <|> parseStructField@@ -180,6 +188,7 @@              <|> parseImage              <|> parseSectionHeader              <|> parseList+             <|> parseComment              <|> parseBoringLiteral  -- | Parse a signal name, of the form@@ -196,6 +205,18 @@   signal <- signalOrPropName   return (SymbolRef (SignalRef obj 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, of the form -- > #Object:property --@@ -210,6 +231,18 @@   property <- signalOrPropName   return (SymbolRef (PropertyRef obj property)) +-- | Parse an xml comment, of the form+-- > <!-- comment -->+-- Note that this function keeps spaces.+--+-- === __Examples__+-- >>> parseOnly (parseComment <* endOfInput) "<!-- comment -->"+-- Right (Comment " comment ")+parseComment :: Parser Token+parseComment = do+  comment <- string "<!--" *> manyTill anyChar (string "-->")+  return (Comment $ T.pack comment)+ -- | Parse a reference to a virtual method, of the form -- > #Struct.method() --@@ -338,6 +371,7 @@ special '[' = True special '!' = True special '\n' = True+special ':' = True special c = isCIdent c  -- | Parse a verbatim string, of the form

@@ -10,12 +10,15 @@   , 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) @@ -31,7 +34,7 @@ import Data.GI.CodeGen.GtkDoc (GtkDoc(..), Token(..), CRef(..), Language(..),                                Link(..), ListItem(..), parseGtkDoc) import Data.GI.CodeGen.Overrides (onlineDocsMap)-import Data.GI.CodeGen.SymbolNaming (lowerSymbol)+import Data.GI.CodeGen.SymbolNaming (lowerSymbol, signalHaskellName)  -- | Where is the documentation located with respect to the relevant -- symbol, useful for determining whether we want to start with @|@ or @^@.@@ -47,9 +50,9 @@ -- >>> formatHaddock M.empty "" (GtkDoc [Literal "Hello ", Literal "World!"]) -- "Hello World!" ----- >>> let c2h = M.fromList [(FunctionRef "foo", "foo()")]+-- >>> let c2h = M.fromList [(FunctionRef "foo", ValueIdentifier "foo")] -- >>> formatHaddock c2h "" (GtkDoc [SymbolRef (FunctionRef "foo")])--- "'foo()'"+-- "'foo'" -- -- >>> let onlineDocs = "http://wiki.haskell.org" -- >>> formatHaddock M.empty onlineDocs (GtkDoc [ExternalLink (Link "GI" "GObjectIntrospection")])@@ -61,13 +64,13 @@ formatHaddock c2h docBase (GtkDoc doc) = T.concat $ map formatToken doc   where formatToken :: Token -> Text         formatToken (Literal l) = escape 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 (SymbolRef cr) = case M.lookup cr c2h of           Just hr -> formatHyperlink hr           Nothing -> formatUnknownCRef c2h cr@@ -75,7 +78,10 @@ -- | 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 _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/"+formatUnknownCRef _ (LocalSignalRef s) =+  let sn = signalHaskellName s+  in "[" <> sn <> "](#signal:" <> sn <> ")" formatUnknownCRef c2h (SignalRef owner signal) =   case M.lookup (TypeRef owner) c2h of     Nothing -> formatCRef $ owner <> "::" <> signal@@ -101,9 +107,13 @@  -- | 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@@ -220,14 +230,9 @@ -- | Write the given documentation into generated code. writeDocumentation :: RelativeDocPosition -> Documentation -> CodeGen () 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 "-}"+  writeHaddock pos (formatDocumentation c2h docBase doc)  -- | Like `writeDocumentation`, but allows us to pass explicitly the -- Haddock comment to write.@@ -236,12 +241,10 @@   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 ()@@ -251,8 +254,9 @@     Just raw -> do       c2h <- getC2HMap       docBase <- getDocBase-      line $ "{- ^ /@" <> lowerSymbol (argCName arg) <> "@/: " <>-        formatHaddock c2h docBase (parseGtkDoc raw) <> " -}"+      let haddock = "/@" <> lowerSymbol (argCName arg) <> "@/: " <>+                    formatHaddock c2h docBase (parseGtkDoc raw)+      writeHaddock DocAfterSymbol haddock  -- | Write the documentation for the given return value. writeReturnDocumentation :: Callable -> Bool -> CodeGen ()@@ -271,7 +275,7 @@                    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 ()

@@ -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@@ -70,9 +70,9 @@ apiInheritables :: Inheritable i => Name -> CodeGen [(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)]

@@ -82,9 +82,10 @@     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)+                               (\gerror -> error $ "Could not load typelib for "+                                           ++ show ns ++ " version "+                                           ++ show version ++ ".\n"+                                           ++ "Error was: " ++ show gerror)         return (Typelib typelib)  foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::

@@ -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

@@ -6,7 +6,9 @@ import Control.Applicative ((<$>)) #endif import Data.Maybe (isNothing)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Control.Monad (forM_) import qualified Data.Set as S import Data.Text (Text)

@@ -5,11 +5,14 @@     ) 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@@ -26,14 +29,15 @@ -- | Appropriate instances so overloaded labels are properly resolved. genMethodResolver :: Text -> CodeGen () genMethodResolver n = do+  addLanguagePragma "TypeApplications"   group $ do     line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "           <> "O.MethodInfo info " <> n <> " p) => OL.IsLabel t ("           <> n <> " -> p) where"     line $ "#if MIN_VERSION_base(4,10,0)"-    indent $ line $ "fromLabel = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"+    indent $ line $ "fromLabel = O.overloadedMethod @info"     line $ "#else"-    indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"+    indent $ line $ "fromLabel _ = O.overloadedMethod @info"     line $ "#endif"  -- | Generate the `MethodList` instance given the list of methods for@@ -51,6 +55,7 @@               return ((lowerName . methodName) method, mi)   group $ do     let resolver = "Resolve" <> name <> "Method"+    export (NamedSubsection MethodSection "Overloaded methods") resolver     line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where"     indent $ forM_ infos $ \(label, info) -> do         line $ resolver <> " \"" <> label <> "\" o = " <> info@@ -74,7 +79,7 @@       group $ do         infoName <- methodInfoName n m         let callable = fixupCallerAllocates (methodCallable m)-        sig <- callableSignature callable (KnownForeignSymbol undefined)+        sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures         bline $ "data " <> infoName         -- This should not happen, since ordinary methods always         -- have the instance as first argument.@@ -88,7 +93,7 @@                  <> ") => O.MethodInfo " <> infoName <> " " <> obj <> " signature where"         let mn = methodName m             mangled = lowerName (mn {name = name n <> "_" <> name mn})-        indent $ line $ "overloadedMethod _ = " <> mangled+        indent $ line $ "overloadedMethod = " <> mangled         export (NamedSubsection MethodSection $ lowerName mn) infoName  -- | Generate a method info that is not actually callable, but rather@@ -99,8 +104,8 @@   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 \""+  line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \""            <> lowerName (methodName m) <> "\" " <> name n            <> ") => O.MethodInfo " <> infoName <> " o p where"-  indent $ line $ "overloadedMethod _ = undefined"+  indent $ line $ "overloadedMethod = undefined"   export ToplevelSection infoName

@@ -9,7 +9,9 @@ #endif import Control.Monad (forM_, when) +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T import qualified Data.Set as S@@ -18,10 +20,9 @@ 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)+                                     signalInfoName)+import Data.GI.CodeGen.Util (lcFirst)  -- A list of distinct signal names for all GObjects appearing in the -- given list of APIs.@@ -61,36 +62,12 @@     line $ "pattern " <> camelName <> " = SignalProxy"     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- -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen () 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,7 +83,6 @@ genInterfaceSignals :: Name -> Interface -> CodeGen () 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

@@ -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

@@ -14,7 +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) @@ -25,7 +27,7 @@ authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte"  maintainers :: Text-maintainers = "Iñaki García Etxebarria (inaki@blueleaf.cc)"+maintainers = "Iñaki García Etxebarria"  license :: Text license = "LGPL-2.1"@@ -42,7 +44,7 @@ -- | 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]

@@ -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@@ -25,7 +27,9 @@ import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint,                                      hyphensToCamelCase, qualifiedSymbol,-                                     callbackDynamicWrapper)+                                     typeConstraint, callbackDynamicWrapper,+                                     callbackHaskellToForeign,+                                     callbackWrapperAllocator) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -39,6 +43,7 @@    TVariant -> return "Variant"    TParamSpec -> return "ParamSpec"    TGClosure _ -> return "Closure"+   TError -> return "GError"    TBasicType TInt -> case sizeOf (0 :: CInt) of                         4 -> return "Int32"                         n -> error ("Unsupported `gint' type length: " ++@@ -85,6 +90,70 @@        _ -> error $ "Unknown interface property of type : " ++ show t    _ -> error $ "Don't know how to handle properties of type " ++ show t +-- | The constraint for setting the given type in properties.+propSetTypeConstraint :: Type -> CodeGen 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 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 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 ()+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)@@ -96,7 +165,7 @@       ftype <- foreignType (propType prop)       return ([], typeShow ftype)     else do-      (t,constraints) <- argumentType $ propType prop+      (t,constraints) <- argumentType (propType prop) WithoutClosures       return (constraints, t)  -- | Generate documentation for the given setter.@@ -142,7 +211,7 @@ genPropertyGetter getter n docSection prop = group $ do   isNullable <- typeIsNullable (propType prop)   let isMaybe = isNullable && propReadNullable prop /= Just False-  constructorType <- inboundHaskellType (propType prop)+  constructorType <- isoHaskellType (propType prop)   tStr <- propTypeStr $ propType prop   cls <- classConstraint n   let constraints = "(MonadIO m, " <> cls <> " o)"@@ -323,8 +392,8 @@              then return "()"              else do                sOutType <- if isNullable && propReadNullable prop /= Just False-                           then typeShow . maybeT <$> inboundHaskellType (propType prop)-                           else typeShow <$> inboundHaskellType (propType prop)+                           then typeShow . maybeT <$> isoHaskellType (propType prop)+                           else typeShow <$> isoHaskellType (propType prop)                return $ if T.any (== ' ') sOutType                         then parenthesize sOutType                         else sOutType@@ -333,8 +402,14 @@   cppIf CPPOverloading $ do     cls <- classConstraint owner     inConstraint <- if writable || constructOnly-                    then haskellTypeConstraint (propType prop)+                    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 allowedOps = (if writable                       then ["'AttrSet", "'AttrConstruct"]                       else [])@@ -354,16 +429,23 @@     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 writable || constructOnly+              then do line $ "attrTransfer _ v = do"+                      indent $ genPropTransfer "v" (propType prop)+              else line $ "attrTransfer _ = undefined"+            line $ "attrConstruct = " <> constructor+            line $ "attrClear = " <> clear  -- | Generate a placeholder property for those cases in which code -- generation failed.@@ -379,6 +461,8 @@   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 <> " = \"\""@@ -387,6 +471,7 @@     line $ "attrSet = undefined"     line $ "attrConstruct = undefined"     line $ "attrClear = undefined"+    line $ "attrTransfer = undefined"  genProperties :: Name -> [Property] -> [Text] -> CodeGen () genProperties n ownedProps allProps = do

@@ -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)+#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@@ -53,7 +51,7 @@     line $ "type " <> name' <> " ="     indent $ do       forM_ inArgsWithArrows $ \(arrow, arg) -> do-        ht <- inboundHaskellType (argType arg)+        ht <- isoHaskellType (argType arg)         isMaybe <- wrapMaybe arg         let formattedType = if isMaybe                             then typeShow (maybeT ht)@@ -383,13 +381,48 @@         genClosure name' cb' name' name' False         genCallbackWrapper name' cb' name' False --- | 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 ()+genSignalInfoInstance 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 detail = do"+      indent $ genSignalConnector signal cbHaskellType "connectMode" "detail"+  export (NamedSubsection SignalSection $ lcFirst sn) 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 ()+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 : ", describeCGError 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 ()+genSignal s@(Signal { sigName = sn, sigCallable = cb }) on =+  handleCGExc (processSignalError s on) $ do   let on' = upperName on    line $ "-- signal " <> on' <> "::" <> sn@@ -425,7 +458,9 @@     -- GObject.     klass <- classConstraint on     let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>"-        signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"+        signatureArgs = if sigDetailed s+          then "a -> P.Maybe T.Text -> " <> cbType <> " -> m SignalHandlerId"+          else "a -> " <> cbType <> " -> m SignalHandlerId"         signature = " :: " <> signatureConstraints <> " " <> signatureArgs         onName = "on" <> signalConnectorName         afterName = "after" <> signalConnectorName@@ -433,48 +468,78 @@     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 $ genSignalConnector s cbType "SignalConnectBefore" "detail"+        else do+        line $ onName <> " obj cb = liftIO $ do"+        indent $ genSignalConnector s cbType "SignalConnectBefore" "Nothing"       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 $ genSignalConnector s cbType "SignalConnectAfter" "detail"+        else do+        line $ afterName <> " obj cb = liftIO $ do"+        indent $ genSignalConnector s cbType "SignalConnectAfter" "Nothing"       export docSection afterName +  cppIf CPPOverloading (genSignalInfoInstance on s)+   where     onDoc :: Text-    onDoc = T.unlines [-      "Connect a signal handler for the “@" <> sn <>-        "@” signal, to be run before the default handler."+    onDoc = let hsn = signalHaskellName sn+            in T.unlines [+      "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <>+        ") signal, to be run before the default handler."       , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"       , ""       , "@"       , "'Data.GI.Base.Signals.on' " <> lowerName on <> " #"-        <> lcFirst (hyphensToCamelCase sn) <> " callback"-      , "@" ]+        <> hsn <> " callback"+      , "@"+      , ""+      , detailedDoc ]      afterDoc :: Text-    afterDoc = T.unlines [-      "Connect a signal handler for the “@" <> sn <>-        "@” signal, to be run after the default handler."+    afterDoc = let hsn = signalHaskellName sn+               in T.unlines [+      "Connect a signal handler for the [" <> hsn <> "](#signal:" <> hsn <>+        ") signal, to be run after the default handler."       , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"       , ""       , "@"       , "'Data.GI.Base.Signals.after' " <> lowerName on <> " #"-        <> lcFirst (hyphensToCamelCase sn) <> " callback"-      , "@" ]+        <> hsn <> " callback"+      , "@"+      , ""+      , detailedDoc ] +    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."+      ]++ -- | 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+                   -> Text -- ^ Detail                    -> CodeGen ()-genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when = do+genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when detail = do   cb' <- genWrappedCallback cb "cb" cbType True   let cb'' = prime cb'   line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb'   line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when+          <> " " <> detail

@@ -14,7 +14,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,14 +25,20 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock,                                 RelativeDocPosition(DocBeforeSymbol))-import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.SymbolNaming (upperName, lowerName,+                                     underscoresToCamelCase,+                                     qualifiedSymbol,+                                     callbackHaskellToForeign,+                                     callbackWrapperAllocator)+ 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 Bool@@ -139,8 +147,8 @@                  then return Nothing                  else maybeNullConvert (fieldType field)   hType <- typeShow <$> if isJust nullConvert-                        then maybeT <$> inboundHaskellType (fieldType field)-                        else inboundHaskellType (fieldType field)+                        then maybeT <$> isoHaskellType (fieldType field)+                        else isoHaskellType (fieldType field)   fType <- typeShow <$> foreignType (fieldType field)    writeHaddock DocBeforeSymbol (getterDoc n field)@@ -244,6 +252,58 @@     line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)          <> ") ("  <> nullPtr <> " :: " <> fType <> ")" +-- | Return whether the given type corresponds to a callback that does+-- not throw exceptions. See [Note: Callables that throw] for the+-- reason why we do not try to wrap callbacks that throw exceptions.+isRegularCallback :: Type -> CodeGen Bool+isRegularCallback t@(TInterface _) = do+  api <- getAPI t+  case api of+    APICallback (Callback {cbCallable = callable}) ->+      return (not $ callableThrows callable)+    _ -> return False+isRegularCallback _ = return False++-- | The types accepted by the allocating set function+-- 'Data.GI.Base.Attributes.(:&=)'.+fieldTransferTypeConstraint :: Type -> CodeGen Text+fieldTransferTypeConstraint t = do+  isPtr <- typeIsPtr t+  isRegularCallback <- isRegularCallback t+  inType <- if isPtr && not isRegularCallback+            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 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 ()+genFieldTransfer var t@(TInterface tn@(Name _ n)) = do+  isRegularCallback <- isRegularCallback t+  if isRegularCallback+    then do+      wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn+      maker <- qualifiedSymbol (callbackWrapperAllocator n) tn+      line $ maker <> " " <>+        parenthesize (wrapper <> " Nothing " <> var)+    else line $ "return " <> var+genFieldTransfer var _ = line $ "return " <> var+ -- | Haskell name for the field fName :: Field -> Text fName = underscoresToCamelCase . fieldName@@ -265,15 +325,18 @@   embedded <- isEmbedded field   isNullable <- typeIsNullable (fieldType field)   outType <- typeShow <$> if not embedded && isNullable-                          then maybeT <$> inboundHaskellType (fieldType field)-                          else inboundHaskellType (fieldType field)+                          then maybeT <$> isoHaskellType (fieldType field)+                          else isoHaskellType (fieldType field)   inType <- if isPtr             then typeShow <$> foreignType (fieldType field)             else typeShow <$> haskellType (fieldType field)+  transferType <- fieldTransferType (fieldType field)+  transferConstraint <- fieldTransferTypeConstraint (fieldType field)    line $ "data " <> it   line $ "instance AttrInfo " <> it <> " where"   indent $ do+    line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on     line $ "type AttrAllowedOps " <> it <>              if embedded              then " = '[ 'AttrGet]"@@ -284,18 +347,24 @@              <> 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"    blank 

@@ -21,12 +21,17 @@     , callbackHaskellToForeignWithClosures     , callbackClosureGenerator +    , signalHaskellName+    , signalInfoName+     , submoduleLocation     , qualifiedAPI     , qualifiedSymbol     ) where +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text) import qualified Data.Text as T @@ -235,3 +240,15 @@     | "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 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 = let (w:ws) = T.split (== '-') sn+                       in w <> T.concat (map ucFirst ws)

@@ -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@@ -230,15 +232,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

@@ -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) 

@@ -19,14 +19,15 @@   , splitOn   ) where +#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-  padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " "

@@ -6,7 +6,9 @@     , parseTransfer     ) where +#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))+#endif import Data.Text (Text)  import Data.GI.GIR.BasicTypes (Transfer(..), Type)

@@ -8,7 +8,9 @@ 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,14 +33,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

@@ -5,7 +5,9 @@     ) 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)

@@ -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               }

@@ -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

@@ -8,12 +8,10 @@     , parseOptionalType     ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif- 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)