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

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 Mischief.ECS.World.Query.Markers hiding (Q)
import Text.Megaparsec (Parsec, many, optional, (<|>))
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

data CompType = Single | Pair Text | PairAny | Resource 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