{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Vulkan.Utils.Requirements
  ( -- * Instance requirements
    checkInstanceRequirements

    -- * Device requirements
  , checkDeviceRequirements

    -- * Results
  , RequirementResult (..)
  , Unsatisfied (..)
  , requirementReport
  , prettyRequirementResult
  ) where

import Control.Arrow (Arrow ((***)))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Functor.Product (Product (..))
import qualified Data.HashMap.Strict as Map
import Data.Kind (Type)
import Data.List (intercalate, intersect)
import Data.List.Extra (nubOrd)
import qualified Data.Map.Strict as TRMap
import Data.Proxy
import Data.Semigroup (Endo (..))
import Data.Traversable
import Data.Typeable (eqT)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word
import Foreign.Ptr
  ( FunPtr
  , Ptr
  , nullFunPtr
  )
import GHC.Base (Proxy#)
import GHC.Exts (proxy#)
import Type.Reflection
import Vulkan.CStruct
  ( FromCStruct
  , ToCStruct
  )
import Vulkan.CStruct.Extends
import Vulkan.Core10
import qualified Vulkan.Core10 as Device
  ( DeviceCreateInfo (..)
  )
import qualified Vulkan.Core10 as Extension
  ( ExtensionProperties (..)
  )
import qualified Vulkan.Core10 as Instance
  ( InstanceCreateInfo (..)
  )
import qualified Vulkan.Core10 as PhysicalDevice
  ( PhysicalDevice (instanceCmds)
  , PhysicalDeviceProperties (..)
  )
import Vulkan.Core11.DeviceInitialization
import Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2
import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2 as PhysicalDevice
  ( PhysicalDeviceProperties2 (..)
  , features
  )
import Vulkan.Dynamic
  ( InstanceCmds
      ( pVkGetPhysicalDeviceFeatures2
      , pVkGetPhysicalDeviceProperties2
      )
  )
import Vulkan.NamedType
import Vulkan.Requirement
import Vulkan.Version
import Vulkan.Zero (Zero (..))

----------------------------------------------------------------

-- * Instance Creation

----------------------------------------------------------------

checkInstanceRequirements
  :: forall m o r es
   . (MonadIO m, Traversable r, Traversable o)
  => r InstanceRequirement
  -- ^ Required requests
  -> o InstanceRequirement
  -- ^ Optional requests
  -> InstanceCreateInfo es
  {- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by
  the requirements
  -}
  -> m
       ( Maybe (InstanceCreateInfo es)
       , r RequirementResult
       , o RequirementResult
       )
checkInstanceRequirements :: forall (m :: * -> *) (o :: * -> *) (r :: * -> *) (es :: [*]).
(MonadIO m, Traversable r, Traversable o) =>
r InstanceRequirement
-> o InstanceRequirement
-> InstanceCreateInfo es
-> m (Maybe (InstanceCreateInfo es), r RequirementResult,
      o RequirementResult)
checkInstanceRequirements r InstanceRequirement
required o InstanceRequirement
optional InstanceCreateInfo es
baseCreateInfo = do
  let
    requiredList :: [InstanceRequirement]
requiredList = r InstanceRequirement -> [InstanceRequirement]
forall a. r a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList r InstanceRequirement
required
    allAsList :: [InstanceRequirement]
allAsList = [InstanceRequirement]
requiredList [InstanceRequirement]
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. Semigroup a => a -> a -> a
<> o InstanceRequirement -> [InstanceRequirement]
forall a. o a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o InstanceRequirement
optional
  foundVersion <- m Word32
forall (io :: * -> *). MonadIO io => io Word32
enumerateInstanceVersion
  (_, layerProps) <- enumerateInstanceLayerProperties
  lookupExtension <-
    getLookupExtension
      layerProps
      Nothing
      [ instanceExtensionLayerName
      | RequireInstanceExtension{instanceExtensionLayerName} <- allAsList
      ]

  (r, continue) <- flip runStateT True $ for required $ \InstanceRequirement
r ->
    case Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
r of
      RequirementResult
res -> do
        Bool -> StateT Bool m () -> StateT Bool m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RequirementResult
res RequirementResult -> RequirementResult -> Bool
forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (Bool -> StateT Bool m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
False)
        RequirementResult -> StateT Bool m RequirementResult
forall a. a -> StateT Bool m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  (o, goodOptions) <- flip runStateT mempty $ for optional $ \InstanceRequirement
o ->
    case Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
o of
      RequirementResult
res -> do
        Bool
-> StateT [InstanceRequirement] m ()
-> StateT [InstanceRequirement] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequirementResult
res RequirementResult -> RequirementResult -> Bool
forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (StateT [InstanceRequirement] m ()
 -> StateT [InstanceRequirement] m ())
-> StateT [InstanceRequirement] m ()
-> StateT [InstanceRequirement] m ()
forall a b. (a -> b) -> a -> b
$ ([InstanceRequirement] -> [InstanceRequirement])
-> StateT [InstanceRequirement] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (InstanceRequirement
o InstanceRequirement
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. a -> [a] -> [a]
:)
        RequirementResult
-> StateT [InstanceRequirement] m RequirementResult
forall a. a -> StateT [InstanceRequirement] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  let ici = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
        InstanceCreateInfo es -> Maybe (InstanceCreateInfo es)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstanceCreateInfo es -> Maybe (InstanceCreateInfo es))
-> InstanceCreateInfo es -> Maybe (InstanceCreateInfo es)
forall a b. (a -> b) -> a -> b
$
          [InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
forall (es :: [*]).
[InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
makeInstanceCreateInfo
            ([InstanceRequirement]
requiredList [InstanceRequirement]
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. Semigroup a => a -> a -> a
<> [InstanceRequirement]
goodOptions)
            InstanceCreateInfo es
baseCreateInfo
  pure (ici, r, o)

{- | Insert the settings of the requirements in to the provided instance create
info
-}
makeInstanceCreateInfo
  :: forall es
   . [InstanceRequirement]
  -> InstanceCreateInfo es
  -> InstanceCreateInfo es
makeInstanceCreateInfo :: forall (es :: [*]).
[InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
makeInstanceCreateInfo [InstanceRequirement]
reqs InstanceCreateInfo es
baseCreateInfo =
  let
    layers :: [ByteString]
layers = [ByteString
instanceLayerName | RequireInstanceLayer{Word32
ByteString
instanceLayerName :: ByteString
instanceLayerMinVersion :: Word32
instanceLayerMinVersion :: InstanceRequirement -> Word32
instanceLayerName :: InstanceRequirement -> ByteString
..} <- [InstanceRequirement]
reqs]
    extensions :: [ByteString]
extensions =
      [ByteString
instanceExtensionName | RequireInstanceExtension{"layerName" ::: Maybe ByteString
Word32
ByteString
instanceExtensionLayerName :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionName :: ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
instanceExtensionMinVersion :: Word32
instanceExtensionMinVersion :: InstanceRequirement -> Word32
instanceExtensionName :: InstanceRequirement -> ByteString
..} <- [InstanceRequirement]
reqs]
  in
    InstanceCreateInfo es
baseCreateInfo
      { Instance.enabledLayerNames =
          Instance.enabledLayerNames baseCreateInfo
            <> V.fromList layers
      , Instance.enabledExtensionNames =
          Instance.enabledExtensionNames baseCreateInfo
            <> V.fromList extensions
      }

checkInstanceRequest
  :: ("apiVersion" ::: Word32)
  -> ("properties" ::: Vector LayerProperties)
  -> ( ("layerName" ::: Maybe ByteString)
       -> ByteString
       -> Maybe ExtensionProperties
     )
  -> InstanceRequirement
  -> RequirementResult
checkInstanceRequest :: Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireInstanceVersion Word32
minVersion ->
    if Word32
foundVersion Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
minVersion
      then RequirementResult
Satisfied
      else Unsatisfied Word32 -> RequirementResult
UnsatisfiedInstanceVersion (Word32 -> Word32 -> Unsatisfied Word32
forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
minVersion Word32
foundVersion)
  RequireInstanceLayer{ByteString
instanceLayerName :: InstanceRequirement -> ByteString
instanceLayerName :: ByteString
instanceLayerName, Word32
instanceLayerMinVersion :: InstanceRequirement -> Word32
instanceLayerMinVersion :: Word32
instanceLayerMinVersion}
    | Just LayerProperties
props <- (LayerProperties -> Bool)
-> ("properties" ::: Vector LayerProperties)
-> Maybe LayerProperties
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
instanceLayerName) (ByteString -> Bool)
-> (LayerProperties -> ByteString) -> LayerProperties -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerProperties -> ByteString
layerName) "properties" ::: Vector LayerProperties
layerProps
    , Word32
foundLayerVersion <- LayerProperties -> Word32
implementationVersion LayerProperties
props ->
        if Word32
foundVersion Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
instanceLayerMinVersion
          then RequirementResult
Satisfied
          else
            ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedLayerVersion
              ByteString
instanceLayerName
              (Word32 -> Word32 -> Unsatisfied Word32
forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
instanceLayerMinVersion Word32
foundLayerVersion)
    | Bool
otherwise ->
        ByteString -> RequirementResult
MissingLayer ByteString
instanceLayerName
  RequireInstanceExtension{"layerName" ::: Maybe ByteString
instanceExtensionLayerName :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
instanceExtensionLayerName, ByteString
instanceExtensionName :: InstanceRequirement -> ByteString
instanceExtensionName :: ByteString
instanceExtensionName, Word32
instanceExtensionMinVersion :: InstanceRequirement -> Word32
instanceExtensionMinVersion :: Word32
instanceExtensionMinVersion}
    | Just ExtensionProperties
eProps <-
        ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension
          "layerName" ::: Maybe ByteString
instanceExtensionLayerName
          ByteString
instanceExtensionName ->
        let foundInstanceExtensionVersion :: Word32
foundInstanceExtensionVersion =
              ExtensionProperties -> Word32
Extension.specVersion ExtensionProperties
eProps
        in if Word32
foundInstanceExtensionVersion Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
instanceExtensionMinVersion
             then RequirementResult
Satisfied
             else
               ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedInstanceExtensionVersion
                 ByteString
instanceExtensionName
                 ( Word32 -> Word32 -> Unsatisfied Word32
forall a. a -> a -> Unsatisfied a
Unsatisfied
                     Word32
instanceExtensionMinVersion
                     Word32
foundInstanceExtensionVersion
                 )
    | Bool
otherwise ->
        ByteString -> RequirementResult
UnsatisfiedInstanceExtension ByteString
instanceExtensionName

----------------------------------------------------------------
-- Device
----------------------------------------------------------------

checkDeviceRequirements
  :: forall m o r
   . (MonadIO m, Traversable r, Traversable o)
  => r DeviceRequirement
  -- ^ Required requests
  -> o DeviceRequirement
  -- ^ Optional requests
  -> PhysicalDevice
  -> DeviceCreateInfo '[]
  {- ^ A deviceCreateInfo with no extensions. If you need elements in the
  struct chain you can add them later with
  'Vulkan.CStruct.Extends.extendSomeStruct'
  -}
  -> m
       ( Maybe (SomeStruct DeviceCreateInfo)
       , r RequirementResult
       , o RequirementResult
       )
checkDeviceRequirements :: forall (m :: * -> *) (o :: * -> *) (r :: * -> *).
(MonadIO m, Traversable r, Traversable o) =>
r DeviceRequirement
-> o DeviceRequirement
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
checkDeviceRequirements r DeviceRequirement
required o DeviceRequirement
optional PhysicalDevice
phys DeviceCreateInfo '[]
baseCreateInfo = do
  let
    requiredList :: [DeviceRequirement]
requiredList = r DeviceRequirement -> [DeviceRequirement]
forall a. r a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList r DeviceRequirement
required
    allAsList :: [DeviceRequirement]
allAsList = [DeviceRequirement]
requiredList [DeviceRequirement] -> [DeviceRequirement] -> [DeviceRequirement]
forall a. Semigroup a => a -> a -> a
<> o DeviceRequirement -> [DeviceRequirement]
forall a. o a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o DeviceRequirement
optional

  --
  -- First collect the types and properties that we'll need to query using
  -- getPhysicalDeviceProperties2 and getPhysicalDeviceFeatures2
  --
  [DeviceRequirement]
-> ChainCont
     DeviceFeatureChain
     (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
         o RequirementResult))
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
forall a.
[DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs [DeviceRequirement]
allAsList (ChainCont
   DeviceFeatureChain
   (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
       o RequirementResult))
 -> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
       o RequirementResult))
-> ChainCont
     DeviceFeatureChain
     (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
         o RequirementResult))
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
forall a b. (a -> b) -> a -> b
$ \(Proxy es
_ :: Proxy fs) ->
    [DeviceRequirement]
-> ChainCont
     DevicePropertyChain
     (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
         o RequirementResult))
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
forall a.
[DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs [DeviceRequirement]
allAsList (ChainCont
   DevicePropertyChain
   (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
       o RequirementResult))
 -> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
       o RequirementResult))
-> ChainCont
     DevicePropertyChain
     (m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
         o RequirementResult))
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
forall a b. (a -> b) -> a -> b
$ \(Proxy es
_ :: Proxy ps) -> do
      --
      -- Fetch everything
      --
      feats <- forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe @fs PhysicalDevice
phys
      props <- getPhysicalDevicePropertiesMaybe @ps phys
      (_, layerProps) <- enumerateDeviceLayerProperties phys
      lookupExtension <-
        getLookupExtension
          layerProps
          (Just phys)
          [ deviceExtensionLayerName
          | RequireDeviceExtension{deviceExtensionLayerName} <- allAsList
          ]

      (r, continue) <- flip runStateT True $ for required $ \DeviceRequirement
r ->
        case Maybe (PhysicalDeviceFeatures2 es)
-> Maybe (PhysicalDeviceProperties2 es)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 es)
feats Maybe (PhysicalDeviceProperties2 es)
props ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension DeviceRequirement
r of
          RequirementResult
res -> do
            Bool -> StateT Bool m () -> StateT Bool m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RequirementResult
res RequirementResult -> RequirementResult -> Bool
forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (Bool -> StateT Bool m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
False)
            RequirementResult -> StateT Bool m RequirementResult
forall a. a -> StateT Bool m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      (o, goodOptions) <- flip runStateT mempty $ for optional $ \DeviceRequirement
o ->
        case Maybe (PhysicalDeviceFeatures2 es)
-> Maybe (PhysicalDeviceProperties2 es)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 es)
feats Maybe (PhysicalDeviceProperties2 es)
props ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension DeviceRequirement
o of
          RequirementResult
res -> do
            Bool
-> StateT [DeviceRequirement] m ()
-> StateT [DeviceRequirement] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequirementResult
res RequirementResult -> RequirementResult -> Bool
forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (StateT [DeviceRequirement] m ()
 -> StateT [DeviceRequirement] m ())
-> StateT [DeviceRequirement] m ()
-> StateT [DeviceRequirement] m ()
forall a b. (a -> b) -> a -> b
$ ([DeviceRequirement] -> [DeviceRequirement])
-> StateT [DeviceRequirement] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (DeviceRequirement
o DeviceRequirement -> [DeviceRequirement] -> [DeviceRequirement]
forall a. a -> [a] -> [a]
:)
            RequirementResult -> StateT [DeviceRequirement] m RequirementResult
forall a. a -> StateT [DeviceRequirement] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      --
      -- Now create the types for just the available features
      --
      let dci = do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
            SomeStruct DeviceCreateInfo -> Maybe (SomeStruct DeviceCreateInfo)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeStruct DeviceCreateInfo
 -> Maybe (SomeStruct DeviceCreateInfo))
-> SomeStruct DeviceCreateInfo
-> Maybe (SomeStruct DeviceCreateInfo)
forall a b. (a -> b) -> a -> b
$
              [DeviceRequirement]
-> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo
                ([DeviceRequirement]
requiredList [DeviceRequirement] -> [DeviceRequirement] -> [DeviceRequirement]
forall a. Semigroup a => a -> a -> a
<> [DeviceRequirement]
goodOptions)
                DeviceCreateInfo '[]
baseCreateInfo
      pure (dci, r, o)

{-# ANN makeDeviceCreateInfo ("HLint: ignore Move guards forward" :: String) #-}

{- | Generate 'DeviceCreateInfo' from some requirements.

The returned struct chain will enable all required features and extensions.
-}
makeDeviceCreateInfo
  :: [DeviceRequirement] -> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo :: [DeviceRequirement]
-> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo [DeviceRequirement]
allReqs DeviceCreateInfo '[]
baseCreateInfo =
  let
    featureSetters :: DMap (Product (Has KnownFeatureStruct) Endo)
    featureSetters :: DMap (Product (Has KnownFeatureStruct) Endo)
featureSetters =
      (forall a.
 Product (Has KnownFeatureStruct) Endo a
 -> Product (Has KnownFeatureStruct) Endo a
 -> Product (Has KnownFeatureStruct) Endo a)
-> [DSum (Product (Has KnownFeatureStruct) Endo)]
-> DMap (Product (Has KnownFeatureStruct) Endo)
forall {k} (f :: k -> *).
(forall (a :: k). f a -> f a -> f a) -> [DSum f] -> DMap f
dmapFromListWith
        Product (Has KnownFeatureStruct) Endo a
-> Product (Has KnownFeatureStruct) Endo a
-> Product (Has KnownFeatureStruct) Endo a
forall a.
Product (Has KnownFeatureStruct) Endo a
-> Product (Has KnownFeatureStruct) Endo a
-> Product (Has KnownFeatureStruct) Endo a
forall {k} (f :: k -> *) (a :: k) (g :: k -> *).
(Semigroup (f a), Semigroup (g a)) =>
Product f g a -> Product f g a -> Product f g a
catProducts
        [ TypeRep struct
forall {k} (a :: k). Typeable a => TypeRep a
typeRep TypeRep struct
-> Product (Has KnownFeatureStruct) Endo struct
-> DSum (Product (Has KnownFeatureStruct) Endo)
forall {k} (f :: k -> *) (a :: k). TypeRep a -> f a -> DSum f
:=> Has KnownFeatureStruct struct
-> Endo struct -> Product (Has KnownFeatureStruct) Endo struct
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair Has KnownFeatureStruct struct
forall {k} (c :: k -> Constraint) (a :: k). c a => Has c a
Has ((struct -> struct) -> Endo struct
forall a. (a -> a) -> Endo a
Endo struct -> struct
enableFeature)
        | RequireDeviceFeature{struct -> struct
enableFeature :: struct -> struct
enableFeature :: ()
enableFeature} <- [DeviceRequirement]
allReqs
        ]

    makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]
    makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]
makeZeroFeatureExts =
      [ (SomeStruct DeviceCreateInfo -> SomeStruct DeviceCreateInfo)
-> Endo (SomeStruct DeviceCreateInfo)
forall a. (a -> a) -> Endo a
Endo (a -> SomeStruct DeviceCreateInfo -> SomeStruct DeviceCreateInfo
forall (a :: [*] -> *) e.
(Extensible a, Extends a e, ToCStruct e, Show e) =>
e -> SomeStruct a -> SomeStruct a
extendSomeStruct a
s)
      | TypeRep a
_ :=> Pair Has KnownFeatureStruct a
Has (Endo a
f :: Endo s) <- DMap (Product (Has KnownFeatureStruct) Endo)
-> [DSum (Product (Has KnownFeatureStruct) Endo)]
forall {k} (f :: k -> *). DMap f -> [DSum f]
dmapToList DMap (Product (Has KnownFeatureStruct) Endo)
featureSetters
      , SFeatureStruct a
ExtendedFeatureStruct <- SFeatureStruct a -> [SFeatureStruct a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SFeatureStruct a -> [SFeatureStruct a])
-> SFeatureStruct a -> [SFeatureStruct a]
forall a b. (a -> b) -> a -> b
$ forall feat. KnownFeatureStruct feat => SFeatureStruct feat
sFeatureStruct @s
      , let s :: a
s = Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo Endo a
f a
forall a. Zero a => a
zero
      ]

    addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)
    addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)
addBasicFeatures =
      case TypeRep PhysicalDeviceFeatures
-> DMap (Product (Has KnownFeatureStruct) Endo)
-> Maybe
     (Product (Has KnownFeatureStruct) Endo PhysicalDeviceFeatures)
forall {k} (a :: k) (f :: k -> *).
TypeRep a -> DMap f -> Maybe (f a)
dmapLookup (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @PhysicalDeviceFeatures) DMap (Product (Has KnownFeatureStruct) Endo)
featureSetters of
        Maybe
  (Product (Has KnownFeatureStruct) Endo PhysicalDeviceFeatures)
Nothing -> Endo (SomeStruct DeviceCreateInfo)
forall a. Monoid a => a
mempty
        Just (Pair Has KnownFeatureStruct PhysicalDeviceFeatures
_ Endo PhysicalDeviceFeatures
s) ->
          (SomeStruct DeviceCreateInfo -> SomeStruct DeviceCreateInfo)
-> Endo (SomeStruct DeviceCreateInfo)
forall a. (a -> a) -> Endo a
Endo
            ( PhysicalDeviceFeatures2 '[]
-> SomeStruct DeviceCreateInfo -> SomeStruct DeviceCreateInfo
forall (a :: [*] -> *) e.
(Extensible a, Extends a e, ToCStruct e, Show e) =>
e -> SomeStruct a -> SomeStruct a
extendSomeStruct
                ((PhysicalDeviceFeatures2 '[]
forall a. Zero a => a
zero :: PhysicalDeviceFeatures2 '[]){features = appEndo s zero})
            )

    extensionNames :: [ByteString]
    extensionNames :: [ByteString]
extensionNames =
      [ ByteString
deviceExtensionName
      | RequireDeviceExtension{ByteString
deviceExtensionName :: ByteString
deviceExtensionName :: DeviceRequirement -> ByteString
deviceExtensionName} <- [DeviceRequirement]
allReqs
      ]

    newFeatures :: SomeStruct DeviceCreateInfo
    newFeatures :: SomeStruct DeviceCreateInfo
newFeatures =
      Endo (SomeStruct DeviceCreateInfo)
-> SomeStruct DeviceCreateInfo -> SomeStruct DeviceCreateInfo
forall a. Endo a -> a -> a
appEndo
        ([Endo (SomeStruct DeviceCreateInfo)]
-> Endo (SomeStruct DeviceCreateInfo)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Endo (SomeStruct DeviceCreateInfo)
addBasicFeatures Endo (SomeStruct DeviceCreateInfo)
-> [Endo (SomeStruct DeviceCreateInfo)]
-> [Endo (SomeStruct DeviceCreateInfo)]
forall a. a -> [a] -> [a]
: [Endo (SomeStruct DeviceCreateInfo)]
makeZeroFeatureExts))
        ( DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct
            (DeviceCreateInfo '[]
baseCreateInfo :: DeviceCreateInfo '[])
              { Device.enabledExtensionNames = V.fromList extensionNames
              }
        )
  in
    SomeStruct DeviceCreateInfo
newFeatures

checkDeviceRequest
  :: forall fs ps
   . (KnownChain fs, KnownChain ps)
  => Maybe (PhysicalDeviceFeatures2 fs)
  -> Maybe (PhysicalDeviceProperties2 ps)
  -> ( ("layerName" ::: Maybe ByteString)
       -> ("extensionName" ::: ByteString)
       -> Maybe ExtensionProperties
     )
  -- ^ Lookup an extension
  -> DeviceRequirement
  -> RequirementResult
checkDeviceRequest :: forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 fs)
mbFeats Maybe (PhysicalDeviceProperties2 ps)
mbProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireDeviceVersion Word32
minVersion
    | Just PhysicalDeviceProperties2 ps
props <- Maybe (PhysicalDeviceProperties2 ps)
mbProps
    , Word32
foundVersion <- PhysicalDeviceProperties -> Word32
PhysicalDevice.apiVersion (PhysicalDeviceProperties2 ps -> PhysicalDeviceProperties
forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
PhysicalDevice.properties PhysicalDeviceProperties2 ps
props) ->
        if Word32
foundVersion Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
minVersion
          then RequirementResult
Satisfied
          else Unsatisfied Word32 -> RequirementResult
UnsatisfiedDeviceVersion (Word32 -> Word32 -> Unsatisfied Word32
forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
minVersion Word32
foundVersion)
    | Bool
otherwise ->
        ByteString -> RequirementResult
UnattemptedProperties ByteString
"apiVersion"
  RequireDeviceFeature{ByteString
featureName :: ByteString
featureName :: DeviceRequirement -> ByteString
featureName, struct -> Bool
checkFeature :: struct -> Bool
checkFeature :: ()
checkFeature}
    | Just PhysicalDeviceFeatures2 fs
feats <- Maybe (PhysicalDeviceFeatures2 fs)
mbFeats -> case PhysicalDeviceFeatures2 fs -> Maybe struct
forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceFeatures2 es -> Maybe s
getFeatureStruct PhysicalDeviceFeatures2 fs
feats of
        Maybe struct
Nothing ->
          [Char] -> RequirementResult
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: didn't find requested feature in struct chain"
        Just struct
s ->
          if struct -> Bool
checkFeature struct
s then RequirementResult
Satisfied else ByteString -> RequirementResult
UnsatisfiedFeature ByteString
featureName
    | Bool
otherwise -> ByteString -> RequirementResult
UnattemptedFeatures ByteString
featureName
  RequireDeviceProperty{ByteString
propertyName :: ByteString
propertyName :: DeviceRequirement -> ByteString
propertyName, struct -> Bool
checkProperty :: struct -> Bool
checkProperty :: ()
checkProperty}
    | Just PhysicalDeviceProperties2 ps
props <- Maybe (PhysicalDeviceProperties2 ps)
mbProps -> case PhysicalDeviceProperties2 ps -> Maybe struct
forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceProperties2 es -> Maybe s
getPropertyStruct PhysicalDeviceProperties2 ps
props of
        Maybe struct
Nothing ->
          [Char] -> RequirementResult
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: didn't find requested property in struct chain"
        Just struct
s ->
          if struct -> Bool
checkProperty struct
s then RequirementResult
Satisfied else ByteString -> RequirementResult
UnsatisfiedProperty ByteString
propertyName
    | Bool
otherwise -> ByteString -> RequirementResult
UnattemptedProperties ByteString
propertyName
  RequireDeviceExtension{"layerName" ::: Maybe ByteString
deviceExtensionLayerName :: DeviceRequirement -> "layerName" ::: Maybe ByteString
deviceExtensionLayerName :: "layerName" ::: Maybe ByteString
deviceExtensionLayerName, ByteString
deviceExtensionName :: DeviceRequirement -> ByteString
deviceExtensionName :: ByteString
deviceExtensionName, Word32
deviceExtensionMinVersion :: Word32
deviceExtensionMinVersion :: DeviceRequirement -> Word32
deviceExtensionMinVersion}
    | Just ExtensionProperties
eProps <-
        ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension
          "layerName" ::: Maybe ByteString
deviceExtensionLayerName
          ByteString
deviceExtensionName ->
        let foundVersion :: Word32
foundVersion = ExtensionProperties -> Word32
Extension.specVersion ExtensionProperties
eProps
        in if Word32
foundVersion Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
deviceExtensionMinVersion
             then RequirementResult
Satisfied
             else
               ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedDeviceExtensionVersion
                 ByteString
deviceExtensionName
                 (Word32 -> Word32 -> Unsatisfied Word32
forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
deviceExtensionMinVersion Word32
foundVersion)
    | Bool
otherwise ->
        ByteString -> RequirementResult
UnsatisfiedDeviceExtension ByteString
deviceExtensionName

----------------------------------------------------------------
-- Results
----------------------------------------------------------------

-- TODO, better version reporting for extensions
-- TODO, better reporting for properties
data RequirementResult
  = -- | All the requirements were met
    Satisfied
  | {- | Didn't attempt this check because it required
    getPhysicalDeviceProperties2 which wasn't loaded
    -}
    UnattemptedProperties ByteString
  | {- | Didn't attempt this check because it required
    getPhysicalDeviceFeatures2 which wasn't loaded
    -}
    UnattemptedFeatures ByteString
  | -- | A Layer was not found
    MissingLayer ByteString
  | -- | A device version didn't meet the minimum requested
    UnsatisfiedDeviceVersion (Unsatisfied Word32)
  | -- | The instance version didn't meet the minimum requested
    UnsatisfiedInstanceVersion (Unsatisfied Word32)
  | -- | A layer version didn't meet the minimum requested
    UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)
  | -- | A feature was missing
    UnsatisfiedFeature ByteString
  | -- | A propery was not an appropriate value
    UnsatisfiedProperty ByteString
  | -- | A device extension was missing
    UnsatisfiedDeviceExtension ByteString
  | -- | A device extension was found but the version didn't meet requirements
    UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32)
  | -- | An instance extension was missing
    UnsatisfiedInstanceExtension ByteString
  | -- | An instance extension was found but the version didn't meet requirements
    UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32)
  deriving (RequirementResult -> RequirementResult -> Bool
(RequirementResult -> RequirementResult -> Bool)
-> (RequirementResult -> RequirementResult -> Bool)
-> Eq RequirementResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequirementResult -> RequirementResult -> Bool
== :: RequirementResult -> RequirementResult -> Bool
$c/= :: RequirementResult -> RequirementResult -> Bool
/= :: RequirementResult -> RequirementResult -> Bool
Eq, Eq RequirementResult
Eq RequirementResult =>
(RequirementResult -> RequirementResult -> Ordering)
-> (RequirementResult -> RequirementResult -> Bool)
-> (RequirementResult -> RequirementResult -> Bool)
-> (RequirementResult -> RequirementResult -> Bool)
-> (RequirementResult -> RequirementResult -> Bool)
-> (RequirementResult -> RequirementResult -> RequirementResult)
-> (RequirementResult -> RequirementResult -> RequirementResult)
-> Ord RequirementResult
RequirementResult -> RequirementResult -> Bool
RequirementResult -> RequirementResult -> Ordering
RequirementResult -> RequirementResult -> RequirementResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RequirementResult -> RequirementResult -> Ordering
compare :: RequirementResult -> RequirementResult -> Ordering
$c< :: RequirementResult -> RequirementResult -> Bool
< :: RequirementResult -> RequirementResult -> Bool
$c<= :: RequirementResult -> RequirementResult -> Bool
<= :: RequirementResult -> RequirementResult -> Bool
$c> :: RequirementResult -> RequirementResult -> Bool
> :: RequirementResult -> RequirementResult -> Bool
$c>= :: RequirementResult -> RequirementResult -> Bool
>= :: RequirementResult -> RequirementResult -> Bool
$cmax :: RequirementResult -> RequirementResult -> RequirementResult
max :: RequirementResult -> RequirementResult -> RequirementResult
$cmin :: RequirementResult -> RequirementResult -> RequirementResult
min :: RequirementResult -> RequirementResult -> RequirementResult
Ord)

data Unsatisfied a = Unsatisfied
  { forall a. Unsatisfied a -> a
unsatisfiedMinimum :: a
  -- ^ The minimum value to be accepted
  , forall a. Unsatisfied a -> a
unsatisfiedActual :: a
  -- ^ The value we got, less than 'unsatisfiedMinumum'
  }
  deriving (Unsatisfied a -> Unsatisfied a -> Bool
(Unsatisfied a -> Unsatisfied a -> Bool)
-> (Unsatisfied a -> Unsatisfied a -> Bool) -> Eq (Unsatisfied a)
forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
== :: Unsatisfied a -> Unsatisfied a -> Bool
$c/= :: forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
/= :: Unsatisfied a -> Unsatisfied a -> Bool
Eq, Eq (Unsatisfied a)
Eq (Unsatisfied a) =>
(Unsatisfied a -> Unsatisfied a -> Ordering)
-> (Unsatisfied a -> Unsatisfied a -> Bool)
-> (Unsatisfied a -> Unsatisfied a -> Bool)
-> (Unsatisfied a -> Unsatisfied a -> Bool)
-> (Unsatisfied a -> Unsatisfied a -> Bool)
-> (Unsatisfied a -> Unsatisfied a -> Unsatisfied a)
-> (Unsatisfied a -> Unsatisfied a -> Unsatisfied a)
-> Ord (Unsatisfied a)
Unsatisfied a -> Unsatisfied a -> Bool
Unsatisfied a -> Unsatisfied a -> Ordering
Unsatisfied a -> Unsatisfied a -> Unsatisfied a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Unsatisfied a)
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Ordering
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$ccompare :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Ordering
compare :: Unsatisfied a -> Unsatisfied a -> Ordering
$c< :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
< :: Unsatisfied a -> Unsatisfied a -> Bool
$c<= :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
<= :: Unsatisfied a -> Unsatisfied a -> Bool
$c> :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
> :: Unsatisfied a -> Unsatisfied a -> Bool
$c>= :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
>= :: Unsatisfied a -> Unsatisfied a -> Bool
$cmax :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
max :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$cmin :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
min :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
Ord)

{- | Generate a string describing which requirements were not met, if
everything was satisfied return 'Nothing'.
-}
requirementReport
  :: (Foldable r, Foldable o)
  => r RequirementResult
  -> o RequirementResult
  -> Maybe String
requirementReport :: forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe [Char]
requirementReport r RequirementResult
required o RequirementResult
optional =
  let
    pList :: t RequirementResult -> [[Char]]
pList t RequirementResult
xs =
      [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd [RequirementResult -> [Char]
prettyRequirementResult RequirementResult
r | RequirementResult
r <- t RequirementResult -> [RequirementResult]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t RequirementResult
xs, RequirementResult
r RequirementResult -> RequirementResult -> Bool
forall a. Eq a => a -> a -> Bool
/= RequirementResult
Satisfied]
    reqStrings :: [[Char]]
reqStrings = r RequirementResult -> [[Char]]
forall {t :: * -> *}. Foldable t => t RequirementResult -> [[Char]]
pList r RequirementResult
required
    optStrings :: [[Char]]
optStrings = o RequirementResult -> [[Char]]
forall {t :: * -> *}. Foldable t => t RequirementResult -> [[Char]]
pList o RequirementResult
optional
    withHeader :: a -> [a] -> [a]
withHeader a
s = \case
      [] -> []
      [a]
xs -> (a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" requirements not met:") a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ((a
"  " a -> a -> a
forall a. Semigroup a => a -> a -> a
<>) (a -> a) -> [a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs)
    reportLines :: [[Char]]
reportLines =
      [Char] -> [[Char]] -> [[Char]]
forall {a}. (Semigroup a, IsString a) => a -> [a] -> [a]
withHeader [Char]
"Required" [[Char]]
reqStrings [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [[Char]] -> [[Char]]
forall {a}. (Semigroup a, IsString a) => a -> [a] -> [a]
withHeader [Char]
"Optional" [[Char]]
optStrings
  in
    if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
reportLines then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
reportLines

prettyRequirementResult :: RequirementResult -> String
prettyRequirementResult :: RequirementResult -> [Char]
prettyRequirementResult = \case
  RequirementResult
Satisfied -> [Char]
"Satisfied"
  UnattemptedProperties ByteString
n ->
    [Char]
"Did not attempt to check "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" because the 'getPhysicalDeviceProperties' function was not loaded"
  UnattemptedFeatures ByteString
n ->
    [Char]
"Did not attempt to check "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" because the 'getPhysicalDeviceFeatures' function was not loaded"
  MissingLayer ByteString
n -> [Char]
"Couldn't find layer: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceVersion Unsatisfied Word32
u -> [Char]
"Unsatisfied Instance version: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedDeviceVersion Unsatisfied Word32
u -> [Char]
"Unsatisfied Device version: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedLayerVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied layer version for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedFeature ByteString
n -> [Char]
"Missing feature: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedProperty ByteString
n -> [Char]
"Unsatisfied property: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceExtension ByteString
n ->
    [Char]
"Couldn't find instance extension: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceExtensionVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied Instance extension version " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedDeviceExtension ByteString
n -> [Char]
"Couldn't find device extension: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedDeviceExtensionVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied Device extension version " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  where
    p :: Unsatisfied Word32 -> [Char]
p = (Word32 -> [Char]) -> Unsatisfied Word32 -> [Char]
forall t. (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied Word32 -> [Char]
showVersion

-- How I'm feeling after writing all this type level nonsense
prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String
prettyUnsatisfied :: forall t. (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied t -> [Char]
s Unsatisfied{t
unsatisfiedMinimum :: forall a. Unsatisfied a -> a
unsatisfiedActual :: forall a. Unsatisfied a -> a
unsatisfiedMinimum :: t
unsatisfiedActual :: t
..} =
  [Char]
"Wanted minimum of "
    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> t -> [Char]
s t
unsatisfiedMinimum
    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", got: "
    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> t -> [Char]
s t
unsatisfiedActual

----------------------------------------------------------------
-- Chain lenses
----------------------------------------------------------------

-- | Enough information to focus on any structure within a Vulkan structure chain.
class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where
  {- | If the given structure can be found within a chain, return a lens to it.
  Otherwise, return 'Nothing'.
  -}
  has :: forall a. (Typeable a) => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))

  -- | Is this chain empty?
  knownChainNull :: Maybe (xs :~: '[])

instance KnownChain '[] where
  has :: forall a.
Typeable a =>
Proxy# a
-> Maybe (Chain '[] -> a, (a -> a) -> Chain '[] -> Chain '[])
has Proxy# a
_ = Maybe (() -> a, (a -> a) -> () -> ())
Maybe (Chain '[] -> a, (a -> a) -> Chain '[] -> Chain '[])
forall a. Maybe a
Nothing
  knownChainNull :: Maybe ('[] :~: '[])
knownChainNull = ('[] :~: '[]) -> Maybe ('[] :~: '[])
forall a. a -> Maybe a
Just '[] :~: '[]
forall {k} (a :: k). a :~: a
Refl

instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where
  has :: forall a.
Typeable a =>
Proxy# a
-> Maybe
     (Chain (x : xs) -> a, (a -> a) -> Chain (x : xs) -> Chain (x : xs))
has (Proxy# a
px :: Proxy# a)
    | Just a :~: x
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @x = ((a, Chain xs) -> a, (a -> a) -> (a, Chain xs) -> (a, Chain xs))
-> Maybe
     ((a, Chain xs) -> a, (a -> a) -> (a, Chain xs) -> (a, Chain xs))
forall a. a -> Maybe a
Just ((a, Chain xs) -> a
forall a b. (a, b) -> a
fst, (a -> a) -> (a, Chain xs) -> (a, Chain xs)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first)
    | Bool
otherwise = (((Chain xs -> a)
-> ((x, Chain xs) -> Chain xs) -> (x, Chain xs) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x, Chain xs) -> Chain xs
forall a b. (a, b) -> b
snd) ((Chain xs -> a) -> (x, Chain xs) -> a)
-> (((a -> a) -> Chain xs -> Chain xs)
    -> (a -> a) -> (x, Chain xs) -> (x, Chain xs))
-> (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
-> ((x, Chain xs) -> a, (a -> a) -> (x, Chain xs) -> (x, Chain xs))
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ((Chain xs -> Chain xs) -> (x, Chain xs) -> (x, Chain xs)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Chain xs -> Chain xs) -> (x, Chain xs) -> (x, Chain xs))
-> ((a -> a) -> Chain xs -> Chain xs)
-> (a -> a)
-> (x, Chain xs)
-> (x, Chain xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) ((Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
 -> ((x, Chain xs) -> a,
     (a -> a) -> (x, Chain xs) -> (x, Chain xs)))
-> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
-> Maybe
     ((x, Chain xs) -> a, (a -> a) -> (x, Chain xs) -> (x, Chain xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
forall (xs :: [*]) a.
(KnownChain xs, Typeable a) =>
Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
forall a.
Typeable a =>
Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
has Proxy# a
px
  knownChainNull :: Maybe ((x : xs) :~: '[])
knownChainNull = Maybe ((x : xs) :~: '[])
forall a. Maybe a
Nothing

getPropertyStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceProperties2 es
  -> Maybe s
getPropertyStruct :: forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceProperties2 es -> Maybe s
getPropertyStruct PhysicalDeviceProperties2 es
c = case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @PhysicalDeviceProperties @s of
  Just PhysicalDeviceProperties :~: s
Refl -> PhysicalDeviceProperties -> Maybe PhysicalDeviceProperties
forall a. a -> Maybe a
Just (PhysicalDeviceProperties -> Maybe PhysicalDeviceProperties)
-> PhysicalDeviceProperties -> Maybe PhysicalDeviceProperties
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
PhysicalDevice.properties PhysicalDeviceProperties2 es
c
  Maybe (PhysicalDeviceProperties :~: s)
Nothing -> PhysicalDeviceProperties2 es -> Maybe s
forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct PhysicalDeviceProperties2 es
c

getFeatureStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceFeatures2 es
  -> Maybe s
getFeatureStruct :: forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceFeatures2 es -> Maybe s
getFeatureStruct PhysicalDeviceFeatures2 es
c = case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @PhysicalDeviceFeatures @s of
  Just PhysicalDeviceFeatures :~: s
Refl -> PhysicalDeviceFeatures -> Maybe PhysicalDeviceFeatures
forall a. a -> Maybe a
Just (PhysicalDeviceFeatures -> Maybe PhysicalDeviceFeatures)
-> PhysicalDeviceFeatures -> Maybe PhysicalDeviceFeatures
forall a b. (a -> b) -> a -> b
$ PhysicalDeviceFeatures2 es -> PhysicalDeviceFeatures
forall (es :: [*]).
PhysicalDeviceFeatures2 es -> PhysicalDeviceFeatures
PhysicalDevice.features PhysicalDeviceFeatures2 es
c
  Maybe (PhysicalDeviceFeatures :~: s)
Nothing -> PhysicalDeviceFeatures2 es -> Maybe s
forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct PhysicalDeviceFeatures2 es
c

getStruct
  :: forall s h es
   . (Typeable h, Typeable s, KnownChain es, Extensible h)
  => h es
  -> Maybe s
getStruct :: forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct h es
c = ((Chain es -> s) -> Chain es -> s
forall a b. (a -> b) -> a -> b
$ h es -> Chain es
forall (es :: [*]). h es -> Chain es
forall (a :: [*] -> *) (es :: [*]).
Extensible a =>
a es -> Chain es
getNext h es
c) ((Chain es -> s) -> s)
-> ((Chain es -> s, (s -> s) -> Chain es -> Chain es)
    -> Chain es -> s)
-> (Chain es -> s, (s -> s) -> Chain es -> Chain es)
-> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain es -> s, (s -> s) -> Chain es -> Chain es) -> Chain es -> s
forall a b. (a, b) -> a
fst ((Chain es -> s, (s -> s) -> Chain es -> Chain es) -> s)
-> Maybe (Chain es -> s, (s -> s) -> Chain es -> Chain es)
-> Maybe s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy# s -> Maybe (Chain es -> s, (s -> s) -> Chain es -> Chain es)
forall (xs :: [*]) a.
(KnownChain xs, Typeable a) =>
Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
forall a.
Typeable a =>
Proxy# a -> Maybe (Chain es -> a, (a -> a) -> Chain es -> Chain es)
has (Proxy# s
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# s)

----------------------------------------------------------------
-- Helpers for 'Device' and 'Instance' extensions
----------------------------------------------------------------

{- | Make a lookup function for extensions in layers. Ignores layers not
present in the instance/device
-}
getLookupExtension
  :: (MonadIO m)
  => Vector LayerProperties
  -> Maybe PhysicalDevice
  {- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for
  'Device' extensions.
  -}
  -> ["layerName" ::: Maybe ByteString]
  -> m
       ( ("layerName" ::: Maybe ByteString)
         -> ByteString
         -> Maybe ExtensionProperties
       )
getLookupExtension :: forall (m :: * -> *).
MonadIO m =>
("properties" ::: Vector LayerProperties)
-> Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension "properties" ::: Vector LayerProperties
layerProps Maybe PhysicalDevice
mbPhys ["layerName" ::: Maybe ByteString]
extensionLayers = do
  let
    enumerate :: ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
enumerate =
      (("layerName" ::: Maybe ByteString)
 -> m (Result, Vector ExtensionProperties))
-> (PhysicalDevice
    -> ("layerName" ::: Maybe ByteString)
    -> m (Result, Vector ExtensionProperties))
-> Maybe PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
("layerName" ::: Maybe ByteString)
-> io (Result, Vector ExtensionProperties)
enumerateInstanceExtensionProperties
        PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, Vector ExtensionProperties)
enumerateDeviceExtensionProperties
        Maybe PhysicalDevice
mbPhys
    availableLayers :: ["layerName" ::: Maybe ByteString]
availableLayers = "layerName" ::: Maybe ByteString
forall a. Maybe a
Nothing ("layerName" ::: Maybe ByteString)
-> ["layerName" ::: Maybe ByteString]
-> ["layerName" ::: Maybe ByteString]
forall a. a -> [a] -> [a]
: ((ByteString -> "layerName" ::: Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> "layerName" ::: Maybe ByteString)
-> (LayerProperties -> ByteString)
-> LayerProperties
-> "layerName" ::: Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerProperties -> ByteString
layerName) (LayerProperties -> "layerName" ::: Maybe ByteString)
-> [LayerProperties] -> ["layerName" ::: Maybe ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ("properties" ::: Vector LayerProperties) -> [LayerProperties]
forall a. Vector a -> [a]
V.toList "properties" ::: Vector LayerProperties
layerProps)
    searchedLayers :: ["layerName" ::: Maybe ByteString]
searchedLayers = ["layerName" ::: Maybe ByteString]
availableLayers ["layerName" ::: Maybe ByteString]
-> ["layerName" ::: Maybe ByteString]
-> ["layerName" ::: Maybe ByteString]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` ["layerName" ::: Maybe ByteString]
extensionLayers
  extensions <- ["layerName" ::: Maybe ByteString]
-> (("layerName" ::: Maybe ByteString)
    -> m ("layerName" ::: Maybe ByteString,
          Vector ExtensionProperties))
-> m [("layerName" ::: Maybe ByteString,
       Vector ExtensionProperties)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ["layerName" ::: Maybe ByteString]
searchedLayers ((("layerName" ::: Maybe ByteString)
  -> m ("layerName" ::: Maybe ByteString,
        Vector ExtensionProperties))
 -> m [("layerName" ::: Maybe ByteString,
        Vector ExtensionProperties)])
-> (("layerName" ::: Maybe ByteString)
    -> m ("layerName" ::: Maybe ByteString,
          Vector ExtensionProperties))
-> m [("layerName" ::: Maybe ByteString,
       Vector ExtensionProperties)]
forall a b. (a -> b) -> a -> b
$ \"layerName" ::: Maybe ByteString
layer -> do
    (_, props) <- ("layerName" ::: Maybe ByteString)
-> m (Result, Vector ExtensionProperties)
enumerate "layerName" ::: Maybe ByteString
layer
    pure (layer, props)
  let extensionMap = (Vector ExtensionProperties
 -> Vector ExtensionProperties -> Vector ExtensionProperties)
-> [("layerName" ::: Maybe ByteString, Vector ExtensionProperties)]
-> HashMap
     ("layerName" ::: Maybe ByteString) (Vector ExtensionProperties)
forall k v. Hashable k => (v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith Vector ExtensionProperties
-> Vector ExtensionProperties -> Vector ExtensionProperties
forall a. Semigroup a => a -> a -> a
(<>) [("layerName" ::: Maybe ByteString, Vector ExtensionProperties)]
extensions
  pure $ \"layerName" ::: Maybe ByteString
layer ByteString
name -> do
    es <- ("layerName" ::: Maybe ByteString)
-> HashMap
     ("layerName" ::: Maybe ByteString) (Vector ExtensionProperties)
-> Maybe (Vector ExtensionProperties)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup "layerName" ::: Maybe ByteString
layer HashMap
  ("layerName" ::: Maybe ByteString) (Vector ExtensionProperties)
extensionMap
    find ((== name) . extensionName) es

----------------------------------------------------------------
-- Helpers for extracting the type of chain used by a set of requirements
----------------------------------------------------------------

withDevicePropertyStructs
  :: forall a. [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs :: forall a.
[DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs = forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @'[] []
  where
    go
      :: forall (fs :: [Type])
       . (DevicePropertyChain fs)
      => [SomeTypeRep]
      -> [DeviceRequirement]
      -> ChainCont DevicePropertyChain a
      -> a
    go :: forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go [SomeTypeRep]
seen [DeviceRequirement]
reqs ChainCont DevicePropertyChain a
f = case [DeviceRequirement]
reqs of
      -- We've been through all the reqs, call the continuation with the types
      [] -> Proxy fs -> a
ChainCont DevicePropertyChain a
f (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @fs)
      -- This is a device property, add it to the list if we've not seen it before
      (RequireDeviceProperty ByteString
_ (struct -> Bool
_ :: s -> Bool)) : [DeviceRequirement]
rs
        | SPropertyStruct struct
ExtendedPropertyStruct <- forall prop. KnownPropertyStruct prop => SPropertyStruct prop
sPropertyStruct @s
        , SomeTypeRep
sRep <- TypeRep struct -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @s)
        , SomeTypeRep
sRep SomeTypeRep -> [SomeTypeRep] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [SomeTypeRep]
seen ->
            forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @(s : fs) (SomeTypeRep
sRep SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: [SomeTypeRep]
seen) [DeviceRequirement]
rs Proxy es -> a
ChainCont DevicePropertyChain a
f
      -- Otherwise skip
      DeviceRequirement
_ : [DeviceRequirement]
rs -> forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs Proxy es -> a
ChainCont DevicePropertyChain a
f

withDeviceFeatureStructs
  :: forall a. [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs :: forall a.
[DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs = forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @'[] []
  where
    go
      :: forall (fs :: [Type])
       . (DeviceFeatureChain fs)
      => [SomeTypeRep]
      -> [DeviceRequirement]
      -> ChainCont DeviceFeatureChain a
      -> a
    go :: forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go [SomeTypeRep]
seen [DeviceRequirement]
reqs ChainCont DeviceFeatureChain a
f = case [DeviceRequirement]
reqs of
      -- We've been through all the reqs, call the continuation with the types
      [] -> Proxy fs -> a
ChainCont DeviceFeatureChain a
f (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @fs)
      -- This is a device feature, add it to the list if we've not seen it before
      (RequireDeviceFeature ByteString
_ struct -> Bool
_ (struct -> struct
_ :: s -> s)) : [DeviceRequirement]
rs
        | SFeatureStruct struct
ExtendedFeatureStruct <- forall feat. KnownFeatureStruct feat => SFeatureStruct feat
sFeatureStruct @s
        , SomeTypeRep
sRep <- TypeRep struct -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @s)
        , SomeTypeRep
sRep SomeTypeRep -> [SomeTypeRep] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [SomeTypeRep]
seen ->
            forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @(s : fs) (SomeTypeRep
sRep SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: [SomeTypeRep]
seen) [DeviceRequirement]
rs Proxy es -> a
ChainCont DeviceFeatureChain a
f
      -- Otherwise skip
      DeviceRequirement
_ : [DeviceRequirement]
rs -> forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs Proxy es -> a
ChainCont DeviceFeatureChain a
f

class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es
instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es

class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es
instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es

type ChainCont c a = forall (es :: [Type]). (c es) => Proxy es -> a

----------------------------------------------------------------
-- Helpers for getting features and properties without using the extended
-- versions of the functions if possible.
----------------------------------------------------------------

getPhysicalDeviceFeaturesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe :: forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe =
  (InstanceCmds
 -> FunPtr
      (Ptr PhysicalDevice_T
       -> Ptr (SomeStruct PhysicalDeviceFeatures2) -> IO ()))
-> (PhysicalDeviceFeatures -> PhysicalDeviceFeatures2 '[])
-> (PhysicalDevice -> m PhysicalDeviceFeatures)
-> (PhysicalDevice -> m (PhysicalDeviceFeatures2 fs))
-> PhysicalDevice
-> m (Maybe (PhysicalDeviceFeatures2 fs))
forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe
    InstanceCmds
-> FunPtr
     (Ptr PhysicalDevice_T
      -> Ptr (SomeStruct PhysicalDeviceFeatures2) -> IO ())
pVkGetPhysicalDeviceFeatures2
    (Chain '[] -> PhysicalDeviceFeatures -> PhysicalDeviceFeatures2 '[]
forall (es :: [*]).
Chain es -> PhysicalDeviceFeatures -> PhysicalDeviceFeatures2 es
PhysicalDeviceFeatures2 ())
    PhysicalDevice -> m PhysicalDeviceFeatures
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceFeatures
getPhysicalDeviceFeatures
    PhysicalDevice -> m (PhysicalDeviceFeatures2 fs)
forall (a :: [*]) (io :: * -> *).
(Extendss PhysicalDeviceFeatures2 a, PokeChain a, PeekChain a,
 MonadIO io) =>
PhysicalDevice -> io (PhysicalDeviceFeatures2 a)
getPhysicalDeviceFeatures2

getPhysicalDevicePropertiesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe :: forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs,
 Extendss PhysicalDeviceProperties2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe =
  (InstanceCmds
 -> FunPtr
      (Ptr PhysicalDevice_T
       -> Ptr (SomeStruct PhysicalDeviceProperties2) -> IO ()))
-> (PhysicalDeviceProperties -> PhysicalDeviceProperties2 '[])
-> (PhysicalDevice -> m PhysicalDeviceProperties)
-> (PhysicalDevice -> m (PhysicalDeviceProperties2 fs))
-> PhysicalDevice
-> m (Maybe (PhysicalDeviceProperties2 fs))
forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe
    InstanceCmds
-> FunPtr
     (Ptr PhysicalDevice_T
      -> Ptr (SomeStruct PhysicalDeviceProperties2) -> IO ())
pVkGetPhysicalDeviceProperties2
    (Chain '[]
-> PhysicalDeviceProperties -> PhysicalDeviceProperties2 '[]
forall (es :: [*]).
Chain es
-> PhysicalDeviceProperties -> PhysicalDeviceProperties2 es
PhysicalDeviceProperties2 ())
    PhysicalDevice -> m PhysicalDeviceProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
getPhysicalDeviceProperties
    PhysicalDevice -> m (PhysicalDeviceProperties2 fs)
forall (a :: [*]) (io :: * -> *).
(Extendss PhysicalDeviceProperties2 a, PokeChain a, PeekChain a,
 MonadIO io) =>
PhysicalDevice -> io (PhysicalDeviceProperties2 a)
getPhysicalDeviceProperties2

getMaybe
  :: forall fs s1 s2 m
   . (MonadIO m, KnownChain fs, Extendss s2 fs)
  => ( InstanceCmds
       -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
     )
  -> (s1 -> s2 '[])
  -> (PhysicalDevice -> m s1)
  -> (PhysicalDevice -> m (s2 fs))
  -> PhysicalDevice
  -> m (Maybe (s2 fs))
getMaybe :: forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr s1 -> s2 '[]
wrapper2 PhysicalDevice -> m s1
get1 PhysicalDevice -> m (s2 fs)
get2 PhysicalDevice
phys =
  let hasFunPtr :: Bool
hasFunPtr = InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr (PhysicalDevice -> InstanceCmds
PhysicalDevice.instanceCmds PhysicalDevice
phys) FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
-> Bool
forall a. Eq a => a -> a -> Bool
/= FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
forall a. FunPtr a
nullFunPtr
  in case forall (xs :: [*]). KnownChain xs => Maybe (xs :~: '[])
knownChainNull @fs of
       Just fs :~: '[]
Refl -> s2 fs -> Maybe (s2 fs)
forall a. a -> Maybe a
Just (s2 fs -> Maybe (s2 fs)) -> (s1 -> s2 fs) -> s1 -> Maybe (s2 fs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> s2 fs
s1 -> s2 '[]
wrapper2 (s1 -> Maybe (s2 fs)) -> m s1 -> m (Maybe (s2 fs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m s1
get1 PhysicalDevice
phys
       Maybe (fs :~: '[])
Nothing -> if Bool
hasFunPtr then s2 fs -> Maybe (s2 fs)
forall a. a -> Maybe a
Just (s2 fs -> Maybe (s2 fs)) -> m (s2 fs) -> m (Maybe (s2 fs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m (s2 fs)
get2 PhysicalDevice
phys else Maybe (s2 fs) -> m (Maybe (s2 fs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (s2 fs)
forall a. Maybe a
Nothing

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

showVersion :: Word32 -> String
showVersion :: Word32 -> [Char]
showVersion Word32
ver = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." [Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
ma, Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
mi, Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
pa]
  where
    MAKE_API_VERSION Word32
ma Word32
mi Word32
pa = Word32
ver

data Has c a where
  Has :: (c a) => Has c a

instance Semigroup (Has c a) where
  Has c a
Has <> :: Has c a -> Has c a -> Has c a
<> Has c a
_ = Has c a
forall {k} (c :: k -> Constraint) (a :: k). c a => Has c a
Has

-- | There is no Semigroup instance for 'Product' in base
catProducts
  :: (Semigroup (f a), Semigroup (g a))
  => Product f g a
  -> Product f g a
  -> Product f g a
catProducts :: forall {k} (f :: k -> *) (a :: k) (g :: k -> *).
(Semigroup (f a), Semigroup (g a)) =>
Product f g a -> Product f g a -> Product f g a
catProducts (Pair f a
a1 g a
b1) (Pair f a
a2 g a
b2) = f a -> g a -> Product f g a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
a1 f a -> f a -> f a
forall a. Semigroup a => a -> a -> a
<> f a
a2) (g a
b1 g a -> g a -> g a
forall a. Semigroup a => a -> a -> a
<> g a
b2)

----------------------------------------------------------------
-- A minimal dependent map keyed by 'TypeRep'
--
-- This is just enough to replace the uses of @dependent-map@ and
-- @dependent-sum@ in 'makeDeviceCreateInfo':
-- group the per-feature-struct setters by their
-- (existentially quantified) struct type, recovering that type
-- later to extend the chain.
----------------------------------------------------------------

{- | A dependent pair: a 'TypeRep' tag together with a value whose type is
determined by the tag.
-}
data DSum f = forall a. (TypeRep a) :=> (f a)

infixr 1 :=>

{- | A map from a type (witnessed by its 'TypeRep') to a value whose type
depends on that key.
-}
newtype DMap f = DMap (TRMap.Map SomeTypeRep (DSum f))

{- | Build a 'DMap' from a list of dependent pairs, combining the values of
any entries that share a key.
-}
dmapFromListWith :: (forall a. f a -> f a -> f a) -> [DSum f] -> DMap f
dmapFromListWith :: forall {k} (f :: k -> *).
(forall (a :: k). f a -> f a -> f a) -> [DSum f] -> DMap f
dmapFromListWith forall (a :: k). f a -> f a -> f a
combine =
  Map SomeTypeRep (DSum f) -> DMap f
forall {k} (f :: k -> *). Map SomeTypeRep (DSum f) -> DMap f
DMap
    (Map SomeTypeRep (DSum f) -> DMap f)
-> ([DSum f] -> Map SomeTypeRep (DSum f)) -> [DSum f] -> DMap f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum f -> DSum f -> DSum f)
-> [(SomeTypeRep, DSum f)] -> Map SomeTypeRep (DSum f)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
TRMap.fromListWith DSum f -> DSum f -> DSum f
merge
    ([(SomeTypeRep, DSum f)] -> Map SomeTypeRep (DSum f))
-> ([DSum f] -> [(SomeTypeRep, DSum f)])
-> [DSum f]
-> Map SomeTypeRep (DSum f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum f -> (SomeTypeRep, DSum f))
-> [DSum f] -> [(SomeTypeRep, DSum f)]
forall a b. (a -> b) -> [a] -> [b]
map (\d :: DSum f
d@(TypeRep a
tr :=> f a
_) -> (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
tr, DSum f
d))
  where
    -- Both entries are stored under the same 'SomeTypeRep', so their tags
    -- necessarily witness the same type; 'eqTypeRep' recovers that equality
    -- so the values can be combined. The 'Nothing' case is unreachable.
    merge :: DSum f -> DSum f -> DSum f
merge (TypeRep a
trNew :=> f a
vNew) (TypeRep a
trOld :=> f a
vOld) = case TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
trNew TypeRep a
trOld of
      Just a :~~: a
HRefl -> TypeRep a
trNew TypeRep a -> f a -> DSum f
forall {k} (f :: k -> *) (a :: k). TypeRep a -> f a -> DSum f
:=> f a -> f a -> f a
forall (a :: k). f a -> f a -> f a
combine f a
vNew f a
f a
vOld
      Maybe (a :~~: a)
Nothing -> TypeRep a
trNew TypeRep a -> f a -> DSum f
forall {k} (f :: k -> *) (a :: k). TypeRep a -> f a -> DSum f
:=> f a
vNew

-- | The contents of a 'DMap', as dependent pairs.
dmapToList :: DMap f -> [DSum f]
dmapToList :: forall {k} (f :: k -> *). DMap f -> [DSum f]
dmapToList (DMap Map SomeTypeRep (DSum f)
m) = Map SomeTypeRep (DSum f) -> [DSum f]
forall k a. Map k a -> [a]
TRMap.elems Map SomeTypeRep (DSum f)
m

-- | Look up the value stored under a given type.
dmapLookup :: forall a f. TypeRep a -> DMap f -> Maybe (f a)
dmapLookup :: forall {k} (a :: k) (f :: k -> *).
TypeRep a -> DMap f -> Maybe (f a)
dmapLookup TypeRep a
tr (DMap Map SomeTypeRep (DSum f)
m) = do
  (trStored :=> v) <- SomeTypeRep -> Map SomeTypeRep (DSum f) -> Maybe (DSum f)
forall k a. Ord k => k -> Map k a -> Maybe a
TRMap.lookup (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
tr) Map SomeTypeRep (DSum f)
m
  HRefl <- eqTypeRep tr trStored
  pure v