haskell-gi 0.26.18 → 0.26.19

raw patch · 8 files changed

+598/−19 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• haskell-gi.cabal +2/−1
• lib/Data/GI/CodeGen/API.hs +43/−0
• lib/Data/GI/CodeGen/Code.hs +1/−0
• lib/Data/GI/CodeGen/Conversions.hsc +7/−5
• lib/Data/GI/CodeGen/Struct.hs +97/−10
• lib/Data/GI/CodeGen/StructLayout.hsc +365/−0
• lib/Data/GI/GIR/Field.hs +72/−2
• lib/Data/GI/GIR/Parser.hs +11/−1

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.26.18+version:             0.26.19 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.@@ -81,6 +81,7 @@                        Data.GI.GIR.Union,                        Data.GI.GIR.XMLUtils,                        Data.GI.CodeGen.API,+                       Data.GI.CodeGen.StructLayout,                        Data.GI.CodeGen.CabalHooks,                        Data.GI.CodeGen.Callable,                        Data.GI.CodeGen.Code,

@@ -104,6 +104,8 @@                         lookupAttrWithNamespace, GIRXMLNamespace(..),                         xmlLocalName) +import Data.GI.CodeGen.StructLayout (Aggregate(..), fixupStructLayouts)+ import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem)@@ -329,6 +331,7 @@   (fixup (fixupInterface typelibMap ctypes) >=>     fixup (fixupStruct typelibMap) >=>     fixup fixupUnion >=>+    (return . fixupLayouts) >=>     fixup (fixupMissingSymbols verbose typelibMap)   ) (doc, deps)   where fixup :: ((Name, API) -> IO (Name, API))@@ -347,6 +350,42 @@         ctypes :: M.Map Text Name         ctypes = M.unions (map girCTypes (doc:deps)) +-- | The typelib compiler ignores the widths of bitfields, and+-- anonymous unions and structs, when computing the layout of+-- structs, so we fix the layout of structs and unions (directly or+-- indirectly) containing these using the information in the GIR+-- file. See "Data.GI.CodeGen.StructLayout" for the details. This+-- needs to be done for all the loaded namespaces at once, since+-- structs may embed structs defined in other namespaces.+fixupLayouts :: (GIRInfo, [GIRInfo]) -> (GIRInfo, [GIRInfo])+fixupLayouts (doc, deps) = (fixInfo doc, map fixInfo deps)+  where aggregates :: M.Map Name Aggregate+        aggregates = M.fromList [(n, agg) | info <- doc : deps+                                          , (n, api) <- girAPIs info+                                          , Just agg <- [toAggregate api]]++        toAggregate :: API -> Maybe Aggregate+        toAggregate (APIStruct s) = Just (AggStruct s)+        toAggregate (APIUnion u) = Just (AggUnion u)+        toAggregate (APIEnum e) = Just (AggScalar (enumStorageBytes e))+        toAggregate (APIFlags (Flags e)) = Just (AggScalar (enumStorageBytes e))+        toAggregate (APIObject _) = Just AggPointer+        toAggregate (APIInterface _) = Just AggPointer+        toAggregate (APICallback _) = Just AggPointer+        toAggregate _ = Nothing++        fixed :: M.Map Name Aggregate+        fixed = fixupStructLayouts aggregates++        fixInfo :: GIRInfo -> GIRInfo+        fixInfo info = info {girAPIs = map fixAPI (girAPIs info)}++        fixAPI :: (Name, API) -> (Name, API)+        fixAPI (n, api) = case M.lookup n fixed of+          Just (AggStruct s) -> (n, APIStruct s)+          Just (AggUnion u) -> (n, APIUnion u)+          _ -> (n, api)+ foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType)  -- | List the prerequisites for a 'GType' corresponding to an interface.@@ -434,6 +473,10 @@  -- | Fixup the offsets of fields using the given offset map. fixupField :: M.Map Text FieldInfo -> Field -> Field+fixupField _ f@(Field {fieldAnonymous = Just _}) =+  -- Not present in the typelib, the offset will be computed in+  -- 'fixupLayouts'.+  f fixupField offsetMap f =     f {fieldOffset = case M.lookup (fieldName f) offsetMap of                        Nothing -> error $ "Could not find field "

@@ -965,6 +965,7 @@                 , "import qualified GHC.Records as R"                 , "import qualified Data.Word as DW"                 , "import qualified Data.Int as DI"+                , "import qualified Data.Bits as DB"                 , "import qualified System.Posix.Types as SPT"                 , "import qualified Foreign.C.Types as FCT"] 

@@ -703,11 +703,13 @@                         | (size == 0) = "unpackPtrArrayWithLength"                         | boxed       = "unpackBoxedArrayWithLength " <> tshow size                         | otherwise   = "unpackBlockArrayWithLength " <> tshow size-               -- We always make a copy of the elements when unpacking-               -- boxed types.-           let transfer' | boxed      = if transfer == TransferContainer-                                        then TransferEverything-                                        else transfer+           -- When unpacking structs/unions stored inline in the+           -- array (size > 0) the unpacker always makes a copy of+           -- each element, which we then own, so we wrap it+           -- directly instead of making a second copy (which would+           -- leak the first one).+           let transfer' | isScalar   = transfer+                         | size > 0   = TransferEverything                          | otherwise  = transfer            innerConstructor <- fToH' t a hType fType transfer'            return $ do

@@ -135,6 +135,56 @@   , "'Data.GI.Base.Attributes.get' " <> lowerName n <> " #" <> labelName field   , "@"] +-- | If the given field is a C array whose length is given by another+-- field in the same struct/union, return the field holding the+-- length.+arrayLengthField :: [Field] -> Field -> ExcCodeGen (Maybe Field)+arrayLengthField fields field =+  case fieldType field of+    TCArray False (-1) idx _+      | idx < 0 -> return Nothing+      | idx >= length fields ->+        badIntroError $ "Array length field index " <> tshow idx+                        <> " for field “" <> fieldName field+                        <> "” is out of range."+      | otherwise -> do+          let lengthField = fields !! idx+          case fieldType lengthField of+            TBasicType t | t `elem` [TInt, TUInt, TLong, TULong,+                                     TInt8, TUInt8, TInt16, TUInt16,+                                     TInt32, TUInt32, TInt64, TUInt64,+                                     TSize, TSSize] ->+                             return (Just lengthField)+            t -> badIntroError $ "Array length field “"+                                 <> fieldName lengthField+                                 <> "” for field “" <> fieldName field+                                 <> "” has non-integral type " <> tshow t+    _ -> return Nothing++-- | If the field is a bitfield, return its width and the shift of+-- its least significant bit inside the storage unit.+bitfieldInfo :: Field -> ExcCodeGen (Maybe (Int, Int))+bitfieldInfo field = case fieldBits field of+  Nothing -> return Nothing+  Just width -> case fieldBitShift field of+    Nothing -> notImplementedError "Could not determine the layout of the bitfield"+    Just shift -> do+      supported <- case fieldType field of+        TBasicType t -> return $ t `elem` [TBoolean, TInt, TUInt, TLong, TULong,+                                           TInt8, TUInt8, TInt16, TUInt16,+                                           TInt32, TUInt32, TInt64, TUInt64,+                                           TShort, TUShort, TSize, TSSize,+                                           TUniChar]+        t@(TInterface _) -> findAPI t >>= \case+          Just (APIEnum _) -> return True+          Just (APIFlags _) -> return True+          _ -> return False+        _ -> return False+      if supported+        then return (Just (width, shift))+        else notImplementedError $ "Bitfield of unsupported type "+                                   <> tshow (fieldType field)+ -- Notice that when reading the field we return a copy of any embedded -- structs, so modifications of the returned struct will not affect -- the original struct. This is on purpose, in order to increase@@ -142,12 +192,13 @@ -- parent structure while we are modifying the embedded one, and havoc -- will ensue). -- | Extract a field from a struct.-buildFieldReader :: Name -> Field -> ExcCodeGen ()-buildFieldReader n field = group $ do+buildFieldReader :: Name -> [Field] -> Field -> ExcCodeGen ()+buildFieldReader n fields field = group $ do   let name' = upperName n       getter = fieldGetter n field    embedded <- isEmbedded field+  bitfield <- bitfieldInfo field   nullConvert <- if embedded                  then return Nothing                  else maybeNullConvert (fieldType field)@@ -172,12 +223,31 @@              <> " :: " <> peekedType     else line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)              <> ") :: IO " <> peekedType+    -- For bitfields, we read the whole storage unit, and then+    -- extract the relevant bits (with sign extension for signed+    -- types).+    valName <- case bitfield of+      Nothing -> return "val"+      Just (width, shift) -> do+        line $ "let bitfield = DB.shiftR (DB.shiftL val (DB.finiteBitSize val P.- "+               <> tshow (shift + width) <> ")) (DB.finiteBitSize val P.- "+               <> tshow width <> ")"+        return "bitfield"+    -- C arrays whose length is given by another field in the struct+    -- need the length in order to be unpacked.+    converter <- arrayLengthField fields field >>= \case+      Nothing -> return $ fToH (fieldType field) TransferNothing+      Just lengthField -> do+        lType <- typeShow <$> foreignType (fieldType lengthField)+        line $ "len <- peek (ptr `plusPtr` " <> tshow (fieldOffset lengthField)+               <> ") :: IO " <> lType+        return $ unpackCArray "len" (fieldType field) TransferNothing     result <- case nullConvert of-              Nothing -> convert "val" $ fToH (fieldType field) TransferNothing+              Nothing -> convert valName converter               Just nullConverter -> do                 line $ "result <- " <> nullConverter <> " val $ \\val' -> do"                 indent $ do-                  val' <- convert "val'" $ fToH (fieldType field) TransferNothing+                  val' <- convert "val'" converter                   line $ "return " <> val'                 return "result"     line $ "return " <> result@@ -220,12 +290,25 @@   line $ setter <> " :: MonadIO m => " <> name' <> " -> "            <> hType <> " -> m ()"   line $ setter <> " s val = liftIO $ withManagedPtr s $ \\ptr -> do"+  bitfield <- bitfieldInfo field+   indent $ do     converted <- if isPtr                  then return "val"                  else convert "val" $ hToF (fieldType field) TransferNothing-    line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)-         <> ") (" <> converted <> " :: " <> fType <> ")"+    let location = "(ptr `plusPtr` " <> tshow (fieldOffset field) <> ")"+    case bitfield of+      Nothing ->+        line $ "poke " <> location <> " (" <> converted <> " :: " <> fType <> ")"+      Just (width, shift) -> do+        -- Only modify the bits corresponding to the bitfield in the+        -- storage unit.+        line $ "old <- peek " <> location <> " :: IO " <> parenthesize fType+        line $ "let mask = DB.shiftL (DB.shiftL 1 " <> tshow width+               <> " P.- 1) " <> tshow shift <> " :: " <> fType+        line $ "poke " <> location <> " ((old DB..&. DB.complement mask) DB..|. "+               <> "(DB.shiftL (" <> converted <> " :: " <> fType <> ") "+               <> tshow shift <> " DB..&. mask))"  -- | Name for the clear function fieldClear :: Name -> Field -> Text@@ -398,8 +481,8 @@   return $ "'(\"" <> labelName field <> "\", " <> it <> ")"  -- | Build code for a single field.-buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)-buildFieldAttributes n field+buildFieldAttributes :: Name -> [Field] -> Field -> ExcCodeGen (Maybe Text)+buildFieldAttributes n fields field     | not (fieldVisible field) = return Nothing     | privateType (fieldType field) = return Nothing     | otherwise = group $ do@@ -417,7 +500,7 @@       addSectionDocumentation docSection (fieldDocumentation field) -     buildFieldReader n field+     buildFieldReader n fields field      export docSection (fieldGetter n field)       when (not embedded) $ do@@ -449,7 +532,7 @@                              ":" <> fieldName field <> "\"")                       printCGError e                       return Nothing)-                  (buildFieldAttributes n field)+                  (buildFieldAttributes n fields field)    blank @@ -567,6 +650,8 @@        line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"    copy <- case allocCopy info of+            -- Do not copy, the copy refers to the same memory.+            AllocationOp "none" -> return "return"             AllocationOp op -> do                 copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)"                 return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <>@@ -579,6 +664,8 @@                 else return "return"    free <- case allocFree info of+            -- Never free the memory.+            AllocationOp "none" -> return "\\_x -> return ()"             AllocationOp op -> do               free <- prefixedForeignImport (prefix "free") op "Ptr a -> IO ()"               return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> free

@@ -0,0 +1,365 @@+-- | Fix the memory layout of structs and unions.+--+-- When compiling the typelib, the typelib compiler (both+-- @gi-compile-repository@ in GLib and @g-ir-compiler@ in+-- gobject-introspection) makes two simplifications when computing+-- the layout of structs and unions:+--+-- * It ignores the width of bitfields: each bitfield is laid out as+--   if it was a full member of its declared type.+--+-- * It ignores unions and structs declared inline (such as+--   @union { ... } u;@, or anonymous unions).+--+-- This leads to wrong struct sizes, and wrong offsets for the fields+-- following the affected members. This affects the struct itself,+-- and any struct or union embedding it. See+-- <https://github.com/haskell-gi/haskell-gi/issues/485>.+--+-- The GIR files do contain the required information, so here we+-- recompute the layout ourselves, following the rules of the C+-- ABI. To make sure that we are not missing any information (fields+-- that we could not parse, types of unknown size, ...), we first+-- check that by laying out the struct in the same way that the+-- typelib compiler does we reproduce the typelib data exactly. If+-- this is not the case we keep the data from the typelib.+module Data.GI.CodeGen.StructLayout+  ( Aggregate(..)+  , fixupStructLayouts+  ) where++#include <glib-object.h>++#if !MIN_VERSION_base(4,13,0)+import Data.Monoid ((<>))+#endif++import Control.Monad (forM, unless, when)+import qualified Data.Map.Lazy as ML+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import Foreign.C.Types (CTime)+import Foreign.Storable (alignment, sizeOf)+import qualified System.Info++import Data.GI.GIR.BasicTypes (BasicType(..), Name(..), Type(..))+import Data.GI.GIR.Field (Field(..), AnonymousMember(..))+import Data.GI.GIR.Struct (Struct(..))+import Data.GI.GIR.Union (Union(..))++-- | The information about a named type that we need in order to+-- compute layouts.+data Aggregate = AggStruct Struct+               | AggUnion Union+               | AggScalar Int  -- ^ Enums and flags, with their+                                -- storage size in bytes.+               | AggPointer     -- ^ Types which are always stored+                                -- as pointers in structs (objects,+                                -- interfaces, callbacks).++-- | How to lay out the struct.+data Mode = TypelibMode -- ^ Mimic the typelib compiler.+          | ABIMode     -- ^ Follow the platform C ABI.+  deriving (Eq)++-- | Position of a field in a struct.+data FieldLayout = FieldLayout {+      flOffset   :: Int       -- ^ Offset in bytes.+    , flBitShift :: Maybe Int -- ^ Bit shift, for bitfields.+    }++-- | Layout of a struct or union.+data Layout = Layout {+      lSize   :: Int+    , lAlign  :: Int+    , lFields :: [FieldLayout]+    }++-- | Size and alignment of a C type.+type SizeAlign = (Int, Int)++-- | Given the structs, unions, and other named types in scope,+-- return the structs and unions whose layout has been+-- corrected. Bitfields in the corrected structs and unions will+-- also have their `fieldBitShift` set.+fixupStructLayouts :: ML.Map Name Aggregate -> ML.Map Name Aggregate+fixupStructLayouts aggs = ML.mapMaybeWithKey fix aggs+  where+    fix :: Name -> Aggregate -> Maybe Aggregate+    fix n (AggStruct s) | needsFixing (structFields s) = do+      layout <- either (const Nothing) Just (abiLayout n)+      return $ AggStruct (s { structSize = lSize layout+                            , structFields = applyLayout layout+                                                         (structFields s) })+    fix n (AggUnion u) | needsFixing (unionFields u) = do+      layout <- either (const Nothing) Just (abiLayout n)+      return $ AggUnion (u { unionSize = lSize layout+                           , unionFields = applyLayout layout+                                                       (unionFields u) })+    fix _ _ = Nothing++    -- Structs whose layout may be wrong in the typelib: those+    -- containing bitfields or inline unions or structs, and those+    -- embedding other structs or unions (which may be wrong).+    needsFixing :: [Field] -> Bool+    needsFixing = any (\f -> isJust (fieldBits f) || embedsAggregate f)++    embedsAggregate :: Field -> Bool+    embedsAggregate f+      | isJust (fieldAnonymous f) = True+      | isPointerField f = False+      | otherwise = case elementType (fieldType f) of+          TInterface n -> case ML.lookup n aggs of+                            Just (AggStruct _) -> True+                            Just (AggUnion _) -> True+                            _ -> False+          TGValue -> True+          TGClosure _ -> True+          _ -> False++    elementType :: Type -> Type+    elementType (TCArray _ fixed _ t) | fixed > 0 = elementType t+    elementType t = t++    applyLayout :: Layout -> [Field] -> [Field]+    applyLayout layout =+      zipWith (\fl f -> f { fieldOffset = flOffset fl+                          , fieldBitShift = flBitShift fl })+              (lFields layout)++    -- Layouts computed by mimicking the typelib compiler, keeping+    -- only those that reproduce exactly the data in the typelib. The+    -- map is lazy, so we only compute what we need, and each layout+    -- is computed at most once.+    typelibLayouts :: ML.Map Name (Either Text Layout)+    typelibLayouts = ML.mapMaybe verified aggs+      where verified (AggStruct s) =+              Just (verify (structSize s) (structFields s)+                    =<< structLayout TypelibMode (structFields s))+            verified (AggUnion u) =+              Just (verify (unionSize u) (unionFields u)+                    =<< unionLayout TypelibMode (unionFields u))+            verified _ = Nothing++            verify :: Int -> [Field] -> Layout -> Either Text Layout+            verify size fields layout = do+              when (lSize layout /= size) $+                Left $ "Computed size " <> tshow (lSize layout)+                       <> " does not match typelib size " <> tshow size+              let offsets = [(flOffset fl, fieldOffset f)+                            | (fl, f) <- zip (lFields layout) fields+                            , not (isJust (fieldAnonymous f))]+              unless (all (uncurry (==)) offsets) $+                Left "Computed offsets do not match the typelib offsets"+              return layout++    -- Layouts following the C ABI, for those types whose typelib+    -- layout we can reproduce.+    abiLayouts :: ML.Map Name (Either Text Layout)+    abiLayouts = ML.mapMaybeWithKey abi aggs+      where abi n (AggStruct s) =+              Just (typelibLayout n >> structLayout ABIMode (structFields s))+            abi n (AggUnion u) =+              Just (typelibLayout n >> unionLayout ABIMode (unionFields u))+            abi _ _ = Nothing++    typelibLayout :: Name -> Either Text Layout+    typelibLayout n = case ML.lookup n typelibLayouts of+      Just l -> l+      Nothing -> Left ("No layout for " <> tshow n)++    abiLayout :: Name -> Either Text Layout+    abiLayout n = case ML.lookup n abiLayouts of+      Just l -> l+      Nothing -> Left ("No layout for " <> tshow n)++    -- Size and alignment of an embedded struct or union.+    embeddedSizeAlign :: Mode -> Name -> Either Text SizeAlign+    embeddedSizeAlign mode n = do+      layout <- case mode of+                  TypelibMode -> typelibLayout n+                  ABIMode -> abiLayout n+      return (lSize layout, lAlign layout)++    structLayout :: Mode -> [Field] -> Either Text Layout+    structLayout mode fields = do+      sizes <- forM fields (fieldSizeAlign mode)+      let bitfields = case mode of+                        TypelibMode -> map (const Nothing) fields+                        ABIMode -> map fieldBits fields+          placed = zip3 fields sizes bitfields+      if msBitfields+        then msStructLayout placed+        else sysvStructLayout placed++    unionLayout :: Mode -> [Field] -> Either Text Layout+    unionLayout mode fields = do+      sizes <- forM fields (fieldSizeAlign mode)+      let align = maximum (1 : map snd sizes)+          size = roundUp (maximum (0 : map fst sizes)) align+          fl (f, (s, _)) = case (mode, fieldBits f) of+            (ABIMode, Just w) -> FieldLayout 0 (Just (bitShift s 0 w))+            _ -> FieldLayout 0 Nothing+      return $ Layout size align (map fl (zip fields sizes))++    fieldSizeAlign :: Mode -> Field -> Either Text SizeAlign+    fieldSizeAlign mode f = case fieldAnonymous f of+      -- These are ignored by the typelib compiler.+      Just _ | mode == TypelibMode -> Right (0, 1)+      Just (AnonymousUnion members) -> do+        layout <- unionLayout mode members+        return (lSize layout, lAlign layout)+      Just (AnonymousStruct members) -> do+        layout <- structLayout mode members+        return (lSize layout, lAlign layout)+      Nothing+        | isPointerField f -> Right pointerSizeAlign+        | TCArray _ fixed _ _ <- fieldType f, fixed > 0, fieldArrayOfPointers f ->+            let (size, align) = pointerSizeAlign+            in Right (fixed * size, align)+        | otherwise -> case typeSizeAlign mode (fieldType f) of+            Left err -> Left ("Field “" <> fieldName f <> "”: " <> err)+            r -> r++    -- Size and alignment of a type stored inline.+    typeSizeAlign :: Mode -> Type -> Either Text SizeAlign+    typeSizeAlign mode t = case t of+      TBasicType b -> basicSizeAlign b+      TInterface n -> case ML.lookup n aggs of+        Just (AggStruct _) -> embeddedSizeAlign mode n+        Just (AggUnion _) -> embeddedSizeAlign mode n+        Just (AggScalar size) -> Right (size, size)+        Just AggPointer -> Right pointerSizeAlign+        Nothing -> Left ("Unknown type " <> tshow n)+      TGValue -> embeddedSizeAlign mode (Name "GObject" "Value")+      TGClosure _ -> embeddedSizeAlign mode (Name "GObject" "Closure")+      TCArray _ fixed _ elemType+        | fixed > 0 -> do+            (size, align) <- typeSizeAlign mode elemType+            return (fixed * size, align)+        | otherwise -> Right pointerSizeAlign+      _ -> Right pointerSizeAlign++-- | Whether the field is a pointer (as opposed to being stored inline+-- in the struct).+isPointerField :: Field -> Bool+isPointerField f = isJust (fieldCallback f) || fieldIsPointer f == Just True++-- | Lay out the fields in a struct following the rules of the System+-- V (and Itanium) ABIs: a bitfield is placed at the next available+-- bit, unless it would straddle a storage unit of its declared type,+-- in which case it is placed at the start of the next such unit.+sysvStructLayout :: [(Field, SizeAlign, Maybe Int)] -> Either Text Layout+sysvStructLayout = go 0 1 []+  where+    -- We keep track of the position in bits.+    go :: Int -> Int -> [FieldLayout] -> [(Field, SizeAlign, Maybe Int)]+       -> Either Text Layout+    go pos align acc [] =+      Right $ Layout (roundUp (roundUp pos 8 `div` 8) align) align (reverse acc)+    go pos align acc ((f, (size, falign), bits) : rest) = case bits of+      Nothing ->+        let offset = roundUp (roundUp pos 8 `div` 8) falign+        in go ((offset + size) * 8) (max align falign)+              (FieldLayout offset Nothing : acc) rest+      Just w -> do+        let unitBits = size * 8+        when (w > unitBits) $+          Left ("Bitfield “" <> fieldName f <> "” is wider than its type")+        let start = if pos `mod` unitBits + w > unitBits+                    then roundUp pos unitBits+                    else pos+            unit = (start `div` unitBits) * size+        go (start + w) (max align falign)+           (FieldLayout unit (Just (bitShift size (start - unit * 8) w)) : acc)+           rest++-- | Lay out the fields in a struct following the rules used by MSVC+-- (and by GCC with @-mms-bitfields@, the default on Windows): a+-- bitfield shares the storage unit of the previous bitfield only if+-- their declared types have the same size and there is enough space+-- left, otherwise a new storage unit is allocated.+msStructLayout :: [(Field, SizeAlign, Maybe Int)] -> Either Text Layout+msStructLayout = go 0 Nothing 1 []+  where+    -- We keep track of the end of the struct so far in bytes, and of+    -- the current storage unit (offset, size, bits used), if any.+    go :: Int -> Maybe (Int, Int, Int) -> Int -> [FieldLayout]+       -> [(Field, SizeAlign, Maybe Int)] -> Either Text Layout+    go end _ align acc [] =+      Right $ Layout (roundUp end align) align (reverse acc)+    go end unit align acc ((f, (size, falign), bits) : rest) = case bits of+      Nothing ->+        let offset = roundUp end falign+        in go (offset + size) Nothing (max align falign)+              (FieldLayout offset Nothing : acc) rest+      Just w -> do+        when (w > size * 8) $+          Left ("Bitfield “" <> fieldName f <> "” is wider than its type")+        case unit of+          Just (uOffset, uSize, used) | uSize == size && used + w <= size * 8 ->+            go end (Just (uOffset, uSize, used + w)) (max align falign)+               (FieldLayout uOffset (Just (bitShift size used w)) : acc) rest+          _ -> do+            let offset = roundUp end falign+            go (offset + size) (Just (offset, size, w)) (max align falign)+               (FieldLayout offset (Just (bitShift size 0 w)) : acc) rest++-- | Shift of the least significant bit of a bitfield of the given+-- width, starting at the given bit position in a storage unit of+-- the given size in bytes. On big endian machines bitfields are+-- allocated starting from the most significant bit.+bitShift :: Int -> Int -> Int -> Int+bitShift unitSize pos width+  | bigEndian = unitSize * 8 - pos - width+  | otherwise = pos++-- | Whether we are running on a big endian machine.+bigEndian :: Bool+bigEndian = (#{const G_BYTE_ORDER} :: Int) == #{const G_BIG_ENDIAN}++-- | Whether bitfields are laid out following the MSVC rules.+msBitfields :: Bool+msBitfields = System.Info.os == "mingw32"++pointerSizeAlign :: SizeAlign+pointerSizeAlign = (#{size gpointer}, #{alignment gpointer})++-- | Size and alignment of the basic types.+basicSizeAlign :: BasicType -> Either Text SizeAlign+basicSizeAlign t = case t of+  TBoolean -> Right (#{size gboolean}, #{alignment gboolean})+  TInt -> Right (#{size gint}, #{alignment gint})+  TUInt -> Right (#{size guint}, #{alignment guint})+  TLong -> Right (#{size glong}, #{alignment glong})+  TULong -> Right (#{size gulong}, #{alignment gulong})+  TInt8 -> Right (#{size gint8}, #{alignment gint8})+  TUInt8 -> Right (#{size guint8}, #{alignment guint8})+  TInt16 -> Right (#{size gint16}, #{alignment gint16})+  TUInt16 -> Right (#{size guint16}, #{alignment guint16})+  TInt32 -> Right (#{size gint32}, #{alignment gint32})+  TUInt32 -> Right (#{size guint32}, #{alignment guint32})+  TInt64 -> Right (#{size gint64}, #{alignment gint64})+  TUInt64 -> Right (#{size guint64}, #{alignment guint64})+  TFloat -> Right (#{size gfloat}, #{alignment gfloat})+  TDouble -> Right (#{size gdouble}, #{alignment gdouble})+  TUniChar -> Right (#{size gunichar}, #{alignment gunichar})+  TGType -> Right (#{size GType}, #{alignment GType})+  TUTF8 -> Right pointerSizeAlign+  TFileName -> Right pointerSizeAlign+  TPtr -> Right pointerSizeAlign+  TIntPtr -> Right (#{size gintptr}, #{alignment gintptr})+  TUIntPtr -> Right (#{size guintptr}, #{alignment guintptr})+  TShort -> Right (#{size gshort}, #{alignment gshort})+  TUShort -> Right (#{size gushort}, #{alignment gushort})+  TSize -> Right (#{size gsize}, #{alignment gsize})+  TSSize -> Right (#{size gssize}, #{alignment gssize})+  Ttime_t -> Right (sizeOf (0 :: CTime), alignment (0 :: CTime))+  _ -> Left ("Unsupported basic type " <> tshow t)++roundUp :: Int -> Int -> Int+roundUp n a = ((n + a - 1) `div` a) * a++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -1,6 +1,7 @@ -- | Parsing of object/struct/union fields. module Data.GI.GIR.Field     ( Field(..)+    , AnonymousMember(..)     , FieldInfoFlag     , parseFields     ) where@@ -13,7 +14,7 @@ #endif import Data.Text (Text, isSuffixOf) -import Data.GI.GIR.BasicTypes (Type(..))+import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Callback (Callback, parseCallback) import Data.GI.GIR.Type (parseType, queryElementCType) import Data.GI.GIR.Parser@@ -23,8 +24,27 @@       fieldVisible :: Bool,       fieldType :: Type,       fieldIsPointer :: Maybe Bool, -- ^ `Nothing` if not known.+      fieldArrayOfPointers :: Bool,+      -- ^ For C arrays stored inline in the struct (that is, with a+      -- fixed size), whether the elements are pointers.       fieldCallback :: Maybe Callback,       fieldOffset :: Int,+      -- ^ For bitfields, this is the offset of the storage unit+      -- containing the bitfield.+      fieldBits :: Maybe Int,+      -- ^ The width in bits, if the field is a bitfield.+      fieldBitShift :: Maybe Int,+      -- ^ For bitfields, the position of the least significant bit+      -- of the bitfield inside its storage unit (a value of the+      -- declared type of the field, stored at `fieldOffset`). This+      -- is `Nothing` if the layout of the bitfield could not be+      -- determined.+      fieldAnonymous :: Maybe AnonymousMember,+      -- ^ If this member is an (anonymous type) union or struct+      -- declared inline, its contents. In this case `fieldType`+      -- is meaningless, and the field is never visible. We keep+      -- track of these members since they affect the layout of+      -- the containing struct or union.       fieldFlags :: [FieldInfoFlag],       fieldDocumentation :: Documentation,       fieldDeprecated :: Maybe DeprecationInfo }@@ -33,6 +53,12 @@ data FieldInfoFlag = FieldIsReadable | FieldIsWritable                    deriving Show +-- | Contents of a union or struct declared inline in a struct or+-- union.+data AnonymousMember = AnonymousUnion [Field]+                     | AnonymousStruct [Field]+                     deriving Show+ -- | Parse a single field in a struct or union. We parse -- non-introspectable fields too (but set fieldVisible = False for -- them), this is necessary since they affect the computation of@@ -41,6 +67,7 @@ parseField = do   name <- getAttr "name"   deprecated <- parseDeprecation+  bits <- optionalAttr "bits" Nothing (fmap Just . parseIntegral)   readable <- optionalAttr "readable" True parseBool   writable <- optionalAttr "writable" False parseBool   let flags = if readable then [FieldIsReadable] else []@@ -79,6 +106,11 @@           [n] -> return (TInterface n, Just True, Nothing)           _ -> parseError "Multiple callbacks in field" +    elementCTypes <- parseAllChildrenWithLocalName "array" queryElementCType+    let arrayOfPointers = case elementCTypes of+          [Just ct] -> "*" `isSuffixOf` ct+          _ -> False+     return $ Just $ Field {                fieldName = name              , fieldVisible = introspectable && not private@@ -86,12 +118,50 @@              , fieldIsPointer = if isJust callback                                 then Just True                                 else isPtr+             , fieldArrayOfPointers = arrayOfPointers              , fieldCallback = callback              , fieldOffset = error ("unfixed field offset " ++ show name)+             , fieldBits = if bits == Just 0 then Nothing else bits+             , fieldBitShift = Nothing+             , fieldAnonymous = Nothing              , fieldFlags = flags              , fieldDocumentation = doc              , fieldDeprecated = deprecated           } +-- | Parse an union or struct declared inline in a struct or union.+parseAnonymousMember :: Bool -> Parser Field+parseAnonymousMember isUnion = do+  name <- optionalAttr "name" (if isUnion+                               then "<anonymous union>"+                               else "<anonymous struct>") return+  -- We do not keep track of the offsets of the members of the+  -- anonymous union or struct, only of its total size.+  members <- map (\f -> f {fieldOffset = 0}) <$> parseFields+  doc <- parseDocumentation+  return $ Field {+               fieldName = name+             , fieldVisible = False+             , fieldType = TBasicType TPtr -- Not meaningful+             , fieldIsPointer = Just False+             , fieldArrayOfPointers = False+             , fieldCallback = Nothing+             , fieldOffset = 0+             , fieldBits = Nothing+             , fieldBitShift = Nothing+             , fieldAnonymous = Just (if isUnion+                                      then AnonymousUnion members+                                      else AnonymousStruct members)+             , fieldFlags = []+             , fieldDocumentation = doc+             , fieldDeprecated = Nothing+          }++-- | Parse the members of a struct or union, in order. parseFields :: Parser [Field]-parseFields = catMaybes <$> parseAllChildrenWithLocalName "field" parseField+parseFields = catMaybes <$>+  parseAllChildrenWithLocalNames ["field", "union", "record"] parseMember+  where parseMember :: Text -> Parser (Maybe Field)+        parseMember "union" = Just <$> parseAnonymousMember True+        parseMember "record" = Just <$> parseAnonymousMember False+        parseMember _ = parseField

@@ -14,6 +14,7 @@     , parseBool     , parseChildrenWithLocalName     , parseAllChildrenWithLocalName+    , parseAllChildrenWithLocalNames     , parseChildrenWithNSName      , getAttr@@ -53,7 +54,7 @@ import Data.GI.GIR.Documentation (Documentation, queryDocumentation) import Data.GI.GIR.XMLUtils (localName, GIRXMLNamespace(..),                         childElemsWithLocalName, childElemsWithNSName,-                        lookupAttr, lookupAttrWithNamespace)+                        lookupAttr, lookupAttrWithNamespace, subelements)  -- | Info to carry around when parsing. data ParseContext = ParseContext {@@ -204,6 +205,15 @@ parseAllChildrenWithLocalName n parser = do   ctx <- ask   mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx))++-- | Parse all subelements whose local name is one of the given+-- ones, in document order. The parser is passed the local name of+-- the subelement being parsed.+parseAllChildrenWithLocalNames :: [Text] -> (Text -> Parser a) -> Parser [a]+parseAllChildrenWithLocalNames names parser = do+  ctx <- ask+  mapM (\e -> withElement (parser (localName e)) e)+       (filter ((`elem` names) . localName) (subelements (currentElement ctx)))  -- | Parse all introspectable children with the given namespace and -- local name.