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

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 (Instance(..), Device(..))
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 requestedCommands :: [Name]
requestedCommands = do
  [Name]
instAccessors   <- Name -> Q [Name]
accessorNames ''InstanceCmds
  [Name]
deviceAccessors <- Name -> Q [Name]
accessorNames ''DeviceCmds
  let vkCommandNames :: [DeviceOrInstanceCommand]
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
  Name
inst   <- String -> Q Name
newName "inst"
  Name
device <- String -> Q Name
newName "device"
  let isNull :: DeviceOrInstanceCommand -> Q Exp
isNull = \case
        InstanceCmd i :: Name
i -> [|nullFunPtr == $(varE i) $(varE inst)|]
        DeviceCmd   i :: Name
i -> [|nullFunPtr == $(varE i) $(varE 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 instAccessors :: [Name]
instAccessors deviceAccessors :: [Name]
deviceAccessors =
  let instNames :: [(String, Name)]
instNames   = (Name -> String
nameBase (Name -> String) -> (Name -> Name) -> Name -> (String, Name)
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 -> (String, Name)) -> [Name] -> [(String, Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
instAccessors
      deviceNames :: [(String, Name)]
deviceNames = (Name -> String
nameBase (Name -> String) -> (Name -> Name) -> Name -> (String, Name)
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 -> (String, Name)) -> [Name] -> [(String, Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
deviceAccessors
      findCommand :: String -> Maybe DeviceOrInstanceCommand
      findCommand :: String -> Maybe DeviceOrInstanceCommand
findCommand command :: String
command =
        (Name -> DeviceOrInstanceCommand
InstanceCmd (Name -> DeviceOrInstanceCommand)
-> Maybe Name -> Maybe DeviceOrInstanceCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
command [(String, Name)]
instNames)
          Maybe DeviceOrInstanceCommand
-> Maybe DeviceOrInstanceCommand -> Maybe DeviceOrInstanceCommand
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
<$> String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
command [(String, Name)]
deviceNames)
  in  \n :: Name
n ->
        let candidates :: [String]
candidates = String -> [String]
commandCandidates (Name -> String
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
$ String -> Maybe DeviceOrInstanceCommand
findCommand (String -> Maybe DeviceOrInstanceCommand)
-> [String] -> [Maybe DeviceOrInstanceCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
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
/= :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
$c/= :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
== :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
$c== :: DeviceOrInstanceCommand -> DeviceOrInstanceCommand -> Bool
Eq, Int -> DeviceOrInstanceCommand -> ShowS
[DeviceOrInstanceCommand] -> ShowS
DeviceOrInstanceCommand -> String
(Int -> DeviceOrInstanceCommand -> ShowS)
-> (DeviceOrInstanceCommand -> String)
-> ([DeviceOrInstanceCommand] -> ShowS)
-> Show DeviceOrInstanceCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeviceOrInstanceCommand] -> ShowS
$cshowList :: [DeviceOrInstanceCommand] -> ShowS
show :: DeviceOrInstanceCommand -> String
$cshow :: DeviceOrInstanceCommand -> String
showsPrec :: Int -> DeviceOrInstanceCommand -> ShowS
$cshowsPrec :: Int -> DeviceOrInstanceCommand -> ShowS
Show)

-- | Get the C name of a function
--
-- >>> commandString (DeviceCmd (mkName "pVkCreateInstance"))
-- "vkCreateInstance"
commandString :: DeviceOrInstanceCommand -> String
commandString :: DeviceOrInstanceCommand -> String
commandString = ShowS
unPtrName ShowS
-> (DeviceOrInstanceCommand -> String)
-> DeviceOrInstanceCommand
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> String)
-> (DeviceOrInstanceCommand -> Name)
-> DeviceOrInstanceCommand
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  InstanceCmd n :: Name
n -> Name
n
  DeviceCmd   n :: 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 :: String -> [String]
commandCandidates n :: String
n = if
  | "Safe" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
n
  -> String -> [String]
commandCandidates (Int -> ShowS
forall a. Int -> [a] -> [a]
dropEnd 4 String
n)
  | Just u :: String
u <- String -> Maybe String
stripPrefix "with"
  -> (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"]
  | Just u :: String
u <- String -> Maybe String
stripPrefix "withMapped"
  -> (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ["pVkMap", "pVkUnmap"]
  | Just u :: String
u <- String -> Maybe String
stripPrefix "use"
  -> (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ["pVkBegin", "pVkEnd"]
  | Just u :: String
u <- String -> Maybe String
stripPrefix "cmdUse"
  -> (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
u) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ["pVkCmdBegin", "pVkCmdEnd"]
  | Bool
otherwise
  -> ["pVk" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
upperCaseFirst String
n]
 where
  stripPrefix :: String -> Maybe String
stripPrefix p :: String
p = if String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
n
    then String -> Maybe String
forall a. a -> Maybe a
Just (ShowS
upperCaseFirst (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
p) String
n))
    else Maybe String
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 record :: 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 _ _ _ _ [con :: Con
con] _)
    | RecC _ vars :: [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 _ vars :: [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
  _ -> String -> [Name]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Name wasn't a TyConI"
  where firstOfThree :: (a, b, c) -> a
firstOfThree (a :: a
a, _, _) = a
a

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

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