QF.hs

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

import Control.Monad
import Data.Text (Text)
import Data.Text qualified as T
import Language.Haskell.Meta.Parse
import Language.Haskell.TH
import Mischief.ECS.World.Query.QueryFilter
import Mischief.ECS.World.Query.TH.Common
import Text.Megaparsec (MonadParsec (notFollowedBy, try), choice, many, optional, satisfy, some, (<|>))
import Text.Megaparsec.Char

data Qf = With' [QfType] | Without' [QfType] | Changed' [QfType] Text Text | Tup' [Qf] | And' Qf Qf | Or' Qf Qf 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 "or", string "OR", string "Or"] <* whitespace
  case or of
    Nothing -> pure s
    Just _ -> foldr Or' s <$> pTup'

pAnd :: Parser Qf
pAnd = do
  !s <- pSingle
  whitespace

  !and <- optional $ choice [string "&&", string "and", string "AND", string "And"] <* whitespace
  case and of
    Nothing -> return s
    Just _ -> foldr And' s <$> pTup'

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

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
  Without' <$> pTypes

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

  lambdas <- optional $ do
    void $ char '('
    l1 <- pfLambda "("
    whitespace

    void $ char '('
    l2 <- pfLambda "("
    pure (l1, l2)

  case lambdas of
    Nothing -> pure $ Changed' types "(>=)" "(<)"
    Just (f1, f2) -> pure $ Changed' types f1 f2

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 _ -> pure $ 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
    pure r

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

  pure $
    QfType
      { name,
        compType
      }

quoteQf :: Qf -> Q Exp
quoteQf (Tup' !qf) = processTup qf
quoteQf (With' !x) = processTypes (ConE 'With) x
quoteQf (Without' !x) = processTypes (ConE 'Without) x
quoteQf (Changed' !x f1 f2) = do
  let (Right f1') = parseExp (T.unpack f1)
  let (Right f2') = parseExp (T.unpack f2)
  processChanged (ConE 'Changed) x f1' f2'
quoteQf (Or' !x !y) = do
  !x <- quoteQf x
  !y <- quoteQf y
  pure $ AppE (AppE (ConE 'Or) x) y
quoteQf (And' !x !y) = do
  !x <- quoteQf x
  !y <- quoteQf y
  pure $ AppE (AppE (ConE 'And) x) y

processTup :: [Qf] -> Q Exp
processTup [] = pure $ VarE '()
processTup [!x] = quoteQf x
processTup (!x : !xs) = do
  !x' <- quoteQf x
  AppE (AppE (ConE 'And) x') <$> processTup xs

processTypes :: Exp -> [QfType] -> Q Exp
processTypes _ [] = pure $ VarE '()
processTypes !exp [!x] = AppE exp <$> processType x
processTypes !exp (!x : !xs) = do
  !x' <- processType x
  AppE (AppE (ConE 'And) (AppE exp x')) <$> processTypes exp xs

processChanged :: Exp -> [QfType] -> Exp -> Exp -> Q Exp
processChanged _ [] _ _ = pure $ VarE '()
processChanged !exp [!x] f1 f2 = do
  r <- processType x
  pure $ AppE (AppE (AppE exp r) f1) f2
processChanged !exp (!x : !xs) f1 f2 = do
  !x' <- processType x
  AppE (AppE (ConE 'And) (AppE (AppE (AppE exp x') f1) f2)) <$> processTypes exp xs

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