module Hint.Parser where

import           Control.Applicative (Alternative (..))
import           Control.Monad       (void)
import           Data.Either         (fromRight)
import qualified Data.Text           as T
import           Hint.Data
import           Hint.Lexer          (Input, Token (..), TokenKind (..),
                                      runProd)

data ParseError
  = UnexpectedToken [TokenKind]
  | NoParse
  deriving (Show, Eq)

data BinOp
  = Add
  | Mult
  deriving (Show, Eq)

newtype Parser a = Parser
  { unParser :: [Token] -> Either ParseError (a, [Token]) }

instance Functor Parser where
  fmap f (Parser p) = Parser $ \ts -> do
    (a, rest) <- p ts
    pure (f a, rest)

instance Applicative Parser where
  pure a = Parser $ \ts -> Right (a, ts)

  (<*>) (Parser pf) (Parser px) = Parser $ \ts -> do
    (f, ts') <- pf ts
    (x, ts'') <- px ts'
    pure (f x, ts'')

instance Monad Parser where
  return = pure

  (>>=) (Parser p) f = Parser $ \ts -> do
    (x, ts') <- p ts
    unParser (f x) ts'

instance Alternative Parser where
  empty = Parser $ const $ Left NoParse
  (<|>) (Parser p) (Parser q) = Parser $ \ts ->
    case p ts of
      Right a -> Right a
      Left _  -> q ts

runParser :: Parser a -> Input -> Either ParseError (a, [Token])
runParser p = unParser p . fromRight [] . runProd

token :: TokenKind -> Parser Token
token t = sat (== t)

sat :: (TokenKind -> Bool) -> Parser Token
sat p = Parser parse
  where
    parse [] = Left $ UnexpectedToken [TEof]
    parse (t@(Token kind _) : ts)
      | p kind = Right (t, ts)
      | otherwise = Left $ UnexpectedToken [kind]

pStr :: Parser Literal
pStr = String . T.pack <$> Parser parseString
  where
    parseString (Token (TString s) _ : ts) = pure (s, ts)
    parseString _                          = Left NoParse

pBool :: Parser Literal
pBool = (Boolean False <$ sat (== KeywordFalse)) <|> (Boolean True <$ sat (== KeywordTrue))

pNumeric :: Parser Literal
pNumeric = Int <$> Parser p
  where
    p (Token (TInt i) _ : ts) = pure (i, ts)
    p _                       = Left NoParse

parseWord :: String -> Parser Token
parseWord name = Parser parse
  where
    parse [] = Left NoParse
    parse (t@(Token (TIdent n) _) : ts)
      | name == n = Right (t, ts)
    parse _  = Left NoParse

parseLiteral :: Parser Expr
parseLiteral = Literal <$> (pStr <|> pBool <|> pNumeric)

parseIdentifier :: Parser Identifier
parseIdentifier = Parser p
  where
    p (Token (TIdent s) _ : ts) = pure (Identifier $ T.pack s, ts)
    p _                         = Left NoParse

parseBinding :: Parser Expr
parseBinding = do
  void $ token KeywordLet
  name <- parseIdentifier
  void $ token TEquals
  value <- expr
  void $ token KeywordIn
  body <- expr
  pure $ Bind name value body

parseIf :: Parser Expr
parseIf = do
  void $ token KeywordIf
  cond <- expr
  void $ token KeywordThen
  a <- expr
  void $ token KeywordElse
  b <- expr
  pure $ If cond a b

expr :: Parser Expr
expr = parseLiteral
  <|> parseIf
  <|> parseBinding
  <|> Ident <$> parseIdentifier