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

import Control.Monad
import Data.Text (Text)
import Data.Text qualified as T
import Language.Haskell.TH
import Mischief.ECS.Components (Res (Res))
import Mischief.ECS.World.Query.Markers hiding (Q)
import Mischief.ECS.World.Query.Markers qualified as Markers
import Mischief.ECS.World.Query.TH.Common
import Mischief.ECS.World.Query.TH.QF qualified as QF
import Text.Megaparsec (MonadParsec (notFollowedBy, try), choice, manyTill, optional, 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

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

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 <- ParsecT Void Text Identity Text
pNameTup ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
-> ParsecT Void Text Identity 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

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

pRes :: Maybe Mod -> Parser Qd
pRes :: Maybe Mod -> Parser Qd
pRes !Maybe Mod
mod = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void Text Identity Text
"Res", ParsecT Void Text Identity Text
"res"]
  ParsecT Void Text Identity ()
whitespace

  !name <- ParsecT Void Text Identity Text
pNameTup ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
-> ParsecT Void Text Identity 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

  pure . Type $
    QdType
      { name,
        compType = Resource,
        mod
      }

pType :: Maybe Mod -> Parser Qd
pType :: Maybe Mod -> Parser Qd
pType !Maybe Mod
mod =
  Maybe Mod -> Parser Qd
pRes Maybe Mod
mod 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
pTypeSimple
  where
    pTypeSimple :: Parser Qd
pTypeSimple = do
      !name <- ParsecT Void Text Identity Text
pNameTup ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
-> ParsecT Void Text Identity 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

      pure . Type $
        QdType
          { name,
            compType,
            mod
          }

pTypeGeneric :: Parser Text
pTypeGeneric :: ParsecT Void Text Identity Text
pTypeGeneric = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity 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
Resource, mod :: QdType -> Maybe Mod
mod = Maybe Mod
Nothing}) = Text -> Q Exp
processRes Text
name
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, compType :: QdType -> CompType
compType = CompType
Resource, mod :: QdType -> Maybe Mod
mod = Just Mod
M'}) = Text -> Q Exp
processMRes Text
name
quoteQd (Type QdType {Text
name :: QdType -> Text
name :: Text
name, compType :: QdType -> CompType
compType = CompType
Resource, mod :: QdType -> Maybe Mod
mod = Just Mod
H'}) = Text -> Q Exp
processHasRes Text
name
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)

processRes :: Text -> Q Exp
processRes :: Text -> Q Exp
processRes !Text
name = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'Res) Type
name'

processMRes :: Text -> Q Exp
processMRes :: Text -> Q Exp
processMRes !Text
name = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'MRes) Type
name'

processHasRes :: Text -> Q Exp
processHasRes :: Text -> Q Exp
processHasRes !Text
name = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'HasRes) Type
name'

processM :: Text -> Q Exp
processM :: Text -> Q Exp
processM !Text
name = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'M) Type
name'

processMR :: Text -> Exp -> Q Exp
processMR :: Text -> Exp -> Q Exp
processMR !Text
name !Exp
e = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Exp -> Exp
AppE (Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'MR) Type
name') Exp
e

processH :: Text -> Q Exp
processH :: Text -> Q Exp
processH !Text
name = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'Has) Type
name'

processHR :: Text -> Exp -> Q Exp
processHR :: Text -> Exp -> Q Exp
processHR !Text
name !Exp
e = do
  let !name' :: Type
name' = Text -> Type
getType Text
name
  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
$ Exp -> Exp -> Exp
AppE (Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE 'HasR) Type
name') Exp
e