{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}

module Wingman.Metaprogramming.Lexer where

import           Control.Applicative
import           Control.Monad
import           Data.Foldable (asum)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Void
import           Development.IDE.GHC.Compat.Core (OccName, mkVarOcc)
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as L

type Parser = P.Parsec Void Text



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 Identity (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 Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'\''

symchar :: Parser Char
symchar :: Parser Char
symchar = [Parser Char] -> Parser Char
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
  [ Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.symbolChar
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'!'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'#'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'$'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'%'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'^'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'&'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'*'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'='
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'+'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
':'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'<'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'>'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
','
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'.'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'/'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'?'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'~'
  , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'|'
  , Token Text -> ParsecT Void Text Identity (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 Identity (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 Identity (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 Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'('
    (String -> OccName)
-> ParsecT Void Text Identity String -> Parser OccName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> OccName
mkVarOcc (ParsecT Void Text Identity String -> Parser OccName)
-> ParsecT Void Text Identity String -> Parser OccName
forall a b. (a -> b) -> a -> b
$ case Char
c of
      Char
'(' -> do
        String
cs <- Parser Char -> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many Parser Char
symchar
        Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> Parser ()) -> Parser Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
')'
        String -> ParsecT Void Text Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
cs
      Char
_ -> do
        String
cs <- Parser Char -> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many Parser Char
ichar
        String -> ParsecT Void Text Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ParsecT Void Text Identity String)
-> String -> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
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
    String
cs <- Parser Char -> ParsecT Void Text Identity String
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 Identity (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
$ String -> Text
T.pack (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)

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