{-# 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 (dropWhileEnd, 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 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 = 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 = exps reqExp . 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 a. String -> Q a
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
      r' <- Request [String] String -> Q (Request Name Name)
nameRequest Request [String] String
r
      renderRequest s 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 $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
input)
            checkFeature = $(Q Exp
check)
            enableFeature = $(Q Exp
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 -> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
m) (str :: $Q Type
t)|]
      checker :: Q Exp
checker = case Constraint Name
c of
        GTE Integer
v -> [|(>= $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
IntegerL Integer
v)))|]
        GT Integer
v -> [|(> $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Integer -> Lit
IntegerL Integer
v)))|]
        AndBit Name
b -> [|(.&&. $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
b))|]
        Fun Name
f -> [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f)|]
      check :: Q Exp
check = [|$Q Exp
checker . $Q Exp
getProp|]
    in
      [|
        let
          propertyName = fromString $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
input)
          checkProperty = $(Q Exp
check)
        in
          RequireDeviceProperty propertyName checkProperty
        |]
  Extension String
s Maybe Word32
v ->
    [|
      let
        deviceExtensionLayerName = Nothing
        deviceExtensionName = fromString $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
s)
        deviceExtensionMinVersion = $(Word32 -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word32 -> m Exp
lift (Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe Word32
forall a. Bounded a => a
minBound Maybe Word32
v))
      in
        RequireDeviceExtension
          deviceExtensionLayerName
          deviceExtensionName
          deviceExtensionMinVersion
      |]
  Version Word32
v -> [|RequireDeviceVersion $(Word32 -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word32 -> m Exp
lift Word32
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
    sName <- [String] -> Q Name
getQualTyName [String]
s
    let mName = String -> Name
mkName String
m
    pure $ Feature sName mName
  Property [String]
s String
m Constraint [String]
c -> do
    sName <- [String] -> Q Name
getQualTyName [String]
s
    let mName = String -> Name
mkName String
m
    c' <- for c getQualValueName
    pure $ Property sName mName c'
  Extension String
s Maybe Word32
v -> Request Name Name -> Q (Request Name Name)
forall a. a -> Q a
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 a. a -> Q a
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 a. String -> Q a
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 a. a -> Q a
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 a. String -> Q a
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 a. a -> Q a
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
$cshowsPrec :: forall qual unqual.
(Show qual, Show unqual) =>
Int -> Request qual unqual -> String -> String
showsPrec :: Int -> Request qual unqual -> String -> String
$cshow :: forall qual unqual.
(Show qual, Show unqual) =>
Request qual unqual -> String
show :: Request qual unqual -> String
$cshowList :: forall qual unqual.
(Show qual, Show unqual) =>
[Request qual unqual] -> String -> String
showList :: [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
$cshowsPrec :: forall qual.
Show qual =>
Int -> Constraint qual -> String -> String
showsPrec :: Int -> Constraint qual -> String -> String
$cshow :: forall qual. Show qual => Constraint qual -> String
show :: Constraint qual -> String
$cshowList :: forall qual. Show qual => [Constraint qual] -> String -> String
showList :: [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
$cfmap :: forall a b. (a -> b) -> Constraint a -> Constraint b
fmap :: forall a b. (a -> b) -> Constraint a -> Constraint b
$c<$ :: forall a b. a -> Constraint b -> Constraint a
<$ :: forall a b. a -> Constraint b -> Constraint a
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
$cfold :: forall m. Monoid m => Constraint m -> m
fold :: forall m. Monoid m => Constraint m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> Constraint a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> Constraint a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldr1 :: forall a. (a -> a -> a) -> Constraint a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Constraint a -> a
foldl1 :: forall a. (a -> a -> a) -> Constraint a -> a
$ctoList :: forall a. Constraint a -> [a]
toList :: forall a. Constraint a -> [a]
$cnull :: forall a. Constraint a -> Bool
null :: forall a. Constraint a -> Bool
$clength :: forall a. Constraint a -> Int
length :: forall a. Constraint a -> Int
$celem :: forall a. Eq a => a -> Constraint a -> Bool
elem :: forall a. Eq a => a -> Constraint a -> Bool
$cmaximum :: forall a. Ord a => Constraint a -> a
maximum :: forall a. Ord a => Constraint a -> a
$cminimum :: forall a. Ord a => Constraint a -> a
minimum :: forall a. Ord a => Constraint a -> a
$csum :: forall a. Num a => Constraint a -> a
sum :: forall a. Num a => Constraint a -> a
$cproduct :: forall a. Num a => Constraint a -> a
product :: forall a. Num a => Constraint a -> a
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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Constraint a -> f (Constraint b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Constraint (f a) -> f (Constraint a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Constraint a -> m (Constraint b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Constraint (m a) -> m (Constraint a)
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 a b. ReadP (a -> b) -> ReadP a -> ReadP b
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 a b. ReadP (a -> b) -> ReadP a -> ReadP b
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 a. a -> [a]
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 a. ReadP a -> ReadP a -> ReadP a
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 a b. ReadP a -> ReadP b -> ReadP a
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 a b. ReadP (a -> b) -> ReadP a -> ReadP b
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 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
      pure w

    comp :: ReadP (Constraint qual)
comp = do
      c <- (Integer -> Constraint qual
forall qual. Integer -> Constraint qual
GT (Integer -> Constraint qual)
-> ReadP String -> ReadP (Integer -> Constraint qual)
forall a b. a -> ReadP b -> ReadP a
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 a. ReadP a -> ReadP a -> ReadP a
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 a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
">=")
      skipSpaces
      w <- integer
      pure $ c w
    andBit :: ReadP (Constraint [String])
andBit = do
      _ <- String -> ReadP String
string String
"&"
      skipSpaces
      q <- qual con
      pure $ AndBit 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 a. ReadP a -> ReadP a -> ReadP a
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 a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP (Constraint [String])
fun

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

    feature :: ReadP (Request [String] String)
feature = do
      s <- ReadP String -> ReadP [String]
qual ReadP String
con
      _ <- separator
      m <- var
      pure $ Feature s m

    property :: ReadP (Request [String] String)
property = do
      s <- ReadP String -> ReadP [String]
qual ReadP String
con
      _ <- separator
      m <- var
      skipSpaces
      c <- constraint
      pure $ Property s m c

    extension :: ReadP (Request qual unqual)
extension = do
      let prefix :: a
prefix = a
"VK_"
      _ <- String -> ReadP String
string String
forall {a}. IsString a => a
prefix
      e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))
      skipSpaces
      v <- optional word
      pure $ Extension e 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 a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces ReadP (Request [String] String)
-> ReadP () -> ReadP (Request [String] String)
forall a b. ReadP a -> ReadP b -> ReadP a
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)
-> String -> [(Request [String] String, String)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP (Request [String] String)
request (String -> [(Request [String] 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 a. a -> Maybe a
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 a. [a] -> 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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 a b c. (a -> b -> c) -> f a -> f b -> f c
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
  (con, ns) <- Name -> Name -> Type -> Q (Name, [Either Type String])
overRecord Name
s Name
m Type
t
  ns' <- traverse (traverse newName) ns
  let 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 = (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
  (con, ns) <- Name -> Name -> Type -> Q (Name, [Either Type String])
overRecord Name
s Name
m Type
t
  x <- newName "x"
  let 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 a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ 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 a. String -> Q a
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 a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
con, [Either Type String]
ns)
                 | Bool
otherwise ->
                     String -> Q (Name, [Either Type String])
forall a. String -> Q a
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 a. String -> Q a
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 a. String -> Q a
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"