Skip to content

Commit b2e0568

Browse files
achirkinachirkin
committed
v1.4: generate vulkan-api for Vulkan:1.2.174 and adapt to GHC 9.0
1 parent c3bc08f commit b2e0568

File tree

425 files changed

+63066
-13016
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

425 files changed

+63066
-13016
lines changed

‎README.md

+15
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,21 @@ Tested using `stack` on:
4646
See `README-macOS.md` for the Mac OS setup tutorial.
4747
* Ubuntu 17.10 x64 with [LunarG Vulkan SDK](https://vulkan.lunarg.com/sdk/home#linux)
4848

49+
## Status update vulan-api-1.4 (2021.04.05)
50+
51+
Vulkan-Docs changed between version 1.1 and 1.2 a lot, which made adapting genvulkan
52+
rather hard.
53+
At this point, I decided to modify the generated code manually until I come up with a better way
54+
to generate haskell code fully automatically (I expect this would require a rather large refactoring).
55+
56+
The current semi-generated code matches v. 1.2.174 of Vulkan-Docs vk.xml.
57+
Here are some manual adjustments I've had to make:
58+
59+
- `VkAccelerationStructureInstanceKHR` has bitfields and not processed by hsc2hs and does not fit `VulkanMarshal.StructRep`;
60+
the manual class instance workarounds this (rather inconveniently).
61+
- A few new cyclic module dependencies must have been fixed with manual .hs-boot
62+
- `Graphics.Vulkan.Ext.VK_NV_ray_tracing` and some related structs are hidden behind `enableBetaExtensions` flag
63+
(seems to compile with the flag enabled though)
4964

5065
# genvulkan
5166

‎genvulkan/app/Main.hs

+9-2
Original file line numberDiff line numberDiff line change
@@ -3,15 +3,22 @@ module Main where
33
import ProcessVkXml
44
import Path
55
import Path.IO
6+
import qualified System.Process.Typed as P
67

78
main :: IO ()
89
main = do
9-
inVkHFolder <- resolveDir' "../vulkan-docs/include/vulkan"
10+
vulkanDocsFolder <- resolveDir' "../vulkan-docs"
11+
vulkanDocsXmlFolder <- (vulkanDocsFolder </>) <$> parseRelDir "xml"
12+
vulkanDocsIncludes <- (vulkanDocsFolder </>) <$> parseRelDir "gen/include/vulkan"
13+
14+
-- generate headers
15+
P.runProcess_ $ P.setWorkingDir (toFilePath vulkanDocsXmlFolder) (P.proc "make" ["install", "test"])
16+
1017
outVkHFolder <- resolveDir' "../vulkan-api/include/vulkan"
1118
removeDirRecur outVkHFolder
1219
createDir outVkHFolder
1320

14-
(_, fnames ) <- listDir inVkHFolder
21+
(_, fnames ) <- listDir vulkanDocsIncludes
1522
mapM_
1623
(\inVkH -> copyFile inVkH (outVkHFolder </> filename inVkH))
1724
(filter ((".h" == ) . fileExtension) fnames)

‎genvulkan/genvulkan.cabal

+3-2
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: genvulkan
2-
version: 1.3.0.0
2+
version: 1.4.0.0
33
synopsis: Generate vulkan-api haskell bindings
44
description: Generate vulkan-api haskell bindings based on vk.xml
55
homepage: https://github.com/achirkin/genvulkan#readme
@@ -69,7 +69,7 @@ library
6969
, primitive -any
7070
, aeson -any
7171
, ghc-prim -any
72-
, hfmt
72+
, hfmt -any
7373
default-language: Haskell2010
7474
ghc-options: -Wall
7575

@@ -81,6 +81,7 @@ executable genvulkan
8181
, genvulkan
8282
, path -any
8383
, path-io -any
84+
, typed-process -any
8485
default-language: Haskell2010
8586

8687
source-repository head

‎genvulkan/src/VkXml/Sections.hs

+16-5
Original file line numberDiff line numberDiff line change
@@ -107,7 +107,7 @@ parseVkXml = fmap fixVkXml . execStateC
107107
-- The data type is foldable and traversable functor
108108
data VkXml
109109
= VkXml
110-
{ globVendorIds :: VendorIds
110+
{ globVendorIds :: Maybe VendorIds
111111
, globPlatforms :: VkPlatforms
112112
, globTags :: VkTags
113113
, globTypes :: Map VkTypeName VkType
@@ -133,16 +133,19 @@ data VkXmlPartial
133133
fixVkXml :: VkXmlPartial
134134
-> VkXml
135135
fixVkXml VkXmlPartial
136-
{ gpVendorIds = Seq.Empty Seq.:|> pVendorIds
136+
{ gpVendorIds = pVendorIds
137137
, gpPlatforms = Seq.Empty Seq.:|> pPlatforms
138138
, gpTags = Seq.Empty Seq.:|> pTags
139139
, gpTypes = Seq.Empty Seq.:|> pTypes
140140
, gpEnums = pEnums
141141
, gpCommands = Seq.Empty Seq.:|> pCommands
142142
, gpFeature = pFeatures
143143
, gpExtensions = Seq.Empty Seq.:|> pExtensions
144-
} = VkXml
145-
{ globVendorIds = pVendorIds
144+
} | Seq.length pVendorIds <= 1
145+
= VkXml
146+
{ globVendorIds = case pVendorIds of
147+
Seq.Empty Seq.:|> vs -> Just vs
148+
_ -> Nothing
146149
, globPlatforms = pPlatforms
147150
, globTags = pTags
148151
, globTypes = pTypes
@@ -154,7 +157,15 @@ fixVkXml VkXmlPartial
154157
, globFeature = toList pFeatures
155158
, globExtensions = pExtensions
156159
}
157-
fixVkXml _ = error "Unexpected number of sections in vk.xml"
160+
fixVkXml VkXmlPartial {..} = error $ "Unexpected number of sections in vk.xml "
161+
++ "\ngpVendorIds: " ++ show (Seq.length gpVendorIds)
162+
++ "\ngpPlatforms: " ++ show (Seq.length gpPlatforms)
163+
++ "\ngpTags: " ++ show (Seq.length gpTags)
164+
++ "\ngpTypes: " ++ show (Seq.length gpTypes)
165+
++ "\ngpEnums: " ++ show (Seq.length gpEnums)
166+
++ "\ngpCommands: " ++ show (Seq.length gpCommands)
167+
++ "\ngpFeature: " ++ show (Seq.length gpFeature)
168+
++ "\ngpExtensions: " ++ show (Seq.length gpExtensions)
158169

159170

160171
reexportedTypesRequire :: VkXml -> VkRequire -> [VkTypeName]

‎genvulkan/src/VkXml/Sections/Extensions.hs

+53-1
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@
66

77
module VkXml.Sections.Extensions
88
( parseExtensions
9-
, VkExtensions, VkExtension (..), VkExtAttrs (..)
9+
, VkExtensions, VkExtension (..), VkExtAttrs (..), VkSpecialUse (..)
1010
) where
1111

1212
import Control.Monad.Except
@@ -15,6 +15,7 @@ import Data.Conduit
1515
import Data.Map (Map)
1616
import qualified Data.Map as Map
1717
import Data.Text (Text)
18+
import qualified Data.Text as T
1819
import Data.XML.Types
1920
import Text.XML.Stream.Parse
2021

@@ -29,6 +30,13 @@ import VkXml.Sections.Feature
2930

3031
type VkExtensions = Map VkExtensionName VkExtension
3132

33+
data VkSpecialUse
34+
= Cadsupport
35+
| D3demulation
36+
| Debugging
37+
| Devtools
38+
| Glemulation
39+
deriving (Eq, Show)
3240

3341
data VkExtension
3442
= VkExtension
@@ -50,6 +58,12 @@ data VkExtAttrs
5058
, extPlatform :: Maybe VkPlatformName
5159
-- ^ seems to be used in a similar way as extProtect
5260
, extComment :: Maybe Text
61+
, extDeprecatedby :: Maybe VkExtensionName
62+
, extSpecialuse :: Maybe VkSpecialUse
63+
, extPromotedto :: Maybe VkExtensionName
64+
, extObsoletedby :: Maybe VkExtensionName
65+
, extSortorder :: Maybe Int
66+
, extProvisional :: Bool
5367
} deriving Show
5468

5569

@@ -73,6 +87,38 @@ parseVkExtension =
7387
(extReqExts extAttributes)
7488
pure VkExtension {..}
7589

90+
parseAttrVkExtensionName :: Name -> ReaderT ParseLoc AttrParser (Maybe VkExtensionName)
91+
parseAttrVkExtensionName name = do
92+
mdb <- lift $ attr name
93+
case mdb of
94+
Nothing -> pure Nothing
95+
Just "" -> pure Nothing
96+
Just db -> Just <$> toHaskellExt db
97+
98+
parseAttrVkExtensionSpeciause :: ReaderT ParseLoc AttrParser (Maybe VkSpecialUse)
99+
parseAttrVkExtensionSpeciause = do
100+
su <- lift $ attr "specialuse"
101+
pure $ case su of
102+
Just "cadsupport" -> Just Cadsupport
103+
Just "d3demulation" -> Just D3demulation
104+
Just "debugging" -> Just Debugging
105+
Just "devtools" -> Just Devtools
106+
Just "glemulation" -> Just Glemulation
107+
_ -> Nothing
108+
109+
parseAttrVkExtensionSortorder :: ReaderT ParseLoc AttrParser (Maybe Int)
110+
parseAttrVkExtensionSortorder = do
111+
x <- lift $ attr "sortorder"
112+
pure $ case decOrHex <$> x of
113+
Just (Right (i, _)) -> Just (fromInteger i)
114+
_ -> Nothing
115+
116+
parseAttrVkExtensionProvisional :: ReaderT ParseLoc AttrParser Bool
117+
parseAttrVkExtensionProvisional = do
118+
mr <- lift $ attr "provisional"
119+
case T.toLower <$> mr of
120+
Just "true" -> pure True
121+
_ -> pure False
76122

77123
parseVkExtAttrs :: ReaderT ParseLoc AttrParser VkExtAttrs
78124
parseVkExtAttrs = do
@@ -88,6 +134,12 @@ parseVkExtAttrs = do
88134
extReqCore <- lift (attr "requiresCore")
89135
eextNumber <- decOrHex <$> forceAttr "number"
90136
extComment <- lift $ attr "comment"
137+
extDeprecatedby <- parseAttrVkExtensionName "deprecatedby"
138+
extSpecialuse <- parseAttrVkExtensionSpeciause
139+
extPromotedto <- parseAttrVkExtensionName "promotedto"
140+
extObsoletedby <- parseAttrVkExtensionName "obsoletedby"
141+
extSortorder <- parseAttrVkExtensionSortorder
142+
extProvisional <- parseAttrVkExtensionProvisional
91143
case eextNumber of
92144
Left err -> parseFailed $ "Could not parse extension.number: " ++ err
93145
Right (extNumber,_) -> pure VkExtAttrs {..}

‎genvulkan/src/VkXml/Sections/Feature.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -97,7 +97,7 @@ parseVkRequire extN baseExtReqs
9797

9898
parseIt = choose
9999
[ parseTagForceAttrs "type"
100-
(forceAttr "name" >>= toHaskellType)
100+
(lift ( attr "comment") >> forceAttr "name" >>= toHaskellType)
101101
(\x -> pure $ \r -> r {requireTypes = x : requireTypes r})
102102
, parseTagForceAttrs "command"
103103
(forceAttr "name" >>= toHaskellComm)

‎genvulkan/src/VkXml/Sections/Types.hs

+28-8
Original file line numberDiff line numberDiff line change
@@ -89,15 +89,16 @@ data VkTypeQualifier
8989
-- <https://www.khronos.org/registry/vulkan/specs/1.1/registry.html#_attributes_of_code_type_code_tags >
9090
data VkTypeAttrs
9191
= VkTypeAttrs
92-
{ name :: Maybe VkTypeName
93-
, alias :: Maybe VkTypeName
92+
{ name :: Maybe VkTypeName
93+
, alias :: Maybe VkTypeName
9494
-- ^ Additional name for this type
95-
, category :: VkTypeCategory
96-
, requires :: Maybe VkTypeName
97-
, parent :: [VkTypeName]
98-
, returnedonly :: Bool
99-
, comment :: Text
100-
, structextends :: [VkTypeName]
95+
, category :: VkTypeCategory
96+
, requires :: Maybe VkTypeName
97+
, parent :: [VkTypeName]
98+
, returnedonly :: Bool
99+
, comment :: Text
100+
, structextends :: [VkTypeName]
101+
, allowduplicate :: Bool
101102
} deriving Show
102103

103104
data VkTypeCategory
@@ -150,6 +151,10 @@ data VkMemberAttrs
150151
-- ^ normally, this is c-like expression depending on other struct members
151152
, noautovalidity :: Bool
152153
, externsync :: Bool
154+
, selector :: Maybe VkMemberName
155+
, selection :: Maybe VkEnumName
156+
-- ^ For a member of a union, attr:selection identifies a value of the
157+
-- attr:selector that indicates this member is valid.
153158
}
154159
deriving Show
155160

@@ -200,6 +205,13 @@ parseAttrVkTypeParent :: ReaderT ParseLoc AttrParser [VkTypeName]
200205
parseAttrVkTypeParent = commaSeparated <$> lift (attr "parent")
201206
>>= mapM toHaskellType
202207

208+
parseAttrVkTypeAllowduplicate :: ReaderT ParseLoc AttrParser Bool
209+
parseAttrVkTypeAllowduplicate = do
210+
mr <- lift $ attr "allowduplicate"
211+
case T.toLower <$> mr of
212+
Just "true" -> pure True
213+
_ -> pure False
214+
203215
parseAttrVkTypeReturnedonly :: ReaderT ParseLoc AttrParser Bool
204216
parseAttrVkTypeReturnedonly = do
205217
mr <- lift $ attr "returnedonly"
@@ -225,6 +237,7 @@ parseVkTypeAttrs = VkTypeAttrs <$> parseAttrVkTypeName
225237
<*> parseAttrVkTypeReturnedonly
226238
<*> parseAttrVkTypeComment
227239
<*> parseAttrVkTypeStructextends
240+
<*> parseAttrVkTypeAllowduplicate
228241

229242

230243

@@ -261,13 +274,20 @@ parseAttrVkMemberExternsync = do
261274
Just "true" -> pure True
262275
_ -> pure False
263276

277+
parseAttrVkMemberSelector :: ReaderT ParseLoc AttrParser (Maybe VkMemberName)
278+
parseAttrVkMemberSelector = lift (attr "selector") >>= mapM toHaskellMemb
279+
280+
parseAttrVkMemberSelection :: ReaderT ParseLoc AttrParser (Maybe VkEnumName)
281+
parseAttrVkMemberSelection = lift (attr "selection") >>= mapM toHaskellPat
264282

265283
parseVkMemberAttrs :: ReaderT ParseLoc AttrParser VkMemberAttrs
266284
parseVkMemberAttrs = VkMemberAttrs <$> parseAttrVkMemberValues
267285
<*> parseAttrVkMemberOptional
268286
<*> parseAttrVkMemberLen
269287
<*> parseAttrVkMemberNoautovalidity
270288
<*> parseAttrVkMemberExternsync
289+
<*> parseAttrVkMemberSelector
290+
<*> parseAttrVkMemberSelection
271291

272292

273293
-- TODO: rewrite this either using regex or language-c

‎genvulkan/src/Write/Types.hs

+16-2
Original file line numberDiff line numberDiff line change
@@ -114,8 +114,7 @@ writeAllTypes vkXml@VkXml{..}
114114
((), mr) <- runModuleWriter vkXml
115115
("Graphics.Vulkan.Types.Struct."
116116
<> T.unpack modN
117-
-- T.unpack (unVkTypeName
118-
-- $ (name :: VkType -> VkTypeName) t)
117+
-- T.unpack (unVkTypeName $ (name :: VkType -> VkTypeName) t)
119118
) mds $ do
120119
writePragma "Strict"
121120
writePragma "DataKinds"
@@ -423,6 +422,21 @@ genBasetypeAlias t@VkTypeSimple
423422
} = do
424423
writeImport $ DIThing (unVkTypeName vkTRef) DITNo
425424
genAlias t
425+
genBasetypeAlias VkTypeSimple
426+
{ name = name
427+
, typeData = VkTypeData
428+
{ reference = []
429+
, code = c
430+
}
431+
} = do
432+
writeDecl . setComment rezComment $ parseDecl'
433+
[text|
434+
data $tnametxt
435+
|]
436+
writeExport $ DIThing tnametxt DITEmpty
437+
where
438+
tnametxt = unVkTypeName name
439+
rezComment = preComment $ T.unpack . T.unlines . map ("> " <>) . T.lines $ c
426440
genBasetypeAlias t
427441
= error $ "genBasetypeAlias: expected a simple basetype, but got: "
428442
<> show t

‎genvulkan/src/Write/Types/Define.hs

+17-1
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,10 @@ genDefine t@VkTypeSimple
5050
}
5151

5252
| vkName == VkTypeName "VK_MAKE_VERSION"
53-
&& c == "#define VK_MAKE_VERSION(major, minor, patch) \\\n (((major) << 22) | ((minor) << 12) | (patch))" || c == "#define VK_MAKE_VERSION(major, minor, patch) \\\r\n (((major) << 22) | ((minor) << 12) | (patch))"
53+
&& c == "#define VK_MAKE_VERSION(major, minor, patch) \\\n (((major) << 22) | ((minor) << 12) | (patch))"
54+
|| c == "#define VK_MAKE_VERSION(major, minor, patch) \\\r\n (((major) << 22) | ((minor) << 12) | (patch))"
55+
|| c == "#define VK_MAKE_VERSION(major, minor, patch) \\\n ((((uint32_t)(major)) << 22) | (((uint32_t)(minor)) << 12) | ((uint32_t)(patch)))"
56+
|| c == "#define VK_MAKE_VERSION(major, minor, patch) \\\r\n ((((uint32_t)(major)) << 22) | (((uint32_t)(minor)) << 12) | ((uint32_t)(patch)))"
5457
= go (writeImport $ DIThing "Bits" DITAll)
5558
[text|_VK_MAKE_VERSION :: Bits a => a -> a -> a -> a|]
5659
[text|_VK_MAKE_VERSION major minor patch = unsafeShiftL major 22 .|. unsafeShiftL minor 12 .|. patch|]
@@ -117,6 +120,19 @@ genDefine t@VkTypeSimple
117120
"(Num a, Eq a) => a"
118121
}
119122

123+
| VkTypeName "VK_HEADER_VERSION_COMPLETE" <- vkName
124+
, Just rawVals
125+
<- matchedText (c ?=~ [reBS|#define[[:space:]]+VK_HEADER_VERSION_COMPLETE[[:space:]]+VK_MAKE_VERSION[[:space:]]*\(.*\)|])
126+
>>= \c' ->
127+
matchedText (c' ?=~ [reBS|\(.*\)|])
128+
, [major, minor, patch] <- map T.strip . T.split (== ',') . T.init . T.tail $ rawVals
129+
= go (writeImport $ DIThing "Bits" DITAll)
130+
[text|_VK_HEADER_VERSION_COMPLETE :: (Bits a, Num a) => a|]
131+
[text|_VK_HEADER_VERSION_COMPLETE = _VK_MAKE_VERSION $major $minor $patch|]
132+
[text|{-# INLINE _VK_HEADER_VERSION_COMPLETE #-}|]
133+
[text|###define VK_HEADER_VERSION_COMPLETE _VK_HEADER_VERSION_COMPLETE|]
134+
"_VK_HEADER_VERSION_COMPLETE"
135+
120136
| vkName == VkTypeName "VK_DEFINE_HANDLE"
121137
&& "#define VK_DEFINE_HANDLE(object) typedef struct object##_T* object;" `T.isInfixOf` c
122138
= do

‎genvulkan/src/Write/Types/Enum.hs

+13
Original file line numberDiff line numberDiff line change
@@ -347,6 +347,19 @@ bitmaskPattern tnameTxt constrTxt
347347
where
348348
patVal = T.pack $ show n
349349
rezComment = preComment $ T.unpack comm
350+
bitmaskPattern tnameTxt _
351+
VkEnum
352+
{ _vkEnumName = VkEnumName patnameTxt
353+
, _vkEnumComment = comm
354+
, _vkEnumValue = VkEnumAlias patAlias
355+
} = do
356+
writeDecl . setComment rezComment
357+
$ parseDecl' [text|pattern $patnameTxt :: $tnameTxt|]
358+
writeDecl $ parseDecl' [text|pattern $patnameTxt = $patVal|]
359+
return patnameTxt
360+
where
361+
patVal = unVkEnumName patAlias
362+
rezComment = preComment $ T.unpack comm
350363
bitmaskPattern _ _ p = error $ "Unexpected bitmask pattern " ++ show p
351364

352365

‎genvulkan/stack.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ extra-deps:
1717
- git: https://github.com/DanielG/cabal-helper
1818
commit: 4bfc6b916fcc696a5d82e7cd35713d6eabcb0533
1919
- git: https://github.com/achirkin/hfmt
20-
commit: d03e4b950cf309f57bbeb55b4d2c9cee162e6de7
20+
commit: f8cc777a0663798d38e297b64e544e0bbffda57b
2121

2222

2323

0 commit comments

Comments
 (0)