{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

module Vulkan.Utils.Requirements.TH
  ( req
  , reqs
  ) where

import           Control.Applicative
import           Control.Category               ( (>>>) )
import           Control.Monad
import           Data.Char
import           Data.Foldable
import           Data.List                      ( intercalate
                                                , isPrefixOf
                                                )
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           Prelude                 hiding ( GT )
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_VERSION )

-- $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
--
-- - @myFunctioName@: 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 = [req|PhysicalDeviceMultiviewFeatures.multiview|]
-- >>> featureName r
-- "PhysicalDeviceMultiviewFeatures.multiview"
req :: QuasiQuoter
req :: QuasiQuoter
req = (String -> QuasiQuoter
badQQ "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 "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 s :: String
s = do
  case String -> Maybe (Request [String] String)
parse String
s of
    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
$ "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 r :: 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 input :: String
input = \case
  Feature s :: Name
s m :: Name
m ->
    let t :: TypeQ
t = Name -> TypeQ
conT Name
s
        check :: Q Exp
check = [|$(varE m) :: $t -> Bool|]
        enable :: Q Exp
enable = [|\str -> $(recUpdE [| str :: $t |] [fieldExp m [|True|]])|]
    in [| let featureName = fromString $(lift input)
              checkFeature = $(check)
              enableFeature = $(enable)
          in RequireDeviceFeature featureName checkFeature enableFeature
       |]
  Property s :: Name
s m :: Name
m c :: Constraint Name
c ->
    let t :: TypeQ
t = Name -> TypeQ
conT Name
s
        getProp :: Q Exp
getProp = [|\str -> $(varE m) (str :: $t)|]
        checker :: Q Exp
checker = case Constraint Name
c of
                  GTE v :: Integer
v -> [|(>= $(litE (IntegerL v)))|]
                  GT v :: Integer
v -> [|(> $(litE (IntegerL v)))|]
                  AndBit b :: Name
b -> [|(.&&. $(conE b))|]
                  Fun f :: Name
f -> [|$(varE f)|]
        check :: Q Exp
check = [|$checker . $getProp|]
    in [| let propertyName = fromString $(lift input)
              checkProperty = $(check)
          in RequireDeviceProperty propertyName checkProperty
       |]
  Extension s :: String
s v :: Maybe Word32
v ->
       [| let deviceExtensionLayerName = Nothing
              deviceExtensionName = fromString $(lift s)
              deviceExtensionMinVersion = $(lift (fromMaybe minBound v))
          in RequireDeviceExtension
               deviceExtensionLayerName
               deviceExtensionName
               deviceExtensionMinVersion
       |]
  Version v :: Word32
v -> [| RequireDeviceVersion $(lift v) |]

nameRequest :: Request [String] String -> Q (Request Name Name)
nameRequest :: Request [String] String -> Q (Request Name Name)
nameRequest = \case
  Feature s :: [String]
s m :: 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 s :: [String]
s m :: String
m c :: 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 s :: String
s v :: 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 v :: 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 n :: [String]
n = do
      let q :: String
q = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." [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
$ "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 n :: [String]
n = do
      let q :: String
q = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." [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
$ "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, a -> Constraint b -> Constraint a
(a -> b) -> Constraint a -> Constraint b
(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
<$ :: a -> Constraint b -> Constraint a
$c<$ :: forall a b. a -> Constraint b -> Constraint a
fmap :: (a -> b) -> Constraint a -> Constraint b
$cfmap :: forall a b. (a -> b) -> Constraint a -> Constraint b
Functor, Constraint a -> Bool
(a -> m) -> Constraint a -> m
(a -> b -> b) -> b -> Constraint a -> b
(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 :: Constraint a -> a
$cproduct :: forall a. Num a => Constraint a -> a
sum :: Constraint a -> a
$csum :: forall a. Num a => Constraint a -> a
minimum :: Constraint a -> a
$cminimum :: forall a. Ord a => Constraint a -> a
maximum :: Constraint a -> a
$cmaximum :: forall a. Ord a => Constraint a -> a
elem :: a -> Constraint a -> Bool
$celem :: forall a. Eq a => a -> Constraint a -> Bool
length :: Constraint a -> Int
$clength :: forall a. Constraint a -> Int
null :: Constraint a -> Bool
$cnull :: forall a. Constraint a -> Bool
toList :: Constraint a -> [a]
$ctoList :: forall a. Constraint a -> [a]
foldl1 :: (a -> a -> a) -> Constraint a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldr1 :: (a -> a -> a) -> Constraint a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldl' :: (b -> a -> b) -> b -> Constraint a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
foldl :: (b -> a -> b) -> b -> Constraint a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
foldr' :: (a -> b -> b) -> b -> Constraint a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
foldr :: (a -> b -> b) -> b -> Constraint a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Constraint a -> b
foldMap' :: (a -> m) -> Constraint a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
foldMap :: (a -> m) -> Constraint a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
fold :: 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
(a -> f b) -> Constraint a -> f (Constraint b)
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 :: Constraint (m a) -> m (Constraint a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
mapM :: (a -> m b) -> Constraint a -> m (Constraint b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
sequenceA :: Constraint (f a) -> f (Constraint a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
traverse :: (a -> f b) -> Constraint a -> f (Constraint b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
$cp2Traversable :: Foldable Constraint
$cp1Traversable :: Functor Constraint
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 -> 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
== '_'))
    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
== '_')) 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 x :: 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 '.') 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
<$> [".", "->", "::", ":"]))

    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 (Read Integer => ReadS Integer
forall a. Read a => ReadS a
reads @Integer)
    word :: ReadP b
word      = do
      Just w :: 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 ">") 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 ">=")
      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 "&"
      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 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_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 = "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
== '_'))
      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)
      [(r :: Request [String] String
r, "")] -> Request [String] String -> Maybe (Request [String] String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request [String] String
r
      _         -> 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 -> 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 -> 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 ((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
. String -> [String]
lines

exps :: (String -> ExpQ) -> [String] -> ExpQ
exps :: (String -> Q Exp) -> [String] -> Q Exp
exps f :: String -> Q Exp
f = [Q Exp] -> Q 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
<||> :: 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
(||)