diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,17 @@ +The haskell-gi library and included works are provided under the terms of the +GNU Library General Public License (LGPL) version 2.1 with the following +exception: + +Static linking of applications or any other source to the haskell-gi library +does not constitute a modified or derivative work and does not require the +author(s) to provide source code for said work, to link against the shared +haskell-gi libraries, or to link their applications against a user-supplied +version of haskell-gi. If you link applications to a modified version of +haskell-gi, then the changes to haskell-gi must be provided under the terms of +the LGPL. + +---------------------------------------------------------------------------- + GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -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 diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -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) diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs --- a/lib/Data/GI/CodeGen/Conversions.hs +++ b/lib/Data/GI/CodeGen/Conversions.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Fixups.hs b/lib/Data/GI/CodeGen/Fixups.hs --- a/lib/Data/GI/CodeGen/Fixups.hs +++ b/lib/Data/GI/CodeGen/Fixups.hs @@ -3,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) diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs --- a/lib/Data/GI/CodeGen/OverloadedSignals.hs +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -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. diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -14,6 +14,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" ,"" diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -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"] diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -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. diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -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) diff --git a/lib/Data/GI/CodeGen/Transfer.hs b/lib/Data/GI/CodeGen/Transfer.hs --- a/lib/Data/GI/CodeGen/Transfer.hs +++ b/lib/Data/GI/CodeGen/Transfer.hs @@ -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 diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs --- a/lib/Data/GI/GIR/BasicTypes.hs +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -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) diff --git a/lib/Data/GI/GIR/Property.hs b/lib/Data/GI/GIR/Property.hs --- a/lib/Data/GI/GIR/Property.hs +++ b/lib/Data/GI/GIR/Property.hs @@ -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 } diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs --- a/lib/Data/GI/GIR/Type.hs +++ b/lib/Data/GI/GIR/Type.hs @@ -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]