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
  { QueueSpec m -> Float
queueSpecQueuePriority :: Float
  , QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecFamilyPredicate
      :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
  }

newtype QueueFamilyIndex = QueueFamilyIndex { QueueFamilyIndex -> Word32
unQueueFamilyIndex :: Word32 }
  deriving (QueueFamilyIndex -> QueueFamilyIndex -> Bool
(QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> Eq QueueFamilyIndex
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
Eq QueueFamilyIndex =>
(QueueFamilyIndex -> QueueFamilyIndex -> Ordering)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex)
-> (QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex)
-> Ord 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
$cp1Ord :: Eq QueueFamilyIndex
Ord, Int -> QueueFamilyIndex
QueueFamilyIndex -> Int
QueueFamilyIndex -> [QueueFamilyIndex]
QueueFamilyIndex -> QueueFamilyIndex
QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
QueueFamilyIndex
-> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
(QueueFamilyIndex -> QueueFamilyIndex)
-> (QueueFamilyIndex -> QueueFamilyIndex)
-> (Int -> QueueFamilyIndex)
-> (QueueFamilyIndex -> Int)
-> (QueueFamilyIndex -> [QueueFamilyIndex])
-> (QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex])
-> (QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex])
-> (QueueFamilyIndex
    -> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex])
-> Enum 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
(Int -> QueueFamilyIndex -> ShowS)
-> (QueueFamilyIndex -> String)
-> ([QueueFamilyIndex] -> ShowS)
-> Show QueueFamilyIndex
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
(QueueIndex -> QueueIndex -> Bool)
-> (QueueIndex -> QueueIndex -> Bool) -> Eq QueueIndex
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
Eq QueueIndex =>
(QueueIndex -> QueueIndex -> Ordering)
-> (QueueIndex -> QueueIndex -> Bool)
-> (QueueIndex -> QueueIndex -> Bool)
-> (QueueIndex -> QueueIndex -> Bool)
-> (QueueIndex -> QueueIndex -> Bool)
-> (QueueIndex -> QueueIndex -> QueueIndex)
-> (QueueIndex -> QueueIndex -> QueueIndex)
-> Ord 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
$cp1Ord :: Eq QueueIndex
Ord, Int -> QueueIndex
QueueIndex -> Int
QueueIndex -> [QueueIndex]
QueueIndex -> QueueIndex
QueueIndex -> QueueIndex -> [QueueIndex]
QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex]
(QueueIndex -> QueueIndex)
-> (QueueIndex -> QueueIndex)
-> (Int -> QueueIndex)
-> (QueueIndex -> Int)
-> (QueueIndex -> [QueueIndex])
-> (QueueIndex -> QueueIndex -> [QueueIndex])
-> (QueueIndex -> QueueIndex -> [QueueIndex])
-> (QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex])
-> Enum 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
(Int -> QueueIndex -> ShowS)
-> (QueueIndex -> String)
-> ([QueueIndex] -> ShowS)
-> Show QueueIndex
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 :: PhysicalDevice
-> f (QueueSpec m)
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> n (f (QueueFamilyIndex, Queue))))
assignQueues phys :: PhysicalDevice
phys specs :: f (QueueSpec m)
specs = MaybeT
  m
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> n (f (QueueFamilyIndex, Queue)))
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> n (f (QueueFamilyIndex, Queue))))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   m
   (Vector (DeviceQueueCreateInfo '[]),
    Device -> n (f (QueueFamilyIndex, Queue)))
 -> m (Maybe
         (Vector (DeviceQueueCreateInfo '[]),
          Device -> n (f (QueueFamilyIndex, Queue)))))
-> MaybeT
     m
     (Vector (DeviceQueueCreateInfo '[]),
      Device -> n (f (QueueFamilyIndex, Queue)))
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> n (f (QueueFamilyIndex, Queue))))
forall a b. (a -> b) -> a -> b
$ do
  [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties <-
    [QueueFamilyIndex]
-> [QueueFamilyProperties]
-> [(QueueFamilyIndex, QueueFamilyProperties)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32 -> QueueFamilyIndex
QueueFamilyIndex 0 ..]
    ([QueueFamilyProperties]
 -> [(QueueFamilyIndex, QueueFamilyProperties)])
-> (Vector QueueFamilyProperties -> [QueueFamilyProperties])
-> Vector QueueFamilyProperties
-> [(QueueFamilyIndex, QueueFamilyProperties)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   Vector QueueFamilyProperties -> [QueueFamilyProperties]
forall a. Vector a -> [a]
V.toList
    (Vector QueueFamilyProperties
 -> [(QueueFamilyIndex, QueueFamilyProperties)])
-> MaybeT m (Vector QueueFamilyProperties)
-> MaybeT m [(QueueFamilyIndex, QueueFamilyProperties)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> MaybeT m (Vector QueueFamilyProperties)
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 <- f (QueueSpec m)
-> (QueueSpec m -> MaybeT m (QueueSpec m, [QueueFamilyIndex]))
-> MaybeT m (f (QueueSpec m, [QueueFamilyIndex]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m)
specs ((QueueSpec m -> MaybeT m (QueueSpec m, [QueueFamilyIndex]))
 -> MaybeT m (f (QueueSpec m, [QueueFamilyIndex])))
-> (QueueSpec m -> MaybeT m (QueueSpec m, [QueueFamilyIndex]))
-> MaybeT m (f (QueueSpec m, [QueueFamilyIndex]))
forall a b. (a -> b) -> a -> b
$ \spec :: QueueSpec m
spec -> do
    [(QueueFamilyIndex, QueueFamilyProperties)]
families <- ((QueueFamilyIndex, QueueFamilyProperties) -> MaybeT m Bool)
-> [(QueueFamilyIndex, QueueFamilyProperties)]
-> MaybeT m [(QueueFamilyIndex, QueueFamilyProperties)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (m Bool -> MaybeT m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> MaybeT m Bool)
-> ((QueueFamilyIndex, QueueFamilyProperties) -> m Bool)
-> (QueueFamilyIndex, QueueFamilyProperties)
-> MaybeT m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> (QueueFamilyIndex, QueueFamilyProperties) -> m Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
forall (m :: * -> *).
QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecFamilyPredicate QueueSpec m
spec))
                        [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties
    (QueueSpec m, [QueueFamilyIndex])
-> MaybeT m (QueueSpec m, [QueueFamilyIndex])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueSpec m
spec, (QueueFamilyIndex, QueueFamilyProperties) -> QueueFamilyIndex
forall a b. (a, b) -> a
fst ((QueueFamilyIndex, QueueFamilyProperties) -> QueueFamilyIndex)
-> [(QueueFamilyIndex, QueueFamilyProperties)]
-> [QueueFamilyIndex]
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)
        | (i :: QueueFamilyIndex
i, QueueFamilyProperties {..}) <- [(QueueFamilyIndex, QueueFamilyProperties)]
queueFamilyProperties
        ]

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

  let maxFamilyIndex :: Maybe QueueFamilyIndex
      maxFamilyIndex :: Maybe QueueFamilyIndex
maxFamilyIndex = [QueueFamilyIndex] -> Maybe QueueFamilyIndex
forall (f :: * -> *) a. (Foldable f, Ord a) => f a -> Maybe a
maximumMay ((QueueSpec m, QueueFamilyIndex) -> QueueFamilyIndex
forall a b. (a, b) -> b
snd ((QueueSpec m, QueueFamilyIndex) -> QueueFamilyIndex)
-> [(QueueSpec m, QueueFamilyIndex)] -> [QueueFamilyIndex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (QueueSpec m, QueueFamilyIndex)
-> [(QueueSpec m, QueueFamilyIndex)]
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 =
        (State [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
 -> [QueueIndex] -> f (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> [QueueIndex]
-> State
     [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> f (QueueSpec m, QueueFamilyIndex, QueueIndex)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> [QueueIndex] -> f (QueueSpec m, QueueFamilyIndex, QueueIndex)
forall s a. State s a -> s -> a
evalState (QueueIndex -> [QueueIndex]
forall a. a -> [a]
repeat (Word32 -> QueueIndex
QueueIndex 0))
          (State [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
 -> f (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> State
     [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> f (QueueSpec m, QueueFamilyIndex, QueueIndex)
forall a b. (a -> b) -> a -> b
$ f (QueueSpec m, QueueFamilyIndex)
-> ((QueueSpec m, QueueFamilyIndex)
    -> StateT
         [QueueIndex] Identity (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> State
     [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m, QueueFamilyIndex)
specsWithFamily
          (((QueueSpec m, QueueFamilyIndex)
  -> StateT
       [QueueIndex] Identity (QueueSpec m, QueueFamilyIndex, QueueIndex))
 -> State
      [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex)))
-> ((QueueSpec m, QueueFamilyIndex)
    -> StateT
         [QueueIndex] Identity (QueueSpec m, QueueFamilyIndex, QueueIndex))
-> State
     [QueueIndex] (f (QueueSpec m, QueueFamilyIndex, QueueIndex))
forall a b. (a -> b) -> a -> b
$ \(spec :: QueueSpec m
spec, familyIndex :: QueueFamilyIndex
familyIndex) -> do
              [QueueIndex]
indices <- StateT [QueueIndex] Identity [QueueIndex]
forall (m :: * -> *) s. Monad m => StateT s m s
get
              let (index :: QueueIndex
index, indices' :: [QueueIndex]
indices') =
                    Word32 -> [QueueIndex] -> (QueueIndex, [QueueIndex])
forall a. (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a])
incrementAt (QueueFamilyIndex -> Word32
unQueueFamilyIndex QueueFamilyIndex
familyIndex) [QueueIndex]
indices
              [QueueIndex] -> StateT [QueueIndex] Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [QueueIndex]
indices'
              (QueueSpec m, QueueFamilyIndex, QueueIndex)
-> StateT
     [QueueIndex] Identity (QueueSpec m, QueueFamilyIndex, QueueIndex)
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 = ((QueueSpec m, QueueFamilyIndex) -> [[Float]] -> [[Float]])
-> [[Float]] -> f (QueueSpec m, QueueFamilyIndex) -> [[Float]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(QueueSpec {..}, QueueFamilyIndex i :: Word32
i) ps :: [[Float]]
ps ->
          Word32 -> Float -> [[Float]] -> [[Float]]
forall a. HasCallStack => Word32 -> a -> [[a]] -> [[a]]
prependAt Word32
i Float
queueSpecQueuePriority [[Float]]
ps
        )
        (Int -> [Float] -> [[Float]]
forall a. Int -> a -> [a]
replicate
          (Int -> (QueueFamilyIndex -> Int) -> Maybe QueueFamilyIndex -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int)
-> (QueueFamilyIndex -> Word32) -> QueueFamilyIndex -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueFamilyIndex -> Word32
unQueueFamilyIndex (QueueFamilyIndex -> Word32)
-> (QueueFamilyIndex -> QueueFamilyIndex)
-> QueueFamilyIndex
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueFamilyIndex -> QueueFamilyIndex
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 = [DeviceQueueCreateInfo '[]] -> Vector (DeviceQueueCreateInfo '[])
forall a. [a] -> Vector a
V.fromList
        [ DeviceQueueCreateInfo '[]
forall a. Zero a => a
zero { $sel:queueFamilyIndex:DeviceQueueCreateInfo :: Word32
queueFamilyIndex = Word32
familyIndex
               , $sel:queuePriorities:DeviceQueueCreateInfo :: Vector Float
queuePriorities  = [Float] -> Vector Float
forall a. [a] -> Vector a
V.fromList [Float]
ps
               }
        | (familyIndex :: Word32
familyIndex, ps :: [Float]
ps) <- [Word32] -> [[Float]] -> [(Word32, [Float])]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 ..] [[Float]]
queuePriorities
        , Bool -> Bool
not ([Float] -> Bool
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 dev :: Device
dev =
        f (QueueSpec m, QueueFamilyIndex, QueueIndex)
-> ((QueueSpec m, QueueFamilyIndex, QueueIndex)
    -> n (QueueFamilyIndex, Queue))
-> n (f (QueueFamilyIndex, Queue))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (QueueSpec m, QueueFamilyIndex, QueueIndex)
specsWithQueueIndex
          (((QueueSpec m, QueueFamilyIndex, QueueIndex)
  -> n (QueueFamilyIndex, Queue))
 -> n (f (QueueFamilyIndex, Queue)))
-> ((QueueSpec m, QueueFamilyIndex, QueueIndex)
    -> n (QueueFamilyIndex, Queue))
-> n (f (QueueFamilyIndex, Queue))
forall a b. (a -> b) -> a -> b
$ \(_, i :: QueueFamilyIndex
i@(QueueFamilyIndex familyIndex :: Word32
familyIndex), QueueIndex index :: Word32
index) ->
              (QueueFamilyIndex
i, ) (Queue -> (QueueFamilyIndex, Queue))
-> n Queue -> n (QueueFamilyIndex, Queue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Device -> Word32 -> Word32 -> n Queue
forall (io :: * -> *).
MonadIO io =>
Device -> Word32 -> Word32 -> io Queue
getDeviceQueue Device
dev Word32
familyIndex Word32
index

  (Vector (DeviceQueueCreateInfo '[]),
 Device -> n (f (QueueFamilyIndex, Queue)))
-> MaybeT
     m
     (Vector (DeviceQueueCreateInfo '[]),
      Device -> n (f (QueueFamilyIndex, Queue)))
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 q :: QueueFamilyProperties
q = QueueFlags
QUEUE_COMPUTE_BIT QueueFlags -> QueueFlags -> Bool
forall a. Bits a => a -> a -> Bool
.&&. QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q

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

isTransferQueueFamily :: QueueFamilyProperties -> Bool
isTransferQueueFamily :: QueueFamilyProperties -> Bool
isTransferQueueFamily q :: QueueFamilyProperties
q = QueueFlags
QUEUE_TRANSFER_BIT QueueFlags -> QueueFlags -> Bool
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 q :: QueueFamilyProperties
q =
  (   QueueFamilyProperties -> QueueFlags
queueFlags QueueFamilyProperties
q
    QueueFlags -> QueueFlags -> QueueFlags
forall a. Bits a => a -> a -> a
.&. (QueueFlags
QUEUE_TRANSFER_BIT QueueFlags -> QueueFlags -> QueueFlags
forall a. Bits a => a -> a -> a
.|. QueueFlags
QUEUE_GRAPHICS_BIT QueueFlags -> QueueFlags -> QueueFlags
forall a. Bits a => a -> a -> a
.|. QueueFlags
QUEUE_COMPUTE_BIT)
    )
    QueueFlags -> QueueFlags -> Bool
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 :: PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
isPresentQueueFamily phys :: PhysicalDevice
phys surf :: SurfaceKHR
surf (QueueFamilyIndex i :: Word32
i) =
  PhysicalDevice -> Word32 -> SurfaceKHR -> m Bool
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 :: [(a, Word32)] -> f (a -> Maybe b) -> [f b]
assign capacities :: [(a, Word32)]
capacities = (StateT [(a, Word32)] [] (f b) -> [(a, Word32)] -> [f b])
-> [(a, Word32)] -> StateT [(a, Word32)] [] (f b) -> [f b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [(a, Word32)] [] (f b) -> [(a, Word32)] -> [f b]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [(a, Word32)]
capacities (StateT [(a, Word32)] [] (f b) -> [f b])
-> (f (a -> Maybe b) -> StateT [(a, Word32)] [] (f b))
-> f (a -> Maybe b)
-> [f b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Maybe b) -> StateT [(a, Word32)] [] b)
-> f (a -> Maybe b) -> StateT [(a, Word32)] [] (f b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
  (\p :: a -> Maybe b
p -> do
    [(a, Word32)]
cs            <- StateT [(a, Word32)] [] [(a, Word32)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (choice :: b
choice, cs' :: [(a, Word32)]
cs') <- [(b, [(a, Word32)])] -> StateT [(a, Word32)] [] (b, [(a, Word32)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
forall a b. (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select a -> Maybe b
p [(a, Word32)]
cs)
    [(a, Word32)] -> StateT [(a, Word32)] [] ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [(a, Word32)]
cs'
    b -> StateT [(a, Word32)] [] b
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 :: (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select p :: a -> Maybe b
p = \case
  [] -> []
  x :: (a, Word32)
x : xs :: [(a, Word32)]
xs ->
    let hit :: b -> (b, [(a, Word32)])
hit b :: b
b = (b
b, if (a, Word32) -> Word32
forall a b. (a, b) -> b
snd (a, Word32)
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then [(a, Word32)]
xs else (Word32 -> Word32
forall a. Enum a => a -> a
pred (Word32 -> Word32) -> (a, Word32) -> (a, Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, Word32)
x) (a, Word32) -> [(a, Word32)] -> [(a, Word32)]
forall a. a -> [a] -> [a]
: [(a, Word32)]
xs)
        miss :: [(b, [(a, Word32)])]
miss = do
          (selected :: b
selected, xs' :: [(a, Word32)]
xs') <- (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
forall a b. (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])]
select a -> Maybe b
p [(a, Word32)]
xs
          (b, [(a, Word32)]) -> [(b, [(a, Word32)])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
selected, (a, Word32)
x (a, Word32) -> [(a, Word32)] -> [(a, Word32)]
forall a. a -> [a] -> [a]
: [(a, Word32)]
xs')
    in  if (a, Word32) -> Word32
forall a b. (a, b) -> b
snd (a, Word32)
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          then [(b, [(a, Word32)])]
miss
          else case a -> Maybe b
p ((a, Word32) -> a
forall a b. (a, b) -> a
fst (a, Word32)
x) of
            Nothing -> [(b, [(a, Word32)])]
miss
            Just b :: b
b  -> b -> (b, [(a, Word32)])
hit b
b (b, [(a, Word32)]) -> [(b, [(a, Word32)])] -> [(b, [(a, Word32)])]
forall a. a -> [a] -> [a]
: [(b, [(a, Word32)])]
miss

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

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

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

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

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