Add support for 64 bit bitmasks in vulkan

Fixes #266

generate-new/src/Bespoke.hs

@@ -863,6 +863,7 @@ bespokeElements = \case
       $  shared
       <> [ baseType "VkSampleMask"    ''Word32
          , baseType "VkFlags"         ''Word32
+         , baseType "VkFlags64"       ''Word64
          , baseType "VkDeviceSize"    ''Word64
          , baseType "VkDeviceAddress" ''Word64
          ]

generate-new/src/Bespoke/MarshalParams.hs

@@ -27,9 +27,9 @@ marshalParams spec@Spec {..} = do
     bitmaskNames :: HashSet CName
     bitmaskNames = fromList
       [ n
-      | Enum {..}      <- toList specEnums
-      , ABitmask flags <- pure eType
-      , n              <- [eName, flags]
+      | Enum {..}        <- toList specEnums
+      , ABitmask flags _ <- pure eType
+      , n                <- [eName, flags]
       ]
     isBitmask     = (`member` bitmaskNames)
     isBitmaskType = \case

generate-new/src/Bespoke/RenderParams.hs

@@ -32,6 +32,7 @@ import           Render.Stmts.Poke              ( CmdsDoc(..) )
 import           Render.Type.Preserve
 import           Spec.Parse
 
+-- This is in `src` rather than `vk` as it's also used by the xr and vma generators
 renderParams :: V.Vector Handle -> RenderParams
 renderParams handles = r
  where
@@ -64,6 +65,7 @@ renderParams handles = r
     , lowerPrefix                    = "vk"
     , upperPrefix                    = "VK"
     , flagsTypeName                  = "VkFlags"
+    , flags64TypeName                = "VkFlags64"
     , alwaysQualifiedNames           = mempty
     , extraNewtypes                  = mempty
     , mkIdiomaticType                =

generate-new/src/Render/Element.hs

@@ -251,7 +251,9 @@ data RenderParams = RenderParams
   , upperPrefix                 :: Text
     -- ^ "VK" or "XR" or "VMA"
   , flagsTypeName               :: CName
-    -- ^ "VkFlags" or "XrFlags64"
+    -- ^ 32 bit flag type
+  , flags64TypeName             :: CName
+    -- ^ 64 bit flag type
   , alwaysQualifiedNames        :: Vector Name
   , extraNewtypes               :: Vector Name
   , mkIdiomaticType             :: Type -> Maybe IdiomaticType

generate-new/src/Render/Element/Write.hs

@@ -430,8 +430,8 @@ specTypeInfo Spec {..} = do
         [ (mkConName eExportedName evName, mkTyName eExportedName)
         | Enum {..} <- V.toList specEnums
         , let eExportedName = case eType of
-                AnEnum         -> eName
-                ABitmask flags -> flags
+                AnEnum           -> eName
+                ABitmask flags _ -> flags
         , EnumValue {..} <- V.toList eValues
         ]
   pure $ TypeInfo (`Map.lookup` tyMap)

generate-new/src/Render/Enum.hs

@@ -37,16 +37,18 @@ renderEnum e@Enum {..} = do
     tellCanFormat
 
     innerTy <- case eType of
-      AnEnum     -> pure $ ConT ''Int32
-      ABitmask _ -> cToHsType DoNotPreserve (TypeName flagsTypeName)
+      AnEnum               -> pure $ ConT ''Int32
+      ABitmask _ Bitmask32 -> cToHsType DoNotPreserve (TypeName flagsTypeName)
+      ABitmask _ Bitmask64 ->
+        cToHsType DoNotPreserve (TypeName flags64TypeName)
     let n       = mkTyName eName
         conName = mkConName eName eName
 
     -- Export the type cinnamon first so that it appears above the Flags in the
     -- Haddocks, this means when viewing the page there, the user will also
     -- have the flags visible
     case eType of
-      ABitmask flags | flags /= eName -> do
+      ABitmask flags _ | flags /= eName -> do
         let flagsName = mkTyName flags
         let syn :: HasRenderElem r => Sem r ()
             syn = do
@@ -64,15 +66,15 @@ renderEnum e@Enum {..} = do
       tellDoc $ "data" <+> pretty n
     tDoc <- renderType innerTy
     let complete = case eType of
-          AnEnum     -> completePragma n (mkPatternName . evName <$> eValues)
-          ABitmask _ -> Nothing
+          AnEnum       -> completePragma n (mkPatternName . evName <$> eValues)
+          ABitmask _ _ -> Nothing
     tellImport (TyConName "Zero")
     derivedClasses <- do
       tellImport ''Storable
       let always = ["Eq", "Ord", "Storable", "Zero"]
       special <- case eType of
-        AnEnum     -> pure []
-        ABitmask _ -> do
+        AnEnum       -> pure []
+        ABitmask _ _ -> do
           tellImport ''Bits
           tellImport ''FiniteBits
           pure ["Bits", "FiniteBits"]
@@ -124,8 +126,9 @@ renderEnumValue eName conName enumType EnumValue {..} = do
   RenderParams {..} <- input
   let n = mkPatternName evName
       v = case enumType of
-        AnEnum     -> showsPrec 9 evValue ""
-        ABitmask _ -> printf "0x%08x" evValue
+        AnEnum               -> showsPrec 9 evValue ""
+        ABitmask _ Bitmask32 -> printf "0x%08x" evValue
+        ABitmask _ Bitmask64 -> printf "0x%016x" evValue
   pure
     ( \getDoc -> vsep
       [ getDoc (Nested eName evName)
@@ -204,7 +207,7 @@ renderShowInstance prefixString showTableName conNameName Enum {..} = do
     AnEnum -> do
       tellImport 'showsPrec
       pure ("(showsPrec 11)" :: Text)
-    ABitmask _ -> do
+    ABitmask _ _ -> do
       tellImport 'showString
       tellImport 'showHex
       pure "(\\x -> showString \"0x\" . showHex x)"

generate-new/src/Render/Names.hs

@@ -58,7 +58,7 @@ specRenderedNames Spec {..} = do
     rnEnums  = Set.fromList
       [ mkTyName n
       | Enum {..} <- toList specEnums
-      , n <- eName : [ flags | ABitmask flags <- pure eType ]
+      , n <- eName : [ flags | ABitmask flags _ <- pure eType ]
       ]
     (dispHandles, nonDispHandles) =
       partition ((== Dispatchable) . hDispatchable) $ toList specHandles
@@ -72,8 +72,8 @@ specRenderedNames Spec {..} = do
          , TypeAlias == aType
          ]
       <> [ (mkTyName flags, mkTyName eName)
-         | Enum {..}      <- toList specEnums
-         , ABitmask flags <- pure eType
+         | Enum {..}        <- toList specEnums
+         , ABitmask flags _ <- pure eType
          , flags /= eName
          ]
       )

generate-new/src/Spec/Parse.hs

@@ -133,7 +133,12 @@ parseSpec bs = do
                   $  bespokeSizes (specFlavor @t)
                   <> [ (eName, (4, 4)) | Enum {..} <- V.toList specEnums ]
                   <> [ (n, (4, 4))
-                     | Enum { eType = ABitmask n } <- V.toList specEnums
+                     | Enum { eType = ABitmask n Bitmask32 } <- V.toList
+                       specEnums
+                     ]
+                  <> [ (n, (8, 8))
+                     | Enum { eType = ABitmask n Bitmask64 } <- V.toList
+                       specEnums
                      ]
                   <> [ (atName, (8, 8)) | Atom {..} <- V.toList specAtoms ]
                   <> [ (hName, (8, 8)) | Handle {..} <- V.toList specHandles ]
@@ -661,27 +666,44 @@ parseEmptyBitmasks es = fromList <$> traverseV
   | Element n <- es
   , "type" == name n
   , not (isAlias n)
-  , Nothing        <- pure $ getAttr "requires" n
+  , Nothing        <- pure $ getAttr "requires" n <|> getAttr "bitvalues" n
   , Just "bitmask" <- pure $ getAttr "category" n
   ]
  where
   parseEmptyBitmask :: Node -> P Enum'
   parseEmptyBitmask n = do
     eName <- nameElem "bitmask" n
-    pure Enum { eValues = mempty, eType = ABitmask eName, .. }
+    -- TODO: Are these always 32bit?
+    pure Enum { eValues = mempty, eType = ABitmask eName Bitmask32, .. }
 
 parseEnums :: [Content] -> [Content] -> P (Vector Enum')
 parseEnums types es = do
   flagNameMap <- Map.fromList <$> sequence
-    [ liftA2 (,) (decodeName bits) (nameElem "bitmask" n)
+    [ do
+        f        <- decodeName bits
+        b        <- nameElem "bitmask" n
+        typeElem <- traverse decode (elemText "type" n)
+        w        <- case typeElem of
+          Nothing          -> throw ("No type found for bitmask: " <> show bits)
+          Just "VkFlags"   -> pure Bitmask32
+          Just "VkFlags64" -> pure Bitmask64
+          Just "XrFlags32" -> pure Bitmask32
+          Just "XrFlags64" -> pure Bitmask64
+          Just _ -> throw ("Unexpected type for bitmask: " <> show bits)
+        pure (f, (b, w))
     | Element n <- types
     , "type" == name n
     , not (isAlias n)
-    , Just bits      <- pure $ getAttr "requires" n
+    , Just bits      <- pure $ getAttr "requires" n <|> getAttr "bitvalues" n
     , Just "bitmask" <- pure $ getAttr "category" n
     ]
   fromList <$> traverseV
-    (uncurry (parseEnum (`Map.lookup` flagNameMap) False))
+    (uncurry
+      (parseEnum (fmap snd . (`Map.lookup` flagNameMap))
+                 (fmap fst . (`Map.lookup` flagNameMap))
+                 False
+      )
+    )
     [ (isBitmask, n)
     | Element n <- es
     , name n == "enums"
@@ -692,16 +714,25 @@ parseEnums types es = do
     ]
 
  where
-  parseEnum :: (CName -> Maybe CName) -> Bool -> Bool -> Node -> P Enum'
-  parseEnum getFlagsName evIsExtension isBitmask n = do
+  parseEnum
+    :: (CName -> Maybe BitmaskWidth)
+    -> (CName -> Maybe CName)
+    -> Bool
+    -> Bool
+    -> Node
+    -> P Enum'
+  parseEnum getBitmaskWidth getFlagsName evIsExtension isBitmask n = do
     eName   <- nameAttr "enum" n
     eValues <- fromList <$> traverseV
       (context (unCName eName) . parseValue)
       [ e | Element e <- contents n, name e == "enum", not (isAlias e) ]
-    let eType = if isBitmask
-          then -- If we can't find the flags name, use the bits name
-               ABitmask (fromMaybe eName (getFlagsName eName))
-          else AnEnum
+    eType <- if isBitmask
+      -- If we can't find the flags name, use the bits name
+      then do
+        width <- note ("No width found for bitmask: " <> unCName eName)
+                      (getBitmaskWidth eName)
+        pure $ ABitmask (fromMaybe eName (getFlagsName eName)) width
+      else pure AnEnum
     pure Enum { .. }
    where
     parseValue :: Node -> P EnumValue
@@ -950,7 +981,11 @@ allTypeNames es = do
     ]
   requiresTypeNames <- traverseV
     nameText
-    [ n | Element n <- es, name n == "type", hasAttr "requires" n ]
+    [ n
+    | Element n <- es
+    , name n == "type"
+    , hasAttr "requires" n || hasAttr "bitvalues" n
+    ]
   fromList <$> traverseV
     ( fromEither
     . first fromList

generate-new/src/Spec/Types.hs

@@ -260,10 +260,13 @@ data EnumValue = EnumValue
 
 data EnumType
   = AnEnum
-  | ABitmask CName
+  | ABitmask CName BitmaskWidth
   -- ^ Stores the name of the "Flags" type
   deriving (Show, Eq)
 
+data BitmaskWidth = Bitmask32 | Bitmask64
+  deriving (Show, Eq)
+
 --
 -- SPIR-V stuff
 --

generate-new/vma/VMA/RenderParams.hs

@@ -56,6 +56,7 @@ renderParams handles = r
     , lowerPrefix                    = "vma"
     , upperPrefix                    = "VMA"
     , flagsTypeName                  = "VkFlags"
+    , flags64TypeName                = "VkFlags64"
     , alwaysQualifiedNames           = mempty
     , extraNewtypes                  = mempty
     , mkIdiomaticType = let dropVulkanModule = transformBi

generate-new/xr/XR/RenderParams.hs

@@ -71,7 +71,8 @@ renderParams handles = r
     , camelPrefix                    = "Xr"
     , lowerPrefix                    = "xr"
     , upperPrefix                    = "XR"
-    , flagsTypeName                  = "XrFlags64"
+    , flagsTypeName                  = "XrFlags32" -- doesn't exist
+    , flags64TypeName                = "XrFlags64"
     , alwaysQualifiedNames           = vulkanHaskellNames vulkanParams
     , extraNewtypes                  = vulkanNewtypes vulkanParams
     , mkIdiomaticType                =