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.14 +version: 0.15 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. @@ -23,7 +23,7 @@ Library pkgconfig-depends: gobject-introspection-1.0 >= 1.42, gobject-2.0 >= 2.36 build-depends: base >= 4.7 && < 5, - haskell-gi-base == 0.14, + haskell-gi-base == 0.15, Cabal >= 1.24, containers, directory, @@ -46,6 +46,7 @@ build-tools: hsc2hs hs-source-dirs: lib exposed-modules: Data.GI.GIR.Alias, + Data.GI.GIR.Allocation, Data.GI.GIR.Arg, Data.GI.GIR.BasicTypes, Data.GI.GIR.Callable, diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs --- a/lib/Data/GI/CodeGen/API.hs +++ b/lib/Data/GI/CodeGen/API.hs @@ -14,6 +14,11 @@ , Name(..) , Transfer(..) + -- Reexported from Data.GI.GIR.Allocation + , AllocationInfo(..) + , AllocationOp(..) + , unknownAllocationInfo + -- Reexported from Data.GI.GIR.Arg , Direction(..) , Scope(..) @@ -67,6 +72,7 @@ import qualified Text.XML as XML import Data.GI.GIR.Alias (documentListAliases) +import Data.GI.GIR.Allocation (AllocationInfo(..), AllocationOp(..), unknownAllocationInfo) import Data.GI.GIR.Arg (Arg(..), Direction(..), Scope(..)) import Data.GI.GIR.BasicTypes (Alias, Name(..), Transfer(..)) import Data.GI.GIR.Callable (Callable(..)) @@ -252,8 +258,8 @@ -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search -> [GIRRule] -- ^ fixups - -> IO (Document, -- ^ loaded document - M.Map (Text, Text) Document) -- ^ dependencies + -> IO (Document, + M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies) loadGIRFile verbose name version extraPaths rules = do doc <- fixupGIRDocument rules <$> readGiRepository verbose name version extraPaths @@ -296,8 +302,8 @@ -> Maybe Text -- ^ version -> [FilePath] -- ^ extra paths to search -> [GIRRule] -- ^ fixups - -> IO (GIRInfo, -- ^ parsed document - [GIRInfo]) -- ^ parsed deps + -> IO (GIRInfo, + [GIRInfo]) -- ^ (parsed doc, parsed deps) loadGIRInfo verbose name version extraPaths rules = do (doc, deps) <- loadGIRFile verbose name version extraPaths rules let aliases = M.unions (map documentListAliases (doc : M.elems deps)) diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -1,12 +1,13 @@ -- | Convenience hooks for writing custom @Setup.hs@ files for -- bindings. module Data.GI.CodeGen.CabalHooks - ( confCodeGenHook + ( simpleHaskellGIHooks ) where import qualified Distribution.ModuleName as MN import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup +import Distribution.Simple (UserHooks(..), simpleUserHooks) import Distribution.PackageDescription import Data.GI.CodeGen.API (loadGIRInfo) @@ -61,3 +62,16 @@ gpd' = gpd {condLibrary = Just cL'} defaultConfHook (gpd', hbi) flags + +-- | A version of `simpleUserHooks` which generates the bindings as needed. +simpleHaskellGIHooks :: Text -- ^ name + -> Text -- ^ version + -> Bool -- ^ verbose + -> Maybe FilePath -- ^ overrides file + -> Maybe FilePath -- ^ output dir + -> UserHooks +simpleHaskellGIHooks name version verbose overridesFile outputDir = + simpleUserHooks { confHook = confCodeGenHook name version verbose + overridesFile outputDir + (confHook simpleUserHooks) + } 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 @@ -34,7 +34,8 @@ genUnsupportedMethodInfo) import Data.GI.CodeGen.Signal (genSignal, genCallback) import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct, - fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion) + fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion, + genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) @@ -190,6 +191,7 @@ exportToplevel ("catch" <> name') exportToplevel ("handle" <> name') +-- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do name' <- upperName n @@ -201,8 +203,10 @@ addModuleDocumentation (structDocumentation s) - when (structIsBoxed s) $ - genBoxedObject n (fromJust $ structTypeInit s) + if structIsBoxed s + then genBoxedObject n (fromJust $ structTypeInit s) + else genWrappedPtr n (structAllocationInfo s) (structSize s) + exportDecl (name' <> ("(..)")) -- Generate a builder for a structure filled with zeroes. @@ -229,6 +233,7 @@ -- Overloaded methods genMethodList n (catMaybes methods) +-- | Generated wrapper for unions. genUnion :: Name -> Union -> CodeGen () genUnion n u = do name' <- upperName n @@ -238,8 +243,10 @@ hsBoot decl decl - when (unionIsBoxed u) $ - genBoxedObject n (fromJust $ unionTypeInit u) + if unionIsBoxed u + then genBoxedObject n (fromJust $ unionTypeInit u) + else genWrappedPtr n (unionAllocationInfo u) (unionSize u) + exportDecl (name' <> "(..)") -- Generate a builder for a structure filled with zeroes. 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 @@ -384,28 +384,23 @@ TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor _ -> M $ parenthesize $ "newBoxed " <> constructor -suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor -suForeignPtr isBoxed size hType transfer = do +suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor +suForeignPtr isBoxed hType transfer = do let constructor = T.pack . tyConName . typeRepTyCon $ hType if isBoxed then boxedForeignPtr constructor transfer - else case size of - 0 -> do - line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?" - return $ M $ parenthesize $ - "\\x -> " <> constructor <> " <$> newForeignPtr_ x" - n -> return $ M $ parenthesize $ - case transfer of - TransferEverything -> "wrapPtr " <> constructor - _ -> "newPtr " <> tshow n <> " " <> constructor + else return $ M $ parenthesize $ + case transfer of + TransferEverything -> "wrapPtr " <> constructor + _ -> "newPtr " <> constructor structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor structForeignPtr s = - suForeignPtr (structIsBoxed s) (structSize s) + suForeignPtr (structIsBoxed s) unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor unionForeignPtr u = - suForeignPtr (unionIsBoxed u) (unionSize u) + suForeignPtr (unionIsBoxed u) fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor fObjectToH t hType transfer = do diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs --- a/lib/Data/GI/CodeGen/Overrides.hs +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -35,6 +35,8 @@ ignoredAPIs :: S.Set Name, -- | Structs for which accessors should not be auto-generated. sealedStructs :: S.Set Name, + -- | Explicit calloc/copy/free for structs/unions. + allocInfo :: M.Map Name AllocationInfo, -- | Mapping from GObject Introspection namespaces to pkg-config pkgConfigMap :: M.Map Text Text, -- | Version number for the generated .cabal package. @@ -48,13 +50,15 @@ -- | Construct the generic config for a module. defaultOverrides :: Overrides defaultOverrides = Overrides { - ignoredElems = M.empty, - ignoredAPIs = S.empty, - sealedStructs = S.empty, - pkgConfigMap = M.empty, - cabalPkgVersion = Nothing, - nsChooseVersion = M.empty, - girFixups = [] } + ignoredElems = M.empty, + ignoredAPIs = S.empty, + sealedStructs = S.empty, + allocInfo = M.empty, + pkgConfigMap = M.empty, + cabalPkgVersion = Nothing, + nsChooseVersion = M.empty, + girFixups = [] + } -- | There is a sensible notion of zero and addition of Overridess, -- encode this so that we can view the parser as a writer monad of @@ -64,6 +68,7 @@ mappend a b = Overrides { ignoredAPIs = ignoredAPIs a <> ignoredAPIs b, sealedStructs = sealedStructs a <> sealedStructs b, + allocInfo = allocInfo a <> allocInfo b, ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b), pkgConfigMap = pkgConfigMap a <> pkgConfigMap b, cabalPkgVersion = if isJust (cabalPkgVersion b) @@ -145,6 +150,8 @@ withFlags $ getNS >>= parseIgnore ign parseOneLine (T.stripPrefix "seal " -> Just s) = withFlags $ getNS >>= parseSeal s +parseOneLine (T.stripPrefix "alloc-info " -> Just s) = + withFlags $ getNS >>= parseAllocInfo s parseOneLine (T.stripPrefix "pkg-config-name " -> Just s) = withFlags $ parsePkgConfigName s parseOneLine (T.stripPrefix "cabal-pkg-version " -> Just s) = @@ -179,6 +186,31 @@ throwError ("seal syntax is of the form \"seal name\".\nGot \"seal " <> seal <> "\" instead.") +-- | Explicit allocation info for wrapped pointers. +parseAllocInfo :: Text -> Maybe Text -> Parser () +parseAllocInfo _ Nothing = throwError "'alloc-info' requires a namespace to be defined first." +parseAllocInfo (T.words -> (n:ops)) (Just ns) = do + parsedOps <- traverse parseKeyValuePair ops + info <- foldM applyOp unknownAllocationInfo parsedOps + tell $ defaultOverrides {allocInfo = M.singleton (Name ns n) info} + where applyOp :: AllocationInfo -> (Text, Text) -> Parser AllocationInfo + applyOp a ("calloc", f) = return (a {allocCalloc = AllocationOp f}) + applyOp a ("copy", f) = return (a {allocCopy = AllocationOp f}) + applyOp a ("free", f) = return (a {allocFree = AllocationOp f}) + applyOp _ (op, _) = throwError ("Unknown alloc op \"" <> op <> "\".") +parseAllocInfo info _ = + throwError ("alloc-info syntax is of the form " + <> "\"alloc-info name calloc copy free\", with \"-\" meaning " + <> "a masked operation. Got \"alloc-info " <> info + <> "\" instead.") + +-- | Parse a explicit key=value pair into a (key, value) tuple. +parseKeyValuePair :: Text -> Parser (Text, Text) +parseKeyValuePair p = + case T.splitOn "=" p of + [k,v] -> return (k, v) + _ -> throwError ("Could not parse \"" <> p <> "\"as a \"key=value\" pair.") + -- | Mapping from GObject Introspection namespaces to pkg-config. parsePkgConfigName :: Text -> Parser () parsePkgConfigName (T.words -> [gi,pc]) = tell $ @@ -274,15 +306,43 @@ filterMethods set ignores = filter ((`S.notMember` ignores) . name . methodName) set +-- | Given the previous allocation info, and a new allocation info, +-- replace those entries in the old allocation info which are +-- specified in the new info. +filterAllocInfo :: AllocationInfo -> AllocationInfo -> AllocationInfo +filterAllocInfo old new = + AllocationInfo { allocCalloc = replace (allocCalloc old) (allocCalloc new) + , allocCopy = replace (allocCopy old) (allocCopy new) + , allocFree = replace (allocFree old) (allocFree new) } + where replace :: AllocationOp -> AllocationOp -> AllocationOp + replace o AllocationOpUnknown = o + replace _ o = o + -- | Filter one API according to the given config. filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API) filterOneAPI ovs (n, APIStruct s, maybeIgnores) = - (n, APIStruct s {structMethods = maybe (structMethods s) - (filterMethods (structMethods s)) - maybeIgnores, - structFields = if n `S.member` sealedStructs ovs + (n, APIStruct s { structMethods = maybe (structMethods s) + (filterMethods (structMethods s)) + maybeIgnores + , structFields = if n `S.member` sealedStructs ovs then [] - else structFields s}) + else structFields s + , structAllocationInfo = + let ai = structAllocationInfo s + in case M.lookup n (allocInfo ovs) of + Just info -> filterAllocInfo ai info + Nothing -> ai + }) +filterOneAPI ovs (n, APIUnion u, maybeIgnores) = + (n, APIUnion u {unionMethods = maybe (unionMethods u) + (filterMethods (unionMethods u)) + maybeIgnores + , unionAllocationInfo = + let ai = unionAllocationInfo u + in case M.lookup n (allocInfo ovs) of + Just info -> filterAllocInfo ai info + Nothing -> ai + }) -- The rest only apply if there are ignores. filterOneAPI _ (n, api, Nothing) = (n, api) filterOneAPI _ (n, APIObject o, Just ignores) = @@ -295,8 +355,6 @@ ifSignals = filter ((`S.notMember` ignores) . sigName) (ifSignals i) }) -filterOneAPI _ (n, APIUnion u, Just ignores) = - (n, APIUnion u {unionMethods = filterMethods (unionMethods u) ignores}) filterOneAPI _ (n, api, _) = (n, api) -- | Given a list of APIs modify them according to the given config. 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 @@ -1,10 +1,12 @@ +-- | Marshalling of structs and unions. module Data.GI.CodeGen.Struct ( genStructOrUnionFields - , genZeroStruct - , genZeroUnion - , extractCallbacksInStruct - , fixAPIStructs - , ignoreStruct) - where + , genZeroStruct + , genZeroUnion + , extractCallbacksInStruct + , fixAPIStructs + , ignoreStruct + , genWrappedPtr + ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) @@ -264,8 +266,7 @@ -- | Generate a constructor for a zero-filled struct/union of the given -- type, using the boxed (or GLib, for unboxed types) allocator. genZeroSU :: Name -> Int -> Bool -> CodeGen () -genZeroSU n size isBoxed = - when (size /= 0) $ group $ do +genZeroSU n size isBoxed = group $ do name <- upperName n let builder = "newZero" <> name tsize = tshow size @@ -274,7 +275,7 @@ line $ builder <> " = liftIO $ " <> if isBoxed then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name - else "callocBytes " <> tsize <> " >>= wrapPtr " <> name + else "wrappedPtrCalloc >>= wrapPtr " <> name exportDecl builder blank @@ -291,8 +292,74 @@ -- | Specialization for structs of `genZeroSU`. genZeroStruct :: Name -> Struct -> CodeGen () -genZeroStruct n s = genZeroSU n (structSize s) (structIsBoxed s) +genZeroStruct n s = + when (allocCalloc (structAllocationInfo s) /= AllocationOp "none" && + structSize s /= 0) $ + genZeroSU n (structSize s) (structIsBoxed s) -- | Specialization for unions of `genZeroSU`. genZeroUnion :: Name -> Union -> CodeGen () -genZeroUnion n u = genZeroSU n (unionSize u) (unionIsBoxed u) +genZeroUnion n u = + when (allocCalloc (unionAllocationInfo u ) /= AllocationOp "none" && + unionSize u /= 0) $ + genZeroSU n (unionSize u) (unionIsBoxed u) + +-- | Construct a import with the given prefix. +prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text +prefixedForeignImport prefix symbol prototype = group $ do + line $ "foreign import ccall \"" <> symbol <> "\" " <> prefix <> symbol + <> " :: " <> prototype + return (prefix <> symbol) + +-- | Same as `prefixedForeignImport`, but import a `FunPtr` to the symbol. +prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text +prefixedFunPtrImport prefix symbol prototype = group $ do + line $ "foreign import ccall \"&" <> symbol <> "\" " <> prefix <> symbol + <> " :: FunPtr (" <> prototype <> ")" + return (prefix <> symbol) + +-- | Generate the typeclass with information for how to +-- allocate/deallocate unboxed structs and unions. +genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () +genWrappedPtr n info size = group $ do + name' <- upperName n + + let prefix = \op -> "_" <> name' <> "_" <> op <> "_" + + when (size == 0) $ + line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?" + + calloc <- case allocCalloc info of + AllocationOp "none" -> + return ("error \"calloc not permitted for " <> name' <> "\"") + AllocationOp op -> + prefixedForeignImport (prefix "calloc") op "IO (Ptr a)" + AllocationOpUnknown -> + if size > 0 + then return ("callocBytes " <> tshow size) + else return "return nullPtr" + + copy <- case allocCopy info of + AllocationOp op -> + prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)" + AllocationOpUnknown -> + if size > 0 + then return ("copyPtr " <> tshow size) + else return "return" + + free <- case allocFree info of + AllocationOp op -> ("Just " <>) <$> + prefixedFunPtrImport (prefix "free") op "Ptr a -> IO ()" + AllocationOpUnknown -> + if size > 0 + then return "Just ptr_to_g_free" + else return "Nothing" + + line $ "instance WrappedPtr " <> name' <> " where" + indent $ do + line $ "wrappedPtrCalloc = " <> calloc + line $ "wrappedPtrCopy = " <> copy + line $ "wrappedPtrFree = " <> free + + hsBoot $ line $ "instance WrappedPtr " <> name' <> " where" + diff --git a/lib/Data/GI/GIR/Allocation.hs b/lib/Data/GI/GIR/Allocation.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Allocation.hs @@ -0,0 +1,31 @@ +-- | Information on explicit allocation/deallocation for foreign pointers. +module Data.GI.GIR.Allocation + ( AllocationInfo(..) + , AllocationOp(..) + , unknownAllocationInfo + ) where + +import Data.Text (Text) + +-- | Allocation/deallocation information for a given foreign pointer. +data AllocationInfo = AllocationInfo { + allocCalloc :: AllocationOp + , allocCopy :: AllocationOp + , allocFree :: AllocationOp + } deriving (Show) + +-- | Information about a given allocation operation. It is either disallowed, +-- allowed via the given function, or it is unknown at the current +-- stage how to perform the operation. +data AllocationOp = AllocationOpUnknown + | AllocationOp Text + deriving (Show, Eq) + +-- | A convenience function, filling in all the allocation info to unknown. +unknownAllocationInfo :: AllocationInfo +unknownAllocationInfo = AllocationInfo { + allocCalloc = AllocationOpUnknown + , allocCopy = AllocationOpUnknown + , allocFree = AllocationOpUnknown + + } diff --git a/lib/Data/GI/GIR/Struct.hs b/lib/Data/GI/GIR/Struct.hs --- a/lib/Data/GI/GIR/Struct.hs +++ b/lib/Data/GI/GIR/Struct.hs @@ -6,12 +6,14 @@ import Data.Text (Text) +import Data.GI.GIR.Allocation (AllocationInfo(..), unknownAllocationInfo) import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser data Struct = Struct { structIsBoxed :: Bool, + structAllocationInfo :: AllocationInfo, structTypeInit :: Maybe Text, structSize :: Int, gtypeStructFor :: Maybe Name, @@ -40,6 +42,7 @@ return (name, Struct { structIsBoxed = error ("[boxed] unfixed struct " ++ show name) + , structAllocationInfo = unknownAllocationInfo , structTypeInit = typeInit , structSize = error ("[size] unfixed struct " ++ show name) , gtypeStructFor = structFor diff --git a/lib/Data/GI/GIR/Union.hs b/lib/Data/GI/GIR/Union.hs --- a/lib/Data/GI/GIR/Union.hs +++ b/lib/Data/GI/GIR/Union.hs @@ -7,12 +7,14 @@ import Data.Maybe (isJust) import Data.Text (Text) +import Data.GI.GIR.Allocation (AllocationInfo(..), unknownAllocationInfo) import Data.GI.GIR.Field (Field, parseFields) import Data.GI.GIR.Method (Method, MethodType(..), parseMethod) import Data.GI.GIR.Parser data Union = Union { unionIsBoxed :: Bool, + unionAllocationInfo :: AllocationInfo, unionSize :: Int, unionTypeInit :: Maybe Text, unionFields :: [Field], @@ -32,6 +34,7 @@ return (name, Union { unionIsBoxed = isJust typeInit + , unionAllocationInfo = unknownAllocationInfo , unionTypeInit = typeInit , unionSize = error ("unfixed union size " ++ show name) , unionFields = fields