haskell-gi 0.14 → 0.15

raw patch · 10 files changed

+235/−50 lines, 10 filesdep ~haskell-gi-basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-gi-base

API changes (from Hackage documentation)

Files

• haskell-gi.cabal +3/−2
• lib/Data/GI/CodeGen/API.hs +10/−4
• lib/Data/GI/CodeGen/CabalHooks.hs +15/−1
• lib/Data/GI/CodeGen/CodeGen.hs +12/−5
• lib/Data/GI/CodeGen/Conversions.hs +8/−13
• lib/Data/GI/CodeGen/Overrides.hs +72/−14
• lib/Data/GI/CodeGen/Struct.hs +78/−11
• lib/Data/GI/GIR/Allocation.hs +31/−0
• lib/Data/GI/GIR/Struct.hs +3/−0
• lib/Data/GI/GIR/Union.hs +3/−0

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

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

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

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

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

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

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

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

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

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