Requirements.hs

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

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

    -- * Device requirements
  , checkDeviceRequirements

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

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

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

-- * Instance Creation

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

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

  (r, continue) <- flip runStateT True $ for required $ \r ->
    case checkInstanceRequest foundVersion layerProps lookupExtension r of
      res -> do
        unless (res == Satisfied) (put False)
        pure res

  (o, goodOptions) <- flip runStateT mempty $ for optional $ \o ->
    case checkInstanceRequest foundVersion layerProps lookupExtension o of
      res -> do
        when (res == Satisfied) $ modify (o :)
        pure res

  let ici = do
        guard continue
        pure $
          makeInstanceCreateInfo
            (requiredList <> goodOptions)
            baseCreateInfo
  pure (ici, r, o)

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

checkInstanceRequest
  :: ("apiVersion" ::: Word32)
  -> ("properties" ::: Vector LayerProperties)
  -> ( ("layerName" ::: Maybe ByteString)
       -> ByteString
       -> Maybe ExtensionProperties
     )
  -> InstanceRequirement
  -> RequirementResult
checkInstanceRequest foundVersion layerProps lookupExtension = \case
  RequireInstanceVersion minVersion ->
    if foundVersion >= minVersion
      then Satisfied
      else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion)
  RequireInstanceLayer{instanceLayerName, instanceLayerMinVersion}
    | Just props <- find ((== instanceLayerName) . layerName) layerProps
    , foundLayerVersion <- implementationVersion props ->
        if foundVersion >= instanceLayerMinVersion
          then Satisfied
          else
            UnsatisfiedLayerVersion
              instanceLayerName
              (Unsatisfied instanceLayerMinVersion foundLayerVersion)
    | otherwise ->
        MissingLayer instanceLayerName
  RequireInstanceExtension{instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion}
    | Just eProps <-
        lookupExtension
          instanceExtensionLayerName
          instanceExtensionName ->
        let foundInstanceExtensionVersion =
              Extension.specVersion eProps
        in if foundInstanceExtensionVersion >= instanceExtensionMinVersion
             then Satisfied
             else
               UnsatisfiedInstanceExtensionVersion
                 instanceExtensionName
                 ( Unsatisfied
                     instanceExtensionMinVersion
                     foundInstanceExtensionVersion
                 )
    | otherwise ->
        UnsatisfiedInstanceExtension 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 required optional phys baseCreateInfo = do
  let
    requiredList = toList required
    allAsList = requiredList <> toList optional

  --
  -- First collect the types and properties that we'll need to query using
  -- getPhysicalDeviceProperties2 and getPhysicalDeviceFeatures2
  --
  withDeviceFeatureStructs allAsList $ \(_ :: Proxy fs) ->
    withDevicePropertyStructs allAsList $ \(_ :: Proxy ps) -> do
      --
      -- Fetch everything
      --
      feats <- getPhysicalDeviceFeaturesMaybe @fs phys
      props <- getPhysicalDevicePropertiesMaybe @ps phys
      (_, layerProps) <- enumerateDeviceLayerProperties phys
      lookupExtension <-
        getLookupExtension
          layerProps
          (Just phys)
          [ deviceExtensionLayerName
          | RequireDeviceExtension{deviceExtensionLayerName} <- allAsList
          ]

      (r, continue) <- flip runStateT True $ for required $ \r ->
        case checkDeviceRequest feats props lookupExtension r of
          res -> do
            unless (res == Satisfied) (put False)
            pure res

      (o, goodOptions) <- flip runStateT mempty $ for optional $ \o ->
        case checkDeviceRequest feats props lookupExtension o of
          res -> do
            when (res == Satisfied) $ modify (o :)
            pure res

      --
      -- Now create the types for just the available features
      --
      let dci = do
            guard continue
            pure $
              makeDeviceCreateInfo
                (requiredList <> goodOptions)
                baseCreateInfo
      pure (dci, r, o)

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

{- | Generate 'DeviceCreateInfo' from some requirements.

The returned struct chain will enable all required features and extensions.
-}
makeDeviceCreateInfo
  :: [DeviceRequirement] -> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo allReqs baseCreateInfo =
  let
    featureSetters :: DMap (Product (Has KnownFeatureStruct) Endo)
    featureSetters =
      dmapFromListWith
        catProducts
        [ typeRep :=> Pair Has (Endo enableFeature)
        | RequireDeviceFeature{enableFeature} <- allReqs
        ]

    makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]
    makeZeroFeatureExts =
      [ Endo (extendSomeStruct s)
      | _ :=> Pair Has (f :: Endo s) <- dmapToList featureSetters
      , ExtendedFeatureStruct <- pure $ sFeatureStruct @s
      , let s = appEndo f zero
      ]

    addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)
    addBasicFeatures =
      case dmapLookup (typeRep @PhysicalDeviceFeatures) featureSetters of
        Nothing -> mempty
        Just (Pair _ s) ->
          Endo
            ( extendSomeStruct
                ((zero :: PhysicalDeviceFeatures2 '[]){features = appEndo s zero})
            )

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

    newFeatures :: SomeStruct DeviceCreateInfo
    newFeatures =
      appEndo
        (fold (addBasicFeatures : makeZeroFeatureExts))
        ( SomeStruct
            (baseCreateInfo :: DeviceCreateInfo '[])
              { Device.enabledExtensionNames = V.fromList extensionNames
              }
        )
  in
    newFeatures

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

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

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

data Unsatisfied a = Unsatisfied
  { unsatisfiedMinimum :: a
  -- ^ The minimum value to be accepted
  , unsatisfiedActual :: a
  -- ^ The value we got, less than 'unsatisfiedMinumum'
  }
  deriving (Eq, 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 required optional =
  let
    pList xs =
      nubOrd [prettyRequirementResult r | r <- toList xs, r /= Satisfied]
    reqStrings = pList required
    optStrings = pList optional
    withHeader s = \case
      [] -> []
      xs -> (s <> " requirements not met:") : (("  " <>) <$> xs)
    reportLines =
      withHeader "Required" reqStrings <> withHeader "Optional" optStrings
  in
    if null reportLines then Nothing else Just $ unlines reportLines

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

-- How I'm feeling after writing all this type level nonsense
prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String
prettyUnsatisfied s Unsatisfied{..} =
  "Wanted minimum of "
    <> s unsatisfiedMinimum
    <> ", got: "
    <> s 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 _ = Nothing
  knownChainNull = Just Refl

instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where
  has (px :: Proxy# a)
    | Just Refl <- eqT @a @x = Just (fst, first)
    | otherwise = ((. snd) *** (second .)) <$> has px
  knownChainNull = Nothing

getPropertyStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceProperties2 es
  -> Maybe s
getPropertyStruct c = case eqT @PhysicalDeviceProperties @s of
  Just Refl -> Just $ PhysicalDevice.properties c
  Nothing -> getStruct c

getFeatureStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceFeatures2 es
  -> Maybe s
getFeatureStruct c = case eqT @PhysicalDeviceFeatures @s of
  Just Refl -> Just $ PhysicalDevice.features c
  Nothing -> getStruct c

getStruct
  :: forall s h es
   . (Typeable h, Typeable s, KnownChain es, Extensible h)
  => h es
  -> Maybe s
getStruct c = ($ getNext c) . fst <$> has (proxy# :: Proxy# s)

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

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

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

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

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

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

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

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

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

getPhysicalDeviceFeaturesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe =
  getMaybe
    pVkGetPhysicalDeviceFeatures2
    (PhysicalDeviceFeatures2 ())
    getPhysicalDeviceFeatures
    getPhysicalDeviceFeatures2

getPhysicalDevicePropertiesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe =
  getMaybe
    pVkGetPhysicalDeviceProperties2
    (PhysicalDeviceProperties2 ())
    getPhysicalDeviceProperties
    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 funPtr wrapper2 get1 get2 phys =
  let hasFunPtr = funPtr (PhysicalDevice.instanceCmds phys) /= nullFunPtr
  in case knownChainNull @fs of
       Just Refl -> Just . wrapper2 <$> get1 phys
       Nothing -> if hasFunPtr then Just <$> get2 phys else pure Nothing

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

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

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

instance Semigroup (Has c a) where
  Has <> _ = 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 (Pair a1 b1) (Pair a2 b2) = Pair (a1 <> a2) (b1 <> b2)

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

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

infixr 1 :=>

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

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

-- | The contents of a 'DMap', as dependent pairs.
dmapToList :: DMap f -> [DSum f]
dmapToList (DMap m) = TRMap.elems m

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