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

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 qualified Data.Dependent.Map            as DMap
import           Data.Dependent.Map             ( DMap )
import           Data.Dependent.Sum             ( DSum((:=>)) )
import           Data.Foldable
import           Data.Functor.Product           ( Product(..) )
import qualified Data.HashMap.Strict           as Map
import           Data.Kind                      ( Type )
import           Data.List.Extra                ( nubOrd )
import           Data.Proxy
import           Data.Semigroup                 ( Endo(..) )
import           Data.Traversable
import           Data.Typeable                  ( eqT )
import qualified Data.Vector                   as V
import           Data.Vector                    ( Vector )
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           Vulkan.Core11.DeviceInitialization
import           Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2
import           Vulkan.Dynamic                 ( InstanceCmds
                                                  ( pVkGetPhysicalDeviceFeatures2
                                                  , pVkGetPhysicalDeviceProperties2
                                                  )
                                                )
import           Vulkan.NamedType
import           Vulkan.Requirement
import           Vulkan.Version
import           Vulkan.Zero                    ( Zero(..) )
import Data.List (intercalate)

----------------------------------------------------------------
-- * 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 :: r InstanceRequirement
-> o InstanceRequirement
-> InstanceCreateInfo es
-> m (Maybe (InstanceCreateInfo es), r RequirementResult,
      o RequirementResult)
checkInstanceRequirements required :: r InstanceRequirement
required optional :: o InstanceRequirement
optional baseCreateInfo :: InstanceCreateInfo es
baseCreateInfo = do
  let requiredList :: [InstanceRequirement]
requiredList = r InstanceRequirement -> [InstanceRequirement]
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 (t :: * -> *) a. Foldable t => t a -> [a]
toList o InstanceRequirement
optional
  "apiVersion" ::: Word32
foundVersion    <- m ("apiVersion" ::: Word32)
forall (io :: * -> *). MonadIO io => io ("apiVersion" ::: Word32)
enumerateInstanceVersion
  (_, layerProps :: "properties" ::: Vector LayerProperties
layerProps) <- m (Result, "properties" ::: Vector LayerProperties)
forall (io :: * -> *).
MonadIO io =>
io (Result, "properties" ::: Vector LayerProperties)
enumerateInstanceLayerProperties
  ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension <- Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
forall (m :: * -> *).
MonadIO m =>
Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension
    Maybe PhysicalDevice
forall a. Maybe a
Nothing
    [ "layerName" ::: Maybe ByteString
instanceExtensionLayerName
    | RequireInstanceExtension { "layerName" ::: Maybe ByteString
$sel:instanceExtensionLayerName:RequireInstanceVersion :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
instanceExtensionLayerName } <- [InstanceRequirement]
allAsList
    ]

  (r :: r RequirementResult
r, continue :: Bool
continue) <- (StateT Bool m (r RequirementResult)
 -> Bool -> m (r RequirementResult, Bool))
-> Bool
-> StateT Bool m (r RequirementResult)
-> m (r RequirementResult, Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m (r RequirementResult)
-> Bool -> m (r RequirementResult, Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
True (StateT Bool m (r RequirementResult)
 -> m (r RequirementResult, Bool))
-> StateT Bool m (r RequirementResult)
-> m (r RequirementResult, Bool)
forall a b. (a -> b) -> a -> b
$ r InstanceRequirement
-> (InstanceRequirement -> StateT Bool m RequirementResult)
-> StateT Bool m (r RequirementResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for r InstanceRequirement
required ((InstanceRequirement -> StateT Bool m RequirementResult)
 -> StateT Bool m (r RequirementResult))
-> (InstanceRequirement -> StateT Bool m RequirementResult)
-> StateT Bool m (r RequirementResult)
forall a b. (a -> b) -> a -> b
$ \r :: InstanceRequirement
r ->
    case ("apiVersion" ::: Word32)
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest "apiVersion" ::: Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
r of
      res :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  (o :: o RequirementResult
o, goodOptions :: [InstanceRequirement]
goodOptions) <- (StateT [InstanceRequirement] m (o RequirementResult)
 -> [InstanceRequirement]
 -> m (o RequirementResult, [InstanceRequirement]))
-> [InstanceRequirement]
-> StateT [InstanceRequirement] m (o RequirementResult)
-> m (o RequirementResult, [InstanceRequirement])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [InstanceRequirement] m (o RequirementResult)
-> [InstanceRequirement]
-> m (o RequirementResult, [InstanceRequirement])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT [InstanceRequirement]
forall a. Monoid a => a
mempty (StateT [InstanceRequirement] m (o RequirementResult)
 -> m (o RequirementResult, [InstanceRequirement]))
-> StateT [InstanceRequirement] m (o RequirementResult)
-> m (o RequirementResult, [InstanceRequirement])
forall a b. (a -> b) -> a -> b
$ o InstanceRequirement
-> (InstanceRequirement
    -> StateT [InstanceRequirement] m RequirementResult)
-> StateT [InstanceRequirement] m (o RequirementResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for o InstanceRequirement
optional ((InstanceRequirement
  -> StateT [InstanceRequirement] m RequirementResult)
 -> StateT [InstanceRequirement] m (o RequirementResult))
-> (InstanceRequirement
    -> StateT [InstanceRequirement] m RequirementResult)
-> StateT [InstanceRequirement] m (o RequirementResult)
forall a b. (a -> b) -> a -> b
$ \o :: InstanceRequirement
o ->
    case ("apiVersion" ::: Word32)
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest "apiVersion" ::: Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
o of
      res :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  let ici :: Maybe (InstanceCreateInfo es)
ici = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
        InstanceCreateInfo es -> Maybe (InstanceCreateInfo es)
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
  (Maybe (InstanceCreateInfo es), r RequirementResult,
 o RequirementResult)
-> m (Maybe (InstanceCreateInfo es), r RequirementResult,
      o RequirementResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InstanceCreateInfo es)
ici, r RequirementResult
r, o RequirementResult
o)

-- | Insert the settings of the requirements in to the provided instance create
-- info
makeInstanceCreateInfo
  :: forall es
   . [InstanceRequirement]
  -> InstanceCreateInfo es
  -> InstanceCreateInfo es
makeInstanceCreateInfo :: [InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
makeInstanceCreateInfo reqs :: [InstanceRequirement]
reqs baseCreateInfo :: InstanceCreateInfo es
baseCreateInfo =
  let
    layers :: [ByteString]
layers = [ ByteString
instanceLayerName | RequireInstanceLayer {..} <- [InstanceRequirement]
reqs ]
    extensions :: [ByteString]
extensions =
      [ ByteString
instanceExtensionName | RequireInstanceExtension {..} <- [InstanceRequirement]
reqs ]
  in
    InstanceCreateInfo es
baseCreateInfo
      { $sel:enabledLayerNames:InstanceCreateInfo :: Vector ByteString
enabledLayerNames     =
        InstanceCreateInfo es -> Vector ByteString
forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
enabledLayerNames (InstanceCreateInfo es
baseCreateInfo :: InstanceCreateInfo es)
          Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
layers
      , $sel:enabledExtensionNames:InstanceCreateInfo :: Vector ByteString
enabledExtensionNames =
        InstanceCreateInfo es -> Vector ByteString
forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
enabledExtensionNames (InstanceCreateInfo es
baseCreateInfo :: InstanceCreateInfo es)
          Vector ByteString -> Vector ByteString -> Vector ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
extensions
      }

checkInstanceRequest
  :: ("apiVersion" ::: Word32)
  -> ("properties" ::: Vector LayerProperties)
  -> (  ("layerName" ::: Maybe ByteString)
     -> ByteString
     -> Maybe ExtensionProperties
     )
  -> InstanceRequirement
  -> RequirementResult
checkInstanceRequest :: ("apiVersion" ::: Word32)
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest foundVersion :: "apiVersion" ::: Word32
foundVersion layerProps :: "properties" ::: Vector LayerProperties
layerProps lookupExtension :: ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireInstanceVersion minVersion :: "apiVersion" ::: Word32
minVersion -> if "apiVersion" ::: Word32
foundVersion ("apiVersion" ::: Word32) -> ("apiVersion" ::: Word32) -> Bool
forall a. Ord a => a -> a -> Bool
>= "apiVersion" ::: Word32
minVersion
    then RequirementResult
Satisfied
    else Unsatisfied ("apiVersion" ::: Word32) -> RequirementResult
UnsatisfiedInstanceVersion (("apiVersion" ::: Word32)
-> ("apiVersion" ::: Word32)
-> Unsatisfied ("apiVersion" ::: Word32)
forall a. a -> a -> Unsatisfied a
Unsatisfied "apiVersion" ::: Word32
minVersion "apiVersion" ::: Word32
foundVersion)

  RequireInstanceLayer { ByteString
instanceLayerName :: ByteString
$sel:instanceLayerName:RequireInstanceVersion :: InstanceRequirement -> ByteString
instanceLayerName, "apiVersion" ::: Word32
instanceLayerMinVersion :: "apiVersion" ::: Word32
$sel:instanceLayerMinVersion:RequireInstanceVersion :: InstanceRequirement -> "apiVersion" ::: Word32
instanceLayerMinVersion }
    | Just props :: 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
    , "apiVersion" ::: Word32
foundLayerVersion <- LayerProperties -> "apiVersion" ::: Word32
implementationVersion LayerProperties
props
    -> if "apiVersion" ::: Word32
foundVersion ("apiVersion" ::: Word32) -> ("apiVersion" ::: Word32) -> Bool
forall a. Ord a => a -> a -> Bool
>= "apiVersion" ::: Word32
instanceLayerMinVersion
      then RequirementResult
Satisfied
      else ByteString
-> Unsatisfied ("apiVersion" ::: Word32) -> RequirementResult
UnsatisfiedLayerVersion
        ByteString
instanceLayerName
        (("apiVersion" ::: Word32)
-> ("apiVersion" ::: Word32)
-> Unsatisfied ("apiVersion" ::: Word32)
forall a. a -> a -> Unsatisfied a
Unsatisfied "apiVersion" ::: Word32
instanceLayerMinVersion "apiVersion" ::: Word32
foundLayerVersion)
    | Bool
otherwise
    -> ByteString -> RequirementResult
MissingLayer ByteString
instanceLayerName

  RequireInstanceExtension { "layerName" ::: Maybe ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
$sel:instanceExtensionLayerName:RequireInstanceVersion :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionLayerName, ByteString
instanceExtensionName :: ByteString
$sel:instanceExtensionName:RequireInstanceVersion :: InstanceRequirement -> ByteString
instanceExtensionName, "apiVersion" ::: Word32
instanceExtensionMinVersion :: "apiVersion" ::: Word32
$sel:instanceExtensionMinVersion:RequireInstanceVersion :: InstanceRequirement -> "apiVersion" ::: Word32
instanceExtensionMinVersion }
    | Just eProps :: ExtensionProperties
eProps <- ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension "layerName" ::: Maybe ByteString
instanceExtensionLayerName
                                     ByteString
instanceExtensionName
    , ExtensionProperties -> "apiVersion" ::: Word32
specVersion (ExtensionProperties
eProps :: ExtensionProperties) ("apiVersion" ::: Word32) -> ("apiVersion" ::: Word32) -> Bool
forall a. Ord a => a -> a -> Bool
>= "apiVersion" ::: Word32
instanceExtensionMinVersion
    -> RequirementResult
Satisfied
    | 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 :: r DeviceRequirement
-> o DeviceRequirement
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
checkDeviceRequirements required :: r DeviceRequirement
required optional :: o DeviceRequirement
optional phys :: PhysicalDevice
phys baseCreateInfo :: DeviceCreateInfo '[]
baseCreateInfo = do
  let requiredList :: [DeviceRequirement]
requiredList = r DeviceRequirement -> [DeviceRequirement]
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 (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
      --
      Maybe (PhysicalDeviceFeatures2 es)
feats           <- PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 es))
forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe @fs PhysicalDevice
phys
      Maybe (PhysicalDeviceProperties2 es)
props           <- PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 es))
forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs,
 Extendss PhysicalDeviceProperties2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe @ps PhysicalDevice
phys
      ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension <- Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
forall (m :: * -> *).
MonadIO m =>
Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension
        (PhysicalDevice -> Maybe PhysicalDevice
forall a. a -> Maybe a
Just PhysicalDevice
phys)
        [ "layerName" ::: Maybe ByteString
deviceExtensionLayerName
        | RequireDeviceExtension { "layerName" ::: Maybe ByteString
$sel:deviceExtensionLayerName:RequireDeviceVersion :: DeviceRequirement -> "layerName" ::: Maybe ByteString
deviceExtensionLayerName :: "layerName" ::: Maybe ByteString
deviceExtensionLayerName } <- [DeviceRequirement]
allAsList
        ]

      (r :: r RequirementResult
r, continue :: Bool
continue) <- (StateT Bool m (r RequirementResult)
 -> Bool -> m (r RequirementResult, Bool))
-> Bool
-> StateT Bool m (r RequirementResult)
-> m (r RequirementResult, Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool m (r RequirementResult)
-> Bool -> m (r RequirementResult, Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
True (StateT Bool m (r RequirementResult)
 -> m (r RequirementResult, Bool))
-> StateT Bool m (r RequirementResult)
-> m (r RequirementResult, Bool)
forall a b. (a -> b) -> a -> b
$ r DeviceRequirement
-> (DeviceRequirement -> StateT Bool m RequirementResult)
-> StateT Bool m (r RequirementResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for r DeviceRequirement
required ((DeviceRequirement -> StateT Bool m RequirementResult)
 -> StateT Bool m (r RequirementResult))
-> (DeviceRequirement -> StateT Bool m RequirementResult)
-> StateT Bool m (r RequirementResult)
forall a b. (a -> b) -> a -> b
$ \r :: 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
          res :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      (o :: o RequirementResult
o, goodOptions :: [DeviceRequirement]
goodOptions) <- (StateT [DeviceRequirement] m (o RequirementResult)
 -> [DeviceRequirement]
 -> m (o RequirementResult, [DeviceRequirement]))
-> [DeviceRequirement]
-> StateT [DeviceRequirement] m (o RequirementResult)
-> m (o RequirementResult, [DeviceRequirement])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [DeviceRequirement] m (o RequirementResult)
-> [DeviceRequirement]
-> m (o RequirementResult, [DeviceRequirement])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT [DeviceRequirement]
forall a. Monoid a => a
mempty (StateT [DeviceRequirement] m (o RequirementResult)
 -> m (o RequirementResult, [DeviceRequirement]))
-> StateT [DeviceRequirement] m (o RequirementResult)
-> m (o RequirementResult, [DeviceRequirement])
forall a b. (a -> b) -> a -> b
$ o DeviceRequirement
-> (DeviceRequirement
    -> StateT [DeviceRequirement] m RequirementResult)
-> StateT [DeviceRequirement] m (o RequirementResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for o DeviceRequirement
optional ((DeviceRequirement
  -> StateT [DeviceRequirement] m RequirementResult)
 -> StateT [DeviceRequirement] m (o RequirementResult))
-> (DeviceRequirement
    -> StateT [DeviceRequirement] m RequirementResult)
-> StateT [DeviceRequirement] m (o RequirementResult)
forall a b. (a -> b) -> a -> b
$ \o :: 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
          res :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      --
      -- Now create the types for just the available features
      --
      let dci :: Maybe (SomeStruct DeviceCreateInfo)
dci = do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
            SomeStruct DeviceCreateInfo -> Maybe (SomeStruct DeviceCreateInfo)
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
      (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
 o RequirementResult)
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SomeStruct DeviceCreateInfo)
dci, r RequirementResult
r, o RequirementResult
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 allReqs :: [DeviceRequirement]
allReqs baseCreateInfo :: DeviceCreateInfo '[]
baseCreateInfo =
  let
    featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
    featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters = (forall v.
 TypeRep v
 -> Product (Has KnownFeatureStruct) Endo v
 -> Product (Has KnownFeatureStruct) Endo v
 -> Product (Has KnownFeatureStruct) Endo v)
-> [DSum TypeRep (Product (Has KnownFeatureStruct) Endo)]
-> DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> [DSum k2 f] -> DMap k2 f
DMap.fromListWithKey
      (\_ l :: Product (Has KnownFeatureStruct) Endo v
l r :: Product (Has KnownFeatureStruct) Endo v
r -> Product (Has KnownFeatureStruct) Endo v
-> Product (Has KnownFeatureStruct) Endo v
-> Product (Has KnownFeatureStruct) Endo v
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 Product (Has KnownFeatureStruct) Endo v
l Product (Has KnownFeatureStruct) Endo v
r)
      [ TypeRep struct
forall k (a :: k). Typeable a => TypeRep a
typeRep TypeRep struct
-> Product (Has KnownFeatureStruct) Endo struct
-> DSum TypeRep (Product (Has KnownFeatureStruct) Endo)
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag 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
$sel:enableFeature:RequireDeviceVersion :: ()
enableFeature :: struct -> struct
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)
      | _ :=> Pair Has (Endo a
f :: Endo s) <- DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
-> [DSum TypeRep (Product (Has KnownFeatureStruct) Endo)]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters
      , SFeatureStruct a
ExtendedFeatureStruct <- SFeatureStruct a -> [SFeatureStruct 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
$ KnownFeatureStruct a => SFeatureStruct a
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 TypeRep (Product (Has KnownFeatureStruct) Endo)
-> Maybe
     (Product (Has KnownFeatureStruct) Endo PhysicalDeviceFeatures)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup (Typeable PhysicalDeviceFeatures => TypeRep PhysicalDeviceFeatures
forall k (a :: k). Typeable a => TypeRep a
typeRep @PhysicalDeviceFeatures) DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters of
        Nothing         -> Endo (SomeStruct DeviceCreateInfo)
forall a. Monoid a => a
mempty
        Just (Pair _ s :: 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 '[]) { $sel:features:PhysicalDeviceFeatures2 :: PhysicalDeviceFeatures
features = Endo PhysicalDeviceFeatures
-> PhysicalDeviceFeatures -> PhysicalDeviceFeatures
forall a. Endo a -> a -> a
appEndo Endo PhysicalDeviceFeatures
s PhysicalDeviceFeatures
forall a. Zero a => a
zero }
            )
          )

    extensionNames :: [ByteString]
    extensionNames :: [ByteString]
extensionNames =
      [ ByteString
deviceExtensionName
      | RequireDeviceExtension { ByteString
$sel:deviceExtensionName:RequireDeviceVersion :: DeviceRequirement -> ByteString
deviceExtensionName :: 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 (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 '[])
        { $sel:enabledExtensionNames:DeviceCreateInfo :: Vector ByteString
enabledExtensionNames = [ByteString] -> Vector ByteString
forall a. [a] -> Vector a
V.fromList [ByteString]
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
  -- ^ The requirement to test
  -> RequirementResult
  -- ^ The result
checkDeviceRequest :: Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest mbFeats :: Maybe (PhysicalDeviceFeatures2 fs)
mbFeats mbProps :: Maybe (PhysicalDeviceProperties2 ps)
mbProps lookupExtension :: ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireDeviceVersion minVersion :: "apiVersion" ::: Word32
minVersion
    | Just props :: PhysicalDeviceProperties2 ps
props <- Maybe (PhysicalDeviceProperties2 ps)
mbProps
    , "apiVersion" ::: Word32
foundVersion <- PhysicalDeviceProperties -> "apiVersion" ::: Word32
apiVersion
      (PhysicalDeviceProperties2 ps -> PhysicalDeviceProperties
forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
properties (PhysicalDeviceProperties2 ps
props :: PhysicalDeviceProperties2 ps) :: PhysicalDeviceProperties
      )
    -> if "apiVersion" ::: Word32
foundVersion ("apiVersion" ::: Word32) -> ("apiVersion" ::: Word32) -> Bool
forall a. Ord a => a -> a -> Bool
>= "apiVersion" ::: Word32
minVersion
      then RequirementResult
Satisfied
      else Unsatisfied ("apiVersion" ::: Word32) -> RequirementResult
UnsatisfiedDeviceVersion (("apiVersion" ::: Word32)
-> ("apiVersion" ::: Word32)
-> Unsatisfied ("apiVersion" ::: Word32)
forall a. a -> a -> Unsatisfied a
Unsatisfied "apiVersion" ::: Word32
minVersion "apiVersion" ::: Word32
foundVersion)
    | Bool
otherwise
    -> ByteString -> RequirementResult
UnattemptedProperties "apiVersion"

  RequireDeviceFeature { ByteString
$sel:featureName:RequireDeviceVersion :: DeviceRequirement -> ByteString
featureName :: ByteString
featureName, struct -> Bool
$sel:checkFeature:RequireDeviceVersion :: ()
checkFeature :: struct -> Bool
checkFeature }
    | Just feats :: 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
      Nothing ->
        [Char] -> RequirementResult
forall a. HasCallStack => [Char] -> a
error "Impossible: didn't find requested feature in struct chain"
      Just s :: 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
$sel:propertyName:RequireDeviceVersion :: DeviceRequirement -> ByteString
propertyName :: ByteString
propertyName, struct -> Bool
$sel:checkProperty:RequireDeviceVersion :: ()
checkProperty :: struct -> Bool
checkProperty }
    | Just props :: 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
      Nothing ->
        [Char] -> RequirementResult
forall a. HasCallStack => [Char] -> a
error "Impossible: didn't find requested property in struct chain"
      Just s :: 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 :: "layerName" ::: Maybe ByteString
$sel:deviceExtensionLayerName:RequireDeviceVersion :: DeviceRequirement -> "layerName" ::: Maybe ByteString
deviceExtensionLayerName, ByteString
deviceExtensionName :: ByteString
$sel:deviceExtensionName:RequireDeviceVersion :: DeviceRequirement -> ByteString
deviceExtensionName, "apiVersion" ::: Word32
$sel:deviceExtensionMinVersion:RequireDeviceVersion :: DeviceRequirement -> "apiVersion" ::: Word32
deviceExtensionMinVersion :: "apiVersion" ::: Word32
deviceExtensionMinVersion }
    | Just eProps :: ExtensionProperties
eProps <- ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension "layerName" ::: Maybe ByteString
deviceExtensionLayerName
                                     ByteString
deviceExtensionName
    , ExtensionProperties -> "apiVersion" ::: Word32
specVersion (ExtensionProperties
eProps :: ExtensionProperties) ("apiVersion" ::: Word32) -> ("apiVersion" ::: Word32) -> Bool
forall a. Ord a => a -> a -> Bool
>= "apiVersion" ::: Word32
deviceExtensionMinVersion
    -> RequirementResult
Satisfied
    | Bool
otherwise
    -> ByteString -> RequirementResult
UnsatisfiedDeviceExtension ByteString
deviceExtensionName


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

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

data Unsatisfied a = Unsatisfied
  { Unsatisfied a -> a
unsatisfiedMinimum :: a
    -- ^ The minimum value to be accepted
  , 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
/= :: Unsatisfied a -> Unsatisfied a -> Bool
$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
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
min :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$cmin :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
max :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$cmax :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
>= :: 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
$c< :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
compare :: Unsatisfied a -> Unsatisfied a -> Ordering
$ccompare :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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 :: r RequirementResult -> o RequirementResult -> Maybe [Char]
requirementReport required :: r RequirementResult
required optional :: o RequirementResult
optional =
  let pList :: t RequirementResult -> [[Char]]
pList xs :: t RequirementResult
xs =
        [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd [ RequirementResult -> [Char]
prettyRequirementResult RequirementResult
r | RequirementResult
r <- t RequirementResult -> [RequirementResult]
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 s :: a
s = \case
        [] -> []
        xs :: [a]
xs -> (a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> " requirements not met:") a -> [a] -> [a]
forall 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 "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 "Optional" [[Char]]
optStrings
  in  if [[Char]] -> 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
  Satisfied -> "Satisfied"
  UnattemptedProperties n :: ByteString
n ->
    "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
<> " because the 'getPhysicalDeviceProperties' function was not loaded"
  UnattemptedFeatures n :: ByteString
n ->
    "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
<> " because the 'getPhysicalDeviceFeatures' function was not loaded"
  MissingLayer               n :: ByteString
n -> "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 u :: Unsatisfied ("apiVersion" ::: Word32)
u -> "Unsatisfied Instance version: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied ("apiVersion" ::: Word32) -> [Char]
p Unsatisfied ("apiVersion" ::: Word32)
u
  UnsatisfiedDeviceVersion   u :: Unsatisfied ("apiVersion" ::: Word32)
u -> "Unsatisfied Device version: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied ("apiVersion" ::: Word32) -> [Char]
p Unsatisfied ("apiVersion" ::: Word32)
u
  UnsatisfiedLayerVersion n :: ByteString
n u :: Unsatisfied ("apiVersion" ::: Word32)
u ->
    "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]
forall a. Semigroup a => a -> a -> a
<> Unsatisfied ("apiVersion" ::: Word32) -> [Char]
p Unsatisfied ("apiVersion" ::: Word32)
u
  UnsatisfiedFeature           n :: ByteString
n -> "Missing feature: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedProperty          n :: ByteString
n -> "Unsatisfied property: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceExtension n :: ByteString
n -> "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
  UnsatisfiedDeviceExtension   n :: ByteString
n -> "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
  where p :: Unsatisfied ("apiVersion" ::: Word32) -> [Char]
p = (("apiVersion" ::: Word32) -> [Char])
-> Unsatisfied ("apiVersion" ::: Word32) -> [Char]
forall t. (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied ("apiVersion" ::: Word32) -> [Char]
showVersion

-- How I'm feeling after writing all this type level nonsense
prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String
prettyUnsatisfied :: (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied s :: t -> [Char]
s Unsatisfied {..} =
  "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
<> ", 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 :: Proxy# a
-> Maybe (Chain '[] -> a, (a -> a) -> Chain '[] -> Chain '[])
has _ = 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 :: Proxy# a
-> Maybe
     (Chain (x : xs) -> a, (a -> a) -> Chain (x : xs) -> Chain (x : xs))
has (Proxy# a
px :: Proxy# a)
    | Just Refl <- (Typeable a, Typeable x) => Maybe (a :~: x)
forall k (a :: k) (b :: k).
(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 (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 (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 (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)
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 :: PhysicalDeviceProperties2 es -> Maybe s
getPropertyStruct c :: PhysicalDeviceProperties2 es
c = case (Typeable PhysicalDeviceProperties, Typeable s) =>
Maybe (PhysicalDeviceProperties :~: s)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @PhysicalDeviceProperties @s of
  Just Refl -> PhysicalDeviceProperties -> Maybe PhysicalDeviceProperties
forall a. a -> Maybe a
Just (PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
properties (PhysicalDeviceProperties2 es
c :: PhysicalDeviceProperties2 es))
  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 :: PhysicalDeviceFeatures2 es -> Maybe s
getFeatureStruct c :: PhysicalDeviceFeatures2 es
c = case (Typeable PhysicalDeviceFeatures, Typeable s) =>
Maybe (PhysicalDeviceFeatures :~: s)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @PhysicalDeviceFeatures @s of
  Just Refl -> PhysicalDeviceFeatures -> Maybe PhysicalDeviceFeatures
forall a. a -> Maybe a
Just (PhysicalDeviceFeatures2 es -> PhysicalDeviceFeatures
forall (es :: [*]).
PhysicalDeviceFeatures2 es -> PhysicalDeviceFeatures
features (PhysicalDeviceFeatures2 es
c :: PhysicalDeviceFeatures2 es))
  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 :: h es -> Maybe s
getStruct c :: h es
c = ((Chain es -> s) -> Chain es -> s
forall a b. (a -> b) -> a -> b
$ 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)
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
getLookupExtension
  :: MonadIO m
  => Maybe PhysicalDevice
  -- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for
  -- device extensions.
  -> ["layerName" ::: Maybe ByteString]
  -> m
       (  ("layerName" ::: Maybe ByteString)
       -> ByteString
       -> Maybe ExtensionProperties
       )
getLookupExtension :: Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension mbPhys :: Maybe PhysicalDevice
mbPhys extensionLayers :: ["layerName" ::: Maybe ByteString]
extensionLayers = do
  let enumerate :: ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
enumerate = (("layerName" ::: Maybe ByteString)
 -> m (Result, "properties" ::: Vector ExtensionProperties))
-> (PhysicalDevice
    -> ("layerName" ::: Maybe ByteString)
    -> m (Result, "properties" ::: Vector ExtensionProperties))
-> Maybe PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
enumerateInstanceExtensionProperties
                        PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
enumerateDeviceExtensionProperties
                        Maybe PhysicalDevice
mbPhys
  [("layerName" ::: Maybe ByteString,
  "properties" ::: Vector ExtensionProperties)]
extensions <- ["layerName" ::: Maybe ByteString]
-> (("layerName" ::: Maybe ByteString)
    -> m ("layerName" ::: Maybe ByteString,
          "properties" ::: Vector ExtensionProperties))
-> m [("layerName" ::: Maybe ByteString,
       "properties" ::: Vector ExtensionProperties)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (["layerName" ::: Maybe ByteString]
-> ["layerName" ::: Maybe ByteString]
forall a. Ord a => [a] -> [a]
nubOrd ["layerName" ::: Maybe ByteString]
extensionLayers) ((("layerName" ::: Maybe ByteString)
  -> m ("layerName" ::: Maybe ByteString,
        "properties" ::: Vector ExtensionProperties))
 -> m [("layerName" ::: Maybe ByteString,
        "properties" ::: Vector ExtensionProperties)])
-> (("layerName" ::: Maybe ByteString)
    -> m ("layerName" ::: Maybe ByteString,
          "properties" ::: Vector ExtensionProperties))
-> m [("layerName" ::: Maybe ByteString,
       "properties" ::: Vector ExtensionProperties)]
forall a b. (a -> b) -> a -> b
$ \layer :: "layerName" ::: Maybe ByteString
layer -> do
    (_, props :: "properties" ::: Vector ExtensionProperties
props) <- ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
enumerate "layerName" ::: Maybe ByteString
layer
    ("layerName" ::: Maybe ByteString,
 "properties" ::: Vector ExtensionProperties)
-> m ("layerName" ::: Maybe ByteString,
      "properties" ::: Vector ExtensionProperties)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("layerName" ::: Maybe ByteString
layer, "properties" ::: Vector ExtensionProperties
props)
  let extensionMap :: HashMap
  ("layerName" ::: Maybe ByteString)
  ("properties" ::: Vector ExtensionProperties)
extensionMap = (("properties" ::: Vector ExtensionProperties)
 -> ("properties" ::: Vector ExtensionProperties)
 -> "properties" ::: Vector ExtensionProperties)
-> [("layerName" ::: Maybe ByteString,
     "properties" ::: Vector ExtensionProperties)]
-> HashMap
     ("layerName" ::: Maybe ByteString)
     ("properties" ::: Vector ExtensionProperties)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith ("properties" ::: Vector ExtensionProperties)
-> ("properties" ::: Vector ExtensionProperties)
-> "properties" ::: Vector ExtensionProperties
forall a. Semigroup a => a -> a -> a
(<>) [("layerName" ::: Maybe ByteString,
  "properties" ::: Vector ExtensionProperties)]
extensions
  (("layerName" ::: Maybe ByteString)
 -> ByteString -> Maybe ExtensionProperties)
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((("layerName" ::: Maybe ByteString)
  -> ByteString -> Maybe ExtensionProperties)
 -> m (("layerName" ::: Maybe ByteString)
       -> ByteString -> Maybe ExtensionProperties))
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
forall a b. (a -> b) -> a -> b
$ \layer :: "layerName" ::: Maybe ByteString
layer name :: ByteString
name ->
    let es :: "properties" ::: Vector ExtensionProperties
es = ("properties" ::: Vector ExtensionProperties)
-> ("layerName" ::: Maybe ByteString)
-> HashMap
     ("layerName" ::: Maybe ByteString)
     ("properties" ::: Vector ExtensionProperties)
-> "properties" ::: Vector ExtensionProperties
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault "properties" ::: Vector ExtensionProperties
forall a. Monoid a => a
mempty "layerName" ::: Maybe ByteString
layer HashMap
  ("layerName" ::: Maybe ByteString)
  ("properties" ::: Vector ExtensionProperties)
extensionMap
    in  (ExtensionProperties -> Bool)
-> ("properties" ::: Vector ExtensionProperties)
-> Maybe ExtensionProperties
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name) (ByteString -> Bool)
-> (ExtensionProperties -> ByteString)
-> ExtensionProperties
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionProperties -> ByteString
extensionName) "properties" ::: Vector ExtensionProperties
es

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

withDevicePropertyStructs
  :: forall a
   . [DeviceRequirement]
  -> ChainCont DevicePropertyChain a
  -> a
withDevicePropertyStructs :: [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs = [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
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 :: [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go seen :: [SomeTypeRep]
seen reqs :: [DeviceRequirement]
reqs f :: 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 (Proxy fs
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 _ (struct -> Bool
_ :: s -> Bool)) : rs :: [DeviceRequirement]
rs
      | KnownPropertyStruct struct => SPropertyStruct struct
ExtendedPropertyStruct <- KnownPropertyStruct struct => SPropertyStruct struct
forall prop. KnownPropertyStruct prop => SPropertyStruct prop
sPropertyStruct @s
      , SomeTypeRep
sRep <- TypeRep struct -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (Typeable struct => TypeRep struct
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
      -> [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
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 ChainCont DevicePropertyChain a
f
    -- Otherwise skip
    _ : rs :: [DeviceRequirement]
rs -> [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs ChainCont DevicePropertyChain a
f

withDeviceFeatureStructs
  :: forall a
   . [DeviceRequirement]
  -> ChainCont DeviceFeatureChain a
  -> a
withDeviceFeatureStructs :: [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs = [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
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 :: [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go seen :: [SomeTypeRep]
seen reqs :: [DeviceRequirement]
reqs f :: 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 (Proxy fs
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 _ _ (struct -> struct
_ :: s -> s)) : rs :: [DeviceRequirement]
rs
      | KnownFeatureStruct struct => SFeatureStruct struct
ExtendedFeatureStruct <- KnownFeatureStruct struct => SFeatureStruct struct
forall feat. KnownFeatureStruct feat => SFeatureStruct feat
sFeatureStruct @s
      , SomeTypeRep
sRep <- TypeRep struct -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (Typeable struct => TypeRep struct
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
      -> [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
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 ChainCont DeviceFeatureChain a
f
    -- Otherwise skip
    _ : rs :: [DeviceRequirement]
rs -> [SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs ChainCont DeviceFeatureChain a
f

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

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

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 :: 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 :: 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 :: (InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe funPtr :: InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr wrapper2 :: s1 -> s2 '[]
wrapper2 get1 :: PhysicalDevice -> m s1
get1 get2 :: PhysicalDevice -> m (s2 fs)
get2 phys :: PhysicalDevice
phys =
  let hasFunPtr :: Bool
hasFunPtr = InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr (PhysicalDevice -> InstanceCmds
instanceCmds (PhysicalDevice
phys :: PhysicalDevice)) 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 KnownChain fs => Maybe (fs :~: '[])
forall (xs :: [*]). KnownChain xs => Maybe (xs :~: '[])
knownChainNull @fs of
        Just Refl -> s2 '[] -> Maybe (s2 '[])
forall a. a -> Maybe a
Just (s2 '[] -> Maybe (s2 '[]))
-> (s1 -> s2 '[]) -> s1 -> Maybe (s2 '[])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> s2 '[]
wrapper2 (s1 -> Maybe (s2 '[])) -> m s1 -> m (Maybe (s2 '[]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m s1
get1 PhysicalDevice
phys
        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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (s2 fs)
forall a. Maybe a
Nothing

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

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

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

instance Semigroup (Has c a) where
  Has <> :: 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 :: Product f g a -> Product f g a -> Product f g a
catProducts (Pair a1 :: f a
a1 b1 :: g a
b1) (Pair a2 :: f a
a2 b2 :: 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)