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 Data.Vector (Vector)
import qualified Data.Vector as V
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
(QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> (QueueFamilyIndex -> QueueFamilyIndex -> Bool)
-> Eq QueueFamilyIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
== :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$c/= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
/= :: 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
$ccompare :: QueueFamilyIndex -> QueueFamilyIndex -> Ordering
compare :: QueueFamilyIndex -> QueueFamilyIndex -> Ordering
$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
>= :: QueueFamilyIndex -> QueueFamilyIndex -> Bool
$cmax :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
max :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
$cmin :: QueueFamilyIndex -> QueueFamilyIndex -> QueueFamilyIndex
min :: QueueFamilyIndex -> QueueFamilyIndex -> 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
$csucc :: QueueFamilyIndex -> QueueFamilyIndex
succ :: QueueFamilyIndex -> QueueFamilyIndex
$cpred :: QueueFamilyIndex -> QueueFamilyIndex
pred :: QueueFamilyIndex -> QueueFamilyIndex
$ctoEnum :: Int -> QueueFamilyIndex
toEnum :: Int -> QueueFamilyIndex
$cfromEnum :: QueueFamilyIndex -> Int
fromEnum :: QueueFamilyIndex -> Int
$cenumFrom :: QueueFamilyIndex -> [QueueFamilyIndex]
enumFrom :: QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromThen :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFromThen :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromTo :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFromTo :: QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
$cenumFromThenTo :: QueueFamilyIndex
-> QueueFamilyIndex -> QueueFamilyIndex -> [QueueFamilyIndex]
enumFromThenTo :: QueueFamilyIndex
-> QueueFamilyIndex -> 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
$cshowsPrec :: Int -> QueueFamilyIndex -> ShowS
showsPrec :: Int -> QueueFamilyIndex -> ShowS
$cshow :: QueueFamilyIndex -> String
show :: QueueFamilyIndex -> String
$cshowList :: [QueueFamilyIndex] -> ShowS
showList :: [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
$c== :: QueueIndex -> QueueIndex -> Bool
== :: QueueIndex -> QueueIndex -> Bool
$c/= :: QueueIndex -> QueueIndex -> Bool
/= :: 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
$ccompare :: QueueIndex -> QueueIndex -> Ordering
compare :: QueueIndex -> QueueIndex -> Ordering
$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
>= :: QueueIndex -> QueueIndex -> Bool
$cmax :: QueueIndex -> QueueIndex -> QueueIndex
max :: QueueIndex -> QueueIndex -> QueueIndex
$cmin :: QueueIndex -> QueueIndex -> QueueIndex
min :: QueueIndex -> QueueIndex -> 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
$csucc :: QueueIndex -> QueueIndex
succ :: QueueIndex -> QueueIndex
$cpred :: QueueIndex -> QueueIndex
pred :: QueueIndex -> QueueIndex
$ctoEnum :: Int -> QueueIndex
toEnum :: Int -> QueueIndex
$cfromEnum :: QueueIndex -> Int
fromEnum :: QueueIndex -> Int
$cenumFrom :: QueueIndex -> [QueueIndex]
enumFrom :: QueueIndex -> [QueueIndex]
$cenumFromThen :: QueueIndex -> QueueIndex -> [QueueIndex]
enumFromThen :: QueueIndex -> QueueIndex -> [QueueIndex]
$cenumFromTo :: QueueIndex -> QueueIndex -> [QueueIndex]
enumFromTo :: QueueIndex -> QueueIndex -> [QueueIndex]
$cenumFromThenTo :: QueueIndex -> QueueIndex -> QueueIndex -> [QueueIndex]
enumFromThenTo :: QueueIndex -> QueueIndex -> 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
$cshowsPrec :: Int -> QueueIndex -> ShowS
showsPrec :: Int -> QueueIndex -> ShowS
$cshow :: QueueIndex -> String
show :: QueueIndex -> String
$cshowList :: [QueueIndex] -> ShowS
showList :: [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 = 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
  queueFamilyProperties <-
    [QueueFamilyIndex]
-> [QueueFamilyProperties]
-> [(QueueFamilyIndex, QueueFamilyProperties)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32 -> QueueFamilyIndex
QueueFamilyIndex Word32
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
  specsWithFamilies <- for specs $ \QueueSpec m
spec -> do
    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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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
    pure (spec, fst <$> families)

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

  -- Assign each QueueSpec to a queue family
  specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <-
    headMay
      ( assign
          familiesWithCapacities
          ( specsWithFamilies <&> \(QueueSpec m
spec, [QueueFamilyIndex]
indices) QueueFamilyIndex
index ->
              if QueueFamilyIndex
index QueueFamilyIndex -> [QueueFamilyIndex] -> Bool
forall a. Eq a => a -> [a] -> 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 = [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 a. f a -> [a]
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 =
      (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 Word32
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
$
          \(QueueSpec m
spec, QueueFamilyIndex
familyIndex) -> do
            indices <- StateT [QueueIndex] Identity [QueueIndex]
forall (m :: * -> *) s. Monad m => StateT s m s
get
            let (index, indices') =
                  incrementAt (unQueueFamilyIndex familyIndex) indices
            put indices'
            pure (spec, familyIndex, index)

    -- Gather the priorities for each queue in each queue family
    queuePriorities :: [[Float]]
    queuePriorities =
      ((QueueSpec m, QueueFamilyIndex) -> [[Float]] -> [[Float]])
-> [[Float]] -> f (QueueSpec m, QueueFamilyIndex) -> [[Float]]
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \(QueueSpec{Float
QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecQueuePriority :: forall (m :: * -> *). QueueSpec m -> Float
queueSpecFamilyPredicate :: forall (m :: * -> *).
QueueSpec m -> QueueFamilyIndex -> QueueFamilyProperties -> m Bool
queueSpecQueuePriority :: Float
queueSpecFamilyPredicate :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
..}, QueueFamilyIndex Word32
i) [[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 Int
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 =
      [DeviceQueueCreateInfo '[]] -> Vector (DeviceQueueCreateInfo '[])
forall a. [a] -> Vector a
V.fromList
        [ DeviceQueueCreateInfo '[]
forall a. Zero a => a
zero
            { queueFamilyIndex = familyIndex
            , queuePriorities = V.fromList ps
            }
        | (Word32
familyIndex, [Float]
ps) <- [Word32] -> [[Float]] -> [(Word32, [Float])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [[Float]]
queuePriorities
        , Bool -> Bool
not ([Float] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Float]
ps)
        ]

    extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))
    extractQueues 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
$
        \(QueueSpec m
_, i :: QueueFamilyIndex
i@(QueueFamilyIndex Word32
familyIndex), QueueIndex 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

  pure (queueCreateInfos, extractQueues)

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

isComputeQueueFamily :: QueueFamilyProperties -> Bool
isComputeQueueFamily :: QueueFamilyProperties -> Bool
isComputeQueueFamily 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 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 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 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 :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
isPresentQueueFamily PhysicalDevice
phys SurfaceKHR
surf (QueueFamilyIndex 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 :: forall (f :: * -> *) a b.
Traversable f =>
[(a, Word32)] -> f (a -> Maybe b) -> [f b]
assign [(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse
      ( \a -> Maybe b
p -> do
          cs <- StateT [(a, Word32)] [] [(a, Word32)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
          (choice, cs') <- lift (select p cs)
          put cs'
          pure 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 (a, Word32) -> Word32
forall a b. (a, b) -> b
snd (a, Word32)
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
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, 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
        pure (selected, x : 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
== Word32
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
          Maybe b
Nothing -> [(b, [(a, Word32)])]
miss
          Just 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 :: forall (f :: * -> *) a. Alternative f => [a] -> f a
headMay = \case
  [] -> f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
  a
x : [a]
_ -> a -> f a
forall a. a -> f 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 f a -> Bool
forall a. 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 a. Ord a => 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 :: forall a. (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a])
incrementAt 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 :: forall a. HasCallStack => Word32 -> a -> [[a]] -> [[a]]
prependAt Word32
index 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 :: forall a. HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a])
modAt Word32
index 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
    ([a]
_, []) -> String -> (a, [a])
forall a. HasCallStack => String -> a
error String
"modAt, out of bounds"
    ([a]
xs, a
y : [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))