module Mischief.ECS.World.Query.TH.QF where

import Control.Monad
import Data.Text (Text)
import Data.Text qualified as T
import Language.Haskell.Meta.Parse
import Language.Haskell.TH
import Mischief.ECS.World.Query.QueryFilter
import Mischief.ECS.World.Query.TH.Common
import Text.Megaparsec (MonadParsec (notFollowedBy, try), choice, many, optional, satisfy, some, (<|>))
import Text.Megaparsec.Char

data Qf = With' [QfType] | Added' [QfType] | Changed' [QfType] | Not' Qf | Tup' [Qf] | And' Qf Qf | Or' Qf Qf deriving (Int -> Qf -> ShowS
[Qf] -> ShowS
Qf -> String
(Int -> Qf -> ShowS)
-> (Qf -> String) -> ([Qf] -> ShowS) -> Show Qf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Qf -> ShowS
showsPrec :: Int -> Qf -> ShowS
$cshow :: Qf -> String
show :: Qf -> String
$cshowList :: [Qf] -> ShowS
showList :: [Qf] -> ShowS
Show)

data QfType = QfType {QfType -> Text
name :: Text, QfType -> CompType
compType :: CompType} deriving (Int -> QfType -> ShowS
[QfType] -> ShowS
QfType -> String
(Int -> QfType -> ShowS)
-> (QfType -> String) -> ([QfType] -> ShowS) -> Show QfType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QfType -> ShowS
showsPrec :: Int -> QfType -> ShowS
$cshow :: QfType -> String
show :: QfType -> String
$cshowList :: [QfType] -> ShowS
showList :: [QfType] -> ShowS
Show)

pQf :: Parser Qf
pQf :: Parser Qf
pQf = [Qf] -> Qf
Tup' ([Qf] -> Qf) -> ([[Qf]] -> [Qf]) -> [[Qf]] -> Qf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Qf]] -> [Qf]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Qf]] -> Qf) -> ParsecT Void Text Identity [[Qf]] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Qf] -> ParsecT Void Text Identity [[Qf]]
forall a. Parser a -> Parser [a]
pTup Parser [Qf]
pTup'

pTup' :: Parser [Qf]
pTup' :: Parser [Qf]
pTup' = Parser [Qf] -> Parser [Qf]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'(' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
whitespace) ParsecT Void Text Identity () -> Parser [Qf] -> Parser [Qf]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([[Qf]] -> [Qf]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Qf]] -> [Qf])
-> ParsecT Void Text Identity [[Qf]] -> Parser [Qf]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Qf] -> ParsecT Void Text Identity [[Qf]]
forall a. Parser a -> Parser [a]
pTup Parser [Qf]
pTup') Parser [Qf] -> ParsecT Void Text Identity () -> Parser [Qf]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
')' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
whitespace)) Parser [Qf] -> Parser [Qf] -> Parser [Qf]
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Qf -> [Qf] -> [Qf]
forall a. a -> [a] -> [a]
: []) (Qf -> [Qf]) -> Parser Qf -> Parser [Qf]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Qf
pOr

pOr :: Parser Qf
pOr :: Parser Qf
pOr = do
  s <- Parser Qf
pSingle
  whitespace

  or <- optional $ choice [string "||", string "or", string "OR", string "Or"] <* whitespace
  case or of
    Maybe (Tokens Text)
Nothing -> Qf -> Parser Qf
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Qf
s
    Just Tokens Text
_ -> (Qf -> Qf -> Qf) -> Qf -> [Qf] -> Qf
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Qf -> Qf -> Qf
Or' Qf
s ([Qf] -> Qf) -> Parser [Qf] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Qf]
pTup'

pAnd :: Parser Qf
pAnd :: Parser Qf
pAnd = do
  s <- Parser Qf
pSingle
  whitespace

  and <- optional $ choice [string "&&", string "and", string "AND", string "And"] <* whitespace
  case and of
    Maybe (Tokens Text)
Nothing -> Qf -> Parser Qf
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Qf
s
    Just Tokens Text
_ -> (Qf -> Qf -> Qf) -> Qf -> [Qf] -> Qf
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Qf -> Qf -> Qf
And' Qf
s ([Qf] -> Qf) -> Parser [Qf] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Qf]
pTup'

pSingle :: Parser Qf
pSingle :: Parser Qf
pSingle = Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Qf
pWith Parser Qf -> Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Qf
pWithout Parser Qf -> Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Qf
pAdded Parser Qf -> Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Qf
pChanged Parser Qf -> Parser Qf -> Parser Qf
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Qf
pNot

pNot :: Parser Qf
pNot :: Parser Qf
pNot = do
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"Not", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"not", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"!"]
  ParsecT Void Text Identity ()
whitespace

  [Qf] -> Qf
Tup' ([Qf] -> Qf) -> Parser [Qf] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Qf]
pTup'

pWith :: Parser Qf
pWith :: Parser Qf
pWith = do
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"With", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"with"] ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  ParsecT Void Text Identity ()
whitespace
  [QfType] -> Qf
With' ([QfType] -> Qf)
-> ParsecT Void Text Identity [QfType] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [QfType]
pTypes

pWithout :: Parser Qf
pWithout :: Parser Qf
pWithout = do
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"Without", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"without"] ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  ParsecT Void Text Identity ()
whitespace
  Qf -> Qf
Not' (Qf -> Qf) -> ([QfType] -> Qf) -> [QfType] -> Qf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [QfType] -> Qf
With' ([QfType] -> Qf)
-> ParsecT Void Text Identity [QfType] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [QfType]
pTypes

pAdded :: Parser Qf
pAdded :: Parser Qf
pAdded = do
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"Added", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"added"] ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  ParsecT Void Text Identity ()
whitespace
  [QfType] -> Qf
Added' ([QfType] -> Qf)
-> ParsecT Void Text Identity [QfType] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [QfType]
pTypes

pChanged :: Parser Qf
pChanged :: Parser Qf
pChanged = do
  ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"Changed", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"changed"] ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  ParsecT Void Text Identity ()
whitespace
  [QfType] -> Qf
Changed' ([QfType] -> Qf)
-> ParsecT Void Text Identity [QfType] -> Parser Qf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [QfType]
pTypes

pF :: Parser Text
pF :: Parser Text
pF = Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'(' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
whitespace) ParsecT Void Text Identity () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Parser Text
pfLambda String
"(" Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
whitespace) Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar

pfLambda :: String -> Parser Text
pfLambda :: String -> Parser Text
pfLambda String
str = do
  x <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
')'))
  void $ char ')'
  let str' = String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
')']
  case parseExp str' of
    Left String
_ -> do
      String -> Parser Text
pfLambda String
str'
    Right Exp
_ -> Text -> Parser Text
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str'

pTypes :: Parser [QfType]
pTypes :: ParsecT Void Text Identity [QfType]
pTypes = ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity [QfType]
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'(' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
whitespace) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity [QfType]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([[QfType]] -> [QfType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[QfType]] -> [QfType])
-> ParsecT Void Text Identity [[QfType]]
-> ParsecT Void Text Identity [QfType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity [[QfType]]
forall a. Parser a -> Parser [a]
pTup ParsecT Void Text Identity [QfType]
pTypes) ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [QfType]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
')' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
whitespace)) ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity [QfType]
-> ParsecT Void Text Identity [QfType]
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (QfType -> [QfType] -> [QfType]
forall a. a -> [a] -> [a]
: []) (QfType -> [QfType])
-> ParsecT Void Text Identity QfType
-> ParsecT Void Text Identity [QfType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity QfType
pType

pType :: Parser QfType
pType :: ParsecT Void Text Identity QfType
pType = do
  name <- Parser Text
pNameTup Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  whitespace

  target <- optional $ do
    void $ string "->"
    whitespace
    r <- string "*" <|> T.pack <$> some alphaNumChar
    whitespace
    return r

  let compType = case Maybe Text
target of
        Maybe Text
Nothing -> CompType
Single
        Just Text
"*" -> CompType
PairAny
        Just Text
e -> Text -> CompType
Pair Text
e

  return $
    QfType
      { name,
        compType
      }

quoteQf :: Qf -> Q Exp
quoteQf :: Qf -> Q Exp
quoteQf (Tup' [Qf]
qf) = [Qf] -> Q Exp
processTup [Qf]
qf
quoteQf (With' [QfType]
x) = Exp -> [QfType] -> Q Exp
processTypes (Name -> Exp
ConE 'With) [QfType]
x
quoteQf (Changed' [QfType]
x) = Exp -> [QfType] -> Q Exp
processTypes (Name -> Exp
ConE 'Changed) [QfType]
x
quoteQf (Added' [QfType]
x) = Exp -> [QfType] -> Q Exp
processTypes (Name -> Exp
ConE 'Added) [QfType]
x
quoteQf (Or' Qf
x Qf
y) = do
  x <- Qf -> Q Exp
quoteQf Qf
x
  y <- quoteQf y
  pure $ AppE (AppE (ConE 'Or) x) y
quoteQf (And' Qf
x Qf
y) = do
  x <- Qf -> Q Exp
quoteQf Qf
x
  y <- quoteQf y
  pure $ AppE (AppE (ConE 'And) x) y
quoteQf (Not' Qf
x) = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Not) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qf -> Q Exp
quoteQf Qf
x

processTup :: [Qf] -> Q Exp
processTup :: [Qf] -> Q Exp
processTup [] = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE '()
processTup [Qf
x] = Qf -> Q Exp
quoteQf Qf
x
processTup (Qf
x : [Qf]
xs) = do
  x' <- Qf -> Q Exp
quoteQf Qf
x
  AppE (AppE (ConE 'And) x') <$> processTup xs

processTypes :: Exp -> [QfType] -> Q Exp
processTypes :: Exp -> [QfType] -> Q Exp
processTypes Exp
_ [] = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE '()
processTypes Exp
exp [QfType
x] = Exp -> Exp -> Exp
AppE Exp
exp (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QfType -> Q Exp
processType QfType
x
processTypes Exp
exp (QfType
x : [QfType]
xs) = do
  x' <- QfType -> Q Exp
processType QfType
x
  AppE (AppE (ConE 'And) (AppE exp x')) <$> processTypes exp xs

processType :: QfType -> Q Exp
processType :: QfType -> Q Exp
processType (QfType {Text
name :: QfType -> Text
name :: Text
name, compType :: QfType -> CompType
compType = CompType
Single}) = Text -> Q Exp
processC Text
name
processType (QfType {Text
name :: QfType -> Text
name :: Text
name, CompType
compType :: QfType -> CompType
compType :: CompType
compType}) = Text -> Exp -> Q Exp
processR Text
name (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompType -> Q Exp
relExp CompType
compType