{-# 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)
req :: QuasiQuoter
req :: QuasiQuoter
req = (String -> QuasiQuoter
badQQ String
"req"){quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
reqExp}
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 :: 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
[(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) #-}
filterComments :: String -> [String]
=
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
(||)
explicitRecordSet
:: Name
-> Name
-> Type
-> ExpQ
-> 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
-> Name
-> 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
-> Name
-> Type
-> Q (Name, [Either Type String])
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"