module CC.Parser(runPass, parseProgram) where

import Control.Monad
import Text.Parsec hiding (SourcePos, getPosition, token)
import qualified Text.Parsec

import CC.AST.Source
import CC.Context
import CC.Pretty


type Parser a = Parsec String () a

runPass :: Context -> RawString -> Either (PrettyShow ParseError) Program
runPass (Context path) (RawString src) = fmapLeft PrettyShow (parseProgram path src)
  where fmapLeft f (Left x) = Left (f x)
        fmapLeft _ (Right x) = Right x

parseProgram :: FilePath -> String -> Either ParseError Program
parseProgram fname src = parse pProgram fname src

pProgram :: Parser Program
pProgram = do
    prog <- Program <$> many pDecl
    emptyLines
    eof
    return prog

pDecl :: Parser Decl
pDecl = Def <$> pDef

pDef :: Parser Def
pDef = do
    func <- try $ do
        emptyLines
        name <- pName0 <?> "declaration head name"
        return name
    mtyp <- optionMaybe $ do
        symbol "::"
        typ <- pType
        whitespace >> void newline
        emptyLines
        func' <- fst <$> pName0
        guard (fst func == func')
        return typ
    args <- many pName
    symbol "="
    expr <- pExpr
    return (Function mtyp func args expr)

pType :: Parser Type
pType = chainr1 pTypeAtom (symbol "->" >> return TFun)

pTypeAtom :: Parser Type
pTypeAtom = (wordToken "Int" >> return TInt) <|> pParenType

pParenType :: Parser Type
pParenType = do
    token "("
    tys <- pType `sepBy` token ","
    token ")"
    case tys of
        [ty] -> return ty
        _ -> return (TTup tys)

pExpr :: Parser Expr
pExpr = label (pCall <|> pLam) "expression"
  where
    pCall = do
        atoms <- many1 pExprAtom
        annot <- optionMaybe (do symbol "::"
                                 p1 <- getPosition
                                 ty <- pType
                                 p2 <- getPosition
                                 return (ty, SourceRange p1 p2))
        let call = foldl1 (\a b -> Call (mergeRange (range a) (range b)) a b) atoms
        case annot of
            Just (ty, sr) -> return (Annot (mergeRange (range call) sr) call ty)
            Nothing -> return call

    pLam = do
        p1 <- try $ do
            whitespace
            p <- getPosition
            void (char '\\')
            return p
        names <- many1 pName
        symbol "->"
        body <- pExpr
        p2 <- getPosition
        return (Lam (SourceRange p1 p2) names body)

pExprAtom :: Parser Expr
pExprAtom =
    choice [ uncurry (flip Int) <$> pInt
           , uncurry (flip Var) <$> pName
           , pParenExpr ]

pParenExpr :: Parser Expr
pParenExpr = do
    p1 <- getPosition
    token "("
    exprs <- pExpr `sepBy` token ","
    token ")"
    p2 <- getPosition
    case exprs of
        [expr] -> return expr
        _ -> return (Tup (SourceRange p1 p2) exprs)

pInt :: Parser (Int, SourceRange)
pInt = try (whitespace >> pInt0)
  where
    pInt0 = do
        p1 <- getPosition
        num <- read <$> many1 digit
        p2 <- getPosition
        return (num, SourceRange p1 p2)

pName0 :: Parser (Name, SourceRange)
pName0 = do
    p1 <- getPosition
    c <- pWordFirstChar
    cs <- many pWordMidChar
    p2 <- getPosition
    notFollowedBy pWordMidChar
    return (c : cs, SourceRange p1 p2)

pWordFirstChar :: Parser Char
pWordFirstChar = letter <|> oneOf "_$#!"

pWordMidChar :: Parser Char
pWordMidChar = alphaNum <|> oneOf "_$#!"

pName :: Parser (Name, SourceRange)
pName = try (whitespace >> pName0)

symbol :: String -> Parser ()
symbol s = token s >> (eof <|> void space <|> void (oneOf "(){}[]"))

wordToken :: String -> Parser ()
wordToken s = token s >> notFollowedBy pWordMidChar

token :: String -> Parser ()
token s = try (whitespace >> void (string s))

emptyLines :: Parser ()
emptyLines = (try (whitespace >> newline) >> emptyLines) <|> try (whitespace >> eof) <|> return ()

whitespace :: Parser ()
whitespace = void (many (char ' '))

getPosition :: Parser SourcePos
getPosition = do
    pos <- Text.Parsec.getPosition
    return (SourcePos (sourceLine pos - 1) (sourceColumn pos - 1))