{-# 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 :: QuasiQuoter
req = (String -> QuasiQuoter
badQQ String
"req"){quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
reqExp}

-- | Like 'reqs' except that this parses a list of newline separated
-- requirements
--
-- It ignores
--
-- - Blank lines
-- - Lines beginning with @--@ or @#@
reqs :: QuasiQuoter
reqs :: QuasiQuoter
reqs = (String -> QuasiQuoter
badQQ String
"req"){quoteExp :: String -> Q Exp
quoteExp = (String -> Q Exp) -> [String] -> Q Exp
exps String -> Q Exp
reqExp ([String] -> Q Exp) -> (String -> [String]) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
filterComments}

reqExp :: String -> Q Exp
reqExp :: String -> Q Exp
reqExp String
s = do
  case String -> Maybe (Request [String] String)
parse String
s of
    Maybe (Request [String] String)
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s
    Just Request [String] String
r -> do
      Request Name Name
r' <- Request [String] String -> Q (Request Name Name)
nameRequest Request [String] String
r
      String -> Request Name Name -> Q Exp
renderRequest String
s Request Name Name
r'

renderRequest :: String -> Request Name Name -> ExpQ
renderRequest :: String -> Request Name Name -> Q Exp
renderRequest String
input = \case
  Feature Name
s Name
m ->
    let check :: Q Exp
check = Name -> Name -> Type -> Q Exp
explicitRecordGet Name
s Name
m (Name -> Type
ConT ''Bool)
        enable :: Q Exp
enable = Name -> Name -> Type -> Q Exp -> Q Exp
explicitRecordSet Name
s Name
m (Name -> Type
ConT ''Bool) [|True|]
     in do
          [|
            let featureName = fromString $(lift input)
                checkFeature = $(check)
                enableFeature = $(enable)
             in RequireDeviceFeature featureName checkFeature enableFeature
            |]
  Property Name
s Name
m Constraint Name
c ->
    let t :: Q Type
t = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
s
        getProp :: Q Exp
getProp = [|\str -> $(varE m) (str :: $t)|]
        checker :: Q Exp
checker = case Constraint Name
c of
          GTE Integer
v -> [|(>= $(litE (IntegerL v)))|]
          GT Integer
v -> [|(> $(litE (IntegerL v)))|]
          AndBit Name
b -> [|(.&&. $(conE b))|]
          Fun Name
f -> [|$(varE f)|]
        check :: Q Exp
check = [|$checker . $getProp|]
     in [|
          let propertyName = fromString $(lift input)
              checkProperty = $(check)
           in RequireDeviceProperty propertyName checkProperty
          |]
  Extension String
s Maybe Word32
v ->
    [|
      let deviceExtensionLayerName = Nothing
          deviceExtensionName = fromString $(lift s)
          deviceExtensionMinVersion = $(lift (fromMaybe minBound v))
       in RequireDeviceExtension
            deviceExtensionLayerName
            deviceExtensionName
            deviceExtensionMinVersion
      |]
  Version Word32
v -> [|RequireDeviceVersion $(lift v)|]

nameRequest :: Request [String] String -> Q (Request Name Name)
nameRequest :: Request [String] String -> Q (Request Name Name)
nameRequest = \case
  Feature [String]
s String
m -> do
    Name
sName <- [String] -> Q Name
getQualTyName [String]
s
    let mName :: Name
mName = String -> Name
mkName String
m
    Request Name Name -> Q (Request Name Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request Name Name -> Q (Request Name Name))
-> Request Name Name -> Q (Request Name Name)
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Request Name Name
forall qual unqual. qual -> unqual -> Request qual unqual
Feature Name
sName Name
mName
  Property [String]
s String
m Constraint [String]
c -> do
    Name
sName <- [String] -> Q Name
getQualTyName [String]
s
    let mName :: Name
mName = String -> Name
mkName String
m
    Constraint Name
c' <- Constraint [String] -> ([String] -> Q Name) -> Q (Constraint Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Constraint [String]
c [String] -> Q Name
getQualValueName
    Request Name Name -> Q (Request Name Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request Name Name -> Q (Request Name Name))
-> Request Name Name -> Q (Request Name Name)
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Constraint Name -> Request Name Name
forall qual unqual.
qual -> unqual -> Constraint qual -> Request qual unqual
Property Name
sName Name
mName Constraint Name
c'
  Extension String
s Maybe Word32
v -> Request Name Name -> Q (Request Name Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request Name Name -> Q (Request Name Name))
-> Request Name Name -> Q (Request Name Name)
forall a b. (a -> b) -> a -> b
$ String -> Maybe Word32 -> Request Name Name
forall qual unqual. String -> Maybe Word32 -> Request qual unqual
Extension String
s Maybe Word32
v
  Version Word32
v -> Request Name Name -> Q (Request Name Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request Name Name -> Q (Request Name Name))
-> Request Name Name -> Q (Request Name Name)
forall a b. (a -> b) -> a -> b
$ Word32 -> Request Name Name
forall qual unqual. Word32 -> Request qual unqual
Version Word32
v
 where
  getQualTyName :: [String] -> Q Name
getQualTyName [String]
n = do
    let q :: String
q = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
n
    Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find type name " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
q) Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupTypeName String
q
  getQualValueName :: [String] -> Q Name
getQualValueName [String]
n = do
    let q :: String
q = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
n
    Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find value name " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
q) Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupValueName String
q

data Request qual unqual
  = Version Word32
  | Feature qual unqual
  | Property qual unqual (Constraint qual)
  | Extension String (Maybe Word32)
  deriving (Int -> Request qual unqual -> String -> String
[Request qual unqual] -> String -> String
Request qual unqual -> String
(Int -> Request qual unqual -> String -> String)
-> (Request qual unqual -> String)
-> ([Request qual unqual] -> String -> String)
-> Show (Request qual unqual)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall qual unqual.
(Show qual, Show unqual) =>
Int -> Request qual unqual -> String -> String
forall qual unqual.
(Show qual, Show unqual) =>
[Request qual unqual] -> String -> String
forall qual unqual.
(Show qual, Show unqual) =>
Request qual unqual -> String
showList :: [Request qual unqual] -> String -> String
$cshowList :: forall qual unqual.
(Show qual, Show unqual) =>
[Request qual unqual] -> String -> String
show :: Request qual unqual -> String
$cshow :: forall qual unqual.
(Show qual, Show unqual) =>
Request qual unqual -> String
showsPrec :: Int -> Request qual unqual -> String -> String
$cshowsPrec :: forall qual unqual.
(Show qual, Show unqual) =>
Int -> Request qual unqual -> String -> String
Show)

data Constraint qual
  = GTE Integer
  | GT Integer
  | AndBit qual
  | Fun qual
  deriving (Int -> Constraint qual -> String -> String
[Constraint qual] -> String -> String
Constraint qual -> String
(Int -> Constraint qual -> String -> String)
-> (Constraint qual -> String)
-> ([Constraint qual] -> String -> String)
-> Show (Constraint qual)
forall qual.
Show qual =>
Int -> Constraint qual -> String -> String
forall qual. Show qual => [Constraint qual] -> String -> String
forall qual. Show qual => Constraint qual -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Constraint qual] -> String -> String
$cshowList :: forall qual. Show qual => [Constraint qual] -> String -> String
show :: Constraint qual -> String
$cshow :: forall qual. Show qual => Constraint qual -> String
showsPrec :: Int -> Constraint qual -> String -> String
$cshowsPrec :: forall qual.
Show qual =>
Int -> Constraint qual -> String -> String
Show, (forall a b. (a -> b) -> Constraint a -> Constraint b)
-> (forall a b. a -> Constraint b -> Constraint a)
-> Functor Constraint
forall a b. a -> Constraint b -> Constraint a
forall a b. (a -> b) -> Constraint a -> Constraint b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Constraint b -> Constraint a
$c<$ :: forall a b. a -> Constraint b -> Constraint a
fmap :: forall a b. (a -> b) -> Constraint a -> Constraint b
$cfmap :: forall a b. (a -> b) -> Constraint a -> Constraint b
Functor, (forall m. Monoid m => Constraint m -> m)
-> (forall m a. Monoid m => (a -> m) -> Constraint a -> m)
-> (forall m a. Monoid m => (a -> m) -> Constraint a -> m)
-> (forall a b. (a -> b -> b) -> b -> Constraint a -> b)
-> (forall a b. (a -> b -> b) -> b -> Constraint a -> b)
-> (forall b a. (b -> a -> b) -> b -> Constraint a -> b)
-> (forall b a. (b -> a -> b) -> b -> Constraint a -> b)
-> (forall a. (a -> a -> a) -> Constraint a -> a)
-> (forall a. (a -> a -> a) -> Constraint a -> a)
-> (forall a. Constraint a -> [a])
-> (forall a. Constraint a -> Bool)
-> (forall a. Constraint a -> Int)
-> (forall a. Eq a => a -> Constraint a -> Bool)
-> (forall a. Ord a => Constraint a -> a)
-> (forall a. Ord a => Constraint a -> a)
-> (forall a. Num a => Constraint a -> a)
-> (forall a. Num a => Constraint a -> a)
-> Foldable Constraint
forall a. Eq a => a -> Constraint a -> Bool
forall a. Num a => Constraint a -> a
forall a. Ord a => Constraint a -> a
forall m. Monoid m => Constraint m -> m
forall a. Constraint a -> Bool
forall a. Constraint a -> Int
forall a. Constraint a -> [a]
forall a. (a -> a -> a) -> Constraint a -> a
forall m a. Monoid m => (a -> m) -> Constraint a -> m
forall b a. (b -> a -> b) -> b -> Constraint a -> b
forall a b. (a -> b -> b) -> b -> Constraint a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Constraint a -> a
$cproduct :: forall a. Num a => Constraint a -> a
sum :: forall a. Num a => Constraint a -> a
$csum :: forall a. Num a => Constraint a -> a
minimum :: forall a. Ord a => Constraint a -> a
$cminimum :: forall a. Ord a => Constraint a -> a
maximum :: forall a. Ord a => Constraint a -> a
$cmaximum :: forall a. Ord a => Constraint a -> a
elem :: forall a. Eq a => a -> Constraint a -> Bool
$celem :: forall a. Eq a => a -> Constraint a -> Bool
length :: forall a. Constraint a -> Int
$clength :: forall a. Constraint a -> Int
null :: forall a. Constraint a -> Bool
$cnull :: forall a. Constraint a -> Bool
toList :: forall a. Constraint a -> [a]
$ctoList :: forall a. Constraint a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Constraint a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldr1 :: forall a. (a -> a -> a) -> Constraint a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
fold :: forall m. Monoid m => Constraint m -> m
$cfold :: forall m. Monoid m => Constraint m -> m
Foldable, Functor Constraint
Foldable Constraint
Functor Constraint
-> Foldable Constraint
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Constraint a -> f (Constraint b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Constraint (f a) -> f (Constraint a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Constraint a -> m (Constraint b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Constraint (m a) -> m (Constraint a))
-> Traversable Constraint
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
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 :: String -> Maybe (Request [String] String)
parse =
  let varRemChars :: ReadP String
varRemChars = (Char -> Bool) -> ReadP String
munch (Char -> Bool
isAlphaNum (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))
      var :: ReadP String
var = (:) (Char -> String -> String)
-> ReadP Char -> ReadP (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP Char
satisfy (Char -> Bool
isLower (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')) ReadP (String -> String) -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP String
varRemChars
      con :: ReadP String
con = (:) (Char -> String -> String)
-> ReadP Char -> ReadP (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isUpper ReadP (String -> String) -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP String
varRemChars
      mod' :: ReadP String
mod' = ReadP String
con
      qual :: ReadP String -> ReadP [String]
      qual :: ReadP String -> ReadP [String]
qual ReadP String
x = (String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> ReadP String -> ReadP [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
x) ReadP [String] -> ReadP [String] -> ReadP [String]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((:) (String -> [String] -> [String])
-> ReadP String -> ReadP ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP String
mod' ReadP String -> ReadP Char -> ReadP String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
'.') ReadP ([String] -> [String]) -> ReadP [String] -> ReadP [String]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP String -> ReadP [String]
qual ReadP String
x)
      separator :: ReadP ()
separator = [ReadP ()] -> ReadP ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (ReadP ()
skipSpaces ReadP () -> [ReadP ()] -> [ReadP ()]
forall a. a -> [a] -> [a]
: (ReadP String -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP String -> ReadP ())
-> (String -> ReadP String) -> String -> ReadP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ReadP String
string (String -> ReadP ()) -> [String] -> [ReadP ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
".", String
"->", String
"::", String
":"]))

      digits :: ReadP String
digits = (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
      integer :: ReadP Integer
integer = ReadS Integer -> ReadP Integer
forall a. ReadS a -> ReadP a
readS_to_P (forall a. Read a => ReadS a
reads @Integer)
      word :: ReadP b
word = do
        Just b
w <- String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe b) -> ReadP String -> ReadP (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
digits
        b -> ReadP b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
w

      comp :: ReadP (Constraint qual)
comp = do
        Integer -> Constraint qual
c <- (Integer -> Constraint qual
forall qual. Integer -> Constraint qual
GT (Integer -> Constraint qual)
-> ReadP String -> ReadP (Integer -> Constraint qual)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
">") ReadP (Integer -> Constraint qual)
-> ReadP (Integer -> Constraint qual)
-> ReadP (Integer -> Constraint qual)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Constraint qual
forall qual. Integer -> Constraint qual
GTE (Integer -> Constraint qual)
-> ReadP String -> ReadP (Integer -> Constraint qual)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
">=")
        ReadP ()
skipSpaces
        Integer
w <- ReadP Integer
integer
        Constraint qual -> ReadP (Constraint qual)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint qual -> ReadP (Constraint qual))
-> Constraint qual -> ReadP (Constraint qual)
forall a b. (a -> b) -> a -> b
$ Integer -> Constraint qual
c Integer
w
      andBit :: ReadP (Constraint [String])
andBit = do
        String
_ <- String -> ReadP String
string String
"&"
        ReadP ()
skipSpaces
        [String]
q <- ReadP String -> ReadP [String]
qual ReadP String
con
        Constraint [String] -> ReadP (Constraint [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint [String] -> ReadP (Constraint [String]))
-> Constraint [String] -> ReadP (Constraint [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Constraint [String]
forall qual. qual -> Constraint qual
AndBit [String]
q
      fun :: ReadP (Constraint [String])
fun = [String] -> Constraint [String]
forall qual. qual -> Constraint qual
Fun ([String] -> Constraint [String])
-> ReadP [String] -> ReadP (Constraint [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String -> ReadP [String]
qual ReadP String
var
      constraint :: ReadP (Constraint [String])
constraint = ReadP (Constraint [String])
forall {qual}. ReadP (Constraint qual)
comp ReadP (Constraint [String])
-> ReadP (Constraint [String]) -> ReadP (Constraint [String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP (Constraint [String])
andBit ReadP (Constraint [String])
-> ReadP (Constraint [String]) -> ReadP (Constraint [String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP (Constraint [String])
fun

      version :: ReadP (Request qual unqual)
version = do
        Word32
ma <- ReadP Word32
forall {b}. Read b => ReadP b
word
        ReadP ()
separator
        Word32
mi <- ReadP Word32
forall {b}. Read b => ReadP b
word
        Word32
pa <- Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe Word32
0 (Maybe Word32 -> Word32) -> ReadP (Maybe Word32) -> ReadP Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP ()
separator ReadP () -> ReadP (Maybe Word32) -> ReadP (Maybe Word32)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Word32 -> ReadP (Maybe Word32)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReadP Word32
forall {b}. Read b => ReadP b
word)
        Request qual unqual -> ReadP (Request qual unqual)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request qual unqual -> ReadP (Request qual unqual))
-> Request qual unqual -> ReadP (Request qual unqual)
forall a b. (a -> b) -> a -> b
$ Word32 -> Request qual unqual
forall qual unqual. Word32 -> Request qual unqual
Version (Word32 -> Word32 -> Word32 -> Word32
MAKE_API_VERSION Word32
ma Word32
mi Word32
pa)

      feature :: ReadP (Request [String] String)
feature = do
        [String]
s <- ReadP String -> ReadP [String]
qual ReadP String
con
        ()
_ <- ReadP ()
separator
        String
m <- ReadP String
var
        Request [String] String -> ReadP (Request [String] String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request [String] String -> ReadP (Request [String] String))
-> Request [String] String -> ReadP (Request [String] String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> Request [String] String
forall qual unqual. qual -> unqual -> Request qual unqual
Feature [String]
s String
m

      property :: ReadP (Request [String] String)
property = do
        [String]
s <- ReadP String -> ReadP [String]
qual ReadP String
con
        ()
_ <- ReadP ()
separator
        String
m <- ReadP String
var
        ReadP ()
skipSpaces
        Constraint [String]
c <- ReadP (Constraint [String])
constraint
        Request [String] String -> ReadP (Request [String] String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request [String] String -> ReadP (Request [String] String))
-> Request [String] String -> ReadP (Request [String] String)
forall a b. (a -> b) -> a -> b
$ [String]
-> String -> Constraint [String] -> Request [String] String
forall qual unqual.
qual -> unqual -> Constraint qual -> Request qual unqual
Property [String]
s String
m Constraint [String]
c

      extension :: ReadP (Request qual unqual)
extension = do
        let prefix :: p
prefix = p
"VK_"
        String
_ <- String -> ReadP String
string String
forall {p}. IsString p => p
prefix
        String
e <- (String
forall {p}. IsString p => p
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch (Char -> Bool
isAlphaNum (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))
        ReadP ()
skipSpaces
        Maybe Word32
v <- ReadP Word32 -> ReadP (Maybe Word32)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReadP Word32
forall {b}. Read b => ReadP b
word
        Request qual unqual -> ReadP (Request qual unqual)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request qual unqual -> ReadP (Request qual unqual))
-> Request qual unqual -> ReadP (Request qual unqual)
forall a b. (a -> b) -> a -> b
$ String -> Maybe Word32 -> Request qual unqual
forall qual unqual. String -> Maybe Word32 -> Request qual unqual
Extension String
e Maybe Word32
v

      request :: ReadP (Request [String] String)
request = do
        ReadP ()
skipSpaces
        [ReadP (Request [String] String)]
-> ReadP (Request [String] String)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ ReadP (Request [String] String)
p ReadP (Request [String] String)
-> ReadP () -> ReadP (Request [String] String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces ReadP (Request [String] String)
-> ReadP () -> ReadP (Request [String] String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
eof
          | ReadP (Request [String] String)
p <- [ReadP (Request [String] String)
forall {qual} {unqual}. ReadP (Request qual unqual)
version, ReadP (Request [String] String)
feature, ReadP (Request [String] String)
property, ReadP (Request [String] String)
forall {qual} {unqual}. ReadP (Request qual unqual)
extension]
          ]
   in ReadP (Request [String] String) -> ReadS (Request [String] String)
forall a. ReadP a -> ReadS a
readP_to_S ReadP (Request [String] String)
request ReadS (Request [String] String)
-> ([(Request [String] String, String)]
    -> Maybe (Request [String] String))
-> String
-> Maybe (Request [String] String)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
        -- xs        -> pure $ Feature [] (show xs)
        [(Request [String] String
r, String
"")] -> Request [String] String -> Maybe (Request [String] String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request [String] String
r
        [(Request [String] String, String)]
_ -> Maybe (Request [String] String)
forall a. Maybe a
Nothing
{-# ANN parse ("HLint: ignore Use <$>" :: String) #-}

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

-- | Filters blank or commented lines, remove duplicates
filterComments :: String -> [String]
filterComments :: String -> [String]
filterComments =
  let bad :: String -> Bool
bad = ((String
"--" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool) -> (String -> Bool) -> String -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (String
"#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool) -> (String -> Bool) -> String -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
   in [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
bad) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
strip ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

strip :: String -> String
strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

exps :: (String -> ExpQ) -> [String] -> ExpQ
exps :: (String -> Q Exp) -> [String] -> Q Exp
exps String -> Q Exp
f = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> ([String] -> [Q Exp]) -> [String] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Q Exp) -> [String] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Q Exp
f

(<||>) :: Applicative f => f Bool -> f Bool -> f Bool
<||> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
(<||>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)

----------------------------------------------------------------
-- TH Utils
----------------------------------------------------------------

explicitRecordSet
  :: Name
  -- ^ Type name
  -> Name
  -- ^ member name
  -> Type
  -- ^ member type
  -> ExpQ
  -- ^ new value
  -> ExpQ
explicitRecordSet :: Name -> Name -> Type -> Q Exp -> Q Exp
explicitRecordSet Name
s Name
m Type
t Q Exp
x = do
  (Name
con, [Either Type String]
ns) <- Name -> Name -> Type -> Q (Name, [Either Type String])
overRecord Name
s Name
m Type
t
  [Either Type Name]
ns' <- (Either Type String -> Q (Either Type Name))
-> [Either Type String] -> Q [Either Type Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((String -> Q Name) -> Either Type String -> Q (Either Type Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName) [Either Type String]
ns
  let pats :: [Q Pat]
pats = (Type -> Q Pat) -> (Name -> Q Pat) -> Either Type Name -> Q Pat
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q Pat -> Type -> Q Pat
forall a b. a -> b -> a
const Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP) Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Either Type Name -> Q Pat) -> [Either Type Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type Name]
ns'
  let apps :: [Q Exp]
apps = (Type -> Q Exp) -> (Name -> Q Exp) -> Either Type Name -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q Exp -> Type -> Q Exp
forall a b. a -> b -> a
const Q Exp
x) Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Either Type Name -> Q Exp) -> [Either Type Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type Name]
ns'
  [|\ $(conP con pats) -> $(foldl appE (conE con) apps)|]

explicitRecordGet
  :: Name
  -- ^ Type name
  -> Name
  -- ^ member name
  -> Type
  -- ^ member type
  -> ExpQ
explicitRecordGet :: Name -> Name -> Type -> Q Exp
explicitRecordGet Name
s Name
m Type
t = do
  (Name
con, [Either Type String]
ns) <- Name -> Name -> Type -> Q (Name, [Either Type String])
overRecord Name
s Name
m Type
t
  Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  let pats :: [Q Pat]
pats = (Type -> Q Pat) -> (String -> Q Pat) -> Either Type String -> Q Pat
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q Pat -> Type -> Q Pat
forall a b. a -> b -> a
const (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x)) (Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP) (Either Type String -> Q Pat) -> [Either Type String] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type String]
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 :: Name -> Name -> Type -> Q (Name, [Either Type String])
overRecord Name
s (Name -> String
nameBase -> String
m) Type
t = do
  Name -> Q Info
reify Name
s Q Info
-> (Info -> Q (Name, [Either Type String]))
-> Q (Name, [Either Type String])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con
c] [DerivClause]
_) | RecC Name
con [VarBangType]
vs <- Con
c ->
      let ns :: [Either Type String]
ns = [VarBangType]
vs [VarBangType]
-> (VarBangType -> Either Type String) -> [Either Type String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            (Name -> String
nameBase -> String
n, Bang
_bang, Type
t') | String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
m    -> Type -> Either Type String
forall a b. a -> Either a b
Left Type
t'
                                       | Bool
otherwise -> String -> Either Type String
forall a b. b -> Either a b
Right String
n
      in  case [Either Type String] -> Cxt
forall a b. [Either a b] -> [a]
lefts [Either Type String]
ns of
            [] -> String -> Q (Name, [Either Type String])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Either Type String]))
-> String -> Q (Name, [Either Type String])
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find member " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
s
            [Type
t']
              | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t'
              -> (Name, [Either Type String]) -> Q (Name, [Either Type String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
con, [Either Type String]
ns)
              | Bool
otherwise
              -> String -> Q (Name, [Either Type String])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                (String -> Q (Name, [Either Type String]))
-> String -> Q (Name, [Either Type String])
forall a b. (a -> b) -> a -> b
$  String
"Member "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
m
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
s
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has type "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t'
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but we expected "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t
            Cxt
_ ->
              String -> Q (Name, [Either Type String])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                (String -> Q (Name, [Either Type String]))
-> String -> Q (Name, [Either Type String])
forall a b. (a -> b) -> a -> b
$  String
"Found multiple members called"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
m
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
s
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ...what?"
    Info
_ ->
      String -> Q (Name, [Either Type String])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Either Type String]))
-> String -> Q (Name, [Either Type String])
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" doesn't seem to be the type of a record constructor"