{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoMonadComprehensions #-}

module Vulkan.Utils.CommandCheck
  ( checkCommandsExp
  ) where

import Control.Applicative ((<|>))
import Control.Arrow ((&&&))
import Data.Char
import Data.Functor ((<&>))
import Data.List
  ( isPrefixOf
  , isSuffixOf
  , nub
  )
import Data.List.Extra (dropEnd)
import Data.Maybe (catMaybes)
import Foreign.Ptr
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Vulkan.Core10 (Device (..), Instance (..))
import Vulkan.Dynamic

{- | Create an expression which checks the function pointers for all the Vulkan
commands depended upon by the specified list of function names.

It returns a list of function names corresponding to those functions with
null pointers.

Your program can use this function to fail early if a command couldn't be
loaded for some reason (missing extension or layer for example).

One can create a function called @checkCommands@ with the following:
@
[d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |]
@

It has the type @IsString a => Instance -> Device -> [a]@

It looks basically like

@
\inst dev ->
  [ name
  | True <- [ nullFunPtr == pVkCreateDevice inst
            , nullFunPtr == pVkCreateFence dev
              ..
            ]
  | name <- [ "vkCreateDevice"
            , "vkCreateFence"
              ..
            ]
  ]
@
-}
checkCommandsExp
  :: [Name]
  {- ^ The names of functions from the @vulkan@ package. Unknown commands are
  ignored
  -}
  -> Q Exp
checkCommandsExp :: [Name] -> Q Exp
checkCommandsExp [Name]
requestedCommands = do
  instAccessors <- Name -> Q [Name]
accessorNames ''InstanceCmds
  deviceAccessors <- accessorNames ''DeviceCmds
  let vkCommandNames =
        [DeviceOrInstanceCommand] -> [DeviceOrInstanceCommand]
forall a. Eq a => [a] -> [a]
nub ([DeviceOrInstanceCommand] -> [DeviceOrInstanceCommand])
-> (Name -> [DeviceOrInstanceCommand])
-> Name
-> [DeviceOrInstanceCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]
commandNames [Name]
instAccessors [Name]
deviceAccessors (Name -> [DeviceOrInstanceCommand])
-> [Name] -> [DeviceOrInstanceCommand]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Name]
requestedCommands
  inst <- newName "inst"
  device <- newName "device"
  let isNull = \case
        InstanceCmd Name
i -> [|nullFunPtr == $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
i) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
inst)|]
        DeviceCmd Name
i -> [|nullFunPtr == $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
i) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
device)|]
  [|
    \(Instance _ $(varP inst)) (Device _ $(varP device)) ->
      [ name
      | (True, name) <-
          zip
            $(listE (isNull <$> vkCommandNames))
            $(lift (commandString <$> vkCommandNames))
      ]
    |]

{- | Given instance and device accessors and a function, find the function
pointer accessor names which it depends on

>>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice")
[InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice]
-}
commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]
commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]
commandNames [Name]
instAccessors [Name]
deviceAccessors =
  let
    instNames :: [([Char], Name)]
instNames = (Name -> [Char]
nameBase (Name -> [Char]) -> (Name -> Name) -> Name -> ([Char], Name)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Name
forall a. a -> a
id) (Name -> ([Char], Name)) -> [Name] -> [([Char], Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
instAccessors
    deviceNames :: [([Char], Name)]
deviceNames = (Name -> [Char]
nameBase (Name -> [Char]) -> (Name -> Name) -> Name -> ([Char], Name)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Name
forall a. a -> a
id) (Name -> ([Char], Name)) -> [Name] -> [([Char], Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
deviceAccessors
    findCommand :: String -> Maybe DeviceOrInstanceCommand
    findCommand :: [Char] -> Maybe DeviceOrInstanceCommand
findCommand [Char]
command =
      (Name -> DeviceOrInstanceCommand
InstanceCmd (Name -> DeviceOrInstanceCommand)
-> Maybe Name -> Maybe DeviceOrInstanceCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [([Char], Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
command [([Char], Name)]
instNames)
        Maybe DeviceOrInstanceCommand
-> Maybe DeviceOrInstanceCommand -> Maybe DeviceOrInstanceCommand
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Name -> DeviceOrInstanceCommand
DeviceCmd (Name -> DeviceOrInstanceCommand)
-> Maybe Name -> Maybe DeviceOrInstanceCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [([Char], Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
command [([Char], Name)]
deviceNames)
  in
    \Name
n ->
      let candidates :: [[Char]]
candidates = [Char] -> [[Char]]
commandCandidates (Name -> [Char]
nameBase Name
n)
      in [Maybe DeviceOrInstanceCommand] -> [DeviceOrInstanceCommand]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DeviceOrInstanceCommand] -> [DeviceOrInstanceCommand])
-> [Maybe DeviceOrInstanceCommand] -> [DeviceOrInstanceCommand]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe DeviceOrInstanceCommand
findCommand ([Char] -> Maybe DeviceOrInstanceCommand)
-> [[Char]] -> [Maybe DeviceOrInstanceCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
candidates

data DeviceOrInstanceCommand
  = DeviceCmd Name
  | InstanceCmd Name
  deriving (DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
(DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool)
-> (DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool)
-> Eq DeviceOrInstanceCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
== :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
$c/= :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
/= :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
Eq, Int -> DeviceOrInstanceCommand -> ShowS
[DeviceOrInstanceCommand] -> ShowS
DeviceOrInstanceCommand -> [Char]
(Int -> DeviceOrInstanceCommand -> ShowS)
-> (DeviceOrInstanceCommand -> [Char])
-> ([DeviceOrInstanceCommand] -> ShowS)
-> Show DeviceOrInstanceCommand
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeviceOrInstanceCommand -> ShowS
showsPrec :: Int -> DeviceOrInstanceCommand -> ShowS
$cshow :: DeviceOrInstanceCommand -> [Char]
show :: DeviceOrInstanceCommand -> [Char]
$cshowList :: [DeviceOrInstanceCommand] -> ShowS
showList :: [DeviceOrInstanceCommand] -> ShowS
Show)

{- | Get the C name of a function

>>> commandString (DeviceCmd (mkName "pVkCreateInstance"))
"vkCreateInstance"
-}
commandString :: DeviceOrInstanceCommand -> String
commandString :: DeviceOrInstanceCommand -> [Char]
commandString =
  ShowS
unPtrName ShowS
-> (DeviceOrInstanceCommand -> [Char])
-> DeviceOrInstanceCommand
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase (Name -> [Char])
-> (DeviceOrInstanceCommand -> Name)
-> DeviceOrInstanceCommand
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    InstanceCmd Name
n -> Name
n
    DeviceCmd Name
n -> Name
n

{- | A list of potential sets of vulkan commands this name depends on, not all
of them will be valid names.

>>> commandCandidates "withDevice"
["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"]

>>> commandCandidates "waitSemaphoresSafe"
["pVkWaitSemaphores"]

>>> commandCandidates "useCmdBuffer"
["pVkBeginCmdBuffer","pVkEndCmdBuffer"]

>>> commandCandidates "withSemaphore"
["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"]
-}
commandCandidates :: String -> [String]
commandCandidates :: [Char] -> [[Char]]
commandCandidates [Char]
n =
  if
    | [Char]
"Safe" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
n ->
        [Char] -> [[Char]]
commandCandidates (Int -> ShowS
forall a. Int -> [a] -> [a]
dropEnd Int
4 [Char]
n)
    | Just [Char]
u <- [Char] -> Maybe [Char]
stripPrefix [Char]
"with" ->
        ([Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
u) ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"pVkAllocate", [Char]
"pVkFree", [Char]
"pVkCreate", [Char]
"pVkDestroy"]
    | Just [Char]
u <- [Char] -> Maybe [Char]
stripPrefix [Char]
"withMapped" ->
        ([Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
u) ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"pVkMap", [Char]
"pVkUnmap"]
    | Just [Char]
u <- [Char] -> Maybe [Char]
stripPrefix [Char]
"use" ->
        ([Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
u) ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"pVkBegin", [Char]
"pVkEnd"]
    | Just [Char]
u <- [Char] -> Maybe [Char]
stripPrefix [Char]
"cmdUse" ->
        ([Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
u) ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"pVkCmdBegin", [Char]
"pVkCmdEnd"]
    | Bool
otherwise ->
        [[Char]
"pVk" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
upperCaseFirst [Char]
n]
  where
    stripPrefix :: [Char] -> Maybe [Char]
stripPrefix [Char]
p =
      if [Char]
p [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
n
        then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (ShowS
upperCaseFirst (Int -> ShowS
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
p) [Char]
n))
        else Maybe [Char]
forall a. Maybe a
Nothing

{- | Get the record accessors of a type

>>> $(lift . fmap show =<< accessorNames ''Device)
["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"]
-}
accessorNames :: Name -> Q [Name]
accessorNames :: Name -> Q [Name]
accessorNames Name
record =
  Name -> Q Info
reify Name
record Q Info -> (Info -> [Name]) -> Q [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con
con] [DerivClause]
_)
      | RecC Name
_ [VarBangType]
vars <- Con
con -> VarBangType -> Name
forall {a} {b} {c}. (a, b, c) -> a
firstOfThree (VarBangType -> Name) -> [VarBangType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
vars
      | RecGadtC [Name]
_ [VarBangType]
vars Kind
_ <- Con
con -> VarBangType -> Name
forall {a} {b} {c}. (a, b, c) -> a
firstOfThree (VarBangType -> Name) -> [VarBangType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
vars
    Info
_ -> [Char] -> [Name]
forall a. [Char] -> [a]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Name wasn't a TyConI"
  where
    firstOfThree :: (a, b, c) -> a
firstOfThree (a
a, b
_, c
_) = a
a

unPtrName :: String -> String
unPtrName :: ShowS
unPtrName = \case
  Char
'p' : Char
'V' : [Char]
xs -> Char
'v' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
xs
  [Char]
s -> [Char]
s

upperCaseFirst :: String -> String
upperCaseFirst :: ShowS
upperCaseFirst = \case
  Char
x : [Char]
xs -> Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
xs
  [] -> []