module Mischief.ECS.World.Query.TH.Common 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 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 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)

type Parser = Parsec Void Text

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]

whitespace :: Parser ()
whitespace :: Parser ()
whitespace =
  Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
    Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
    (Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//")
    (Tokens Text -> Tokens Text -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens Text
"*/")

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 -> Parser () -> Parser ()
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 ()
whitespace) Parser () -> 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 -> Parser () -> 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 -> Parser () -> Parser ()
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 ()
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 -> Parser () -> 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
<$ Parser ()
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

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

processC :: Text -> Q Exp
processC :: Text -> Q Exp
processC Text
name = do
  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

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

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