QF.hs

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

data Qf = With' [QfType] | Added' [QfType] | Changed' [QfType] | Not' Qf | Tup' [Qf] | Or' Qf Qf | Check' CompType Text deriving (Show)

data QfType = QfType {name :: Text, compType :: CompType} deriving (Show)

pQf :: Parser Qf
pQf = Tup' . concat <$> pTup pTup'

pTup' :: Parser [Qf]
pTup' = try ((char '(' *> whitespace) *> (concat <$> pTup pTup') <* (char ')' *> whitespace)) <|> (: []) <$> pOr

pOr :: Parser Qf
pOr = do
  s <- pSingle
  whitespace

  or <- optional $ choice [string "|.", string "||", string "or", string "OR", string "Or"] <* whitespace
  case or of
    Nothing -> return s
    Just _ -> foldr Or' s <$> pTup'

pSingle :: Parser Qf
pSingle = try pWith <|> pWithout <|> pAdded <|> try pChanged <|> pCheck <|> pNot

pNot :: Parser Qf
pNot = do
  void $ choice [string "Not", string "not", string "!"]
  whitespace

  Tup' <$> pTup'

pWith :: Parser Qf
pWith = do
  void $ choice [string "With", string "with"] <* notFollowedBy alphaNumChar
  whitespace
  With' <$> pTypes

pWithout :: Parser Qf
pWithout = do
  void $ choice [string "Without", string "without"] <* notFollowedBy alphaNumChar
  whitespace
  Not' . With' <$> pTypes

pAdded :: Parser Qf
pAdded = do
  void $ choice [string "Added", string "added"] <* notFollowedBy alphaNumChar
  whitespace
  Added' <$> pTypes

pChanged :: Parser Qf
pChanged = do
  void $ choice [string "Changed", string "changed"] <* notFollowedBy alphaNumChar
  whitespace
  Changed' <$> pTypes

pCheck :: Parser Qf
pCheck = do
  void $ choice [string "Check", string "check"] <* notFollowedBy alphaNumChar
  whitespace

  f <- pF
  whitespace

  target <- optional $ do
    void $ string "->"
    whitespace
    r <- string "*" <|> T.pack <$> some alphaNumChar
    whitespace
    return r

  let compType = case target of
        Nothing -> Single
        Just "*" -> PairAny
        Just e -> Pair e

  return $ Check' compType f

pF :: Parser Text
pF = try ((char '(' *> whitespace) *> pfLambda "(" <* whitespace) <|> T.pack <$> some alphaNumChar

pfLambda :: String -> Parser Text
pfLambda str = do
  x <- many (satisfy (/= ')'))
  void $ char ')'
  let str' = str ++ x ++ [')']
  case parseExp str' of
    Left _ -> do
      pfLambda str'
    Right _ -> return $ T.pack str'

pTypes :: Parser [QfType]
pTypes = try ((char '(' *> whitespace) *> (concat <$> pTup pTypes) <* (char ')' *> whitespace)) <|> (: []) <$> pType

pType :: Parser QfType
pType = do
  name <- pNameTup <|> T.pack <$> some alphaNumChar
  whitespace

  target <- optional $ do
    void $ string "->"
    whitespace
    r <- string "*" <|> T.pack <$> some alphaNumChar
    whitespace
    return r

  let compType = case target of
        Nothing -> Single
        Just "*" -> PairAny
        Just e -> Pair e

  return $
    QfType
      { name,
        compType
      }

quoteQf :: Qf -> Q Exp
quoteQf (Tup' qf) = processTup qf
quoteQf (With' x) = AppE (ConE 'With) <$> processTypes x
quoteQf (Changed' x) = AppE (ConE 'Changed) <$> processTypes x
quoteQf (Added' x) = AppE (ConE 'Added) <$> processTypes x
quoteQf (Or' x y) = do
  x <- quoteQf x
  y <- quoteQf y
  return $ AppE (AppE (ConE 'Or) x) y
quoteQf (Not' x) = AppE (ConE 'Not) <$> quoteQf x
quoteQf (Check' c f) = case parseExp (T.unpack f) of
  Left x -> error x
  Right x -> processCheck c x

processCheck :: CompType -> Exp -> Q Exp
processCheck Single f = return $ AppE (ConE 'Check) f
processCheck (Pair e') f = do
  e <- getValueName e'
  return $ AppE (AppE (ConE 'CheckR) (VarE e)) f
processCheck PairAny f = return $ AppE (AppE (ConE 'CheckR) (ConE 'Any)) f

processTup :: [Qf] -> Q Exp
processTup [x] = quoteQf x
processTup t = TupE . map Just <$> forM t quoteQf

processTypes :: [QfType] -> Q Exp
processTypes [x] = processType x
processTypes t = TupE . map Just <$> forM t processType

processType :: QfType -> Q Exp
processType (QfType {name, compType = Single}) = processC name
processType (QfType {name, compType}) = processR name =<< relExp compType