diff --git a/generate-new/src/Bespoke.hs b/generate-new/src/Bespoke.hs index d85966990..8efaf65db 100644 --- 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 index ed6d584b1..af1eb6cef 100644 --- 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