{-# 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
checkCommandsExp
:: [Name]
-> Q Exp
checkCommandsExp :: [Name] -> Q Exp
checkCommandsExp [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 String
"inst"
Name
device <- String -> Q Name
newName String
"device"
let isNull :: DeviceOrInstanceCommand -> Q Exp
isNull = \case
InstanceCmd Name
i -> [|nullFunPtr == $(varE i) $(varE inst)|]
DeviceCmd Name
i -> [|nullFunPtr == $(varE i) $(varE device)|]
[| \(Instance _ $(varP inst)) (Device _ $(varP device)) ->
[ name
| (True, name) <- zip
$(listE (isNull <$> vkCommandNames))
$(lift (commandString <$> vkCommandNames))
]
|]
commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]
commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]
commandNames [Name]
instAccessors [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 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 \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)
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 Name
n -> Name
n
DeviceCmd Name
n -> Name
n
commandCandidates :: String -> [String]
commandCandidates :: String -> [String]
commandCandidates String
n = if
| String
"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 Int
4 String
n)
| Just String
u <- String -> Maybe String
stripPrefix String
"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
<$> [String
"pVkAllocate", String
"pVkFree", String
"pVkCreate", String
"pVkDestroy"]
| Just String
u <- String -> Maybe String
stripPrefix String
"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
<$> [String
"pVkMap", String
"pVkUnmap"]
| Just String
u <- String -> Maybe String
stripPrefix String
"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
<$> [String
"pVkBegin", String
"pVkEnd"]
| Just String
u <- String -> Maybe String
stripPrefix String
"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
<$> [String
"pVkCmdBegin", String
"pVkCmdEnd"]
| Bool
otherwise
-> [String
"pVk" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
upperCaseFirst String
n]
where
stripPrefix :: String -> Maybe String
stripPrefix 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
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]
_ 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
_ -> String -> [Name]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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' : String
xs -> Char
'v' Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
String
s -> String
s
upperCaseFirst :: String -> String
upperCaseFirst :: ShowS
upperCaseFirst = \case
Char
x:String
xs -> Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
[] -> []