Common.hs

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 (Show)

type Parser = Parsec Void Text

pTup :: Parser a -> Parser [a]
pTup !p = do
  !r <- optional p
  whitespace

  !comma <- optional $ string ","
  whitespace

  case r of
    Nothing -> return []
    Just !r -> do
      case comma of
        (Just _) -> ([r] ++) <$> pTup p
        _ -> return [r]

whitespace :: Parser ()
whitespace =
  L.space
    space1
    (L.skipLineComment "//")
    (L.skipBlockComment "/*" "*/")

pNameTup :: Parser Text
pNameTup = (char '(' *> whitespace) *> pNameRec <* (char ')' *> whitespace)

pNameRec :: Parser Text
pNameRec = do
  !s <- T.pack <$> many (alphaNumChar <|> (' ' <$ space1) <|> char ',')
  whitespace

  !o <- optional $ (char '(' *> whitespace) *> pNameRec <* (char ')' *> whitespace)
  whitespace

  case o of
    Nothing -> do
      pure s
    Just !o -> do
      !n <- pNameRec

      pure $ s <> "(" <> o <> ")" <> n

getType :: Text -> Type
getType !name = do
  let !t = M.parseType (T.unpack name)
  case t of
    Left !e -> error e
    Right !t -> t

getValueName :: Text -> Q Name
getValueName !name = do
  !t <- lookupValueName $ T.unpack name
  pure $ fromMaybe (error $ "Invalid value: " ++ T.unpack name ++ ".") t

processC :: Text -> Q Exp
processC !name = do
  let !t = M.parseType (T.unpack name)
  case t of
    Left !e -> error e
    Right !t -> pure $ AppTypeE (ConE 'C) t

processR :: Text -> Exp -> Q Exp
processR !name !e = do
  let !name' = getType name
  pure $ AppE (AppTypeE (ConE 'R) name') e

relExp :: CompType -> Q Exp
relExp PairAny = return $ ConE 'Any
relExp (Pair !x) = VarE <$> getValueName x
relExp _ = undefined