content: {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Vulkan.Utils.Requirements.TH
    ( req
    , reqs
    )
  where
  
  import Control.Applicative
  import Control.Category ((>>>))
  import Control.Monad
  import Data.Char
  import Data.Either (lefts)
  import Data.Foldable
  import Data.Functor ((<&>))
  import Data.List ( intercalate, isPrefixOf, dropWhileEnd )
  import Data.List.Extra (nubOrd)
  import Data.Maybe
  import Data.String
  import Data.Traversable
  import Data.Word
  import Language.Haskell.TH
  import Language.Haskell.TH.Quote
  import Language.Haskell.TH.Syntax
  import Text.ParserCombinators.ReadP hiding
    ( optional
    )
  import Text.Read (readMaybe)
  import Vulkan.Requirement
  import Vulkan.Utils.Internal
  import Vulkan.Utils.Misc
  import Vulkan.Version (pattern MAKE_API_VERSION)
  import Prelude hiding (GT)
  
  -- $setup
  -- >>> import           Vulkan.Core11.Promoted_From_VK_KHR_multiview
  -- >>> import           Vulkan.Core12
  -- >>> import           Vulkan.Extensions.VK_KHR_ray_tracing_pipeline
  -- >>> import           Vulkan.Zero
  
  -- | Parse a requirement and produce an appropriate 'DeviceRequirement'
  --
  -- 'DeviceVersionRequirement's are specified by in the form
  -- @<major>.<minor>[.<patch>]@
  --
  -- 'DeviceFeatureRequirement's are specified in the form @<type name>.<member
  -- name>@ and produce a 'RequireDeviceFeature' which checks and sets this
  -- feature.
  --
  -- 'DevicePropertyRequirement's are specified like feature requirements except
  -- with an additional description of the constraint. This may be any of
  --
  -- - @myFunctionName@: To check with an in-scope function taking the property
  --   type and returning 'Bool'
  -- - @> 123@: To indicate a minimum bound on a integral property
  -- - @>= 123@: To indicate an inclusive minimum bound on a integral property
  -- - @& SOMETHING_BIT@: To indicate that the specified bit must be present in
  --   the bitmask value
  --
  -- 'DeviceExtensionRequirement's are specified in the form @<extension name>
  -- <optional version>@. @<extension name>@ must start with @VK_@. The version
  -- will be compared against the 'specVersion' field of the
  -- 'ExtensionProperties' record.
  --
  -- - Names may be qualified.
  -- - The separator between the type and member can be any of @.@ @::@ @:@ @->@
  --   or any amount of space
  --
  -- >>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|]
  -- >>> featureName r
  -- "PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline"
  --
  -- >>> let r = [req|PhysicalDeviceVulkan11Features.multiview|]
  -- >>> featureName r
  -- "PhysicalDeviceVulkan11Features.multiview"
  --
  -- >>> let r = [reqs|  PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |]
  -- >>> featureName <$> r
  -- ["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"]
  --
  -- >>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|]
  -- ...
  --     • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures
  -- ...
  --
  -- >>> let r = [req|Doesn'tExist.multiview|]
  -- ...
  --     • Couldn't find type name "Doesn'tExist"
  -- ...
  --
  -- >>> let r = [req|Either.multiview|]
  -- ...
  --     • Data.Either.Either doesn't seem to be the type of a record constructor
  -- ...
  req :: QuasiQuoter
  req = (badQQ "req"){quoteExp = reqExp}
  
  -- | Like 'reqs' except that this parses a list of newline separated
  -- requirements
  --
  -- It ignores
  --
  -- - Blank lines
  -- - Lines beginning with @--@ or @#@
  reqs :: QuasiQuoter
  reqs = (badQQ "req"){quoteExp = exps reqExp . filterComments}
  
  reqExp :: String -> Q Exp
  reqExp s = do
    case parse s of
      Nothing -> fail $ "Couldn't parse " <> show s
      Just r -> do
        r' <- nameRequest r
        renderRequest s r'
  
  renderRequest :: String -> Request Name Name -> ExpQ
  renderRequest input = \case
    Feature s m ->
      let check = explicitRecordGet s m (ConT ''Bool)
          enable = explicitRecordSet s m (ConT ''Bool) [|True|]
       in do
            [|
              let featureName = fromString $(lift input)
                  checkFeature = $(check)
                  enableFeature = $(enable)
               in RequireDeviceFeature featureName checkFeature enableFeature
              |]
    Property s m c ->
      let t = conT s
          getProp = [|\str -> $(varE m) (str :: $t)|]
          checker = case c of
            GTE v -> [|(>= $(litE (IntegerL v)))|]
            GT v -> [|(> $(litE (IntegerL v)))|]
            AndBit b -> [|(.&&. $(conE b))|]
            Fun f -> [|$(varE f)|]
          check = [|$checker . $getProp|]
       in [|
            let propertyName = fromString $(lift input)
                checkProperty = $(check)
             in RequireDeviceProperty propertyName checkProperty
            |]
    Extension s v ->
      [|
        let deviceExtensionLayerName = Nothing
            deviceExtensionName = fromString $(lift s)
            deviceExtensionMinVersion = $(lift (fromMaybe minBound v))
         in RequireDeviceExtension
              deviceExtensionLayerName
              deviceExtensionName
              deviceExtensionMinVersion
        |]
    Version v -> [|RequireDeviceVersion $(lift v)|]
  
  nameRequest :: Request [String] String -> Q (Request Name Name)
  nameRequest = \case
    Feature s m -> do
      sName <- getQualTyName s
      let mName = mkName m
      pure $ Feature sName mName
    Property s m c -> do
      sName <- getQualTyName s
      let mName = mkName m
      c' <- for c getQualValueName
      pure $ Property sName mName c'
    Extension s v -> pure $ Extension s v
    Version v -> pure $ Version v
   where
    getQualTyName n = do
      let q = intercalate "." n
      maybe (fail $ "Couldn't find type name " <> show q) pure
        =<< lookupTypeName q
    getQualValueName n = do
      let q = intercalate "." n
      maybe (fail $ "Couldn't find value name " <> show q) pure
        =<< lookupValueName q
  
  data Request qual unqual
    = Version Word32
    | Feature qual unqual
    | Property qual unqual (Constraint qual)
    | Extension String (Maybe Word32)
    deriving (Show)
  
  data Constraint qual
    = GTE Integer
    | GT Integer
    | AndBit qual
    | Fun qual
    deriving (Show, Functor, Foldable, Traversable)
  
  -- |
  -- >>> parse ""
  -- Nothing
  --
  -- >>> parse "Foo->bar"
  -- Just (Feature ["Foo"] "bar")
  --
  -- >>> parse "V.Foo.bar"
  -- Just (Feature ["V","Foo"] "bar")
  --
  -- >>> parse "V.E.Foo bar"
  -- Just (Feature ["V","E","Foo"] "bar")
  --
  -- >>> parse "1.2"
  -- Just (Version 4202496)
  --
  -- >>> parse "1 2 1"
  -- Just (Version 4202497)
  --
  -- >>> parse "Foo.bar >= 10"
  -- Just (Property ["Foo"] "bar" (GTE 10))
  --
  -- >>> parse "V.Foo.bar & A.B.C_BIT"
  -- Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"]))
  --
  -- >>> parse "V.Foo.bar even"
  -- Just (Property ["V","Foo"] "bar" (Fun ["even"]))
  --
  -- >>> parse "V.Foo.bar Prelude.even"
  -- Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"]))
  parse :: String -> Maybe (Request [String] String)
  parse =
    let varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))
        var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars
        con = (:) <$> satisfy isUpper <*> varRemChars
        mod' = con
        qual :: ReadP String -> ReadP [String]
        qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)
        separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"]))
  
        digits = munch1 isDigit
        integer = readS_to_P (reads @Integer)
        word = do
          Just w <- readMaybe <$> digits
          pure w
  
        comp = do
          c <- (GT <$ string ">") <|> (GTE <$ string ">=")
          skipSpaces
          w <- integer
          pure $ c w
        andBit = do
          _ <- string "&"
          skipSpaces
          q <- qual con
          pure $ AndBit q
        fun = Fun <$> qual var
        constraint = comp <|> andBit <|> fun
  
        version = do
          ma <- word
          separator
          mi <- word
          pa <- fromMaybe 0 <$> (separator *> optional word)
          pure $ Version (MAKE_API_VERSION ma mi pa)
  
        feature = do
          s <- qual con
          _ <- separator
          m <- var
          pure $ Feature s m
  
        property = do
          s <- qual con
          _ <- separator
          m <- var
          skipSpaces
          c <- constraint
          pure $ Property s m c
  
        extension = do
          let prefix = "VK_"
          _ <- string prefix
          e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))
          skipSpaces
          v <- optional word
          pure $ Extension e v
  
        request = do
          skipSpaces
          asum
            [ p <* skipSpaces <* eof
            | p <- [version, feature, property, extension]
            ]
     in readP_to_S request >>> \case
          -- xs        -> pure $ Feature [] (show xs)
          [(r, "")] -> pure r
          _ -> Nothing
  {-# ANN parse ("HLint: ignore Use <$>" :: String) #-}
  
  ----------------------------------------------------------------
  -- Utils
  ----------------------------------------------------------------
  
  -- | Filters blank or commented lines, remove duplicates
  filterComments :: String -> [String]
  filterComments =
    let bad = (("--" `isPrefixOf`) <||> ("#" `isPrefixOf`) <||> null)
     in nubOrd . filter (not . bad) . fmap strip . lines
  
  strip :: String -> String
  strip = dropWhile isSpace . dropWhileEnd isSpace
  
  exps :: (String -> ExpQ) -> [String] -> ExpQ
  exps f = listE . fmap f
  
  (<||>) :: Applicative f => f Bool -> f Bool -> f Bool
  (<||>) = liftA2 (||)
  
  ----------------------------------------------------------------
  -- TH Utils
  ----------------------------------------------------------------
  
  explicitRecordSet
    :: Name
    -- ^ Type name
    -> Name
    -- ^ member name
    -> Type
    -- ^ member type
    -> ExpQ
    -- ^ new value
    -> ExpQ
  explicitRecordSet s m t x = do
    (con, ns) <- overRecord s m t
    ns' <- traverse (traverse newName) ns
    let pats = either (const wildP) varP <$> ns'
    let apps = either (const x) varE <$> ns'
    [|\ $(conP con pats) -> $(foldl appE (conE con) apps)|]
  
  explicitRecordGet
    :: Name
    -- ^ Type name
    -> Name
    -- ^ member name
    -> Type
    -- ^ member type
    -> ExpQ
  explicitRecordGet s m t = do
    (con, ns) <- overRecord s m t
    x <- newName "x"
    let pats = either (const (varP x)) (const wildP) <$> ns
    [|\ $(conP con pats) -> $(varE x)|]
  
  overRecord
    :: Name
    -- ^ Type name
    -> Name
    -- ^ member name
    -> Type
    -- ^ member type
    -> Q (Name, [Either Type String])
    -- ^ (Constructor, [Left var name, Right selected member type])
  overRecord s (nameBase -> m) t = do
    reify s >>= \case
      TyConI (DataD _ _ _ _ [c] _) | RecC con vs <- c ->
        let ns = vs <&> \case
              (nameBase -> n, _bang, t') | n == m    -> Left t'
                                         | otherwise -> Right n
        in  case lefts ns of
              [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s
              [t']
                | t == t'
                -> pure (con, ns)
                | otherwise
                -> fail
                  $  "Member "
                  <> show m
                  <> " of "
                  <> show s
                  <> " has type "
                  <> show t'
                  <> " but we expected "
                  <> show t
              _ ->
                fail
                  $  "Found multiple members called"
                  <> show m
                  <> " in "
                  <> show s
                  <> " ...what?"
      _ ->
        fail $ show s <> " doesn't seem to be the type of a record constructor"
  