haskell-gi 0.21.5 → 0.22.0

raw patch · 18 files changed

+318/−130 lines, 18 filesdep ~basedep ~haskell-gi-basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, haskell-gi-base

API changes (from Hackage documentation)

Files

• LICENSE +14/−0
• haskell-gi.cabal +6/−8
• lib/Data/GI/CodeGen/CabalHooks.hs +34/−13
• lib/Data/GI/CodeGen/Callable.hs +11/−11
• lib/Data/GI/CodeGen/Code.hs +42/−6
• lib/Data/GI/CodeGen/CodeGen.hs +23/−13
• lib/Data/GI/CodeGen/Conversions.hs +93/−18
• lib/Data/GI/CodeGen/Fixups.hs +20/−0
• lib/Data/GI/CodeGen/OverloadedMethods.hs +1/−8
• lib/Data/GI/CodeGen/OverloadedSignals.hs +0/−6
• lib/Data/GI/CodeGen/ProjectInfo.hs +22/−4
• lib/Data/GI/CodeGen/Properties.hs +13/−22
• lib/Data/GI/CodeGen/Signal.hs +6/−5
• lib/Data/GI/CodeGen/Struct.hs +4/−4
• lib/Data/GI/CodeGen/Transfer.hs +5/−0
• lib/Data/GI/GIR/BasicTypes.hs +1/−0
• lib/Data/GI/GIR/Property.hs +3/−3
• lib/Data/GI/GIR/Type.hs +20/−9

@@ -1,3 +1,17 @@+The haskell-gi library and included works are provided under the terms of the+GNU Library General Public License (LGPL) version 2.1 with the following+exception:++Static linking of applications or any other source to the haskell-gi library+does not constitute a modified or derivative work and does not require the+author(s) to provide source code for said work, to link against the shared+haskell-gi libraries, or to link their applications against a user-supplied+version of haskell-gi. If you link applications to a modified version of+haskell-gi, then the changes to haskell-gi must be provided under the terms of+the LGPL.++----------------------------------------------------------------------------+                   GNU LESSER GENERAL PUBLIC LICENSE                        Version 2.1, February 1999 

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.21.5+version:             0.22.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.@@ -10,7 +10,7 @@ author:              Will Thompson,                      Iñaki García Etxebarria,                      Jonas Platte-maintainer:          Iñaki García Etxebarria (garetxe@gmail.com)+maintainer:          Iñaki García Etxebarria (inaki@blueleaf.cc) stability:           Experimental category:            Development build-type:          Simple@@ -25,8 +25,8 @@  Library   pkgconfig-depends:   gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32-  build-depends:       base >= 4.7 && < 5,-                       haskell-gi-base == 0.21.*,+  build-depends:       base >= 4.9 && < 5,+                       haskell-gi-base == 0.22.*,                        Cabal >= 1.24,                        attoparsec == 0.13.*,                        containers,@@ -43,14 +43,12 @@                        regex-tdfa >= 1.2,                        text >= 1.0 -  if !impl(ghc >= 8.0)-    build-depends: semigroups == 0.18.*+  build-depends: semigroups == 0.18.*    extensions:          CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings   ghc-options:         -Wall -fwarn-incomplete-patterns -fno-warn-name-shadowing -  if impl(ghc >= 8.0)-     ghc-options: -Wcompat+  ghc-options: -Wcompat    c-sources:           lib/c/enumStorage.c 

@@ -2,6 +2,7 @@ -- bindings. module Data.GI.CodeGen.CabalHooks     ( setupHaskellGIBinding+    , configureDryRun     ) where  import qualified Distribution.ModuleName as MN@@ -12,7 +13,8 @@ import Distribution.PackageDescription  import Data.GI.CodeGen.API (loadGIRInfo)-import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree)+import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree,+                             ModuleInfo) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)@@ -34,17 +36,13 @@ type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags               -> IO LocalBuildInfo --- | A convenience helper for `confHook`, such that bindings for the--- given module are generated in the @configure@ step of @cabal@.-confCodeGenHook :: Text -- ^ name-                -> Text -- ^ version-                -> Bool -- ^ verbose-                -> Maybe FilePath -- ^ overrides file-                -> Maybe FilePath -- ^ output dir-                -> ConfHook -- ^ previous `confHook`-                -> ConfHook-confCodeGenHook name version verbosity overrides outputDir-                defaultConfHook (gpd, hbi) flags = do+-- | Generate the code for the given module.+genModuleCode :: Text -- ^ name+              -> Text -- ^ version+              -> Bool -- ^ verbose+              -> Maybe FilePath -- ^ overrides file+              -> IO ModuleInfo+genModuleCode name version verbosity overrides = do   setupTypelibSearchPath []    ovs <- case overrides of@@ -61,8 +59,21 @@                     verbose = verbosity,                     overrides = ovs} -  let m = genCode cfg allAPIs (toModulePath name) (genModule apis)+  return $ genCode cfg allAPIs (toModulePath name) (genModule apis) +-- | A convenience helper for `confHook`, such that bindings for the+-- given module are generated in the @configure@ step of @cabal@.+confCodeGenHook :: Text -- ^ name+                -> Text -- ^ version+                -> Bool -- ^ verbose+                -> Maybe FilePath -- ^ overrides file+                -> Maybe FilePath -- ^ output dir+                -> ConfHook -- ^ previous `confHook`+                -> ConfHook+confCodeGenHook name version verbosity overrides outputDir+                defaultConfHook (gpd, hbi) flags = do+  m <- genModuleCode name version verbosity overrides+   let em' = map (MN.fromString . T.unpack) (listModuleTree m)       ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'}       cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'}@@ -90,3 +101,13 @@                                        overridesFile outputDir                                        (confHook simpleUserHooks)                           })++-- | Return the list of modules that `setupHaskellGIBinding` would create.+configureDryRun :: Text -- ^ name+                -> Text -- ^ version+                -> Maybe FilePath+                -> IO [Text]+configureDryRun name version overrides = do+  m <- genModuleCode name version False overrides++  return (listModuleTree m)

@@ -25,7 +25,7 @@ #endif import Control.Monad (forM, forM_, when, void) import Data.Bool (bool)-import Data.List (nub, (\\))+import Data.List (nub) import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Tuple (swap)@@ -123,16 +123,16 @@ -- Given the list of arguments returns the list of constraints and the -- list of types in the signature. inArgInterfaces :: [Arg] -> ExcCodeGen ([Text], [Text])-inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs-  where-    consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text])-    consAndTypes _ [] = return ([], [])-    consAndTypes letters (arg:args) = do-      (ls, t, cons) <- argumentType letters $ argType arg-      t' <- wrapMaybe arg >>= bool (return t)-                                   (return $ "Maybe (" <> t <> ")")-      (restCons, restTypes) <- consAndTypes ls args-      return (cons <> restCons, t' : restTypes)+inArgInterfaces args = do+  resetTypeVariableScope+  go args+  where go [] = return ([], [])+        go (arg:args) = do+          (t, cons) <- argumentType (argType arg)+          t' <- wrapMaybe arg >>= bool (return t)+            (return $ "Maybe (" <> t <> ")")+          (restCons, restTypes) <- go args+          return (cons <> restCons, t' : restTypes)  -- Given a callable, return a list of (array, length) pairs, where in -- each pair "length" is the argument holding the length of the

@@ -44,6 +44,9 @@     , setModuleFlags     , setModuleMinBase +    , getFreshTypeVariable+    , resetTypeVariableScope+     , exportModule     , exportDecl     , export@@ -233,13 +236,21 @@ data CGState = CGState {   cgsCPPConditionals :: [CPPConditional] -- ^ Active CPP conditionals,                                          -- outermost condition first.+  , cgsNextAvailableTyvar :: NamedTyvar -- ^ Next unused type+                                        -- variable.   } +-- | The name for a type variable.+data NamedTyvar = SingleCharTyvar Char+                -- ^ A single variable type variable: 'a', 'b', etc...+                | IndexedTyvar Text Integer+                -- ^ An indexed type variable: 'a17', 'key1', ...+ -- | Clean slate for `CGState`. emptyCGState :: CGState-emptyCGState = CGState {-  cgsCPPConditionals = []-  }+emptyCGState = CGState { cgsCPPConditionals = []+                       , cgsNextAvailableTyvar = SingleCharTyvar 'a'+                       }  -- | The base type for the code generator monad. type BaseCodeGen excType a =@@ -497,6 +508,28 @@ missingInfoError :: Text -> ExcCodeGen a missingInfoError s = throwError $ CGErrorMissingInfo s +-- | Get a type variable unused in the current scope.+getFreshTypeVariable :: CodeGen Text+getFreshTypeVariable = do+  (cgs@(CGState{cgsNextAvailableTyvar = available}), s) <- get+  let (tyvar, next) =+        case available of+          SingleCharTyvar char -> case char of+            'z' -> ("z", IndexedTyvar "a" 0)+            -- 'm' is reserved for the MonadIO constraint in signatures+            'm' -> ("n", SingleCharTyvar 'o')+            c -> (T.singleton c, SingleCharTyvar (toEnum $ fromEnum c + 1))+          IndexedTyvar root index -> (root <> tshow index,+                                      IndexedTyvar root (index+1))+  put (cgs {cgsNextAvailableTyvar = next}, s)+  return tyvar++-- | Introduce a new scope for type variable naming: the next fresh+-- variable will be called 'a'.+resetTypeVariableScope :: CodeGen ()+resetTypeVariableScope =+  modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s))+ findAPI :: Type -> CodeGen (Maybe API) findAPI TError = Just <$> findAPIByName (Name "GLib" "Error") findAPI (TInterface n) = Just <$> findAPIByName n@@ -563,8 +596,8 @@   blank   return x     where addConditional :: CGState -> CGState-          addConditional cgs = CGState {cgsCPPConditionals = CPPIf cond :-                                         cgsCPPConditionals cgs}+          addConditional cgs = cgs {cgsCPPConditionals = CPPIf cond :+                                                         cgsCPPConditionals cgs}  -- | Possible features to test via CPP. data CPPGuard = CPPOverloading -- ^ Enable overloading@@ -853,15 +886,18 @@                 , ""                 , "import qualified Data.GI.Base.Attributes as GI.Attributes"                 , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"+                , "import qualified Data.GI.Base.GClosure as B.GClosure"                 , "import qualified Data.GI.Base.GError as B.GError"                 , "import qualified Data.GI.Base.GVariant as B.GVariant"                 , "import qualified Data.GI.Base.GValue as B.GValue"                 , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec"                 , "import qualified Data.GI.Base.CallStack as B.CallStack"+                , "import qualified Data.GI.Base.Properties as B.Properties"                 , "import qualified Data.Text as T"                 , "import qualified Data.ByteString.Char8 as B"                 , "import qualified Data.Map as Map"-                , "import qualified Foreign.Ptr as FP" ]+                , "import qualified Foreign.Ptr as FP"+                , "import qualified GHC.OverloadedLabels as OL" ]  -- | Like `dotModulePath`, but add a "GI." prefix. dotWithPrefix :: ModulePath -> Text

@@ -22,7 +22,7 @@ import Data.GI.CodeGen.Code import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,-                               detectGObject)+                               detectGObject, dropDuplicatedFields) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation,                                 writeHaddock,@@ -39,7 +39,7 @@                   fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion,                   genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,-                                     submoduleLocation, lowerName)+                                     submoduleLocation, lowerName, qualifiedAPI) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) @@ -246,24 +246,31 @@   group $ do     bline $ "instance GObject " <> name' <> " where"     indent $ group $ do-            line $ "gobjectType _ = c_" <> cn_+            line $ "gobjectType = c_" <> cn_    className <- classConstraint n   group $ do     exportDecl className     writeHaddock DocBeforeSymbol (classDoc name') -    bline $ "class GObject o => " <> className <> " o"-    line $ "#if MIN_VERSION_base(4,9,0)"-    line $ "instance {-# OVERLAPPABLE #-} (GObject a, O.UnknownAncestorError "-             <> name' <> " a) =>"-    line $ "    " <> className <> " a"-    line $ "#endif"-    bline $ "instance " <> className <> " " <> name'-    forM_ parents $ \parent -> do-        pcls <- classConstraint parent-        line $ "instance " <> pcls <> " " <> name'+    -- Create the IsX constraint. We cannot simply say+    --+    -- > type IsX o = (GObject o, ...)+    --+    -- since we sometimes need to refer to @IsX@ itself, without+    -- applying it. We instead use the trick of creating a class with+    -- a universal instance.+    let constraints = "(GObject o, O.IsDescendantOf " <> name' <> " o)"+    bline $ "class " <> constraints <> " => " <> className <> " o"+    bline $ "instance " <> constraints <> " => " <> className <> " o" +    blank++    qualifiedParents <- mapM qualifiedAPI parents+    bline $ "instance O.HasParentTypes " <> name'+    line $ "type instance O.ParentTypes " <> name' <> " = '["+      <> T.intercalate ", " qualifiedParents <> "]"+   -- Safe downcasting.   group $ do     let safeCast = "to" <> name'@@ -449,6 +456,9 @@             -- Not every interface providing signals or properties is             -- correctly annotated as descending from GObject, fix this.           $ map detectGObject+            -- Some APIs contain duplicated fields by mistake, drop+            -- the duplicates.+          $ map dropDuplicatedFields           $ M.toList           $ apis 

@@ -13,6 +13,8 @@     , transientToH     , haskellType     , isoHaskellType+    , inboundHaskellType+    , haskellTypeConstraint     , foreignType      , argumentType@@ -212,6 +214,21 @@   then return $ M "B.GParamSpec.disownGParamSpec"   else return $ M "unsafeManagedPtrGetPtr" +hClosureToF :: Transfer -> Maybe Type -> CodeGen Constructor+-- Untyped closures+hClosureToF transfer Nothing =+  if transfer == TransferEverything+  then return $ M "B.GClosure.disownGClosure"+  -- We cast the point here because the foreign type for untyped+  -- closures is always represented as Ptr (GClosure ()), while the+  -- corresponding Haskell type is the parametric "GClosure a".+  else return $ M "unsafeManagedPtrCastPtr"+-- Typed closures+hClosureToF transfer (Just _) =+  if transfer == TransferEverything+  then return $ M "B.GClosure.disownGClosure"+  else return $ M "unsafeManagedPtrGetPtr"+ hBoxedToF :: Transfer -> CodeGen Constructor hBoxedToF transfer =   if transfer == TransferEverything@@ -245,6 +262,7 @@     | TError <- t = hBoxedToF transfer     | TVariant <- t = hVariantToF transfer     | TParamSpec <- t = hParamSpecToF transfer+    | TGClosure c <- t = hClosureToF transfer c     | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"     | Just (APIFlags _) <- a = return "gflagsToWord"     | Just (APIObject _) <- a = hObjectToF t transfer@@ -460,6 +478,19 @@                   TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr"                   _ -> "B.GParamSpec.newGParamSpecFromPtr" +fClosureToH :: Transfer -> Maybe Type -> CodeGen Constructor+-- Untyped closures+fClosureToH transfer Nothing =+  return $ M $ case transfer of+                  TransferEverything ->+                    parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr"+                  _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr"+-- Typed closures+fClosureToH transfer (Just _) =+  return $ M $ case transfer of+                  TransferEverything -> "B.GClosure.wrapGClosurePtr"+                  _ -> "B.GClosure.newGClosureFromPtr"+ fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer          -> ExcCodeGen Constructor fToH' t a hType fType transfer@@ -469,6 +500,7 @@     | TError <- t = boxedForeignPtr "GError" transfer     | TVariant <- t = fVariantToH transfer     | TParamSpec <- t = fParamSpecToH transfer+    | TGClosure c <- t = fClosureToH transfer c     | Just (APIStruct s) <- a = structForeignPtr s hType transfer     | Just (APIUnion u) <- a = unionForeignPtr u hType transfer     | Just (APIObject _) <- a = fObjectToH t hType transfer@@ -665,15 +697,14 @@ -- | Given a type find the typeclasses the type belongs to, and return -- the representation of the type in the function signature and the -- list of typeclass constraints for the type.-argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text])-argumentType [] _               = error "out of letters"-argumentType letters (TGList a) = do-  (ls, name, constraints) <- argumentType letters a-  return (ls, "[" <> name <> "]", constraints)-argumentType letters (TGSList a) = do-  (ls, name, constraints) <- argumentType letters a-  return (ls, "[" <> name <> "]", constraints)-argumentType letters@(l:ls) t = do+argumentType :: Type -> CodeGen (Text, [Text])+argumentType (TGList a) = do+  (name, constraints) <- argumentType a+  return ("[" <> name <> "]", constraints)+argumentType (TGSList a) = do+  (name, constraints) <- argumentType a+  return ("[" <> name <> "]", constraints)+argumentType t = do   api <- findAPI t   s <- typeShow <$> haskellType t   case api of@@ -681,22 +712,24 @@     -- we allow for any object descending from it.     Just (APIInterface _) -> do       cls <- typeConstraint t-      return (ls, T.singleton l, [cls <> " " <> T.singleton l])+      l <- getFreshTypeVariable+      return (l, [cls <> " " <> l])     Just (APIObject _) -> do       isGO <- isGObject t       if isGO         then do cls <- typeConstraint t-                return (ls, T.singleton l, [cls <> " " <> T.singleton l])-        else return (letters, s, [])+                l <- getFreshTypeVariable+                return (l, [cls <> " " <> l])+        else return (s, [])     Just (APICallback cb) ->       -- See [Note: Callables that throw]       if callableThrows (cbCallable cb)       then do         ft <- typeShow <$> foreignType t-        return (letters, ft, [])+        return (ft, [])       else-        return (letters, s, [])-    _ -> return (letters, s, [])+        return (s, [])+    _ -> return (s, [])  haskellBasicType :: BasicType -> TypeRep haskellBasicType TPtr      = ptr $ con0 "()"@@ -763,7 +796,18 @@ haskellType TError = return $ "GError" `con` [] haskellType TVariant = return $ "GVariant" `con` [] haskellType TParamSpec = return $ "GParamSpec" `con` []-haskellType (TInterface (Name "GObject" "Closure")) = return $ "Closure" `con` []+haskellType (TGClosure (Just inner@(TInterface n))) = do+  innerAPI <- getAPI inner+  case innerAPI of+    APICallback _ -> do+      tname <- qualifiedSymbol (callbackCType $ name n) n+      return $ "GClosure" `con` [con0 tname]+    -- The given inner type does not make sense, so we treat it as an+    -- untyped closure.+    _ -> haskellType (TGClosure Nothing)+haskellType (TGClosure _) = do+  tyvar <- getFreshTypeVariable+  return $ "GClosure" `con` [con0 tyvar] haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` [] haskellType t@(TInterface n) = do   api <- getAPI t@@ -772,6 +816,36 @@              (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@@ -847,8 +921,8 @@ foreignType t@TError = ptr <$> haskellType t foreignType t@TVariant = ptr <$> haskellType t foreignType t@TParamSpec = ptr <$> haskellType t-foreignType (TInterface (Name "GObject" "Closure")) =-    return $ ptr $ "Closure" `con` []+foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"])+foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t foreignType (TInterface (Name "GObject" "Value")) =   return $ ptr $ "GValue" `con` [] foreignType t@(TInterface n) = do@@ -903,6 +977,7 @@ isManaged TError = return True isManaged TVariant = return True isManaged TParamSpec = return True+isManaged (TGClosure _) = return True isManaged t@(TInterface _) = do   a <- findAPI t   case a of

@@ -3,10 +3,12 @@     ( dropMovedItems     , guessPropertyNullability     , detectGObject+    , dropDuplicatedFields     ) where  import Data.Maybe (isNothing, isJust) import Data.Monoid ((<>))+import qualified Data.Set as S import qualified Data.Text as T  import Data.GI.CodeGen.API@@ -130,3 +132,21 @@                                         gobject : ifPrerequisites iface}))   else (n, APIInterface iface) detectGObject api = api++-- | Drop any fields whose name coincides with that of a previous+-- element. Note that this function keeps ordering.+dropDuplicatedEnumFields :: Enumeration -> Enumeration+dropDuplicatedEnumFields enum =+  enum{enumMembers = dropDuplicates S.empty (enumMembers enum)}+  where dropDuplicates :: S.Set T.Text -> [EnumerationMember] -> [EnumerationMember]+        dropDuplicates _        []     = []+        dropDuplicates previous (m:ms) =+          if enumMemberName m `S.member` previous+          then dropDuplicates previous ms+          else m : dropDuplicates (S.insert (enumMemberName m) previous) ms++-- | Some libraries include duplicated flags by mistake, drop those.+dropDuplicatedFields :: (Name, API) -> (Name, API)+dropDuplicatedFields (n, APIFlags (Flags enum)) =+  (n, APIFlags (Flags $ dropDuplicatedEnumFields enum))+dropDuplicatedFields (n, api) = (n, api)

@@ -28,19 +28,12 @@ genMethodResolver n = do   group $ do     line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "-          <> "O.MethodInfo info " <> n <> " p) => O.IsLabelProxy t ("-          <> n <> " -> p) where"-    indent $ line $ "fromLabelProxy _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"-  group $ do-    line $ "#if MIN_VERSION_base(4,9,0)"-    line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "-          <> "O.MethodInfo info " <> n <> " p) => O.IsLabel t ("+          <> "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)"     line $ "#else"     indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy :: O.MethodProxy info)"-    line $ "#endif"     line $ "#endif"  -- | Generate the `MethodList` instance given the list of methods for

@@ -55,16 +55,10 @@   signalNames <- findSignalNames allAPIs   forM_ signalNames $ \sn -> group $ do     let camelName = hyphensToCamelCase sn-    line $ "#if MIN_VERSION_base(4,8,0)"     line $ "pattern " <> camelName <>              " :: SignalProxy object (ResolveSignal \""              <> lcFirst camelName <> "\" object)"     line $ "pattern " <> camelName <> " = SignalProxy"-    line $ "#else"-    line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. "-             <> "info ~ ResolveSignal \"" <> lcFirst camelName-             <> "\" object => SignalProxy object info"-    line $ "#endif"     exportDecl $ "pattern " <> camelName  -- | Qualified name for the "(sigName, info)" tag for a given signal.

@@ -14,6 +14,7 @@     , standardDeps     ) where +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T (unlines) @@ -24,7 +25,7 @@ authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte"  maintainers :: Text-maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)"+maintainers = "Iñaki García Etxebarria (inaki@blueleaf.cc)"  license :: Text license = "LGPL-2.1"@@ -36,7 +37,7 @@                      "OverloadedStrings", "NegativeLiterals", "ConstraintKinds",                      "TypeFamilies", "MultiParamTypeClasses", "KindSignatures",                      "FlexibleInstances", "UndecidableInstances", "DataKinds",-                     "FlexibleContexts"]+                     "FlexibleContexts", "UndecidableSuperClasses"]  -- | Extensions that will be used in some modules, but we do not wish -- to turn on by default.@@ -66,8 +67,25 @@ category :: Text category = "Bindings" -licenseText :: Text-licenseText = T.unlines+staticLinkingException :: Text -> Text+staticLinkingException name = T.unlines+ ["The " <> name <> " library and included works are provided under the terms of the"+ ,"GNU Library General Public License (LGPL) version 2.1 with the following"+ ,"exception:"+ ,""+ ,"Static linking of applications or any other source to the " <> name <> " library"+ ,"does not constitute a modified or derivative work and does not require"+ ,"the author(s) to provide source code for said work, to link against the"+ ,"shared " <> name <> " libraries, or to link their applications against a"+ ,"user-supplied version of " <> name <> ". If you link applications to a modified"+ ,"version of " <> name <> ", then the changes to " <> name <> " must be provided under the"+ ,"terms of the LGPL."+ ,""+ ,"----------------------------------------------------------------------------"+ ,""]++licenseText :: Text -> Text+licenseText name = staticLinkingException name <> T.unlines  ["                  GNU LESSER GENERAL PUBLIC LICENSE"  ,"                       Version 2.1, February 1999"  ,""

@@ -23,8 +23,7 @@ import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock,                                 RelativeDocPosition(DocBeforeSymbol)) import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)-import Data.GI.CodeGen.SymbolNaming (lowerName, upperName,-                                     classConstraint, typeConstraint,+import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint,                                      hyphensToCamelCase, qualifiedSymbol,                                      callbackDynamicWrapper) import Data.GI.CodeGen.Type@@ -39,6 +38,7 @@    TGHash _ _ -> return "Hash"    TVariant -> return "Variant"    TParamSpec -> return "ParamSpec"+   TGClosure _ -> return "Closure"    TBasicType TInt -> case sizeOf (0 :: CInt) of                         4 -> return "Int32"                         n -> error ("Unsupported `gint' type length: " ++@@ -89,13 +89,14 @@ -- the type variables for the object and its value. attrType :: Property -> CodeGen ([Text], Text) attrType prop = do+  resetTypeVariableScope   isCallback <- typeIsCallback (propType prop)   if isCallback     then do       ftype <- foreignType (propType prop)       return ([], typeShow ftype)     else do-      (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop+      (t,constraints) <- argumentType $ propType prop       return (constraints, t)  -- | Generate documentation for the given setter.@@ -120,7 +121,7 @@   writeHaddock DocBeforeSymbol (setterDoc n prop)   line $ setter <> " :: (" <> T.intercalate ", " constraints'            <> ") => o -> " <> t <> " -> m ()"-  line $ setter <> " obj val = liftIO $ setObjectProperty" <> tStr+  line $ setter <> " obj val = liftIO $ B.Properties.setObjectProperty" <> tStr            <> " obj \"" <> propName prop            <> if isNullable && (not isCallback)               then "\" (Just val)"@@ -141,7 +142,7 @@ genPropertyGetter getter n docSection prop = group $ do   isNullable <- typeIsNullable (propType prop)   let isMaybe = isNullable && propReadNullable prop /= Just False-  constructorType <- isoHaskellType (propType prop)+  constructorType <- inboundHaskellType (propType prop)   tStr <- propTypeStr $ propType prop   cls <- classConstraint n   let constraints = "(MonadIO m, " <> cls <> " o)"@@ -151,8 +152,8 @@       returnType = typeShow $ "m" `con` [outType]       getProp = if isNullable && not isMaybe                 then "checkUnexpectedNothing \"" <> getter-                         <> "\" $ getObjectProperty" <> tStr-                else "getObjectProperty" <> tStr+                         <> "\" $ B.Properties.getObjectProperty" <> tStr+                else "B.Properties.getObjectProperty" <> tStr   -- Some property getters require in addition a constructor, which   -- will convert the foreign value to the wrapped Haskell one.   constructorArg <-@@ -189,7 +190,7 @@   writeHaddock DocBeforeSymbol (constructorDoc prop)   line $ constructor <> " :: " <> pconstraints            <> t <> " -> IO (GValueConstruct o)"-  line $ constructor <> " val = constructObjectProperty" <> tStr+  line $ constructor <> " val = B.Properties.constructObjectProperty" <> tStr            <> " \"" <> propName prop            <> if isNullable && (not isCallback)               then "\" (Just val)"@@ -219,7 +220,7 @@                 else "(Nothing :: " <> nothingType <> ")"   line $ clear <> " :: (" <> T.intercalate ", " constraints            <> ") => o -> m ()"-  line $ clear <> " obj = liftIO $ setObjectProperty" <> tStr+  line $ clear <> " obj = liftIO $ B.Properties.setObjectProperty" <> tStr            <> " obj \"" <> propName prop <> "\" " <> nothing   export docSection clear @@ -322,8 +323,8 @@              then return "()"              else do                sOutType <- if isNullable && propReadNullable prop /= Just False-                           then typeShow . maybeT <$> isoHaskellType (propType prop)-                           else typeShow <$> isoHaskellType (propType prop)+                           then typeShow . maybeT <$> inboundHaskellType (propType prop)+                           else typeShow <$> inboundHaskellType (propType prop)                return $ if T.any (== ' ') sOutType                         then parenthesize sOutType                         else sOutType@@ -332,17 +333,7 @@   cppIf CPPOverloading $ do     cls <- classConstraint owner     inConstraint <- if writable || constructOnly-                    then do-                      inIsGO <- isGObject (propType prop)-                      isCallback <- typeIsCallback (propType prop)-                      hInType <- if isCallback-                                 then typeShow <$> foreignType (propType prop)-                                 else typeShow <$> haskellType (propType prop)-                      if inIsGO-                         then typeConstraint (propType prop)-                         else return $ "(~) " <> if T.any (== ' ') hInType-                                                 then parenthesize hInType-                                                 else hInType+                    then haskellTypeConstraint (propType prop)                     else return "(~) ()"     let allowedOps = (if writable                       then ["'AttrSet", "'AttrConstruct"]

@@ -53,7 +53,7 @@     line $ "type " <> name' <> " ="     indent $ do       forM_ inArgsWithArrows $ \(arrow, arg) -> do-        ht <- haskellType (argType arg)+        ht <- inboundHaskellType (argType arg)         isMaybe <- wrapMaybe arg         let formattedType = if isMaybe                             then typeShow (maybeT ht)@@ -149,15 +149,16 @@   export (NamedSubsection SignalSection subsec) closure   writeHaddock DocBeforeSymbol closureDoc   group $ do-      line $ closure <> " :: " <> callback <> " -> IO Closure"-      line $ closure <> " cb = do"+      line $ closure <> " :: MonadIO m => " <> callback <> " -> m (GClosure "+                     <> callbackCType callback <> ")"+      line $ closure <> " cb = liftIO $ do"       indent $ do             wrapped <- genWrappedCallback cb "cb" callback isSignal             line $ callbackWrapperAllocator callback <> " " <> wrapped-                     <> " >>= newCClosure"+                     <> " >>= B.GClosure.newGClosure"   where     closureDoc :: Text-    closureDoc = "Wrap the callback into a `Closure`."+    closureDoc = "Wrap the callback into a `GClosure`."  -- Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL.

@@ -128,8 +128,8 @@                  then return Nothing                  else maybeNullConvert (fieldType field)   hType <- typeShow <$> if isJust nullConvert-                        then maybeT <$> isoHaskellType (fieldType field)-                        else isoHaskellType (fieldType field)+                        then maybeT <$> inboundHaskellType (fieldType field)+                        else inboundHaskellType (fieldType field)   fType <- typeShow <$> foreignType (fieldType field)    writeHaddock DocBeforeSymbol (getterDoc n field)@@ -254,8 +254,8 @@   embedded <- isEmbedded field   isNullable <- typeIsNullable (fieldType field)   outType <- typeShow <$> if not embedded && isNullable-                          then maybeT <$> isoHaskellType (fieldType field)-                          else isoHaskellType (fieldType field)+                          then maybeT <$> inboundHaskellType (fieldType field)+                          else inboundHaskellType (fieldType field)   inType <- if isPtr             then typeShow <$> foreignType (fieldType field)             else typeShow <$> haskellType (fieldType field)

@@ -42,6 +42,7 @@ basicFreeFn (TError) = Nothing basicFreeFn (TVariant) = Nothing basicFreeFn (TParamSpec) = Nothing+basicFreeFn (TGClosure _) = Nothing  -- Basic free primitives in the case that an error occured. This is -- run in the exception handler, so any type which we ref/allocate@@ -58,6 +59,10 @@ basicFreeFnOnError TParamSpec transfer =     return $ if transfer == TransferEverything              then Just "unrefGParamSpec"+             else Nothing+basicFreeFnOnError (TGClosure _) transfer =+    return $ if transfer == TransferEverything+             then Just "B.GClosure.unrefGClosure"              else Nothing basicFreeFnOnError t@(TInterface _) transfer = do   api <- findAPI t

@@ -63,5 +63,6 @@     | TGList Type      -- ^ GList     | TGSList Type     -- ^ GSList     | TGHash Type Type -- ^ GHashTable+    | TGClosure (Maybe Type) -- ^ GClosure containing the given API (if known)     | TInterface Name  -- ^ A reference to some API in the GIR       deriving (Eq, Show, Ord)

@@ -39,6 +39,7 @@   writable <- optionalAttr "writable" False parseBool   construct <- optionalAttr "construct" False parseBool   constructOnly <- optionalAttr "construct-only" False parseBool+  maybeNullable <- optionalAttr "nullable" Nothing (\t -> Just <$> parseBool t)   let flags = (if readable then [PropertyReadable] else [])               <> (if writable then [PropertyWritable] else [])               <> (if construct then [PropertyConstruct] else [])@@ -51,7 +52,6 @@                 , propTransfer = transfer                 , propDeprecated = deprecated                 , propDoc = doc-                -- No support in the GIR for nullability info-                , propReadNullable = Nothing-                , propWriteNullable = Nothing+                , propReadNullable = maybeNullable+                , propWriteNullable = maybeNullable                 }

@@ -100,6 +100,12 @@                  other -> parseError $ "Unsupported hash type: "                                        <> T.pack (show other) +-- | Parse a `GClosure` declaration.+parseClosure :: Parser Type+parseClosure = queryAttr "closure-type" >>= \case+                Just t -> (TGClosure . Just) <$> parseTypeName t+                Nothing -> return $ TGClosure Nothing+ -- | For GLists and GSLists there is sometimes no information about -- the type of the elements. In these cases we report them as -- pointers.@@ -116,18 +122,13 @@ parseFundamentalType "GLib" "Error" = return TError parseFundamentalType "GLib" "Variant" = return TVariant parseFundamentalType "GObject" "ParamSpec" = return TParamSpec+parseFundamentalType "GObject" "Closure" = parseClosure -- A TInterface type (basically, everything that is not of a known type). parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n) --- | Parse information on a "type" element. Returns either a `Type`,--- or `Nothing` indicating that the name of the type in the--- introspection data was "none" (associated with @void@ in C).-parseTypeInfo :: Parser (Maybe Type)-parseTypeInfo = do-  typeName <- getAttr "name"-  if typeName == "none"-  then return Nothing-  else Just <$> case nameToBasicType typeName of+-- | Parse a type given as a string.+parseTypeName :: Text -> Parser Type+parseTypeName typeName = case nameToBasicType typeName of     Just b -> return (TBasicType b)     Nothing -> case T.split ('.' ==) typeName of                  [ns, n] -> parseFundamentalType ns n@@ -136,6 +137,16 @@                    parseFundamentalType ns n                  _ -> parseError $ "Unsupported type form: \""                                    <> typeName <> "\""++-- | Parse information on a "type" element. Returns either a `Type`,+-- or `Nothing` indicating that the name of the type in the+-- introspection data was "none" (associated with @void@ in C).+parseTypeInfo :: Parser (Maybe Type)+parseTypeInfo = do+  typeName <- getAttr "name"+  if typeName == "none"+  then return Nothing+  else Just <$> parseTypeName typeName  -- | Find the children giving the type of the given element. parseTypeElements :: Parser [Maybe Type]