Allow overriding zero instances in generator

And add overrides for TransformMatrixKHR
expipiplus1 · Jan 8, 2021 · 60fe4b6 · 60fe4b6
1 parent ef54b5f
commit 60fe4b6
Show file tree

Hide file tree

Showing 2 changed files with 108 additions and 38 deletions.
diff --git a/generate-new/src/Bespoke.hs b/generate-new/src/Bespoke.hs
@@ -10,6 +10,8 @@ module Bespoke
   , bespokeSizes
   , bespokeOptionality
   , bespokeLengths
+  , bespokeZeroInstances
+  , bespokeZeroCStruct
   , bespokeSchemes
   , BespokeScheme(..)
   , structChainVar
@@ -40,7 +42,9 @@ import           Foreign.Marshal.Utils
 import           Numeric
 
 import           CType
+import           Data.List                      ( lookup )
 import           Error
+import           Foreign                        ( Storable(poke) )
 import           Foreign.C.String               ( CString )
 import           Foreign.Storable               ( Storable )
 import           Haskell                       as H
@@ -797,6 +801,56 @@ bespokeLengths = \case
     _             -> Nothing
   _ -> const Nothing
 
+bespokeZeroInstances
+  :: ( HasErr r
+     , HasRenderElem r
+     , HasSpecInfo r
+     , HasRenderParams r
+     , HasSiblingInfo StructMember r
+     , HasStmts r
+     )
+  => HasRenderElem r => CName -> Maybe (Sem r ())
+bespokeZeroInstances = flip
+  lookup
+  [ ( "VkTransformMatrixKHR"
+    , do
+      tellImportWithAll (TyConName "Zero")
+      tellDoc [qqi|
+        instance Zero TransformMatrixKHR where
+         zero = TransformMatrixKHR
+                  (1,0,0,0)
+                  (0,1,0,0)
+                  (0,0,1,0)
+      |]
+    )
+  ]
+
+bespokeZeroCStruct
+  :: ( HasErr r
+     , HasRenderElem r
+     , HasSpecInfo r
+     , HasRenderParams r
+     , HasSiblingInfo StructMember r
+     , HasStmts r
+     )
+  => HasRenderElem r => CName -> Maybe (Sem r (Doc ()))
+bespokeZeroCStruct = flip
+  lookup
+  [ ( "VkTransformMatrixKHR"
+    , do
+      tellImport ''CFloat
+      tellImport 'plusPtr
+      tellImportWith ''Storable 'poke
+      pure [qqi|
+        pokeZeroCStruct p f = do
+          poke (p `plusPtr` 0) (CFloat 1)
+          poke (p `plusPtr` 20) (CFloat 1)
+          poke (p `plusPtr` 40) (CFloat 1)
+          f
+      |]
+    )
+  ]
+
 bespokeElements
   :: (HasErr r, HasRenderParams r) => SpecFlavor -> Vector (Sem r RenderElement)
 bespokeElements = \case

diff --git a/generate-new/src/Render/Struct.hs b/generate-new/src/Render/Struct.hs
@@ -492,27 +492,31 @@ pokeZeroCStructDecl
      )
   => MarshaledStruct AStruct
   -> Sem r (Doc ())
-pokeZeroCStructDecl ms@MarshaledStruct {..} = context "ZeroCStruct" $ do
-  let replaceWithZeroChainPoke m = case msmScheme m of
-        Custom s@(CustomScheme "Chain" _ _ _ _ _) -> m
-          { msmScheme = Custom s { csDirectPoke = APoke $ const zeroNextPointer
-                                 }
-          }
-        _ -> m
-      ms' = ms { msMembers = replaceWithZeroChainPoke <$> msMembers }
-  pokeDoc <- renderPokes zeroMemberVal (IOAction $ pretty contVar) ms' >>= \case
-    ContTStmts d -> do
-      tellImport 'evalContT
-      pure $ "evalContT $" <+> d
-    IOStmts d -> pure d
-
-  addrVar' <- bool "_" addrVar . V.any isJust <$> forV msMembers zeroMemberVal
-  pure
-    $   "pokeZeroCStruct"
-    <+> pretty addrVar'
-    <+> pretty contVar
-    <+> "="
-    <+> pokeDoc
+pokeZeroCStructDecl ms@MarshaledStruct {..}
+  | Just a <- bespokeZeroCStruct msName = a
+  | otherwise = context "ZeroCStruct" $ do
+    let replaceWithZeroChainPoke m = case msmScheme m of
+          Custom s@(CustomScheme "Chain" _ _ _ _ _) -> m
+            { msmScheme = Custom s
+                            { csDirectPoke = APoke $ const zeroNextPointer
+                            }
+            }
+          _ -> m
+        ms' = ms { msMembers = replaceWithZeroChainPoke <$> msMembers }
+    pokeDoc <-
+      renderPokes zeroMemberVal (IOAction $ pretty contVar) ms' >>= \case
+        ContTStmts d -> do
+          tellImport 'evalContT
+          pure $ "evalContT $" <+> d
+        IOStmts d -> pure d
+
+    addrVar' <- bool "_" addrVar . V.any isJust <$> forV msMembers zeroMemberVal
+    pure
+      $   "pokeZeroCStruct"
+      <+> pretty addrVar'
+      <+> pretty contVar
+      <+> "="
+      <+> pokeDoc
 
 zeroInstanceDecl
   :: ( HasErr r
@@ -524,23 +528,35 @@ zeroInstanceDecl
      )
   => MarshaledStruct AStruct
   -> Sem r ()
-zeroInstanceDecl MarshaledStruct {..} = do
-  RenderParams {..} <- input
-  let n    = mkTyName msName
-      con  = mkConName msName msName
-      head = if hasChildren msStruct
-        then " " <> pretty structChainVar <> " ~ '[] =>"
-        else ""
-      tDoc = if hasChildren msStruct
-        then parens (pretty n <+> pretty structChainVar)
-        else pretty n
-  zeroMembers <- catMaybes . toList <$> forV msMembers (zeroScheme . msmScheme)
-  tellImportWithAll (TyConName "Zero")
-  tellDoc $ "instance" <> head <+> "Zero" <+> tDoc <+> "where" <> line <> indent
-    2
-    (vsep
-      ["zero =" <+> align (pretty con <> line <> indent 2 (vsep zeroMembers))]
-    )
+zeroInstanceDecl MarshaledStruct {..}
+  | Just a <- bespokeZeroInstances msName = a
+  | otherwise = do
+    RenderParams {..} <- input
+    let n    = mkTyName msName
+        con  = mkConName msName msName
+        head = if hasChildren msStruct
+          then " " <> pretty structChainVar <> " ~ '[] =>"
+          else ""
+        tDoc = if hasChildren msStruct
+          then parens (pretty n <+> pretty structChainVar)
+          else pretty n
+    zeroMembers <- catMaybes . toList <$> forV msMembers
+                                               (zeroScheme . msmScheme)
+    tellImportWithAll (TyConName "Zero")
+    tellDoc
+      $   "instance"
+      <>  head
+      <+> "Zero"
+      <+> tDoc
+      <+> "where"
+      <>  line
+      <>  indent
+            2
+            (vsep
+              [ "zero ="
+                  <+> align (pretty con <> line <> indent 2 (vsep zeroMembers))
+              ]
+            )
 
 renderPokes
   :: ( HasErr r