{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

module Mischief.ECS.World.Query.TH (q, qd, qf) where

import Control.Monad
import Data.Text (Text)
import Data.Text qualified as T
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Mischief.ECS.World.Query
import Mischief.ECS.World.Query.TH.Common
import Mischief.ECS.World.Query.TH.QD
import Mischief.ECS.World.Query.TH.QF (Qf, pQf, quoteQf)
import Text.Megaparsec (MonadParsec (eof, try), optional, parse, some, (<|>))
import Text.Megaparsec.Char

q :: QuasiQuoter
q :: QuasiQuoter
q =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
str -> do
        let x :: Either (ParseErrorBundle Text Void) QueryBuilder
x = Parsec Void Text QueryBuilder
-> String
-> Text
-> Either (ParseErrorBundle Text Void) QueryBuilder
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser ()
whitespace Parser ()
-> Parsec Void Text QueryBuilder -> Parsec Void Text QueryBuilder
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
*> (Parsec Void Text QueryBuilder -> Parsec Void Text QueryBuilder
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text QueryBuilder
pGet Parsec Void Text QueryBuilder
-> Parsec Void Text QueryBuilder -> Parsec Void Text QueryBuilder
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
<|> Parsec Void Text QueryBuilder
pQuery) Parsec Void Text QueryBuilder
-> Parser () -> Parsec Void Text QueryBuilder
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
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"inline_input" (String -> Text
T.pack String
str)
        case Either (ParseErrorBundle Text Void) QueryBuilder
x of
          Left ParseErrorBundle Text Void
f -> String -> Q Exp
forall a. HasCallStack => String -> a
error (ParseErrorBundle Text Void -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Void
f)
          Right QueryBuilder
x -> QueryBuilder -> Q Exp
quoteQuery QueryBuilder
x,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined,
      quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined,
      quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
    }

data QueryBuilder = QueryBuilder Qd (Maybe Qf) (Maybe Text) deriving (Int -> QueryBuilder -> ShowS
[QueryBuilder] -> ShowS
QueryBuilder -> String
(Int -> QueryBuilder -> ShowS)
-> (QueryBuilder -> String)
-> ([QueryBuilder] -> ShowS)
-> Show QueryBuilder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryBuilder -> ShowS
showsPrec :: Int -> QueryBuilder -> ShowS
$cshow :: QueryBuilder -> String
show :: QueryBuilder -> String
$cshowList :: [QueryBuilder] -> ShowS
showList :: [QueryBuilder] -> ShowS
Show)

pQuery :: Parser QueryBuilder
pQuery :: Parsec Void Text QueryBuilder
pQuery = do
  qd <- Parser Qd
pQd
  whitespace

  qf <- optional $ do
    void $ char '/'
    whitespace
    pQf

  pure $ QueryBuilder qd qf Nothing

pGet :: Parser QueryBuilder
pGet :: Parsec Void Text QueryBuilder
pGet = do
  name <- String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some 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
  whitespace

  void $ char '.'
  whitespace

  QueryBuilder a b _ <- pQuery
  pure $ QueryBuilder a b (Just name)

quoteQuery :: QueryBuilder -> Q Exp
quoteQuery :: QueryBuilder -> Q Exp
quoteQuery (QueryBuilder Qd
qd Maybe Qf
Nothing Maybe Text
Nothing) = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mkQuery) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qd -> Q Exp
quoteQd Qd
qd
quoteQuery (QueryBuilder Qd
qd Maybe Qf
Nothing (Just Text
e)) = do
  e <- Text -> Q Name
getValueName Text
e
  qd <- quoteQd qd
  pure $ AppE (AppE (VarE 'mkGet) (VarE e)) qd
quoteQuery (QueryBuilder Qd
qd (Just Qf
qf) Maybe Text
Nothing) = do
  qd <- Qd -> Q Exp
quoteQd Qd
qd
  qf <- quoteQf qf
  return $ AppE (AppE (VarE 'mkQuery') qd) qf
quoteQuery (QueryBuilder Qd
qd (Just Qf
qf) (Just Text
e)) = do
  e <- Text -> Q Name
getValueName Text
e
  qd <- quoteQd qd
  qf <- quoteQf qf
  return $ AppE (AppE (AppE (VarE 'mkGet') (VarE e)) qd) qf

qf :: QuasiQuoter
qf :: QuasiQuoter
qf =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
str -> do
        let x :: Either (ParseErrorBundle Text Void) Qf
x = ParsecT Void Text Identity Qf
-> String -> Text -> Either (ParseErrorBundle Text Void) Qf
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser ()
whitespace Parser ()
-> ParsecT Void Text Identity Qf -> ParsecT Void Text Identity Qf
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
*> ParsecT Void Text Identity Qf
pQf ParsecT Void Text Identity Qf
-> Parser () -> ParsecT Void Text Identity Qf
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
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"inline_input" (String -> Text
T.pack String
str)
        case Either (ParseErrorBundle Text Void) Qf
x of
          Left ParseErrorBundle Text Void
f -> String -> Q Exp
forall a. HasCallStack => String -> a
error (ParseErrorBundle Text Void -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Void
f)
          Right Qf
x -> Qf -> Q Exp
quoteQf Qf
x,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined,
      quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined,
      quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
    }

qd :: QuasiQuoter
qd :: QuasiQuoter
qd =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
str -> do
        let x :: Either (ParseErrorBundle Text Void) Qd
x = Parser Qd
-> String -> Text -> Either (ParseErrorBundle Text Void) Qd
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser ()
whitespace Parser () -> Parser Qd -> Parser Qd
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 Qd
pQd Parser Qd -> Parser () -> Parser Qd
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
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"inline_input" (String -> Text
T.pack String
str)
        case Either (ParseErrorBundle Text Void) Qd
x of
          Left ParseErrorBundle Text Void
f -> String -> Q Exp
forall a. HasCallStack => String -> a
error (ParseErrorBundle Text Void -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Void
f)
          Right Qd
x -> Qd -> Q Exp
quoteQd Qd
x,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined,
      quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined,
      quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
    }