module Parse where

import Text.Parsec
    ( char,
      ParseError,
      space,
      Parsec,
      letter,
      between,
      chainl1,
      many1,
      (<|>),
      getPosition,
      getState,
      modifyState,
      runParser,
      try )
import Text.Parsec.Combinator (between, sepBy1, chainr1)
import Data.Map as M (fromList)
import Data.List as L (lookup, findIndex)

import AST
import Types
import qualified Error as E (ContextError(IndexOutOfContext))

-- Library name for parsing error messages
lib :: String
lib = "final"

type TmParser = Parsec String Context Term
type TyParser = Parsec String Context Ty

-- Parses string identifiers
parseIdentifier :: Parsec String a String
parseIdentifier = many1 $ letter <|> prime
    where prime = char '\''

-- Parses type identifiers
parseSimpleType :: TyParser
parseSimpleType = do
    ty <- parseIdentifier
    case ty of
        "TyBool" -> return TyBool
        "TyTop" -> return TyTop

parsePairType :: TyParser
parsePairType = do
    ty1 <- parseSimpleType
    space
    TyPair ty1 <$> parseSimpleType

parseRecordType :: TyParser
parseRecordType = do
    char '{'
    fields <- sepBy1 rcdFieldType (char ',')
    char '}'
    return $ TyRecord $ M.fromList fields

rcdFieldType :: Parsec String Context (String, Ty)
rcdFieldType = do
  fieldName <- parseIdentifier
  char ':'
  ty <- parseSimpleType
  return (fieldName, ty)

-- Parses identifier, either binds it to index (TmVar) or free (TmFree)
parseVar :: TmParser
parseVar = do
  v <- parseIdentifier
  ctx <- getState
  findVar v ctx

findVar :: String -> Context -> TmParser
findVar v ctx = case getNameBind of
  Nothing -> return $ TmFree v
  Just n  -> do
    return $ TmVar n (length ctx)
  where
    getNameBind = L.findIndex isNameMatch ctx
    isNameMatch = (== v) . fst

parseAbs :: TmParser -> TmParser
parseAbs termParser = do
  char '\\'
  v <- parseIdentifier
  modifyState (++ [(v, NameBind)])
  char ':'
  ty <- try parsePairType <|> try parseSimpleType <|> parseRecordType
  modifyState (++ [(v, VarBind ty)])
  char '.'
  term <- termParser
  modifyState tail  -- Move out of "scope" from parsing body
  return $ TmAbs v ty term

parens :: Parsec String u a -> Parsec String u a
parens = between left right
    where
        left = char '('
        right = char ')'

parseNonApp :: TmParser
parseNonApp =  parens parseTerm   -- (M)
           <|> parseAbs parseTerm -- $\lambda$x.M
           <|> parseVar

parseTerm :: TmParser
parseTerm = chainl1 parseNonApp $ do
  space
  return TmApp

parse :: String -> Either ParseError Term
parse = parseWith parseTerm

-- Parser, Input, Source Name (for error handling)
parseWith :: Parsec String Context a -> String -> Either ParseError a
parseWith p = runParser p [] lib

indexToName :: Context -> Int -> Either E.ContextError String
indexToName ctx n =
    if n > lastIx then Left E.IndexOutOfContext else Right getName
    where
        lastIx = length ctx - 1
        getName = fst $ ctx !! n

pickFreshName :: Context -> String -> (Context, String)
pickFreshName ctx x = case isBound of
    Just NameBind -> pickFreshName ctx $ x ++ "'"
    Nothing -> ((x, NameBind) : ctx, x)
    where
        isBound = L.lookup x ctx

printTm :: Context -> Term -> String
printTm ctx t = case t of
  TmAbs x ty t -> let
      (ctx', x') = pickFreshName ctx x
      tyAnnotation = ":" ++ show ty
    in "(\\" ++ x' ++ tyAnnotation ++ "." ++ printTm ctx' t ++ ")"
  TmApp t1 t2 ->
    "(" ++ printTm ctx t1 ++ " " ++ printTm ctx t2 ++ ")"
  TmVar x n -> case indexToName ctx x of
    Left err -> error "Attempted access out of context"
    Right n -> n
  TmFree x -> x

printTerm s = case parse s of
  Left err -> print err
  Right t -> print $ printTm [] t
