module Vulkan.Utils.QueueAssignment
  ( assignQueues
  , QueueSpec(..)
  , QueueFamilyIndex(..)
  , QueueIndex(..)
  -- * Queue Family Predicates
  , isComputeQueueFamily
  , isGraphicsQueueFamily
  , isTransferQueueFamily
  , isTransferOnlyQueueFamily
  , isPresentQueueFamily
  ) where

import           Control.Applicative
import           Control.Category               ( (>>>) )
import           Control.Monad                  ( filterM )
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class      ( MonadTrans(lift) )
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.State.Strict
                                                ( evalState
                                                , evalStateT
                                                , get
                                                , put
                                                )
import           Data.Bits
import           Data.Foldable
import           Data.Functor                   ( (<&>) )
import           Data.Traversable
import qualified Data.Vector                   as V
import           Data.Vector                    ( Vector )
import           Data.Word
import           GHC.Stack                      ( HasCallStack )
import           Vulkan.Core10
import           Vulkan.Extensions.VK_KHR_surface
                                                ( SurfaceKHR
                                                , getPhysicalDeviceSurfaceSupportKHR
                                                )
import           Vulkan.Utils.Misc
import           Vulkan.Zero

----------------------------------------------------------------
-- Device Queue creation
----------------------------------------------------------------

-- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'.
--
-- To assign to a specific queue family index @f@:
--
-- @
-- queueSpecFamilyPredicate = \i _ -> i == f
-- @
--
-- To assign to any queue family which supports compute operations:
--
-- @
-- let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q
-- in QueueSpec priority (\_index q -> pure (isComputeQueue q))
-- @
data QueueSpec m = QueueSpec
  { forall (m :: * -> *). QueueSpec m -> Float
queueSpecQueuePriority :: Float
  , forall (m :: * -> *).
QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecFamilyPredicate
      :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
  }

newtype QueueFamilyIndex = QueueFamilyIndex { QueueFamilyIndex -> Word32
unQueueFamilyIndex :: Word32 }
  deriving (QueueFamilyIndex -> QueueFamilyIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c/= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
== :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c== :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
Eq, Eq QueueFamilyIndex
QueueFamilyIndex -> QueueFamilyIndex -> Bool
QueueFamilyIndex -> QueueFamilyIndex -> Ordering
QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
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 :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
$cmin :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
max :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
$cmax :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
>= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c>= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
> :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c> :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
<= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c<= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
< :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c< :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
compare :: QueueFamilyIndex -> QueueFamilyIndex -> Ordering
$ccompare :: QueueFamilyIndex -> QueueFamilyIndex -> Ordering
Ord, Int -> QueueFamilyIndex
QueueFamilyIndex -> Int
QueueFamilyIndex -> [QueueFamilyIndex]
QueueFamilyIndex -> QueueFamilyIndex
QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
QueueFamilyIndex
-> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: QueueFamilyIndex
-> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromThenTo :: QueueFamilyIndex
-> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFromTo :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromTo :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFromThen :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromThen :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFrom :: QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFrom :: QueueFamilyIndex -> [QueueFamilyIndex]
fromEnum :: QueueFamilyIndex -> Int
$cfromEnum :: QueueFamilyIndex -> Int
toEnum :: Int -> QueueFamilyIndex
$ctoEnum :: Int -> QueueFamilyIndex
pred :: QueueFamilyIndex -> QueueFamilyIndex
$cpred :: QueueFamilyIndex -> QueueFamilyIndex
succ :: QueueFamilyIndex -> QueueFamilyIndex
$csucc :: QueueFamilyIndex -> QueueFamilyIndex
Enum, Int -> QueueFamilyIndex -> ShowS
[QueueFamilyIndex] -> ShowS
QueueFamilyIndex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueueFamilyIndex] -> ShowS
$cshowList :: [QueueFamilyIndex] -> ShowS
show :: QueueFamilyIndex -> String
$cshow :: QueueFamilyIndex -> String
showsPrec :: Int -> QueueFamilyIndex -> ShowS
$cshowsPrec :: Int -> QueueFamilyIndex -> ShowS
Show)

newtype QueueIndex = QueueIndex { QueueIndex -> Word32
unQueueIndex :: Word32 }
  deriving (QueueIndex -> QueueIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueueIndex -> QueueIndex -> Bool
$c/= :: QueueIndex -> QueueIndex -> Bool
== :: QueueIndex -> QueueIndex -> Bool
$c== :: QueueIndex -> QueueIndex -> Bool
Eq, Eq QueueIndex
QueueIndex -> QueueIndex -> Bool
QueueIndex -> QueueIndex -> Ordering
QueueIndex -> QueueIndex -> QueueIndex
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 :: QueueIndex -> QueueIndex -> QueueIndex
$cmin :: QueueIndex -> QueueIndex -> QueueIndex
max :: QueueIndex -> QueueIndex -> QueueIndex
$cmax :: QueueIndex -> QueueIndex -> QueueIndex
>= :: QueueIndex -> QueueIndex -> Bool
$c>= :: QueueIndex -> QueueIndex -> Bool
> :: QueueIndex -> QueueIndex -> Bool
$c> :: QueueIndex -> QueueIndex -> Bool
<= :: QueueIndex -> QueueIndex -> Bool
$c<= :: QueueIndex -> QueueIndex -> Bool
< :: QueueIndex -> QueueIndex -> Bool
$c< :: QueueIndex -> QueueIndex -> Bool
compare :: QueueIndex -> QueueIndex -> Ordering
$ccompare :: QueueIndex -> QueueIndex -> Ordering
Ord, Int -> QueueIndex
QueueIndex -> Int
QueueIndex -> [QueueIndex]
QueueIndex -> QueueIndex
QueueIndex -> QueueIndex -> [QueueIndex]
QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex]
$cenumFromThenTo :: QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex]
enumFromTo :: QueueIndex -> QueueIndex -> [QueueIndex]
$cenumFromTo :: QueueIndex -> QueueIndex -> [QueueIndex]
enumFromThen :: QueueIndex -> QueueIndex -> [QueueIndex]
$cenumFromThen :: QueueIndex -> QueueIndex -> [QueueIndex]
enumFrom :: QueueIndex -> [QueueIndex]
$cenumFrom :: QueueIndex -> [QueueIndex]
fromEnum :: QueueIndex -> Int
$cfromEnum :: QueueIndex -> Int
toEnum :: Int -> QueueIndex
$ctoEnum :: Int -> QueueIndex
pred :: QueueIndex -> QueueIndex
$cpred :: QueueIndex -> QueueIndex
succ :: QueueIndex -> QueueIndex
$csucc :: QueueIndex -> QueueIndex
Enum, Int -> QueueIndex -> ShowS
[QueueIndex] -> ShowS
QueueIndex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueueIndex] -> ShowS
$cshowList :: [QueueIndex] -> ShowS
show :: QueueIndex -> String
$cshow :: QueueIndex -> String
showsPrec :: Int -> QueueIndex -> ShowS
$cshowsPrec :: Int -> QueueIndex -> ShowS
Show)

-- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an
-- assignment of queues to queue families and return information with which to
-- create a 'Device' and also a function to extract the requested 'Queue's from
-- the device.
--
-- You may want to create a custom type with a 'Traversable' instance to store
-- your queues like:
--
-- @
-- data MyQueues q = MyQueues
--   { computeQueue            :: q
--   , graphicsAndPresentQueue :: q
--   , transferQueue           :: q
--   }
--
-- myQueueSpecs :: MyQueues QueueSpec
-- myQueueSpecs = MyQueues
--   { computeQueue            = QueueSpec 0.5 isComputeQueueFamily
--   , graphicsAndPresentQueue = QueueSpec 1   isPresentQueueFamily
--   , transferQueue           = QueueSpec 1   isTransferOnlyQueueFamily
--   }
-- @
--
-- Note, this doesn't permit differentiating queue family assignment based on
-- whether or not the queue is protected.
assignQueues
  :: forall f m n
   . (Traversable f, MonadIO m, MonadIO n)
  => PhysicalDevice
  -> f (QueueSpec m)
  -- ^ A set of requirements for 'Queue's to be created
  -> m
       ( Maybe
           ( Vector (DeviceQueueCreateInfo '[])
           , Device -> n (f (QueueFamilyIndex, Queue))
           )
       )
  -- ^
  -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice'
  -- - A function to extract the requested 'Queue's from the 'Device' created
  --   with the 'DeviceQueueCreateInfo's
  --
  -- 'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's
assignQueues :: forall (f :: * -> *) (m :: * -> *) (n :: * -> *).
(Traversable f, MonadIO m, MonadIO n) =>
PhysicalDevice
-> f (QueueSpec m)
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> n (f (QueueFamilyIndex, Queue))))
assignQueues PhysicalDevice
phys f (QueueSpec m)
specs = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties <-
    forall a b. [a] -> [b] -> [(a, b)]
zip [Word32 -> QueueFamilyIndex
QueueFamilyIndex Word32
0 ..]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
.   forall a. Vector a -> [a]
V.toList
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io (Vector QueueFamilyProperties)
getPhysicalDeviceQueueFamilyProperties PhysicalDevice
phys

  -- For each QueueSpec find the list of applicable families
  f (QueueSpec m, [QueueFamilyIndex])
specsWithFamilies <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m)
specs forall a b. (a -> b) -> a -> b
$ \QueueSpec m
spec -> do
    [(QueueFamilyIndex, QueueFamilyProperties)]
families <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (m :: * -> *).
QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecFamilyPredicate QueueSpec m
spec))
                        [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueSpec m
spec, forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(QueueFamilyIndex, QueueFamilyProperties)]
families)

  let -- Get the number of available queues for each family
      familiesWithCapacities :: [(QueueFamilyIndex, Word32)]
      familiesWithCapacities :: [(QueueFamilyIndex, Word32)]
familiesWithCapacities =
        [ (QueueFamilyIndex
i, Word32
queueCount)
        | (QueueFamilyIndex
i, QueueFamilyProperties {Word32
QueueFlags
Extent3D
$sel:queueFlags:QueueFamilyProperties :: QueueFamilyProperties -> QueueFlags
$sel:queueCount:QueueFamilyProperties :: QueueFamilyProperties -> Word32
$sel:timestampValidBits:QueueFamilyProperties :: QueueFamilyProperties -> Word32
$sel:minImageTransferGranularity:QueueFamilyProperties :: QueueFamilyProperties -> Extent3D
minImageTransferGranularity :: Extent3D
timestampValidBits :: Word32
queueFlags :: QueueFlags
queueCount :: Word32
..}) <- [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties
        ]

  -- Assign each QueueSpec to a queue family
  f (QueueSpec m, QueueFamilyIndex)
specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <- forall (f :: * -> *) a. Alternative f => [a] -> f a
headMay
    (forall (f :: * -> *) a b.
Traversable f =>
[(a, Word32)] -> f (a -> Maybe b) -> [f b]
assign
      [(QueueFamilyIndex, Word32)]
familiesWithCapacities
      (f (QueueSpec m, [QueueFamilyIndex])
specsWithFamilies forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(QueueSpec m
spec, [QueueFamilyIndex]
indices) QueueFamilyIndex
index ->
        if QueueFamilyIndex
index forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QueueFamilyIndex]
indices then forall a. a -> Maybe a
Just (QueueSpec m
spec, QueueFamilyIndex
index) else forall a. Maybe a
Nothing
      )
    )

  let maxFamilyIndex :: Maybe QueueFamilyIndex
      maxFamilyIndex :: Maybe QueueFamilyIndex
maxFamilyIndex = forall (f :: * -> *) a. (Foldable f, Ord a) => f a -> Maybe a
maximumMay (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (QueueSpec m, QueueFamilyIndex)
specsWithFamily)

      -- Assign each QueueSpec an index within its queue family
      specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex)
      specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex)
specsWithQueueIndex =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState (forall a. a -> [a]
repeat (Word32 -> QueueIndex
QueueIndex Word32
0))
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m, QueueFamilyIndex)
specsWithFamily
          forall a b. (a -> b) -> a -> b
$ \(QueueSpec m
spec, QueueFamilyIndex
familyIndex) -> do
              [QueueIndex]
indices <- forall (m :: * -> *) s. Monad m => StateT s m s
get
              let (QueueIndex
index, [QueueIndex]
indices') =
                    forall a. (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a])
incrementAt (QueueFamilyIndex -> Word32
unQueueFamilyIndex QueueFamilyIndex
familyIndex) [QueueIndex]
indices
              forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [QueueIndex]
indices'
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueSpec m
spec, QueueFamilyIndex
familyIndex, QueueIndex
index)

      -- Gather the priorities for each queue in each queue family
      queuePriorities :: [[Float]]
      queuePriorities :: [[Float]]
queuePriorities = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(QueueSpec {Float
QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecFamilyPredicate :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecQueuePriority :: Float
$sel:queueSpecFamilyPredicate:QueueSpec :: forall (m :: * -> *).
QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
$sel:queueSpecQueuePriority:QueueSpec :: forall (m :: * -> *). QueueSpec m -> Float
..}, QueueFamilyIndex Word32
i) [[Float]]
ps ->
          forall a. HasCallStack => Word32 -> a -> [[a]] -> [[a]]
prependAt Word32
i Float
queueSpecQueuePriority [[Float]]
ps
        )
        (forall a. Int -> a -> [a]
replicate
          (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueFamilyIndex -> Word32
unQueueFamilyIndex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
succ) Maybe QueueFamilyIndex
maxFamilyIndex)
          []
        )
        f (QueueSpec m, QueueFamilyIndex)
specsWithFamily

      -- Make 'DeviceQueueCreateInfo's for the required queue families and
      -- priorities.
      queueCreateInfos :: Vector (DeviceQueueCreateInfo '[])
      queueCreateInfos :: Vector (DeviceQueueCreateInfo '[])
queueCreateInfos = forall a. [a] -> Vector a
V.fromList
        [ forall a. Zero a => a
zero { $sel:queueFamilyIndex:DeviceQueueCreateInfo :: Word32
queueFamilyIndex = Word32
familyIndex
               , $sel:queuePriorities:DeviceQueueCreateInfo :: Vector Float
queuePriorities  = forall a. [a] -> Vector a
V.fromList [Float]
ps
               }
        | (Word32
familyIndex, [Float]
ps) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [[Float]]
queuePriorities
        , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Float]
ps)
        ]

      -- Get
      extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))
      extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))
extractQueues Device
dev =
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m, QueueFamilyIndex, QueueIndex)
specsWithQueueIndex
          forall a b. (a -> b) -> a -> b
$ \(QueueSpec m
_, i :: QueueFamilyIndex
i@(QueueFamilyIndex Word32
familyIndex), QueueIndex Word32
index) ->
              (QueueFamilyIndex
i, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (io :: * -> *).
MonadIO io =>
Device -> Word32 -> Word32 -> io Queue
getDeviceQueue Device
dev Word32
familyIndex Word32
index

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (DeviceQueueCreateInfo '[])
queueCreateInfos, Device -> n (f (QueueFamilyIndex, Queue))
extractQueues)

----------------------------------------------------------------
-- Queue Predicates
----------------------------------------------------------------

isComputeQueueFamily :: QueueFamilyProperties -> Bool
isComputeQueueFamily :: QueueFamilyProperties -> Bool
isComputeQueueFamily QueueFamilyProperties
q = QueueFlags
QUEUE_COMPUTE_BIT forall a. Bits a => a -> a -> Bool
.&&. QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q

isGraphicsQueueFamily :: QueueFamilyProperties -> Bool
isGraphicsQueueFamily :: QueueFamilyProperties -> Bool
isGraphicsQueueFamily QueueFamilyProperties
q = QueueFlags
QUEUE_GRAPHICS_BIT forall a. Bits a => a -> a -> Bool
.&&. QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q

isTransferQueueFamily :: QueueFamilyProperties -> Bool
isTransferQueueFamily :: QueueFamilyProperties -> Bool
isTransferQueueFamily QueueFamilyProperties
q = QueueFlags
QUEUE_TRANSFER_BIT forall a. Bits a => a -> a -> Bool
.&&. QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q

-- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT'
-- or 'QUEUE_GRAPHICS_BIT'
isTransferOnlyQueueFamily :: QueueFamilyProperties -> Bool
isTransferOnlyQueueFamily :: QueueFamilyProperties -> Bool
isTransferOnlyQueueFamily QueueFamilyProperties
q =
  (   QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q
    forall a. Bits a => a -> a -> a
.&. (QueueFlags
QUEUE_TRANSFER_BIT forall a. Bits a => a -> a -> a
.|. QueueFlags
QUEUE_GRAPHICS_BIT forall a. Bits a => a -> a -> a
.|. QueueFlags
QUEUE_COMPUTE_BIT)
    )
    forall a. Eq a => a -> a -> Bool
== QueueFlags
QUEUE_TRANSFER_BIT

-- | Can this queue family present to this surface on this device
isPresentQueueFamily
  :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
isPresentQueueFamily :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
isPresentQueueFamily PhysicalDevice
phys SurfaceKHR
surf (QueueFamilyIndex Word32
i) =
  forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> Word32 -> SurfaceKHR -> io Bool
getPhysicalDeviceSurfaceSupportKHR PhysicalDevice
phys Word32
i SurfaceKHR
surf

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

-- | Find all possible valid assignments for elements of a 'Traversable' with
-- some limited resources.
--
-- >>> assign @[] @_ @() [("a", 1)] []
-- [[]]
--
-- >>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ]
-- [["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]]
--
-- >>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}]
-- [[2,3,4]]
assign
  :: forall f a b
   . Traversable f
  => [(a, Word32)]
  -- ^ How many of each 'a' are available
  -> f (a -> Maybe b)
  -- ^ Which 'a's can each element use
  -> [f b]
  -- ^ A list of assignments, each element in this list has the length of the
  -- requirements list
assign :: forall (f :: * -> *) a b.
Traversable f =>
[(a, Word32)] -> f (a -> Maybe b) -> [f b]
assign [(a, Word32)]
capacities = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [(a, Word32)]
capacities forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
  (\a -> Maybe b
p -> do
    [(a, Word32)]
cs            <- forall (m :: * -> *) s. Monad m => StateT s m s
get
    (b
choice, [(a, Word32)]
cs') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a b. (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select a -> Maybe b
p [(a, Word32)]
cs)
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [(a, Word32)]
cs'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure b
choice
  )

-- | Select an element from the list according to some predicate, and return
-- that element along with the decremented list.
select :: (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select :: forall a b. (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select a -> Maybe b
p = \case
  [] -> []
  (a, Word32)
x : [(a, Word32)]
xs ->
    let hit :: b -> (b, [(a, Word32)])
hit b
b = (b
b, if forall a b. (a, b) -> b
snd (a, Word32)
x forall a. Eq a => a -> a -> Bool
== Word32
1 then [(a, Word32)]
xs else (forall a. Enum a => a -> a
pred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, Word32)
x) forall a. a -> [a] -> [a]
: [(a, Word32)]
xs)
        miss :: [(b, [(a, Word32)])]
miss = do
          (b
selected, [(a, Word32)]
xs') <- forall a b. (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select a -> Maybe b
p [(a, Word32)]
xs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
selected, (a, Word32)
x forall a. a -> [a] -> [a]
: [(a, Word32)]
xs')
    in  if forall a b. (a, b) -> b
snd (a, Word32)
x forall a. Eq a => a -> a -> Bool
== Word32
0
          then [(b, [(a, Word32)])]
miss
          else case a -> Maybe b
p (forall a b. (a, b) -> a
fst (a, Word32)
x) of
            Maybe b
Nothing -> [(b, [(a, Word32)])]
miss
            Just b
b  -> b -> (b, [(a, Word32)])
hit b
b forall a. a -> [a] -> [a]
: [(b, [(a, Word32)])]
miss

headMay :: Alternative f => [a] -> f a
headMay :: forall (f :: * -> *) a. Alternative f => [a] -> f a
headMay = \case
  []    -> forall (f :: * -> *) a. Alternative f => f a
empty
  a
x : [a]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

maximumMay :: (Foldable f, Ord a) => f a -> Maybe a
maximumMay :: forall (f :: * -> *) a. (Foldable f, Ord a) => f a -> Maybe a
maximumMay f a
f = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
f then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum f a
f)

incrementAt :: (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a])
incrementAt :: forall a. (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a])
incrementAt Word32
index = forall a. HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])
modAt Word32
index forall a. Enum a => a -> a
succ

prependAt :: HasCallStack => Word32 -> a -> [[a]] -> [[a]]
prependAt :: forall a. HasCallStack => Word32 -> a -> [[a]] -> [[a]]
prependAt Word32
index a
p = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])
modAt Word32
index (a
p forall a. a -> [a] -> [a]
:)

modAt :: HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])
modAt :: forall a. HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])
modAt Word32
index a -> a
f = forall a. Int -> [a] -> ([a], [a])
splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
index) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  ([a]
_ , []    ) -> forall a. HasCallStack => String -> a
error String
"modAt, out of bounds"
  ([a]
xs, a
y : [a]
ys) -> (a
y, [a]
xs forall a. Semigroup a => a -> a -> a
<> (a -> a
f a
y forall a. a -> [a] -> [a]
: [a]
ys))