Merge pull request #274 from expipiplus1/fix-generate

Bump vulkan to 1.2.174

VulkanMemoryAllocator/VulkanMemoryAllocator.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.2
 -- see: https://github.com/sol/hpack
 
 name:           VulkanMemoryAllocator
-version:        0.4
+version:        0.5
 synopsis:       Bindings to the VulkanMemoryAllocator library
 category:       Graphics
 homepage:       https://github.com/expipiplus1/vulkan#readme

VulkanMemoryAllocator/changelog.md

@@ -2,6 +2,9 @@
 
 ## WIP
 
+## [0.5] - 2021-03-31
+- Bump VMA, deprecates resizeAllocation
+
 ## [0.4] - 2021-02-18
 - Bump VMA, support for VK_EXT_memory_priority
 

VulkanMemoryAllocator/package.yaml

@@ -1,5 +1,5 @@
 name: VulkanMemoryAllocator
-version: "0.4"
+version: "0.5"
 synopsis: Bindings to the VulkanMemoryAllocator library
 category: Graphics
 maintainer: Joe Hermaszewski <[email protected]>

VulkanMemoryAllocator/src/VulkanMemoryAllocator.hs

@@ -33,7 +33,6 @@ module VulkanMemoryAllocator  ( createAllocator
                               , withMemoryForImage
                               , freeMemory
                               , freeMemoryPages
-                              , resizeAllocation
                               , getAllocationInfo
                               , touchAllocation
                               , setAllocationUserData
@@ -1193,36 +1192,6 @@ freeMemoryPages allocator allocations = liftIO . evalContT $ do
   pure $ ()
 
 
-foreign import ccall
-#if !defined(SAFE_FOREIGN_CALLS)
-  unsafe
-#endif
-  "vmaResizeAllocation" ffiVmaResizeAllocation
-  :: Allocator -> Allocation -> DeviceSize -> IO Result
-
--- | Deprecated.
---
--- /Deprecated/
---
--- In version 2.2.0 it used to try to change allocation\'s size without
--- moving or reallocating it. In current version it returns @VK_SUCCESS@
--- only if @newSize@ equals current allocation\'s size. Otherwise returns
--- @VK_ERROR_OUT_OF_POOL_MEMORY@, indicating that allocation\'s size could
--- not be changed.
-resizeAllocation :: forall io
-                  . (MonadIO io)
-                 => -- No documentation found for Nested "vmaResizeAllocation" "allocator"
-                    Allocator
-                 -> -- No documentation found for Nested "vmaResizeAllocation" "allocation"
-                    Allocation
-                 -> -- No documentation found for Nested "vmaResizeAllocation" "newSize"
-                    ("newSize" ::: DeviceSize)
-                 -> io ()
-resizeAllocation allocator allocation newSize = liftIO $ do
-  r <- traceAroundEvent "vmaResizeAllocation" ((ffiVmaResizeAllocation) (allocator) (allocation) (newSize))
-  when (r < SUCCESS) (throwIO (VulkanException r))
-
-
 foreign import ccall
 #if !defined(SAFE_FOREIGN_CALLS)
   unsafe

cabal.project

@@ -5,5 +5,3 @@ packages:
   ./utils
   ./examples
   ./generate-new/
-
-allow-newer: strict Cabal

changelog.md

@@ -2,6 +2,10 @@
 
 ## WIP
 
+## [3.10.1] - 2021-03-31
+- Bump API version to v1.2.174
+- Fix https://github.com/expipiplus1/vulkan/issues/266
+
 ## [3.10] - 2021-02-18
 - Bump API version to v1.2.170
 

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
          ]
@@ -902,8 +903,9 @@ boolConversion = genRe "Bool conversion" $ do
 wsiTypes
   :: (HasErr r, HasRenderParams r) => SpecFlavor -> [Sem r RenderElement]
 wsiTypes = \case
-  SpecVk -> (snd <$> concat [win32, x11Shared, x11, xcb2, zircon, ggp])
-    <> concat [win32', xcb1, waylandShared, wayland, metal, android, directfb]
+  SpecVk ->
+    (snd <$> concat [win32, x11Shared, x11, xcb2, zircon, ggp]) <> concat
+      [win32', xcb1, waylandShared, wayland, metal, android, directfb, screen]
   SpecXr -> (snd <$> concat [win32Xr, x11Shared, xcb2Xr, egl, gl, d3d])
     <> concat [win32Xr', xcb1, waylandShared, d3d', jni, timespec]
 
@@ -1055,6 +1057,9 @@ android = [voidData "AHardwareBuffer", voidData "ANativeWindow"]
 directfb :: HasRenderParams r => [Sem r RenderElement]
 directfb = [voidData "IDirectFB", voidData "IDirectFBSurface"]
 
+screen :: HasRenderParams r => [Sem r RenderElement]
+screen = [voidData "_screen_window", voidData "screen_context"]
+
 ----------------------------------------------------------------
 -- OpenXR platform stuff
 ----------------------------------------------------------------

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
@@ -114,13 +114,15 @@ isIntegral =
 isFloating :: CType -> Bool
 isFloating = (`elem` [Float, Double])
 
+-- | Foreign handles
 isDefaultableForeignType :: CType -> Bool
 isDefaultableForeignType t =
   (      t
     `elem` [ TypeName "HANDLE"
            , TypeName "DWORD"
            , TypeName "LPCWSTR"
            , Ptr CType.Const (TypeName "SECURITY_ATTRIBUTES")
+           , TypeName "zx_handle_t"
            ]
     )
     || case t of
@@ -149,6 +151,8 @@ isPassAsPointerType' = \case
              , "IDirectFBSurface"
              , "IUnknown"
              , "jobject"
+             , "_screen_window"
+             , "_screen_context"
              -- TODO: remove these
              , "VkInstanceCreateInfo"
              , "VkAllocationCallbacks"

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/Data/Text/Extra.hs

@@ -31,7 +31,7 @@ lowerCaseFirst :: Text -> Text
 lowerCaseFirst = onFirst Data.Char.toLower
 
 upperCaseFirst :: Text -> Text
-upperCaseFirst = onFirst Data.Char.toUpper
+upperCaseFirst = onFirst Data.Char.toUpper . T.dropWhile (not . isAlpha)
 
 onFirst :: (Char -> Char) -> Text -> Text
 onFirst f = \case

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/APIConstant.hs

@@ -69,7 +69,7 @@ int64 :: HasErr r => RE Char (Sem r Int64)
 int64 = readSpec <$> digits <* "LL"
 
 float :: HasErr r => RE Char (Sem r Float)
-float = readSpec <$> (fmap concat . sequenceA $ [digits, ".", digits]) <* "f"
+float = readSpec <$> (fmap concat . sequenceA $ [digits, ".", digits]) <* ("F" <|> "f")
 
 digits :: RE Char String
 digits = many (psym isDigit) <|> ((<>) <$> "0x" <*> many (psym isHexDigit))