{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

module Wingman.Metaprogramming.Lexer where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Reader (ReaderT)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Void
import           Development.IDE.GHC.Compat (HscEnv, Module)
import           GhcPlugins (GlobalRdrElt)
import           Name
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as L
import Wingman.Types (Context)


------------------------------------------------------------------------------
-- | Everything we need in order to call 'Wingman.Machinery.getOccNameType'.
data ParserContext = ParserContext
  { ParserContext -> HscEnv
ps_hscEnv :: HscEnv
  , ParserContext -> OccEnv [GlobalRdrElt]
ps_occEnv :: OccEnv [GlobalRdrElt]
  , ParserContext -> Module
ps_module :: Module
  , ParserContext -> Context
ps_context :: Context
  }

type Parser = P.ParsecT Void Text (ReaderT ParserContext IO)



lineComment :: Parser ()
lineComment :: Parser ()
lineComment = Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"--"

blockComment :: Parser ()
blockComment :: Parser ()
blockComment = Tokens Text -> Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"{-" Tokens Text
"-}"

sc :: Parser ()
sc :: Parser ()
sc = 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 ()
P.space1 Parser ()
lineComment Parser ()
blockComment

ichar :: Parser Char
ichar :: Parser Char
ichar = Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.alphaNumChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text
-> ParsecT Void Text (ReaderT ParserContext IO) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'_' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text
-> ParsecT Void Text (ReaderT ParserContext IO) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\''

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = Parser () -> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
sc

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = Parser ()
-> Tokens Text
-> ParsecT Void Text (ReaderT ParserContext IO) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc

symbol_ :: Text -> Parser ()
symbol_ :: Text -> Parser ()
symbol_ = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ())
-> (Text -> Parser Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
symbol

brackets :: Parser a -> Parser a
brackets :: Parser a -> Parser a
brackets = Parser Text -> Parser Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between (Text -> Parser Text
symbol Text
"[") (Text -> Parser Text
symbol Text
"]")

braces :: Parser a -> Parser a
braces :: Parser a -> Parser a
braces = Parser Text -> Parser Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between (Text -> Parser Text
symbol Text
"{") (Text -> Parser Text
symbol Text
"}")

parens :: Parser a -> Parser a
parens :: Parser a -> Parser a
parens = Parser Text -> Parser Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between (Text -> Parser Text
symbol Text
"(") (Text -> Parser Text
symbol Text
")")

identifier :: Text -> Parser ()
identifier :: Text -> Parser ()
identifier Text
i = Parser () -> Parser ()
forall a. Parser a -> Parser a
lexeme (Tokens Text
-> ParsecT Void Text (ReaderT ParserContext IO) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Text
Tokens Text
i Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy Parser Char
ichar)

-- FIXME [Reed M. 2020-10-18] Check to see if the variables are in the reserved list
variable :: Parser OccName
variable :: Parser OccName
variable = Parser OccName -> Parser OccName
forall a. Parser a -> Parser a
lexeme (Parser OccName -> Parser OccName)
-> Parser OccName -> Parser OccName
forall a b. (a -> b) -> a -> b
$ do
    Char
c <- Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.alphaNumChar
    [Char]
cs <- Parser Char -> ParsecT Void Text (ReaderT ParserContext IO) [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many Parser Char
ichar
    OccName -> Parser OccName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OccName -> Parser OccName) -> OccName -> Parser OccName
forall a b. (a -> b) -> a -> b
$ [Char] -> OccName
mkVarOcc (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs)

-- FIXME [Reed M. 2020-10-18] Check to see if the variables are in the reserved list
name :: Parser Text
name :: Parser Text
name = Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
    Char
c <- Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.alphaNumChar
    [Char]
cs <- Parser Char -> ParsecT Void Text (ReaderT ParserContext IO) [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (Parser Char
ichar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text
-> ParsecT Void Text (ReaderT ParserContext IO) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-')
    Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
cs)

keyword :: Text -> Parser ()
keyword :: Text -> Parser ()
keyword = Text -> Parser ()
identifier