Merge pull request #351 from expipiplus1/ellie-ghcHEAD

expipiplus1 · Nov 18, 2021 · 1028f05 · 1028f05
2 parents 54423f1 + 893618a
commit 1028f05
Show file tree

Hide file tree

Showing 151 changed files with 1,201 additions and 842 deletions.
diff --git a/changelog.md b/changelog.md
@@ -2,6 +2,10 @@
 
 ## WIP
 
+## [3.13.4] - 2021-11-17
+- Support ghc-9.3.20211111
+- No more warnings under 9.2
+
 ## [3.13.3] - 2021-11-17
 - Bump API version to v1.2.199
 

diff --git a/default.nix b/default.nix
@@ -15,8 +15,12 @@ let
 
   packages = p:
     with p;
-    [ vulkan vulkan-utils VulkanMemoryAllocator vulkan-examples openxr ]
-    ++ pkgs.lib.optional (p.ghc.version == "8.10.7") generate-new;
+    if compiler == "ghcHEAD" then [
+      (pkgs.haskell.lib.dontCheck vulkan)
+      (pkgs.haskell.lib.dontCheck VulkanMemoryAllocator)
+    ] else
+      [ vulkan vulkan-utils VulkanMemoryAllocator vulkan-examples openxr ]
+      ++ pkgs.lib.optional (p.ghc.version == "8.10.7") generate-new;
 
 in if forShell then
   haskellPackages.shellFor {

diff --git a/generate-new/flags.sh b/generate-new/flags.sh
@@ -2,7 +2,7 @@
 
 f=$1
 exe_name=$(sed -n 's|^.*generate-new/\([^/]*\)/.*$|\1|p' <<< "$f")
-p=/home/j/projects/vulkan/generate-new/package.yaml
+p=package.yaml
 {
   printf "%s\n" "$(yq < "$p" ".executables.$exe_name.\"source-dirs\"" --raw-output | sed 's|^|-i|')"
   printf "%s\n" "$(yq < "$p" '.library."source-dirs"' --raw-output | sed 's|^|-i|')"

diff --git a/generate-new/khronos-spec/Khronos/Render.hs b/generate-new/khronos-spec/Khronos/Render.hs
@@ -41,6 +41,7 @@ import           Render.Struct
 import           Render.Union
 import           Render.VkException
 import           Spec.Parse
+import qualified Data.HashMap.Strict as HashMap
 
 data RenderedSpec a = RenderedSpec
   { rsHandles            :: Vector a
@@ -141,11 +142,13 @@ renderSpec spec@Spec {..} getDoc brackets ss us cs = do
                                   SSpecXr -> Xr.specVersions spec
                              <> V.singleton (structExtends spec)
                              <> case specFlavor @t of
-                                  SpecVk ->
-                                    V.singleton
-                                      (renderSPIRVElements specSPIRVExtensions
-                                                           specSPIRVCapabilities
+                                  SpecVk -> V.singleton
+                                    (renderSPIRVElements
+                                      specSPIRVExtensions
+                                      specSPIRVCapabilities
+                                      (HashMap.fromList [ (msName s, s) | s <- V.toList ss ]
                                       )
+                                    )
                                   SpecXr -> mempty
                              <> V.singleton (renderExtensionDepElements specExtensions)
     }

diff --git a/generate-new/khronos-spec/Khronos/SPIRVElements.hs b/generate-new/khronos-spec/Khronos/SPIRVElements.hs
@@ -7,9 +7,9 @@ module Khronos.SPIRVElements
 import           CType                          ( CType(TypeName) )
 import           Data.Bits
 import           Data.Foldable
+import qualified Data.HashMap.Strict           as HM
 import           Data.List.Extra                ( nubOrd )
 import qualified Data.Text                     as T
-import           Prettyprinter
 import           Data.Vector                    ( Vector )
 import qualified Data.Vector                   as V
 import           Data.Version                   ( Version
@@ -19,14 +19,18 @@ import           Error
 import           Haskell                        ( HName(..)
                                                 , allTypeNames
                                                 , renderType
-                                                , (~>)
                                                 )
 import           Khronos.Utils
-import           Language.Haskell.TH            ( Type(ConT)
-                                                , mkName
+import           Language.Haskell.TH            ( mkName )
+import           Marshal.Scheme                 ( isElided )
+import           Marshal.Struct                 ( MarshaledStruct
+                                                , msMembers
+                                                , msmScheme
                                                 )
+import           Polysemy                       ( MemberWithError )
 import           Polysemy.Input
 import qualified Prelude
+import           Prettyprinter
 import           Relude
 import           Render.Element
 import           Render.SpecInfo                ( HasSpecInfo
@@ -41,32 +45,52 @@ renderSPIRVElements
   :: (HasErr r, HasRenderParams r, HasSpecInfo r)
   => Vector SPIRVExtension
   -> Vector SPIRVCapability
+  -> HashMap CName (MarshaledStruct AStruct)
   -> Sem r RenderElement
-renderSPIRVElements exts caps = genRe "SPIR-V stuff" $ do
-  tellExplicitModule =<< mkModuleName ["SPIRVRequirements"]
-  tellCanFormat
-  bespokeStuff
-  renderExts exts
-  renderCaps caps
+renderSPIRVElements exts caps structs =
+  genRe "SPIR-V stuff" $ runInputConst (`HM.lookup` structs) $ do
+    tellExplicitModule =<< mkModuleName ["SPIRVRequirements"]
+    tellCanFormat
+    bespokeStuff
+    renderExts exts
+    renderCaps caps
+
+type HasMarshalledStructs r
+  = MemberWithError (Input (CName -> Maybe (MarshaledStruct AStruct))) r
 
 renderExts
-  :: (HasRenderElem r, HasRenderParams r, HasErr r, HasSpecInfo r)
+  :: ( HasRenderElem r
+     , HasRenderParams r
+     , HasErr r
+     , HasSpecInfo r
+     , HasMarshalledStructs r
+     )
   => Vector SPIRVExtension
   -> Sem r ()
 renderExts = renderSPIRVThing "spirvExtensionRequirements"
                               spirvExtensionName
                               spirvExtensionReqs
 
 renderCaps
-  :: (HasRenderElem r, HasRenderParams r, HasErr r, HasSpecInfo r)
+  :: ( HasRenderElem r
+     , HasRenderParams r
+     , HasErr r
+     , HasSpecInfo r
+     , HasMarshalledStructs r
+     )
   => Vector SPIRVCapability
   -> Sem r ()
 renderCaps = renderSPIRVThing "spirvCapabilityRequirements"
                               spirvCapabilityName
                               spirvCapabilityReqs
 
 renderSPIRVThing
-  :: (HasRenderElem r, HasRenderParams r, HasErr r, HasSpecInfo r)
+  :: ( HasRenderElem r
+     , HasRenderParams r
+     , HasErr r
+     , HasSpecInfo r
+     , HasMarshalledStructs r
+     )
   => Text
   -> (a -> Text)
   -> (a -> Vector SPIRVRequirement)
@@ -95,7 +119,12 @@ renderSPIRVThing funName name reqs xs = do
     ]
 
 renderReq
-  :: (HasRenderParams r, HasRenderElem r, HasErr r, HasSpecInfo r)
+  :: ( HasRenderParams r
+     , HasRenderElem r
+     , HasErr r
+     , HasSpecInfo r
+     , HasMarshalledStructs r
+     )
   => SPIRVRequirement
   -> Sem r ([Doc ()], [Doc ()])
 renderReq = \case
@@ -111,20 +140,49 @@ renderReq = \case
     sTy <- cToHsType DoNotPreserve (TypeName s)
     -- TODO: this is pretty lazy, import the accessors properly
     traverse_ tellImportWithAll (allTypeNames sTy)
-    checkTDoc                     <- renderType (sTy ~> ConT ''Bool)
-    sTyDoc                        <- renderType sTy
     (otherInstReqs, otherDevReqs) <- minVersionAndExtensionsReqs rs
+    getStruct                     <- input
+    oneMember                     <- case getStruct s of
+      Nothing -> throw "SPIRV features aren't in a struct"
+      Just str ->
+        pure
+          . null
+          . drop 1
+          $ [ ()
+            | m <- toList $ msMembers @AStruct str
+            , not $ isElided (msmScheme m)
+            ]
     let featureMemberName = mkMemberName s f
+    let con               = mkConName s s
     let xs =
-          [ ("featureName" , viaShow f)
-          , ("checkFeature", pretty featureMemberName <+> "::" <+> checkTDoc)
-          , ( "enableFeature"
-            , "\\f ->"
-              <+> "f"
-              <>  braces (pretty featureMemberName <+> "= True")
-              <+> "::"
-              <+> sTyDoc
+          [ ("featureName", viaShow f)
+          , ( "checkFeature"
+            , "\\"
+              <>  pretty con
+              <>  "{"
+              <>  pretty featureMemberName
+              <>  "} ->"
+              <+> pretty featureMemberName
             )
+          , if oneMember
+            then
+              ( "enableFeature"
+              , "\\_ ->"
+              <+> pretty con
+              <>  "{"
+              <>  pretty featureMemberName
+              <+> "= True}"
+              )
+            else
+              ( "enableFeature"
+              , "\\"
+              <>  pretty con
+              <>  "{..} ->"
+              <+> pretty con
+              <>  "{"
+              <>  pretty featureMemberName
+              <+> "= True, ..}"
+              )
           ]
     pure
       ( otherInstReqs

diff --git a/generate-new/src/Render/Command.hs b/generate-new/src/Render/Command.hs
@@ -884,12 +884,19 @@ getCCallDynamic c = do
           <+> parens ("Ptr" <+> dquotes (pretty (unCName (cName c))) <> "#")
 
       -- What do do if we need to extract the command pointer from a parameter
-      cmdsFunPtr ptrRecTyName getCmdsFun paramName paramType = do
+      cmdsFunPtr ptrRecTyName getCmdsMember paramName paramType = do
         cmdsRef <- stmt Nothing (Just "cmds") $ do
-          paramTDoc <- renderType =<< cToHsType DoNotPreserve paramType
-          getCmds   <- getCmdsFun
-          pure . Pure InlineOnce . CmdsDoc $ getCmds <+> parens
-            (pretty paramName <+> "::" <+> paramTDoc)
+          con <- case paramType of
+                   TypeName t -> do
+                     let con = mkConName t t
+                     let paramTName = mkTyName t
+                     tellImportWith paramTName con
+                     pure con
+                   _ -> throw "Trying to get a command pointer record from something which isn't a struct"
+          cmdsMember <- getCmdsMember
+          pure . Pure InlineOnce . CmdsDoc $
+            "case" <+> pretty paramName <+> "of" <+> pretty con
+              <> "{" <> cmdsMember <> "}" <+> "->" <+> cmdsMember
         nameRef "cmds" cmdsRef
         stmt Nothing (Just (unCName (cName c) <> "Ptr")) $ do
           let memberName = mkFuncPointerMemberName (cName c)

diff --git a/generate-new/src/Render/Spec/Extends.hs b/generate-new/src/Render/Spec/Extends.hs
@@ -285,9 +285,9 @@ classes Spec {..} = do
       else do
         baseOut <- peek p
         join
-          $ peekChainHead @a ({estmn} (baseOut :: BaseOutStructure))
+          $ peekChainHead @a (case baseOut of BaseOutStructure\{{estmn}} -> {estmn})
                              (castPtr @BaseOutStructure @() p)
-          $ \\head' -> peekSomeChain @a (next (baseOut :: BaseOutStructure))
+          $ \\head' -> peekSomeChain @a (case baseOut of BaseOutStructure\{next} -> next)
                                       (\\tail' -> c (head', tail'))
 
     peekChainHead

diff --git a/generate-new/src/Render/Struct.hs b/generate-new/src/Render/Struct.hs
@@ -154,7 +154,12 @@ renderExtensibleInstance MarshaledStruct {..} = do
       2
       (vsep
         [ "extensibleTypeName =" <+> dquotes (pretty n)
-        , "setNext x next = x{next = next}"
+        , "setNext"
+        <+> pretty con
+        <>  "{..}"
+        <+> "next' ="
+        <+> pretty con
+        <>  "{next = next', ..}"
         , "getNext" <+> pretty con <> "{..} = next"
         , "extends :: forall e b proxy. Typeable e => proxy e -> (Extends"
         <+> pretty n

diff --git a/nix/nixpkgs.nix b/nix/nixpkgs.nix
@@ -1,8 +1,9 @@
 let
   nixpkgsSrc = builtins.fetchTarball {
     url =
-      "https://github.com/nixos/nixpkgs/archive/17e2591d9b216634ab501293efa2ba4c55ff6bc9.tar.gz"; # refs/heads/haskell-updates
-    sha256 = "151fkb184mng86dgpyr327by2fr8cr46cqr3wnghmhsgmc5yfz3b";
+      # "https://github.com/nixos/nixpkgs/archive/17e2591d9b216634ab501293efa2ba4c55ff6bc9.tar.gz"; # refs/heads/haskell-updates
+      "https://github.com/expipiplus1/nixpkgs/archive/79cb423531c178af07353e2285a17abe3073e306.tar.gz"; # refs/heads/ellie-ghcHEAD
+    sha256 = "0h7qi4ypl368y6i1458khb2q6db2m579cm5hv5c7d7l7rwvh7n3x";
   };
 
 in import nixpkgsSrc { }
diff --git a/package.yaml b/package.yaml
@@ -1,5 +1,5 @@
 name: vulkan
-version: "3.13.3"
+version: "3.13.4"
 synopsis: Bindings to the Vulkan graphics API.
 description: Please see [the readme](https://github.com/expipiplus1/vulkan/#readme)
 category: Graphics
@@ -97,6 +97,7 @@ default-extensions:
 - InstanceSigs
 - LambdaCase
 - MagicHash
+- NamedFieldPuns
 - NoMonomorphismRestriction
 - OverloadedStrings
 - PartialTypeSignatures

diff --git a/src/Vulkan/CStruct/Extends.hs b/src/Vulkan/CStruct/Extends.hs
@@ -1371,9 +1371,9 @@ peekSomeChain p c = if p == nullPtr
   else do
     baseOut <- peek p
     join
-      $ peekChainHead @a (sType (baseOut :: BaseOutStructure))
+      $ peekChainHead @a (case baseOut of BaseOutStructure{sType} -> sType)
                          (castPtr @BaseOutStructure @() p)
-      $ \head' -> peekSomeChain @a (next (baseOut :: BaseOutStructure))
+      $ \head' -> peekSomeChain @a (case baseOut of BaseOutStructure{next} -> next)
                                   (\tail' -> c (head', tail'))
 
 peekChainHead

diff --git a/src/Vulkan/Core10/Buffer.hs b/src/Vulkan/Core10/Buffer.hs
@@ -65,6 +65,7 @@ import Vulkan.CStruct.Extends (Chain)
 import {-# SOURCE #-} Vulkan.Extensions.VK_NV_dedicated_allocation (DedicatedAllocationBufferCreateInfoNV)
 import Vulkan.Core10.Handles (Device)
 import Vulkan.Core10.Handles (Device(..))
+import Vulkan.Core10.Handles (Device(Device))
 import Vulkan.Dynamic (DeviceCmds(pVkCreateBuffer))
 import Vulkan.Dynamic (DeviceCmds(pVkDestroyBuffer))
 import Vulkan.Core10.FundamentalTypes (DeviceSize)
@@ -167,7 +168,7 @@ createBuffer :: forall a io
                 ("allocator" ::: Maybe AllocationCallbacks)
              -> io (Buffer)
 createBuffer device createInfo allocator = liftIO . evalContT $ do
-  let vkCreateBufferPtr = pVkCreateBuffer (deviceCmds (device :: Device))
+  let vkCreateBufferPtr = pVkCreateBuffer (case device of Device{deviceCmds} -> deviceCmds)
   lift $ unless (vkCreateBufferPtr /= nullFunPtr) $
     throwIO $ IOError Nothing InvalidArgument "" "The function pointer for vkCreateBuffer is null" Nothing Nothing
   let vkCreateBuffer' = mkVkCreateBuffer vkCreateBufferPtr
@@ -256,7 +257,7 @@ destroyBuffer :: forall io
                  ("allocator" ::: Maybe AllocationCallbacks)
               -> io ()
 destroyBuffer device buffer allocator = liftIO . evalContT $ do
-  let vkDestroyBufferPtr = pVkDestroyBuffer (deviceCmds (device :: Device))
+  let vkDestroyBufferPtr = pVkDestroyBuffer (case device of Device{deviceCmds} -> deviceCmds)
   lift $ unless (vkDestroyBufferPtr /= nullFunPtr) $
     throwIO $ IOError Nothing InvalidArgument "" "The function pointer for vkDestroyBuffer is null" Nothing Nothing
   let vkDestroyBuffer' = mkVkDestroyBuffer vkDestroyBufferPtr
@@ -452,7 +453,7 @@ deriving instance Show (Chain es) => Show (BufferCreateInfo es)
 
 instance Extensible BufferCreateInfo where
   extensibleTypeName = "BufferCreateInfo"
-  setNext x next = x{next = next}
+  setNext BufferCreateInfo{..} next' = BufferCreateInfo{next = next', ..}
   getNext BufferCreateInfo{..} = next
   extends :: forall e b proxy. Typeable e => proxy e -> (Extends BufferCreateInfo e => b) -> Maybe b
   extends _ f

diff --git a/src/Vulkan/Core10/BufferView.hs b/src/Vulkan/Core10/BufferView.hs
@@ -48,6 +48,7 @@ import Vulkan.Core10.Handles (BufferView(..))
 import Vulkan.Core10.Enums.BufferViewCreateFlags (BufferViewCreateFlags)
 import Vulkan.Core10.Handles (Device)
 import Vulkan.Core10.Handles (Device(..))
+import Vulkan.Core10.Handles (Device(Device))
 import Vulkan.Dynamic (DeviceCmds(pVkCreateBufferView))
 import Vulkan.Dynamic (DeviceCmds(pVkDestroyBufferView))
 import Vulkan.Core10.FundamentalTypes (DeviceSize)
@@ -116,7 +117,7 @@ createBufferView :: forall io
                     ("allocator" ::: Maybe AllocationCallbacks)
                  -> io (BufferView)
 createBufferView device createInfo allocator = liftIO . evalContT $ do
-  let vkCreateBufferViewPtr = pVkCreateBufferView (deviceCmds (device :: Device))
+  let vkCreateBufferViewPtr = pVkCreateBufferView (case device of Device{deviceCmds} -> deviceCmds)
   lift $ unless (vkCreateBufferViewPtr /= nullFunPtr) $
     throwIO $ IOError Nothing InvalidArgument "" "The function pointer for vkCreateBufferView is null" Nothing Nothing
   let vkCreateBufferView' = mkVkCreateBufferView vkCreateBufferViewPtr
@@ -206,7 +207,7 @@ destroyBufferView :: forall io
                      ("allocator" ::: Maybe AllocationCallbacks)
                   -> io ()
 destroyBufferView device bufferView allocator = liftIO . evalContT $ do
-  let vkDestroyBufferViewPtr = pVkDestroyBufferView (deviceCmds (device :: Device))
+  let vkDestroyBufferViewPtr = pVkDestroyBufferView (case device of Device{deviceCmds} -> deviceCmds)
   lift $ unless (vkDestroyBufferViewPtr /= nullFunPtr) $
     throwIO $ IOError Nothing InvalidArgument "" "The function pointer for vkDestroyBufferView is null" Nothing Nothing
   let vkDestroyBufferView' = mkVkDestroyBufferView vkDestroyBufferViewPtr