{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Lexer where

import Text.Parsec
import Data.Functor.Identity
import Data.Char

tokAny :: (Show t, Monad m) => ParsecT [(SourcePos, t)] u m t
tokAny = tokenPrim showTok updatePos (Just . snd) where
  showTok = show . snd
  updatePos pos _ =
    \case
      [] -> pos
      (pos', _ ) : _ -> pos'

tokSatisfy :: (Show t, Monad m) => (t -> Bool) -> ParsecT [(SourcePos, t)] u m t
tokSatisfy pred = tokenPrim showTok updatePos testTok where
  showTok = show . snd
  updatePos pos _ =
    \case
      [] -> pos
      (pos', _ ) : _ -> pos'
  testTok (_, t)
    | pred t = Just t
    | otherwise = Nothing

tok :: (Eq t, Show t, Monad m) => t -> ParsecT [(SourcePos, t)] u m t
tok x = tokSatisfy (x ==)


data Token
  = TLitInt Int
  | TKeyword String
  | TOperator String
  | TIdent String
  | TNewline
  | TOpenBracket | TCloseBracket
  | TOpenParen | TCloseParen
  | TOpenBrace | TCloseBrace
  deriving (Eq, Show)

--word :: Stream s m Char => ParsecT s u m String
--word = (:) <$> letter <*> (many alphaNum)

exactWord :: Stream s m Char => String -> ParsecT s u m String
exactWord str = string str <* lookAhead (satisfy (not . isAlphaNum))
--wordSatisfy :: Stream s m Char =>

keywords :: [String]
keywords = ["True", "False", "Int", "Bool", "if", "elseif", "else", "while", "debug"]

operators :: [String] -- orderby length
operators = ["==", "/=", "<=", ">=", "=", "<", ">", "&", "|", "+", "-", "*", "/", "%"]

litP :: Stream s m Char => ParsecT s u m Token
litP = try $ do
  sig <- option '+' (oneOf "+-")
  let signum = if sig == '+' then 1 else -1
  digs <- many1 digit
  return $ TLitInt $ signum * read digs


tokenP :: Stream s m Char => ParsecT s u m Token
tokenP = litP <|> keywordP <|> operatorP <|> identP <|> parenP <|> newlineP where
  keywordP = TKeyword <$> choice (map (try . exactWord) keywords)
  operatorP = TOperator <$> choice (map (try . string) operators)
  identP = TIdent <$> ((:) <$> letter <*> many alphaNum)
  newlineP = newline >> spaces >> return TNewline
  parenP = choice . map (\(c, t) -> char c >> return t) $ zip "(){}[]" [TOpenParen, TCloseParen, TOpenBrace, TCloseBrace, TOpenBracket, TCloseBracket]

tokenPairP :: Stream s m Char => ParsecT s u m (SourcePos, Token)
tokenPairP = (,) <$> getPosition <*> tokenP

tokenizer :: Stream s m Char => ParsecT s u m [(SourcePos, Token)]
tokenizer = many (tokenPairP <* many (satisfy hspace)) <* eof where
  hspace c = isSpace c && c /= '\n'

type TokPair = (SourcePos, Token)


tokenizeAndParse :: Stream s Identity Char => Parsec [TokPair] up a -> u -> up -> SourceName -> s -> Either ParseError a
tokenizeAndParse p sl sp name str =
  runParser tokenizer sl name str >>= runParser p sp name


