content: {-# 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 requestedCommands = do
    instAccessors   <- accessorNames ''InstanceCmds
    deviceAccessors <- accessorNames ''DeviceCmds
    let vkCommandNames =
          nub . commandNames instAccessors deviceAccessors =<< requestedCommands
    inst   <- newName "inst"
    device <- newName "device"
    let isNull = \case
          InstanceCmd i -> [|nullFunPtr == $(varE i) $(varE inst)|]
          DeviceCmd   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 instAccessors deviceAccessors =
    let instNames   = (nameBase &&& id) <$> instAccessors
        deviceNames = (nameBase &&& id) <$> deviceAccessors
        findCommand :: String -> Maybe DeviceOrInstanceCommand
        findCommand command =
          (InstanceCmd <$> lookup command instNames)
            <|> (DeviceCmd <$> lookup command deviceNames)
    in  \n ->
          let candidates = commandCandidates (nameBase n)
          in  catMaybes $ findCommand <$> candidates
  
  data DeviceOrInstanceCommand
    = DeviceCmd Name
    | InstanceCmd Name
    deriving (Eq, Show)
  
  -- | Get the C name of a function
  --
  -- >>> commandString (DeviceCmd (mkName "pVkCreateInstance"))
  -- "vkCreateInstance"
  commandString :: DeviceOrInstanceCommand -> String
  commandString = unPtrName . nameBase . \case
    InstanceCmd n -> n
    DeviceCmd   n -> 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 n = if
    | "Safe" `isSuffixOf` n
    -> commandCandidates (dropEnd 4 n)
    | Just u <- stripPrefix "with"
    -> (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"]
    | Just u <- stripPrefix "withMapped"
    -> (<> u) <$> ["pVkMap", "pVkUnmap"]
    | Just u <- stripPrefix "use"
    -> (<> u) <$> ["pVkBegin", "pVkEnd"]
    | Just u <- stripPrefix "cmdUse"
    -> (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"]
    | otherwise
    -> ["pVk" <> upperCaseFirst n]
   where
    stripPrefix p = if p `isPrefixOf` n
      then Just (upperCaseFirst (drop (length p) n))
      else 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 record = reify record <&> \case
    TyConI (DataD _ _ _ _ [con] _)
      | RecC _ vars <- con       -> firstOfThree <$> vars
      | RecGadtC _ vars _ <- con -> firstOfThree <$> vars
    _ -> fail "Name wasn't a TyConI"
    where firstOfThree (a, _, _) = a
  
  unPtrName :: String -> String
  unPtrName = \case
    'p' : 'V' : xs -> 'v' : xs
    s              -> s
  
  upperCaseFirst :: String -> String
  upperCaseFirst = \case
    x:xs -> toUpper x : xs
    [] -> []
  