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.QueryFilter
import Mischief.ECS.World.Query.Queryable hiding (Q)
import Mischief.ECS.World.Query.Queryable qualified as Queryable
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 -> [Char]
(Int -> Qd -> ShowS)
-> (Qd -> [Char]) -> ([Qd] -> ShowS) -> Show Qd
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Qd -> ShowS
showsPrec :: Int -> Qd -> ShowS
$cshow :: Qd -> [Char]
show :: Qd -> [Char]
$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 -> [Char]
(Int -> QdType -> ShowS)
-> (QdType -> [Char]) -> ([QdType] -> ShowS) -> Show QdType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QdType -> ShowS
showsPrec :: Int -> QdType -> ShowS
$cshow :: QdType -> [Char]
show :: QdType -> [Char]
$cshowList :: [QdType] -> ShowS
showList :: [QdType] -> ShowS
Show)

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

data CompType = Single | Pair Text | PairAny deriving (Int -> CompType -> ShowS
[CompType] -> ShowS
CompType -> [Char]
(Int -> CompType -> ShowS)
-> (CompType -> [Char]) -> ([CompType] -> ShowS) -> Show CompType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompType -> ShowS
showsPrec :: Int -> CompType -> ShowS
$cshow :: CompType -> [Char]
show :: CompType -> [Char]
$cshowList :: [CompType] -> ShowS
showList :: [CompType] -> ShowS
Show)

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

type Parser = Parsec Void Text

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

pTup :: Parser a -> Parser [a]
pTup :: forall a. Parser a -> Parser [a]
pTup Parser a
p = do
  r <- Parser a -> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser a
p
  whitespace

  comma <- optional $ string ","
  whitespace

  case r of
    Maybe a
Nothing -> [a] -> ParsecT Void Text Identity [a]
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just a
r -> do
      case Maybe (Tokens Text)
comma of
        (Just Tokens Text
_) -> ([a
r] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [a])
-> ParsecT Void Text Identity [a] -> ParsecT Void Text Identity [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> ParsecT Void Text Identity [a]
forall a. Parser a -> Parser [a]
pTup Parser a
p
        Maybe (Tokens Text)
_ -> [a] -> ParsecT Void Text Identity [a]
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
r]

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
<|> [Char] -> Text
T.pack ([Char] -> Text)
-> ParsecT Void Text Identity [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
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) <* (char ')' *> whitespace)
  return . Trans $
    QdTrans
      { name,
        mod,
        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
<|> [Char] -> Text
T.pack ([Char] -> Text)
-> ParsecT Void Text Identity [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
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 = [Char] -> Text
T.pack ([Char] -> Text)
-> ParsecT Void Text Identity [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
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

pNameTup :: Parser Text
pNameTup :: Parser Text
pNameTup = (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
*> Parser Text
pNameRec 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
<* (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)

pNameRec :: Parser Text
pNameRec :: Parser Text
pNameRec = do
  s <- [Char] -> Text
T.pack ([Char] -> Text)
-> ParsecT Void Text Identity [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (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 Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
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
<|> (Char
' ' Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1) ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
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
<|> 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
',')
  o <- optional $ (char '(' *> whitespace) *> pNameRec <* (char ')' *> whitespace)

  case o of
    Maybe Text
Nothing -> Text -> Parser Text
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
    Just Text
o -> do
      n <- Parser Text
pNameRec
      return $ s <> "(" <> o <> ")" <> n

pTypeGeneric :: Parser Text
pTypeGeneric :: Parser Text
pTypeGeneric = [Char] -> Text
T.pack ([Char] -> Text)
-> ParsecT Void Text Identity [Char] -> 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 [Char]
-> ParsecT Void Text Identity [Char]
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 [Char]
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
'}'))

whitespace :: Parser ()
whitespace :: ParsecT Void Text Identity ()
whitespace =
  ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
    ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
    (Tokens Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//")
    (Tokens Text -> Tokens Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens 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}) = 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 -> Q Exp
relTrans Qd
exp
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'}) = 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 -> Q Exp
relTrans Qd
exp
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'}) = 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 -> Q Exp
relTrans Qd
exp
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 -> Q Exp
relTrans :: Qd -> Q Exp
relTrans Qd
exp = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Queryable.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

relExp :: CompType -> Q Exp
relExp :: CompType -> Q Exp
relExp CompType
PairAny = 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 'Any
relExp (Pair Text
x) = Name -> Exp
VarE (Name -> Exp) -> Q Name -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Q Name
getValueName Text
x
relExp CompType
_ = Q Exp
forall a. HasCallStack => a
undefined

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

processC :: Text -> Q Exp
processC :: Text -> Q Exp
processC Text
name = do
  -- name <- getTypeName name
  let t :: Either [Char] Type
t = [Char] -> Either [Char] Type
M.parseType (Text -> [Char]
T.unpack Text
name)
  case Either [Char] Type
t of
    Left [Char]
e -> [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error [Char]
e
    Right Type
t -> 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 -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'C) Type
t

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)

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

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

getTypeName :: Text -> Q Name
getTypeName :: Text -> Q Name
getTypeName Text
name = do
  t <- [Char] -> Q (Maybe Name)
lookupTypeName ([Char] -> Q (Maybe Name)) -> [Char] -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name
  return $ fromMaybe (error $ "Invalid type: " ++ T.unpack name ++ ".") t

getValueName :: Text -> Q Name
getValueName :: Text -> Q Name
getValueName Text
name = do
  t <- [Char] -> Q (Maybe Name)
lookupValueName ([Char] -> Q (Maybe Name)) -> [Char] -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name
  return $ fromMaybe (error $ "Invalid value: " ++ T.unpack name ++ ".") t