module Parser(parseProgram) where

import Control.Monad
import Data.Char
import Text.Parsec
import qualified Text.Parsec.Expr as E

import AST


type Parser = Parsec String ()


(<<) :: (Monad m) => m a -> m b -> m a
(<<) = (<*)

parseProgram :: Maybe String -> String -> Either ParseError Program
parseProgram fname src = parse pProgram (maybe "" id fname) src

pProgram :: Parser Program
pProgram = (pWhiteComment >> ((Program . Block) <$> pStatement `sepBy` pWhiteComment)) << eof

pStatement :: Parser Statement
pStatement = pCondition <|> pDeclarationAssignment <|> pDive <|> pExpressionStatement <?> "statement"

pDeclarationAssignment :: Parser Statement
pDeclarationAssignment = (do
    (n, constr) <- try $ do  -- after we've seen the assignment operator, there's no turning back
        n' <- pName
        constr' <- (symbol ":=" >> return Declaration) <|> (symbol "=" >> return Assignment)
        return (n', constr')

    e <- pExpression
    symbol ";" <|> void (lookAhead (char '}'))
    return $ constr n e) <?> "variable declaration or assignment"

pCondition :: Parser Statement
pCondition = do
    symbol "if"
    cond <- pExpression
    e1 <- pBlock
    e2 <- (symbol "else" >> pBlock) <|> return (Block [])
    return $ Condition cond e1 e2

pExpressionStatement :: Parser Statement
pExpressionStatement = (Expr <$> pExpression) << symbol ";"

pDive :: Parser Statement
pDive = do
    n <- try $ do
        n' <- pName
        void $ lookAhead (oneOf "({")
        return n'

    al <- option [] $ between (symbol "(") (symbol ")") $ pExpression `sepBy` symbol ","
    (symbol ";" >> return (Dive n al (Block []))) <|> (Dive n al <$> pBlock)


pExpression :: Parser Expression
pExpression = E.buildExpressionParser table pExpressionTerm
  where
    table = [[E.Prefix (symbol "-" >> return (EUn UONeg)),
              E.Prefix (symbol "!" >> return (EUn UONot))],
             [E.Infix (symbol "**" >> return (EBin BOPow)) E.AssocRight],
             [E.Infix (symbol "*" >> return (EBin BOMul)) E.AssocLeft,
              E.Infix (symbol "/" >> return (EBin BODiv)) E.AssocLeft,
              E.Infix (symbol "%" >> return (EBin BOMod)) E.AssocLeft],
             [E.Infix (symbol "+" >> return (EBin BOPlus)) E.AssocLeft,
              E.Infix (symbol "-" >> return (EBin BOMinus)) E.AssocLeft],
             [E.Infix (symbol "<=" >> return (EBin BOLEq)) E.AssocNone,
              E.Infix (symbol ">=" >> return (EBin BOGEq)) E.AssocNone,
              E.Infix (symbol "==" >> return (EBin BOEqual)) E.AssocNone,
              E.Infix (symbol "<" >> return (EBin BOLess)) E.AssocNone,
              E.Infix (symbol ">" >> return (EBin BOGreater)) E.AssocNone],
             [E.Infix (symbol "&&" >> return (EBin BOBoolAnd)) E.AssocLeft,
              E.Infix (symbol "||" >> return (EBin BOBoolOr)) E.AssocLeft]]

    pExpressionTerm :: Parser Expression
    pExpressionTerm = pParenExpression <|> (ELit <$> pLiteral)

pBlock :: Parser Block
pBlock = Block <$> between (symbol "{") (symbol "}") (many pStatement)

pParenExpression :: Parser Expression
pParenExpression = between (symbol "(") (symbol ")") pExpression

pLiteral :: Parser Literal
pLiteral = (pLNil <|> pLStr <|> pLNum <|> pLBlock <|> (LVar <$> pName)
            <?> "literal") << pWhiteComment

pLNil :: Parser Literal
pLNil = symbol "nil" >> return LNil

pLBlock :: Parser Literal
pLBlock = (LBlock BT0 [] <$> pBlock) <|> do
    symbol "??"
    al <- option [] $ between (symbol "(") (symbol ")") $ pName `sepBy` symbol ","
    b <- pBlock
    return $ LBlock BT2 al b

pLNum :: Parser Literal
pLNum = pDecimal <|> pHexa
  where
    pDecimal = do
        pre <- many1 digit <|> (lookAhead (char '.') >> return "")
        post <- ((:) <$> char '.' <*> many1 digit) <|> return ""
        ex <- pExponent <|> return ""
        return $ LNum $ read $ pre ++ post ++ ex

    pHexa = do
        void $ string "0x"
        pre <- many1 hexDigit
        return $ LNum $ read $ "0x" ++ pre

    pExponent = do
        void $ char 'e'
        sgn <- (char '+' >> return "") <|> string "-" <|> return ""
        dig <- many1 digit
        return $ 'e' : sgn ++ dig

pLStr :: Parser Literal
pLStr = LStr <$> between (char '"') (char '"') pStrContents
  where
    pStrContents = many pStrChar
    pStrChar = (char '\\' >> pEscape) <|> noneOf "\""
    pEscape = (char 'n' >> return '\n') <|>
              (char 'r' >> return '\r') <|>
              (char 't' >> return '\t') <|>
              char '"' <|> char '\\'


pName :: Parser Name
pName = do
    c <- satisfy (isAlpha .||. (== '_'))
    rest <- many (satisfy (isAlphaNum .||. (== '_')))
    pWhiteComment
    return $ c : rest


pWhiteComment :: Parser ()
pWhiteComment = void $ pWhite `sepBy` pComment

pWhite :: Parser ()
pWhite = void $ many (oneOf " \t\n")

pComment :: Parser ()
pComment = pLineComment <|> pBlockComment

pLineComment :: Parser ()
pLineComment = void $ try (string "//") >> manyTill anyChar (void (char '\n') <|> eof)

pBlockComment :: Parser ()
pBlockComment = void $ try (string "/*") >> manyTill anyChar (try (string "*/"))

symbol :: String -> Parser ()
symbol s = do
    void $ try (string s)
    when (not (null s) && isAlphaNum (last s)) $ notFollowedBy alphaNum
    pWhiteComment

infixr 2 .||.
(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
f .||. g = \x -> f x || g x