module Mischief.ECS.World.Query.TH.QD 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 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.Markers hiding (Q)
import Mischief.ECS.World.Query.Markers qualified as Markers
import Mischief.ECS.World.Query.QueryFilter
import Mischief.ECS.World.Query.Queryable
import Mischief.ECS.World.Query.Queryable qualified as Queryable
import Mischief.ECS.World.Query.TH.Common
import Mischief.ECS.World.Query.TH.QF qualified as QF
import Text.Megaparsec (MonadParsec (eof, lookAhead, notFollowedBy, try), Parsec, choice, many, manyTill, noneOf, optional, parseTest, some, (<|>))
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

data Qd = Val' Qd | Tup [Qd] | Entity' | Type QdType | Trans QdTrans deriving (Int -> Qd -> ShowS
[Qd] -> ShowS
Qd -> String
(Int -> Qd -> ShowS)
-> (Qd -> String) -> ([Qd] -> ShowS) -> Show Qd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Qd -> ShowS
showsPrec :: Int -> Qd -> ShowS
$cshow :: Qd -> String
show :: Qd -> String
$cshowList :: [Qd] -> ShowS
showList :: [Qd] -> ShowS
Show)

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

data QdTrans = QdTrans {QdTrans -> Text
name :: Text, QdTrans -> Qd
exp :: Qd, QdTrans -> Maybe Qf
filter :: Maybe QF.Qf, QdTrans -> Maybe Mod
mod :: Maybe Mod} deriving (Int -> QdTrans -> ShowS
[QdTrans] -> ShowS
QdTrans -> String
(Int -> QdTrans -> ShowS)
-> (QdTrans -> String) -> ([QdTrans] -> ShowS) -> Show QdTrans
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QdTrans -> ShowS
showsPrec :: Int -> QdTrans -> ShowS
$cshow :: QdTrans -> String
show :: QdTrans -> String
$cshowList :: [QdTrans] -> ShowS
showList :: [QdTrans] -> ShowS
Show)

data Mod = M' | H' deriving (Int -> Mod -> ShowS
[Mod] -> ShowS
Mod -> String
(Int -> Mod -> ShowS)
-> (Mod -> String) -> ([Mod] -> ShowS) -> Show Mod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mod -> ShowS
showsPrec :: Int -> Mod -> ShowS
$cshow :: Mod -> String
show :: Mod -> String
$cshowList :: [Mod] -> ShowS
showList :: [Mod] -> ShowS
Show)

pQd :: Parser Qd
pQd :: Parser Qd
pQd = do
  [Qd] -> Qd
Tup ([Qd] -> Qd) -> ParsecT Void Text Identity [Qd] -> Parser Qd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Qd -> ParsecT Void Text Identity [Qd]
forall a. Parser a -> Parser [a]
pTup Parser Qd
pEl

pEl :: Parser Qd
pEl :: Parser Qd
pEl = Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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
*> ([Qd] -> Qd
Tup ([Qd] -> Qd) -> ParsecT Void Text Identity [Qd] -> Parser Qd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Qd -> ParsecT Void Text Identity [Qd]
forall a. Parser a -> Parser [a]
pTup Parser Qd
pEl) Parser Qd -> ParsecT Void Text Identity () -> Parser Qd
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 Qd -> Parser Qd -> Parser Qd
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 Qd
pSingle

-- case bracket of
--   Nothing -> pSingle
--   Just _ -> Tup <$> pTup pEl

data TestG a b = TestG deriving (Typeable (TestG a b)
Set DefaultComponentType
Hooks (TestG a b)
IsExclusive (RelExclusivity (TestG a b))
(Typeable (TestG a b), IsExclusive (RelExclusivity (TestG a b))) =>
Set DefaultComponentType
-> Hooks (TestG a b) -> Component (TestG a b)
forall c.
(Typeable c, IsExclusive (RelExclusivity c)) =>
Set DefaultComponentType -> Hooks c -> Component c
forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
Typeable (TestG a b)
forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
Set DefaultComponentType
forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
Hooks (TestG a b)
forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
IsExclusive (RelExclusivity (TestG a b))
$crequired :: forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
Set DefaultComponentType
required :: Set DefaultComponentType
$chooks :: forall k (a :: k) k (b :: k).
(Typeable a, Typeable b, Typeable k, Typeable k) =>
Hooks (TestG a b)
hooks :: Hooks (TestG a b)
Component)

pSingle :: Parser Qd
pSingle :: Parser Qd
pSingle = do
  Parser Qd -> Parser Qd
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 Qd
pEntity Parser Qd -> Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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 Qd
pVal Parser Qd -> Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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 Qd
pMaybe Parser Qd -> Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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 Qd
pHas Parser Qd -> Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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 Qd
pValStar Parser Qd -> Parser Qd -> Parser Qd
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 Qd -> Parser Qd
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 (Maybe Mod -> Parser Qd
pTrans Maybe Mod
forall a. Maybe a
Nothing) Parser Qd -> Parser Qd -> Parser Qd
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
<|> Maybe Mod -> Parser Qd
pType Maybe Mod
forall a. Maybe a
Nothing

pEntity :: Parser Qd
pEntity :: Parser Qd
pEntity = 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
"Entity", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"entity", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"E", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"e"] 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

  Qd -> Parser Qd
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Qd
Entity'

pValStar :: Parser Qd
pValStar :: Parser Qd
pValStar = do
  ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ 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 ()
whitespace
  Qd -> Qd
Val' (Qd -> Qd) -> Parser Qd -> Parser Qd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Qd
pEl

pVal :: Parser Qd
pVal :: Parser Qd
pVal = 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
"Val", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"val", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"V", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"v"] 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

  Qd -> Qd
Val' (Qd -> Qd) -> Parser Qd -> Parser Qd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Qd
pEl

pMaybe :: Parser Qd
pMaybe :: Parser Qd
pMaybe = 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
"Maybe", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"maybe", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"M", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"m"] 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

  Parser Qd -> Parser Qd
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 (Maybe Mod -> Parser Qd
pTrans (Mod -> Maybe Mod
forall a. a -> Maybe a
Just Mod
M')) Parser Qd -> Parser Qd -> Parser Qd
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
<|> Maybe Mod -> Parser Qd
pType (Mod -> Maybe Mod
forall a. a -> Maybe a
Just Mod
M')

pHas :: Parser Qd
pHas :: Parser Qd
pHas = 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
"Has", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"has", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"H", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"h"] 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

  Parser Qd -> Parser Qd
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 (Maybe Mod -> Parser Qd
pTrans (Mod -> Maybe Mod
forall a. a -> Maybe a
Just Mod
H')) Parser Qd -> Parser Qd -> Parser Qd
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
<|> Maybe Mod -> Parser Qd
pType (Mod -> Maybe Mod
forall a. a -> Maybe a
Just Mod
H')

pTrans :: Maybe Mod -> Parser Qd
pTrans :: Maybe Mod -> Parser Qd
pTrans Maybe Mod
mod = 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

  void $ string "->"
  whitespace

  qd <- (char '(' *> whitespace) *> (Tup <$> pTup pEl) <* whitespace

  qf <- optional $ do
    void $ char '/'
    whitespace
    QF.pQf

  whitespace
  void $ char ')'
  whitespace

  return . Trans $
    QdTrans
      { name,
        mod,
        filter = qf,
        exp = qd
      }

pType :: Maybe Mod -> Parser Qd
pType :: Maybe Mod -> Parser Qd
pType Maybe Mod
mod = do
  -- name <- pTypeGeneric <|> T.pack <$> some alphaNumChar
  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 . Type $
    QdType
      { name,
        compType,
        mod
      }

pName :: Parser Text
pName :: Parser Text
pName = 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 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
<|> Parser Text
pNameTup

pTypeGeneric :: Parser Text
pTypeGeneric :: Parser Text
pTypeGeneric = 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
<$> (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 String
-> ParsecT Void Text Identity String
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 Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (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
'}'))

quoteQd :: Qd -> Q Exp
quoteQd :: Qd -> Q Exp
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, compType :: QdType -> CompType
compType = CompType
Single, mod :: QdType -> Maybe Mod
mod = Maybe Mod
Nothing}) = Text -> Q Exp
processC Text
name
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, compType :: QdType -> CompType
compType = CompType
Single, mod :: QdType -> Maybe Mod
mod = Just Mod
M'}) = Text -> Q Exp
processM Text
name
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, compType :: QdType -> CompType
compType = CompType
Single, mod :: QdType -> Maybe Mod
mod = Just Mod
H'}) = Text -> Q Exp
processH Text
name
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, CompType
compType :: QdType -> CompType
compType :: CompType
compType, mod :: QdType -> Maybe Mod
mod = Maybe Mod
Nothing}) = 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
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, CompType
compType :: QdType -> CompType
compType :: CompType
compType, mod :: QdType -> Maybe Mod
mod = Just Mod
M'}) = Text -> Exp -> Q Exp
processMR 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
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, CompType
compType :: QdType -> CompType
compType :: CompType
compType, mod :: QdType -> Maybe Mod
mod = Just Mod
H'}) = Text -> Exp -> Q Exp
processHR 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
quoteQd (Trans QdTrans {Text
name :: QdTrans -> Text
name :: Text
name, Qd
exp :: QdTrans -> Qd
exp :: Qd
exp, mod :: QdTrans -> Maybe Mod
mod = Maybe Mod
Nothing, Maybe Qf
filter :: QdTrans -> Maybe Qf
filter :: Maybe Qf
filter}) = 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
=<< Qd -> Maybe Qf -> Q Exp
relTrans Qd
exp Maybe Qf
filter
quoteQd (Trans QdTrans {Text
name :: QdTrans -> Text
name :: Text
name, Qd
exp :: QdTrans -> Qd
exp :: Qd
exp, mod :: QdTrans -> Maybe Mod
mod = Just Mod
M', Maybe Qf
filter :: QdTrans -> Maybe Qf
filter :: Maybe Qf
filter}) = Text -> Exp -> Q Exp
processMR Text
name (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Qd -> Maybe Qf -> Q Exp
relTrans Qd
exp Maybe Qf
filter
quoteQd (Trans QdTrans {Text
name :: QdTrans -> Text
name :: Text
name, Qd
exp :: QdTrans -> Qd
exp :: Qd
exp, mod :: QdTrans -> Maybe Mod
mod = Just Mod
H', Maybe Qf
filter :: QdTrans -> Maybe Qf
filter :: Maybe Qf
filter}) = Text -> Exp -> Q Exp
processHR Text
name (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Qd -> Maybe Qf -> Q Exp
relTrans Qd
exp Maybe Qf
filter
quoteQd (Val' Qd
qd) = Exp -> Exp
processVal (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qd -> Q Exp
quoteQd Qd
qd
quoteQd (Tup []) = 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
$ Name -> Exp
ConE '()
quoteQd (Tup [Qd
x]) = Qd -> Q Exp
quoteQd Qd
x
quoteQd (Tup [Qd]
t) = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> Q [Maybe Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Qd -> Q (Maybe Exp)) -> [Qd] -> Q [Maybe Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Exp -> Maybe Exp) -> Q Exp -> Q (Maybe Exp)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Q Exp -> Q (Maybe Exp)) -> (Qd -> Q Exp) -> Qd -> Q (Maybe Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qd -> Q Exp
quoteQd) [Qd]
t
quoteQd Qd
Entity' = 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
$ Name -> Exp
ConE 'E

relTrans :: Qd -> Maybe QF.Qf -> Q Exp
relTrans :: Qd -> Maybe Qf -> Q Exp
relTrans Qd
exp Maybe Qf
Nothing = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Markers.Q) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qd -> Q Exp
quoteQd Qd
exp
relTrans Qd
exp (Just Qf
f) = do
  qd <- Qd -> Q Exp
quoteQd Qd
exp
  qf <- QF.quoteQf f

  pure $ AppE (AppE (ConE 'Markers.Q') qd) qf

processVal :: Exp -> Exp
processVal :: Exp -> Exp
processVal = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Val)

processM :: Text -> Q Exp
processM :: Text -> Q Exp
processM Text
name = do
  name <- Text -> Q Name
getTypeName Text
name
  return $ AppTypeE (ConE 'M) (ConT name)

processMR :: Text -> Exp -> Q Exp
processMR :: Text -> Exp -> Q Exp
processMR Text
name Exp
e = do
  name <- Text -> Q Name
getTypeName Text
name
  return $ AppE (AppTypeE (ConE 'MR) (ConT name)) e

processH :: Text -> Q Exp
processH :: Text -> Q Exp
processH Text
name = do
  name <- Text -> Q Name
getTypeName Text
name
  return $ AppTypeE (ConE 'Has) (ConT name)

processHR :: Text -> Exp -> Q Exp
processHR :: Text -> Exp -> Q Exp
processHR Text
name Exp
e = do
  name <- Text -> Q Name
getTypeName Text
name
  return $ AppE (AppTypeE (ConE 'HasR) (ConT name)) e