Bespoke.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# language QuasiQuotes #-}
{-# language TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Bespoke
  ( forbiddenConstants
  , neverExtendedStructs
  , forceDisabledExtensions
  , assignBespokeModules
  , bespokeStructsAndUnions
  , bespokeElements
  , bespokeSizes
  , bespokeOptionality
  , bespokeLengths
  , bespokeZeroInstances
  , bespokeZeroCStruct
  , bespokeSchemes
  , BespokeScheme(..)
  , structChainVar
  , zeroNextPointer
  ) where

import qualified Data.List.Extra               as List
import qualified Data.Map                      as Map
import qualified Data.Text                     as T
import           Prettyprinter
import           Data.Vector                    ( Vector )
import qualified Data.Vector.Extra             as V
import           Foreign.C.Types
import           Foreign.Ptr
import           Language.Haskell.TH            ( mkName )
import qualified Language.Haskell.TH.Syntax    as TH
import           Polysemy
import           Polysemy.Input
import           Relude                  hiding ( Const )
import           Text.InterpolatedString.Perl6.Unindented

import           Control.Monad.Trans.Cont       ( ContT )
import           Data.Bits
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Unsafe        as BS
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Utils
import           Numeric

import           CType
import           Data.List                      ( lookup )
import           Error
import           Foreign.C.String               ( CString )
import           Foreign.Storable               ( Storable(poke) )
import           Haskell                       as H
import           Marshal.Marshalable
import           Marshal.Scheme
import           Render.Element
import           Render.Peek                    ( storablePeek
                                                , vectorPeekWithLenRef
                                                )
import           Render.SpecInfo
import           Render.Stmts
import           Render.Stmts.Poke
import           Render.Stmts.Utils
import           Render.Type
import           Render.Utils
import           Spec.Types
import Language.Haskell.TH.Syntax (mkNameG_v)

----------------------------------------------------------------
-- Changes to the spec
----------------------------------------------------------------

-- | These constants are defined elsewhere
forbiddenConstants :: [CName]
forbiddenConstants = ["VK_TRUE", "VK_FALSE", "XR_TRUE", "XR_FALSE"]

-- | Structs which are never extended because they're special, and only used
-- for low-level operations
neverExtendedStructs :: [CName]
neverExtendedStructs = ["VkBaseOutStructure", "VkBaseInStructure"]

forceDisabledExtensions :: [ByteString]
forceDisabledExtensions =
  [ "XR_EXT_conformance_automation"
    -- Video extensions will make it into the xml registry it seems, disable
    -- them until then.
  , "VK_KHR_video_decode_av1"
  , "VK_KHR_video_encode_av1"
  , "VK_KHR_video_encode_quantization_map"
  , "VK_EXT_video_decode_h264"
  , "VK_EXT_video_encode_h264"
  , "VK_EXT_video_decode_h265"
  , "VK_EXT_video_encode_h265"
  , "VK_KHR_video_decode_h264"
  , "VK_KHR_video_encode_h264"
  , "VK_KHR_video_decode_h265"
  , "VK_KHR_video_encode_h265"
  , "VK_KHR_video_decode_queue"
  , "VK_KHR_video_encode_queue"
  , "VK_KHR_video_queue"
  , "VK_KHR_video_maintenance1"
  , "VK_KHR_video_maintenance2"
  , "VK_KHR_video_decode_vp9"
  , "VK_KHR_video_encode_intra_refresh"
  , "VK_VALVE_video_encode_rgb_conversion"
    -- C parser can't handle members where type name == member name
  , "VK_SEC_ubm_surface"
    -- Bitfield structs: size calculator can't handle C bitfields
  , "VK_NV_cluster_acceleration_structure"
  , "VK_NV_partitioned_acceleration_structure"
    -- Marshaling: const VkDeviceAddress* without len attribute
  , "VK_ARM_performance_counters_by_region"
    -- Platform-specific: OHOS types not available
  , "VK_OHOS_external_memory"
  , "VK_OHOS_surface"
    -- Unresolved queries in Vulkan-Docs
  -- , "VK_HUAWEI_subpass_shading" -- https://github.com/KhronosGroup/Vulkan-Docs/issues/1564
  ]

----------------------------------------------------------------
-- Module assignments
----------------------------------------------------------------

assignBespokeModules
  :: (HasErr r, HasRenderParams r, Traversable t)
  => t RenderElement
  -> Sem r (t RenderElement)
assignBespokeModules es = do
  mods <- bespokeModules
  forV es $ \case
    r@RenderElement {..}
      | exports <- fmap exportName . toList $ reExports
      , bespokeMods <-
        List.nubOrd . mapMaybe (`List.lookup` mods) $ exports
      -> case bespokeMods of
        []  -> pure r
        [x] -> case reExplicitModule of
          Just m | m /= x ->
            throw "Render element already has an explicit module"
          _ -> pure $ r { reExplicitModule = Just x }
        _ -> throw "Multiple bespoke module names found for render element"


bespokeModules :: HasRenderParams r => Sem r [(HName, ModName)]
bespokeModules = do
  RenderParams {..} <- input
  mod'              <- mkMkModuleName
  pure
    $  [ ( mkTyName "VkAllocationCallbacks"
         , mod' ["Core10", "AllocationCallbacks"]
         )
       , (mkTyName "VkBaseInStructure" , mod' ["CStruct", "Extends"])
       , (mkTyName "VkBaseOutStructure", mod' ["CStruct", "Extends"])
       , (mkTyName "XrBaseInStructure" , mod' ["CStruct", "Extends"])
       , (mkTyName "XrBaseOutStructure", mod' ["CStruct", "Extends"])
       , (mkTyName "XrFovf"            , mod' ["Core10", "OtherTypes"])
       , (mkTyName "XrPosef"           , mod' ["Core10", "Space"])
       , ( mkTyName "PFN_vkFaultCallbackFunction"
         , mod' ["Core10", "FaultHandlingFunctionality"]
         )
       , ( mkTyName "FN_vkFaultCallbackFunction"
         , mod' ["Core10", "FaultHandlingFunctionality"]
         )
       ]
    <> (   (, mod' ["Core10", "FundamentalTypes"])
       <$> [ mkTyName "VkBool32"
           , TermName "boolToBool32"
           , TermName "bool32ToBool"
           , mkTyName "XrBool32"
           , mkTyName "XrOffset2Df"
           , mkTyName "XrExtent2Df"
           , mkTyName "XrRect2Df"
           , mkTyName "XrOffset2Di"
           , mkTyName "XrExtent2Di"
           , mkTyName "XrRect2Di"
           ]
       )

----------------------------------------------------------------
-- Schemes
----------------------------------------------------------------

data BespokeScheme where
  BespokeScheme ::(forall a. Marshalable a => CName -> a -> Maybe (MarshalScheme a)) -> BespokeScheme
  --- ^ Parent name -> child -> scheme

bespokeSchemes :: KnownSpecFlavor t => Spec t -> Sem r [BespokeScheme]
bespokeSchemes spec =
  pure $
    [baseInOut, wsiScheme, dualPurposeBytestrings, nextPointers spec]
      <> difficultLengths
      <> [ bitfields
         , accelerationStructureGeometry
         , buildingAccelerationStructures
         , micromapUsageCounts
         , cuLaunchSchemes
         , inOutCountWithoutOptionalAttr
         ]
      <> openXRSchemes

-- | Some commands added in v1.4.351 use the two-call enumeration pattern
-- without the customary optional="false,true" annotation on the count
-- pointer; the count is still in/out but the inference in
-- 'returnPointerScheme' relies on the optional attribute. Hard-code the
-- known offenders here.
inOutCountWithoutOptionalAttr :: BespokeScheme
inOutCountWithoutOptionalAttr = BespokeScheme $ \case
  "vkGetDeviceFaultReportsKHR" -> \case
    p | "pFaultCounts" <- name p
      , Ptr NonConst t@(TypeName "uint32_t") <- type' p
      -> Just $ InOutCount (Normal t)
    _ -> Nothing
  _ -> const Nothing

baseInOut :: BespokeScheme
baseInOut = BespokeScheme $ \case
  n | n `elem` ["VkBaseInStructure", "VkBaseOutStructure"] -> \case
    m | "pNext" <- name m -> Just $ Normal (type' m)
    _                     -> Nothing
  n | n `elem` ["XrBaseInStructure", "XrBaseOutStructure"] -> \case
    m | "next" <- name m -> Just $ Normal (type' m)
    _                    -> Nothing
  _ -> const Nothing

data NextType = NextElided | NextChain

nextPointers :: forall t . KnownSpecFlavor t => Spec t -> BespokeScheme
nextPointers Spec {..} =
  let schemeMap :: Map (CName, CName) NextType
      schemeMap = Map.fromList
        [ ((sName s, nextName), scheme)
        | s <- toList specStructs
        , let scheme = case sExtendedBy s of
                V.Empty -> NextElided
                _       -> NextChain
        ]
  in  BespokeScheme $ \n c -> case Map.lookup (n, name c) schemeMap of
        Nothing         -> Nothing
        Just NextElided -> Just (ElidedUnivalued "nullPtr")
        Just NextChain  -> Just (Custom chainScheme)
 where
  nextName :: CName
  nextName = case specFlavor @t of
    SpecVk -> "pNext"
    SpecXr -> "next"
  chainVarT   = VarT (mkName structChainVar)
  chainT      = ConT (mkName "Chain") :@ chainVarT
  chainScheme = CustomScheme
    { csName       = "Chain"
    , csZero       = Just "()"
    , csZeroIsZero = False -- Pointer to chain
    -- , csType = pure $ ForallT [] [ConT (mkName "PokeChain") :@ chainVarT] chainT
    , csType       = pure $ ForallT [] [] chainT
    , csDirectPoke = APoke $ \chainRef ->
      stmt (Just (ConT ''Ptr :@ chainT)) (Just (unCName nextName)) $ do
        tellImportWithAll (TyConName "PokeChain")
        tellImport (TyConName "Chain")
        tellImport 'castPtr
        tellImportWithAll ''ContT
        ValueDoc chain <- use chainRef
        pure
          .   ContTAction
          .   ValueDoc
          $   "fmap castPtr . ContT $ withChain"
          <+> chain
    , csPeek       = \addrRef -> stmt (Just chainT) (Just "next") $ do
      chainPtr <- use
        =<< storablePeek nextName addrRef (Ptr Const (Ptr Const Void))
      tellImportWithAll (TyConName "PeekChain")
      tellImport (TyConName "Chain")
      tellImport 'castPtr
      pure $ IOAction . ValueDoc $ "peekChain" <+> parens
        ("castPtr" <+> chainPtr)
    }

-- | A special poke which writes a zero chain
zeroNextPointer
  :: forall r s
   . (HasRenderElem r, HasRenderParams r, HasErr r, HasStmts r)
  => Stmt s r (Ref s ValueDoc)
zeroNextPointer = do
  let chainVarT = VarT (mkName structChainVar)
      chainT    = ConT (mkName "Chain") :@ chainVarT
  varTDoc <- renderTypeHighPrec chainVarT
  stmt (Just (ConT ''Ptr :@ chainT)) (Just "pNext") $ do
    tellImportWithAll (TyConName "PokeChain")
    tellImport (TyConName "Chain")
    tellImport 'castPtr
    tellImportWithAll ''ContT
    pure
      .  ContTAction
      .  ValueDoc
      $  "fmap castPtr . ContT $ withZeroChain @"
      <> varTDoc

wsiScheme :: BespokeScheme
wsiScheme = BespokeScheme $ const $ \case
  a | t@(Ptr _ (TypeName "xcb_connection_t")) <- type' a -> Just (Normal t)
  a | t@(Ptr _ (TypeName "wl_display")) <- type' a -> Just (Normal t)
  a | t@(Ptr _ (TypeName "Display")) <- type' a -> Just (Normal t)
  _ -> Nothing

-- So we render the dual purpose command properly
dualPurposeBytestrings :: BespokeScheme
dualPurposeBytestrings = BespokeScheme $ \case
  c
    | c `elem` ["vkGetPipelineCacheData", "vkGetValidationCacheDataEXT"] -> \case
      a | (Ptr NonConst Void) <- type' a, "pData" <- name a ->
        Just (Returned ByteString)
      _ -> Nothing
    | c == "vkGetPipelineBinaryDataKHR" -> \case
      a | (Ptr NonConst Void) <- type' a, "pPipelineBinaryData" <- name a ->
        Just (Returned ByteString)
      _ -> Nothing
    | c == "vkGetShaderInfoAMD" -> \case
      a | (Ptr NonConst Void) <- type' a, "pInfo" <- name a ->
        Just (Returned ByteString)
      _ -> Nothing
    | c == "vkGetShaderBinaryDataEXT" -> \case
      a | (Ptr NonConst Void) <- type' a, "pData" <- name a ->
        Just (Returned ByteString)
      _ -> Nothing
    | c == "vkGetCudaModuleCacheNV" -> \case
      a | (Ptr NonConst Void) <- type' a, "pCacheData" <- name a ->
        Just (Returned ByteString)
      _ -> Nothing
  _ -> const Nothing

difficultLengths :: [BespokeScheme]
difficultLengths =
  [ BespokeScheme $ \case
    "VkPipelineMultisampleStateCreateInfo" -> \case
      p | "rasterizationSamples" <- name p -> Just $ Normal (type' p)
      (p :: a) | "pSampleMask" <- name p   -> Just . Custom $ CustomScheme
        { csName       = "Sample mask array"
        , csZero       = Just "mempty"
        , csZeroIsZero = True
        , csType       = do
                           RenderParams {..} <- input
                           let TyConName sm = mkTyName "VkSampleMask"
                           pure $ ConT ''Vector :@ ConT (mkName (T.unpack sm))
        , csDirectPoke = APoke $ \vecRef -> do
          RenderParams {..} <- input
          stmt (Just (ConT ''Ptr :@ ConT ''Word32)) (Just "pSampleMask") $ do
            tellQualImport 'V.length
            tellQualImport 'nullPtr
            ValueDoc vec     <- use vecRef
            ValueDoc samples <- useViaName "rasterizationSamples"
            let
              sampleTy = mkTyName "VkSampleCountFlagBits"
              sampleCon =
                mkConName "VkSampleCountFlagBits" "VkSampleCountFlagBits"
              cond = parens "requiredLen == fromIntegral vecLen"
              err
                = "sampleMask must be either empty or contain enough bits to cover all the sample specified by 'rasterizationSamples'"
            tellImportWith sampleTy sampleCon
            throwErr <- renderSubStmtsIO (unitStmt (throwErrDoc err cond))
            vecPoke  <- renderSubStmts $ do
              vecRef' <- pureStmt =<< raise (use vecRef)
              getVectorPoke @a "pSampleMask"
                               (Ptr Const (TypeName "VkSampleMask"))
                               (Normal (TypeName "VkSampleMask"))
                               NotNullable
                               vecRef'
            vecPokeDoc <- case vecPoke of
              ContTStmts d -> pure d
              IOStmts    d -> do
                tellImportWithAll 'lift
                pure $ "lift $" <+> d
            pure
              .   ContTAction
              .   ValueDoc
              $   "case Data.Vector.length"
              <+> vec
              <+> "of"
              <>  line
              <>  indent
                    2
                    (vsep
                      [ "0      -> pure nullPtr"
                      , "vecLen ->" <+> doBlock
                        [ "let" <+> indent
                          0
                          (   "requiredLen ="
                          <+> "case"
                          <+> samples
                          <+> "of"
                          <>  line
                          <>  indent
                                2
                                (pretty sampleCon <+> "n -> (n + 31) `quot` 32")
                          )
                        , "lift $" <+> throwErr
                        , vecPokeDoc
                        ]
                      ]
                    )
        , csPeek       = \addrRef -> do
          RenderParams {..} <- input
          stmt (Just (ConT ''Vector :@ ConT ''Word32)) (Just "pSampleMask") $ do
            ptr <- use =<< storablePeek
              "pSampleMask"
              addrRef
              (Ptr Const (Ptr Const (TypeName "VkSampleMask")))
            vecPeek <- renderSubStmtsIO $ do
              addrRef'          <- pureStmt (AddrDoc ptr)
              ValueDoc samples <- useViaName "rasterizationSamples"
              let sampleTy = mkTyName "VkSampleCountFlagBits"
                  sampleCon =
                    mkConName "VkSampleCountFlagBits" "VkSampleCountFlagBits"
              tellImportWith sampleTy sampleCon
              len <-
                pureStmt
                .   ValueDoc
                $   "case"
                <+> samples
                <+> "of"
                <>  line
                <>  indent
                      2
                      (   pretty sampleCon
                      <+> "n -> (fromIntegral n + 31) `quot` 32"
                      )
              -- TODO: pass Nullable here and don't reimplement that logic
              vectorPeekWithLenRef @a "sampleMask"
                                      (Normal (TypeName "VkSampleMask"))
                                      addrRef'
                                      (TypeName "VkSampleMask")
                                      mempty
                                      len
                                      NotNullable
            pure
              .   IOAction
              .   ValueDoc
              $   "if"
              <+> ptr
              <+> "== nullPtr"
              <>  line
              <>  indent 2 (vsep ["then pure mempty", "else" <+> vecPeek])
        }
      _ -> Nothing
    _ -> const Nothing
  , BespokeScheme $ \case
    "VkShaderModuleCreateInfo" -> \case
      p | "codeSize" <- name p -> Just . ElidedCustom $ CustomSchemeElided
        { cseName       = "Shader code length"
        , cseDirectPoke = stmt (Just (ConT ''Int)) (Just "codeSizeBytes") $ do
                            tellQualImport 'BS.length
                            ValueDoc bs <- useViaName "pCode"
                            pure
                              .   Pure InlineOnce
                              .   ValueDoc
                              $   "fromIntegral $ Data.ByteString.length"
                              <+> bs
        , csePeek       = Just $ \addrRef ->
          storablePeek "codeSize" addrRef (Ptr Const (TypeName "size_t"))
        }
      p | "pCode" <- name p -> Just . Custom $ CustomScheme
        { csName       = "Shader code"
        , csZero       = Just "mempty"
        , csZeroIsZero = True
        , csType       = pure $ ConT ''ByteString
        , csDirectPoke = APoke $ \bsRef -> do
          assertMul4 <- unitStmt $ do
            ValueDoc bs <- use bsRef
            tellQualImport 'BS.length
            tellImport (mkNameG_v "base" "Data.Bits" ".&.")
            let err = "code size must be a multiple of 4"
                cond =
                  parens $ "Data.ByteString.length" <+> bs <+> ".&. 3 == 0"
            throwErrDoc err cond
          stmt (Just (ConT ''Ptr :@ ConT ''Word32)) (Just "pCode") $ do
            after assertMul4
            ValueDoc bs  <- use bsRef
            maybeAligned <- use =<< stmt
              Nothing
              (Just "unalignedCode")
              (do
                tellImportWithAll ''ContT
                tellImport 'BS.unsafeUseAsCString
                pure . ContTAction $ "ContT $ unsafeUseAsCString" <+> bs
              )
            tellImport 'ptrToWordPtr
            tellImport (mkNameG_v "base" "Data.Bits" ".&.")
            tellImport 'castPtr
            tellImport ''CChar
            tellImport ''Word32
            tellImportWithAll ''ContT
            tellImport 'allocaBytes
            tellImport 'lift
            tellQualImport 'BS.length
            tellImport 'copyBytes
            let len = "Data.ByteString.length" <+> bs
            pure
              .   ContTAction
              .   ValueDoc
              $   "if ptrToWordPtr"
              <+> maybeAligned
              <+> ".&. 3 == 0"
              <>  line
              <>  indent
                    2
                    (vsep
                      [ "-- If this pointer is already aligned properly then use it"
                      , "then pure $ castPtr @CChar @Word32" <+> maybeAligned
                      , "-- Otherwise allocate and copy the bytes"
                      , "else" <+> doBlock
                        [ "let len =" <+> len
                        , "mem <- ContT $ allocaBytes @Word32"
                        <+> "len"
                        , "lift $ copyBytes mem (castPtr @CChar @Word32"
                        <+> maybeAligned
                        <>  ")"
                        <+> "len"
                        , "pure mem"
                        ]
                      ]
                    )
        , csPeek       = \addrRef ->
          stmt (Just (ConT ''ByteString)) (Just "code") $ do
            ValueDoc len <- useViaName "codeSize"
            let bytes = "fromIntegral $" <+> len <+> "* 4"
            ptr <- use =<< storablePeek
              "pCode"
              addrRef
              (Ptr Const (Ptr Const (TypeName "uint32_t")))
            tellImport 'castPtr
            tellImport ''Word32
            tellImport ''CChar
            tellImport 'BS.packCStringLen
            pure . IOAction . ValueDoc $ "packCStringLen" <+> align (tupled
              ["castPtr @Word32 @CChar" <+> ptr, bytes])
        }
      _ -> Nothing
    _ -> const Nothing
  , BespokeScheme $ \case
    structName
      | -- Handle before and after 1.2.162
        structName
        `elem` [ "VkAccelerationStructureVersionInfoKHR"
               , "VkAccelerationStructureVersionKHR"
               , "VkMicromapVersionInfoEXT"
               ]
      -> \case
        p
          | memberName <- name p
          , memberName `elem` ["pVersionData", "versionData"]
          , Ptr Const (TypeName "uint8_t") <- type' p
          , -- TODO, This should be a "MultipleLength" or something
            V.Singleton (NamedLength (CName len)) <- lengths p
          , len == "2*VK_UUID_SIZE"
          -> Just . Custom $ CustomScheme
            { csName       = "Acceleration structure version"
            , csZero       = Just "mempty"
            , csZeroIsZero = True
            , csType       = pure $ ConT ''ByteString
            , csDirectPoke = APoke $ \bsRef -> do
              assertCorrectLength <- unitStmt $ do
                RenderParams {..} <- input
                ValueDoc bs       <- use bsRef
                tellQualImport 'BS.length
                let
                  err =
                    unCName structName
                      <> "::versionData must be "
                      <> len
                      <> " bytes"
                  uuidSizeDoc = mkPatternName "VK_UUID_SIZE"
                  cond =
                    parens
                      $   "Data.ByteString.length"
                      <+> bs
                      <+> "== 2 *"
                      <+> pretty uuidSizeDoc
                tellImport uuidSizeDoc
                throwErrDoc err cond
              stmt (Just (ConT ''Ptr :@ ConT ''Word8)) (Just "versionData'")
                $ do
                    after assertCorrectLength
                    ValueDoc bs <- use bsRef
                    tellImportWithAll ''ContT
                    tellImport 'BS.unsafeUseAsCString
                    tellImport 'castPtr
                    tellImport ''Word8
                    tellImport ''CChar
                    pure
                      .   ContTAction
                      .   ValueDoc
                      $ "fmap (castPtr @CChar @Word8) . ContT $ unsafeUseAsCString"
                      <+> bs
            , csPeek       = \addrRef ->
              stmt (Just (ConT ''ByteString)) (Just "versionData") $ do
                RenderParams {..} <- input
                let uuidSizeDoc = mkPatternName "VK_UUID_SIZE"
                    bytes       = "2 *" <+> pretty uuidSizeDoc
                tellImport uuidSizeDoc
                ptr <- use =<< storablePeek
                  "versionData"
                  addrRef
                  (Ptr Const (Ptr Const (TypeName "uint8_t")))
                tellImport 'castPtr
                tellImport ''Word8
                tellImport ''CChar
                tellImport 'BS.packCStringLen
                pure . IOAction . ValueDoc $ "packCStringLen" <+> align (tupled
                  ["castPtr @Word8 @CChar" <+> ptr, bytes])
            }
        _ -> Nothing
    _ -> const Nothing
  ]

-- | Bitfields at the moment are handled by writing both fields when the first
-- (lower bits) one is written and not doing anything for the second one.
bitfields :: BespokeScheme
bitfields = BespokeScheme $ \case
  "VkAccelerationStructureInstanceKHR" -> rtFields
  "VkAccelerationStructureSRTMotionInstanceNV" -> rtFields
  "VkAccelerationStructureMatrixMotionInstanceNV" -> rtFields
  _ -> const Nothing
 where
  rtFields :: Marshalable a => a -> Maybe (MarshalScheme a)
  rtFields = \case
    p
      | "instanceCustomIndex" <- name p -> Just $ bitfieldMaster p ("mask", 8)
      | "mask" <- name p -> Just $ bitfieldSlave 24 p
      | "instanceShaderBindingTableRecordOffset" <- name p -> Just
      $ bitfieldMaster p ("flags", 8)
      | "flags" <- name p -> Just $ bitfieldSlave 24 p
    _ -> Nothing
  peekBitfield
    :: (HasRenderElem r, HasErr r, HasSpecInfo r, HasRenderParams r)
    => CName
    -> CType
    -> Int
    -> Int
    -> Ref s AddrDoc
    -> Stmt s r (Ref s ValueDoc)
  peekBitfield cName ty szBits bitShift addr = do
    tyH     <- cToHsType DoNotPreserve ty
    base    <- storablePeek cName addr (Ptr Const ty)
    shifted <- if bitShift == 0
      then pure base
      else stmt Nothing Nothing $ do
        ValueDoc base' <- use base
        tellImport (mkName "Data.Bits.shiftR")
        pure . Pure InlineOnce . ValueDoc $ parens
          (base' <+> "`shiftR`" <+> viaShow bitShift)
    masked <- if szBits == 32
      then pure shifted
      else stmt Nothing Nothing $ do
        ValueDoc shifted' <- use shifted
        tellImport (mkNameG_v "base" "Data.Bits" ".&.")
        tellImport 'coerce
        let mask = "coerce @Word32 0x"
              <> pretty (showHex ((1 `shiftL` szBits :: Int) - 1) "")
        pure . Pure InlineOnce . ValueDoc $ parens (shifted' <+> ".&." <+> mask)
    stmt (Just tyH) (Just (unCName cName)) $
      Pure NeverInline <$> use masked

  bitfieldSlave :: Marshalable a => Int -> a -> MarshalScheme a
  bitfieldSlave bitShift = \case
    p
      | Bitfield ty szBits <- type' p -> Custom CustomScheme
        { csName       = "bitfield slave " <> unCName (name p)
        , csZero       = Just "zero"
        , csZeroIsZero = True
        , csType       = cToHsType DoNotPreserve ty
        , csDirectPoke = NoPoke
        , csPeek       = peekBitfield (name p) ty szBits bitShift
        }
      | otherwise -> error "bitfield slave type isn't a bitfield "

  bitfieldMaster :: Marshalable a => a -> (CName, Int) -> MarshalScheme a
  bitfieldMaster master (slaveName, _slaveBitSize) = case type' master of
    Bitfield ty masterBitSize -> Custom CustomScheme
      { csName       = "bitfield master " <> unCName (name master)
      , csZero       = Just "zero"
      , csZeroIsZero = True
      , csType       = cToHsType DoNotPreserve ty
      , csDirectPoke = APoke $ \masterRef -> do
                         tyH <- cToHsType DoPreserve ty
                         stmt (Just tyH) Nothing $ do
                           ValueDoc slaveDoc  <- useViaName (unCName slaveName)
                           ValueDoc masterDoc <- use masterRef
                           tellImport (mkName "Data.Bits.shiftL")
                           tellImport (mkNameG_v "base" "Data.Bits" ".|.")
                           tellImport 'coerce
                           pure
                             .   Pure InlineOnce
                             .   ValueDoc
                             $   parens
                                   (   parens ("coerce @_ @Word32" <+> slaveDoc)
                                   <+> "`shiftL`"
                                   <+> viaShow masterBitSize
                                   )
                             <+> ".|."
                             <+> masterDoc
      , csPeek       = peekBitfield (name master) ty masterBitSize 0
      }
    _ -> error "bitfield master isn't a bitfield"

accelerationStructureGeometry :: BespokeScheme
accelerationStructureGeometry = BespokeScheme $ \case
  "VkAccelerationStructureBuildGeometryInfoKHR" -> \case
    (p :: a) | "ppGeometries" <- name p, Ptr Const (Ptr Const _) <- type' p ->
      Just $ ElidedUnivalued "nullPtr"
    _ -> Nothing
  _ -> const Nothing

-- TODO: Select this when compiling an older spec
_accelerationStructureGeometryPre1_2_162 :: BespokeScheme
_accelerationStructureGeometryPre1_2_162 = BespokeScheme $ \case
  "VkAccelerationStructureBuildGeometryInfoKHR" -> \case
    (p :: a)
      | "geometryArrayOfPointers" <- name p
      -> Just . ElidedCustom $ CustomSchemeElided
        { cseName       = "geometry array type"
        , cseDirectPoke = do
          RenderParams {..} <- input
          let t = mkPatternName "VK_FALSE"
          tellImport t
          tyH <- cToHsType DoNotPreserve (type' p)
          stmt (Just tyH) Nothing $ pure . Pure AlwaysInline . ValueDoc $ pretty
            t
        , csePeek       = Nothing -- TODO assert it's VK_FALSE here
        }
      | "geometryCount" <- name p
      -> Just . ElidedCustom $ CustomSchemeElided
        { cseName       = "geometryCount"
        , cseDirectPoke = elidedLengthPoke @_ @a (name p)
                                                 (type' p)
                                                 mempty
                                                 (V.fromList ["ppGeometries"])
        , csePeek       = Just $ \addr -> storablePeek (name p) addr (type' p)
        }
      | "ppGeometries" <- name p, Ptr Const unPtrTy@(Ptr Const elemTy) <- type'
        p
      -> Just . Custom $ CustomScheme
        { csName       = "ppGeometries"
        , csZero       = Just "mempty"
        , csZeroIsZero = True -- Pointer to empty array
        , csType       = (ConT ''Vector :@) <$> cToHsType DoNotPreserve elemTy
        , csDirectPoke = APoke $ \vecRef -> do
          ptrRef <- getPokeDirect' @a (name p)
                                      unPtrTy
                                      (Vector NotNullable (Normal elemTy))
                                      vecRef
          tyH <- cToHsType DoPreserve (Ptr Const unPtrTy)
          stmt (Just tyH) (Just "ppGeometries") $ do
            ValueDoc ptr <- use ptrRef
            tellImportWithAll ''ContT
            tellImport 'with
            pure . ContTAction . ValueDoc $ "ContT $ with" <+> ptr
        , csPeek       = error "unused csPeek for ppGeometries"
        }
    _ -> Nothing
  _ -> const Nothing

-- TODO: These should have length annotations which check that they match their
-- siblings
buildingAccelerationStructures :: BespokeScheme
buildingAccelerationStructures = BespokeScheme $ \case
  commandName
    | commandName
      `elem` [ "vkCmdBuildAccelerationStructuresKHR"
             , "vkBuildAccelerationStructuresKHR"
             ]
    -> \case
      (p :: a)
        | "ppBuildRangeInfos" <- name p, Ptr Const (Ptr Const elemTy) <- type' p
        -> Just $ Vector NotNullable (Vector NotNullable (Normal elemTy))
      _ -> Nothing
  "vkCmdBuildAccelerationStructuresIndirectKHR" -> \case
    (p :: a)
      | "ppMaxPrimitiveCounts" <- name p, Ptr Const (Ptr Const elemTy) <- type'
        p
      -> Just $ Vector NotNullable (Vector NotNullable (Normal elemTy))
    _ -> Nothing

  _ -> const Nothing

micromapUsageCounts :: BespokeScheme
micromapUsageCounts = BespokeScheme $ \case
  "VkMicromapBuildInfoEXT" -> \case
    (p :: a) | "ppUsageCounts" <- name p, Ptr Const (Ptr Const _) <- type' p ->
      Just $ ElidedUnivalued "nullPtr"
    _ -> Nothing
  "VkAccelerationStructureTrianglesOpacityMicromapEXT" -> \case
    (p :: a) | "ppUsageCounts" <- name p, Ptr Const (Ptr Const _) <- type' p ->
      Just $ ElidedUnivalued "nullPtr"
    _ -> Nothing
  "VkAccelerationStructureTrianglesDisplacementMicromapNV" -> \case
    (p :: a) | "ppUsageCounts" <- name p, Ptr Const (Ptr Const _) <- type' p ->
      Just $ ElidedUnivalued "nullPtr"
    _ -> Nothing
  "VkAccelerationStructureGeometryMicromapDataKHR" -> \case
    (p :: a) | "ppUsageCounts" <- name p, Ptr Const (Ptr Const _) <- type' p ->
      Just $ ElidedUnivalued "nullPtr"
    _ -> Nothing
  _ -> const Nothing

structChainVar :: String
structChainVar = "es"

----------------------------------------------------------------
-- Things which are easier to write by hand
----------------------------------------------------------------

-- | These override the description in the spec, make sure they're correct!
bespokeStructsAndUnions :: [StructOrUnion a WithoutSize WithoutChildren]
bespokeStructsAndUnions =
  [ Struct
      { sName        = "VkTransformMatrixKHR"
      , sMembers     = V.fromList
                         [ StructMember
                           { smName       = "matrixRow0"
                           , smType = Array NonConst (NumericArraySize 4) Float
                           , smValues     = mempty
                           , smLengths    = mempty
                           , smIsOptional = mempty
                           , smOffset     = ()
                           }
                         , StructMember
                           { smName       = "matrixRow1"
                           , smType = Array NonConst (NumericArraySize 4) Float
                           , smValues     = mempty
                           , smLengths    = mempty
                           , smIsOptional = mempty
                           , smOffset     = ()
                           }
                         , StructMember
                           { smName       = "matrixRow2"
                           , smType = Array NonConst (NumericArraySize 4) Float
                           , smValues     = mempty
                           , smLengths    = mempty
                           , smIsOptional = mempty
                           , smOffset     = ()
                           }
                         ]
      , sSize        = ()
      , sAlignment   = ()
      , sExtends     = mempty
      , sExtendedBy  = mempty
      , sInherits    = mempty
      , sInheritedBy = mempty
      }
  ]

bespokeSizes :: SpecFlavor -> [(CName, (Int, Int))]
bespokeSizes t =
  let
    xrSizes =
      [ ("XrFlags64"                , (8, 8))
        , ("XrTime"                   , (8, 8))
        , ("XrDuration"               , (8, 8))
        , ("XrVersion"                , (8, 8))
        , ("timespec"                 , (16, 8))
        -- TODO: Can these be got elsewhere?
        , ("VkResult"                 , (4, 4))
        , ("VkFormat"                 , (4, 4))
        , ("VkInstance"               , (8, 8))
        , ("VkPhysicalDevice"         , (8, 8))
        , ("VkImage"                  , (8, 8))
        , ("VkDevice"                 , (8, 8))
        , ("PFN_vkGetDeviceProcAddr"  , (8, 8))
        , ("PFN_vkGetInstanceProcAddr", (8, 8))
        ]
        <> (fst <$> concat
             [win32Xr @'[Input RenderParams], x11Shared, xcb2Xr, egl, gl, d3d, metalSized]
           )
    vkSizes =
      [ ("VkSampleMask"     , (4, 4))
        , ("VkFlags"          , (4, 4))
        , ("VkDeviceSize"     , (8, 8))
        , ("VkDeviceAddress"  , (8, 8))
        , ("VkRemoteAddressNV", (8, 8))
        ]
        <> (fst <$> concat
             [win32 @'[Input RenderParams], x11Shared, x11, xcb2, zircon, ggp, metalSized]
           )
    sharedSizes = []
  in
    sharedSizes <> case t of
      SpecVk -> vkSizes
      SpecXr -> xrSizes

bespokeOptionality :: CName -> CName -> Maybe (Vector Bool)
bespokeOptionality = \case
  -- These are optional depending on the value of `descriptorType`, treat them
  -- as unconditionally optional and rely on the programmer (and validation
  -- layers) to keep it safe
  "VkWriteDescriptorSet" -> \case
    "pImageInfo"       -> Just (fromList [True])
    "pBufferInfo"      -> Just (fromList [True])
    "pTexelBufferView" -> Just (fromList [True])
    _                  -> Nothing
  -- Because we don't marshal ppGeometries, this is not actually optional
  -- See https://github.com/expipiplus1/vulkan/issues/239
  "VkAccelerationStructureBuildGeometryInfoKHR" -> \case
    "pGeometries" -> Just mempty
    _             -> Nothing
  -- similar for ppUsageCounts
  "VkMicromapBuildInfoEXT" -> \case
    "pUsageCounts" -> Just mempty
    _             -> Nothing
  "VkAccelerationStructureTrianglesOpacityMicromapEXT" -> \case
    "pUsageCounts" -> Just mempty
    _             -> Nothing
  "VkAccelerationStructureTrianglesDisplacementMicromapNV" -> \case
    "pUsageCounts" -> Just mempty
    _             -> Nothing
  "VkAccelerationStructureGeometryMicromapDataKHR" -> \case
    "pUsageCounts" -> Just mempty
    _             -> Nothing
  _ -> const Nothing

bespokeLengths :: CName -> CName -> Maybe (Vector ParameterLength)
bespokeLengths = \case
  -- Work around https://github.com/KhronosGroup/Vulkan-Docs/issues/1414
  "VkDescriptorSetAllocateInfo" -> \case
    "pSetLayouts" -> Just (fromList [NamedLength "descriptorSetCount"])
    _             -> 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|
        -- | The Identity Matrix
        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
  :: forall t r
   . (HasErr r, HasRenderParams r, HasSpecInfo r)
  => Spec t
  -> Vector (Sem r RenderElement)
bespokeElements Spec {..} = case specHeaderVersion of
  VkVersion v ->
    fromList
      $  shared
      <> [ baseType "VkSampleMask"    ''Word32
         , baseType "VkFlags"         ''Word32
         , baseType "VkFlags64"       ''Word64
         , baseType "VkDeviceSize"    ''Word64
         , baseType "VkDeviceAddress" ''Word64
         ]
      <> wsiTypes SpecVk
      <> [ extensionBaseType "VkRemoteAddressNV" (Ptr NonConst Void)
         | v >= 184
         ]
  XrVersion{} ->
    fromList
      $  shared
      <> [ baseType "XrFlags64"  ''Word64
         , baseType "XrTime"     ''Int64
         , baseType "XrDuration" ''Int64
         ]
      <> wsiTypes SpecXr
      <> [resultMatchers]
 where
  shared = [namedType, nullHandle, boolConversion] :: [Sem r RenderElement]

boolConversion :: HasRenderParams r => Sem r RenderElement
boolConversion = genRe "Bool conversion" $ do
  RenderParams {..} <- input
  tellNotReexportable
  let true   = mkPatternName (CName $ upperPrefix <> "_TRUE")
      false  = mkPatternName (CName $ upperPrefix <> "_FALSE")
      bool32 = mkTyName (CName $ camelPrefix <> "Bool32")
  tellExport (ETerm (TermName "boolToBool32"))
  tellExport (ETerm (TermName "bool32ToBool"))
  tellImport 'bool
  tellImportWithAll bool32
  tellDoc [qqi|
    boolToBool32 :: Bool -> {bool32}
    boolToBool32 = bool {false} {true}

    bool32ToBool :: {bool32} -> Bool
    bool32ToBool = \\case
      {false} -> False
      {true}  -> True
  |]

wsiTypes
  :: (HasErr r, HasRenderParams r) => SpecFlavor -> [Sem r RenderElement]
wsiTypes = \case
  SpecVk ->
    (snd <$> concat [win32, x11Shared, x11, xcb2, zircon, ggp, metalSized]) <> concat
      [win32', xcb1, waylandShared, wayland, metalUnsized, android, directfb, screen]
  SpecXr -> (snd <$> concat [win32Xr, x11Shared, xcb2Xr, egl, gl, d3d])
    <> concat [win32Xr', xcb1, waylandShared, d3d', jni, timespec]

namedType :: (HasRenderParams r, HasErr r) => Sem r RenderElement
namedType = genRe "namedType" $ do
  tellExplicitModule =<< mkModuleName ["NamedType"]
  tellNotReexportable
  tellExport (EType (TyConName ":::"))
  tellDoc "-- | Annotate a type with a name\ntype (name :: k) ::: a = a"

baseType
  :: (HasRenderParams r, HasErr r) => CName -> Name -> Sem r RenderElement
baseType n t = fmap identicalBoot . genRe ("base type " <> unCName n) $ do
  RenderParams {..} <- input
  let n' = mkTyName n
  tellExplicitModule =<< mkModuleName ["Core10", "FundamentalTypes"]
  tellExport (EType n')
  tDoc <- renderType (ConT t)
  tellDocWithHaddock $ \getDoc ->
    vsep [getDoc (TopLevel n), "type" <+> pretty n' <+> "=" <+> tDoc]

extensionBaseType
  :: (HasRenderParams r, HasErr r, HasSpecInfo r)
  => CName
  -> CType
  -> Sem r RenderElement
extensionBaseType n t =
  fmap identicalBoot . genRe ("extension base type " <> unCName n) $ do
    RenderParams {..} <- input
    let n' = mkTyName n
    tellExport (EType n')
    tDoc <- renderType =<< cToHsType DoPreserve t
    tellDocWithHaddock $ \getDoc ->
      vsep [getDoc (TopLevel n), "type" <+> pretty n' <+> "=" <+> tDoc]

----------------------------------------------------------------
-- Base Vulkan stuff
----------------------------------------------------------------

nullHandle :: (HasErr r, HasRenderParams r) => Sem r RenderElement
nullHandle = genRe "null handle" $ do
  RenderParams {..} <- input
  let patName = mkPatternName "VK_NULL_HANDLE"
  tellExplicitModule =<< mkModuleName ["Core10", "APIConstants"]
  tellNotReexportable
  tellExport (EPat patName)
  tellExport (EType (TyConName "IsHandle"))
  tellImportWithAll (TyConName "Zero")
  tellImport ''Word64
  tellDocWithHaddock $ \getDoc -> [qqi|
    {getDoc (TopLevel "VK_NULL_HANDLE")}
    pattern {patName} :: IsHandle a => a
    pattern {patName} <- ((== zero) -> True)
      where {patName} = zero

    -- | A class for things which can be created with '{patName}'.
    class (Eq a, Zero a) => IsHandle a where
  |]


----------------------------------------------------------------
-- Base XR stuff
----------------------------------------------------------------

resultMatchers :: (HasErr r, HasRenderParams r) => Sem r RenderElement
resultMatchers = genRe "xr result matchers" $ do
  RenderParams {..} <- input
  let succName = mkPatternName "XR_SUCCEEDED"
      unquName = mkPatternName "XR_UNQUALIFIED_SUCCESS"
      failName = mkPatternName "XR_FAILED"
  tellExplicitModule =<< mkModuleName ["Core10", "Enums", "Result"]
  tellNotReexportable
  tellExport (EPat succName)
  tellExport (EPat unquName)
  tellExport (EPat failName)
  tellDocWithHaddock $ \getDoc -> [qqi|
    {getDoc (TopLevel "XR_SUCCEEDED")}
    pattern SUCCEEDED :: Result
    pattern SUCCEEDED <- ((SUCCESS <=) -> True)

    {getDoc (TopLevel "XR_UNQUALIFIED_SUCCESS")}
    pattern UNQUALIFIED_SUCCESS :: Result
    pattern UNQUALIFIED_SUCCESS <- ((SUCCESS ==) -> True)

    {getDoc (TopLevel "XR_FAILED")}
    pattern FAILED :: Result
    pattern FAILED <- ((SUCCESS >) -> True)

    \{-# complete SUCCEEDED, FAILED #-}
  |]

----------------------------------------------------------------
-- Platform specific nonsense
----------------------------------------------------------------

type BespokeAlias r = ((CName, (Int, Int)), Sem r RenderElement)
-- C name, size, alignment, render element

win32 :: HasRenderParams r => [BespokeAlias r]
win32 =
  [ alias (APtr ''())     "HINSTANCE"
  , alias (APtr ''())     "HWND"
  , alias (APtr ''())     "HMONITOR"
  , alias (APtr ''())     "HANDLE"
  , alias AWord32         "DWORD"
  , alias (APtr ''CWchar) "LPCWSTR"
  ]

win32' :: HasRenderParams r => [Sem r RenderElement]
win32' = [voidData "SECURITY_ATTRIBUTES"]

win32Xr :: HasRenderParams r => [BespokeAlias r]
win32Xr =
  [ alias (APtr ''()) "HDC" -- TODO: should be an alias for HANDLE
  , alias (APtr ''()) "HGLRC" -- TODO: check this
  , alias AWord64     "LUID"
  , alias AWord64     "LARGE_INTEGER"
  ]

win32Xr' :: HasRenderParams r => [Sem r RenderElement]
win32Xr' = [voidData "IUnknown"]

x11Shared :: HasRenderParams r => [BespokeAlias r]
x11Shared = [alias (APtr ''()) "Display"]

x11 :: HasRenderParams r => [BespokeAlias r]
x11 =
  [alias AWord64 "VisualID", alias AWord64 "Window", alias AWord64 "RROutput"]

xcb1 :: HasRenderParams r => [Sem r RenderElement]
xcb1 = [voidData "xcb_connection_t"]

xcb2 :: HasRenderParams r => [BespokeAlias r]
xcb2 = [alias AWord32 "xcb_visualid_t", alias AWord32 "xcb_window_t"]

xcb2Xr :: HasRenderParams r => [BespokeAlias r]
xcb2Xr =
  [ alias AWord32 "xcb_visualid_t"
  , alias AWord32 "xcb_glx_fbconfig_t"
  , alias AWord32 "xcb_glx_drawable_t"
  , alias AWord32 "xcb_glx_context_t"
  ]


ggp :: HasRenderParams r => [BespokeAlias r]
ggp = [alias AWord32 "GgpStreamDescriptor", alias AWord32 "GgpFrameToken"]

metalUnsized :: HasRenderParams r => [Sem r RenderElement]
metalUnsized = [voidData "CAMetalLayer"]

metalSized :: HasRenderParams r => [BespokeAlias r]
metalSized =
  [ alias (APtr ''()) "MTLDevice_id"
  , alias (APtr ''()) "MTLCommandQueue_id"
  , alias (APtr ''()) "MTLBuffer_id"
  , alias (APtr ''()) "MTLTexture_id"
  , alias (APtr ''()) "IOSurfaceRef"
  , alias (APtr ''()) "MTLSharedEvent_id"
  ]

waylandShared :: HasRenderParams r => [Sem r RenderElement]
waylandShared = [voidData "wl_display"]

wayland :: HasRenderParams r => [Sem r RenderElement]
wayland = [voidData "wl_surface"]

zircon :: HasRenderParams r => [BespokeAlias r]
zircon = [alias AWord32 "zx_handle_t"]

android :: HasRenderParams r => [Sem r RenderElement]
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", voidData "_screen_buffer"]

----------------------------------------------------------------
-- OpenXR platform stuff
----------------------------------------------------------------

egl :: HasRenderParams r => [BespokeAlias r]
egl =
  [ alias (AFunPtr $(TH.lift =<< [t|CString -> IO (FunPtr (IO ()))|]))
          "PFNEGLGETPROCADDRESSPROC"
  , alias (APtr ''()) "EGLDisplay"
  , alias (APtr ''()) "EGLConfig"
  , alias (APtr ''()) "EGLContext"
  ]

gl :: HasRenderParams r => [BespokeAlias r]
gl =
  [ alias (APtr ''()) "GLXFBConfig"
  , alias AWord64     "GLXDrawable"
  , alias (APtr ''()) "GLXContext"
  ]

d3d :: HasRenderParams r => [BespokeAlias r]
d3d = [alias AWord32 "D3D_FEATURE_LEVEL"]

d3d' :: HasRenderParams r => [Sem r RenderElement]
d3d' =
  [ voidData "ID3D11Device"
  , voidData "ID3D11Texture2D"
  , voidData "ID3D12CommandQueue"
  , voidData "ID3D12Device"
  , voidData "ID3D12Resource"
  ]

jni :: HasRenderParams r => [Sem r RenderElement]
jni = [voidData "jobject"]

timespec :: HasRenderParams r => [Sem r RenderElement]
timespec = pure $ genRe "timespec" $ do
  tellImport ''CTime
  tellImport ''Int64
  tellImport ''Typeable
  tellImport ''Generic
  tellImportWithAll ''Storable
  tellImport 'castPtr
  tellImport 'plusPtr
  tellDataExport (TyConName "Timespec")
  tellDoc [qqi|
    data Timespec = Timespec
      \{ tv_sec :: CTime
      , tv_nsec :: Int64
      }
      deriving (Typeable, Generic, Read, Show, Eq, Ord)

    instance Storable Timespec where
      sizeOf ~_ = 16
      alignment ~_ = 8
      peek p = Timespec
        <$> peek (castPtr @Timespec @CTime p)
        <*> peek (plusPtr @Timespec @Int64 p 8)
      poke p (Timespec s n) = do
        poke (castPtr @Timespec @CTime p) s
        poke (plusPtr @Timespec @Int64 p 8) n
  |]

----------------------------------------------------------------
-- OpenXR stuff
----------------------------------------------------------------

openXRSchemes :: [BespokeScheme]
openXRSchemes =
  [ BespokeScheme $ \case
      "XrEventDataBuffer" -> \case
        a | "varying" <- name a -> Just ByteString
        _                       -> Nothing
      "XrSpatialGraphNodeSpaceCreateInfoMSFT" -> \case
        a | "nodeId" <- name a -> Just ByteString
        _                      -> Nothing
      -- Work around https://github.com/KhronosGroup/OpenXR-Docs/issues/69
      f
        | f
          `elem` [ "xrPathToString"
                 , "xrGetInputSourceLocalizedName"
                 , "xrGetVulkanInstanceExtensionsKHR"
                 , "xrGetVulkanDeviceExtensionsKHR"
                 ]
        -> \case
          a | "buffer" <- name a -> Just (Returned ByteString)
          _                      -> Nothing

      _ -> const Nothing
  ]

----------------------------------------------------------------
-- Culaunch
----------------------------------------------------------------

cuLaunchSchemes :: BespokeScheme
cuLaunchSchemes =
   BespokeScheme $ \case
      "VkCuLaunchInfoNVX" -> \case
        a | "pParams" <- name a -> Just (Vector NotNullable VoidPtr)
        a | "pExtras" <- name a -> Just (Vector NotNullable VoidPtr)
        _                       -> Nothing
      "VkCudaLaunchInfoNV" -> \case
        a | "pParams" <- name a -> Just (Vector NotNullable VoidPtr)
        a | "pExtras" <- name a -> Just (Vector NotNullable VoidPtr)
        _                       -> Nothing
      _ -> const Nothing

----------------------------------------------------------------
-- Helpers
----------------------------------------------------------------

data AType = AWord32 | AWord64 | APtr Name | AFunPtr H.Type

aTypeSize :: AType -> (Int, Int)
aTypeSize = \case
  AWord32   -> (4, 4)
  AWord64   -> (8, 8)
  APtr    _ -> (8, 8)
  AFunPtr _ -> (8, 8)

aTypeType :: AType -> H.Type
aTypeType = \case
  AWord32   -> ConT ''Word32
  AWord64   -> ConT ''Word64
  APtr    n -> ConT ''Ptr :@ ConT n
  AFunPtr t -> ConT ''FunPtr :@ t

voidData :: HasRenderParams r => CName -> Sem r RenderElement
voidData n = fmap identicalBoot . genRe ("data " <> unCName n) $ do
  RenderParams {..} <- input
  let n' = mkTyName n
  tellExport (EType n')
  tellDoc $ "data" <+> pretty n'

alias :: HasRenderParams r => AType -> CName -> BespokeAlias r
alias t n =
  ( (n, aTypeSize t)
  , fmap identicalBoot . genRe ("alias " <> unCName n) $ do
    RenderParams {..} <- input
    let n' = mkTyName n
    tDoc <- renderType (aTypeType t)
    tellExport (EType n')
    tellDoc $ "type" <+> pretty n' <+> "=" <+> tDoc
  )