{-# 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)
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 ()
= Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"--"
blockComment :: Parser ()
= 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)
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)
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