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

import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void
import Language.Haskell.Meta.Parse
import Language.Haskell.Meta.Parse as M
import Language.Haskell.TH
import Language.Haskell.TH qualified
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Mischief.ECS.Components (Component)
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.QueryFilter
import Mischief.ECS.World.Query.Queryable hiding (Q)
import Mischief.ECS.World.Query.TH.QD (CompType (..), Parser, pTup, whitespace)
import Mischief.ECS.World.Query.TH.QD qualified as QD
import Text.Megaparsec (MonadParsec (eof, lookAhead, notFollowedBy, try), Parsec, choice, many, manyTill, noneOf, optional, parseTest, satisfy, some, (<|>))
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

data Qf = With' [QfType] | Added' [QfType] | Changed' [QfType] | Not' Qf | Tup' [Qf] | Or' Qf Qf | Check' CompType Text 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 "||", 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'

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
pCheck 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

pCheck :: Parser Qf
pCheck :: Parser Qf
pCheck = 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
"Check", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"check"] 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

  f <- Parser Text
pF
  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 $ Check' compType f

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
QD.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 -> Exp -> Exp
AppE (Name -> Exp
ConE 'With) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QfType] -> Q Exp
processTypes [QfType]
x
quoteQf (Changed' [QfType]
x) = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Changed) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QfType] -> Q Exp
processTypes [QfType]
x
quoteQf (Added' [QfType]
x) = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Added) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QfType] -> Q Exp
processTypes [QfType]
x
quoteQf (Or' Qf
x Qf
y) = do
  x <- Qf -> Q Exp
quoteQf Qf
x
  y <- quoteQf y
  return $ AppE (AppE (ConE 'Or) 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
quoteQf (Check' CompType
c Text
f) = case String -> Either String Exp
parseExp (Text -> String
T.unpack Text
f) of
  Left String
x -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
x
  Right Exp
x -> CompType -> Exp -> Q Exp
processCheck CompType
c Exp
x

processCheck :: CompType -> Exp -> Q Exp
processCheck :: CompType -> Exp -> Q Exp
processCheck CompType
Single Exp
f = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Check) Exp
f
processCheck (Pair Text
e') Exp
f = do
  e <- Text -> Q Name
QD.getValueName Text
e'
  return $ AppE (AppE (ConE 'CheckR) (VarE e)) f
processCheck CompType
PairAny Exp
f = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'CheckR) (Name -> Exp
ConE 'Any)) Exp
f

processTup :: [Qf] -> Q Exp
processTup :: [Qf] -> Q Exp
processTup [Qf
x] = Qf -> Q Exp
quoteQf Qf
x
processTup [Qf]
t = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Qf] -> (Qf -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Qf]
t Qf -> Q Exp
quoteQf

processTypes :: [QfType] -> Q Exp
processTypes :: [QfType] -> Q Exp
processTypes [QfType
x] = QfType -> Q Exp
processType QfType
x
processTypes [QfType]
t = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QfType] -> (QfType -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QfType]
t QfType -> Q Exp
processType

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
QD.processC Text
name
processType (QfType {Text
name :: QfType -> Text
name :: Text
name, CompType
compType :: QfType -> CompType
compType :: CompType
compType}) = Text -> Exp -> Q Exp
QD.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
QD.relExp CompType
compType