module Haskell.Parser where

import Control.Monad
import Data.Char
import Haskell.AST
import Text.Parsec
import Text.Parsec.String


parseAST :: String -> String -> Either ParseError AST
parseAST fname source = parse pAST fname source

pAST :: Parser AST
pAST = do
    whitespace
    tops <- many pToplevel
    eof
    return $ AST tops

pToplevel :: Parser Toplevel
pToplevel = TopDef <$> pDef

pDef :: Parser Def
pDef = do
    n <- pVariable
    args <- many pNameV
    symbolO "="
    ex <- pExpr
    symbolO ";"
    case args of
        [] -> return $ Def n ex
        _  -> return $ Def n (Lam args ex)

pExpr :: Parser Expr
pExpr = pLam <|> pCase <|> pApp
  where
    pSimpleExpr = choice [Num <$> pNum
                         ,Ref <$> pVariable
                         ,Con <$> pNameT
                         ,parens (pExpr `sepBy` symbolO ",") >>= \case
                            [ex] -> return ex
                            exs  -> return $ Tup exs]

    pLam = do
        symbolO "\\"
        args <- many1 pNameV
        symbolO "->"
        body <- pExpr
        return $ Lam args body

    pApp = many1 pSimpleExpr >>= \case
            []     -> undefined
            [e]    -> return e
            (e:es) -> return $ App e es

    pCase = do
        symbolW "case"
        e <- pExpr
        symbolW "of"
        arms <- braces (pCaseArm `sepBy` symbolO ";")
        return $ Case e arms

    pCaseArm = do
        pat <- pLargePat
        symbolO "->"
        ex <- pExpr
        return (pat, ex)

pSimplePat :: Parser Pat
pSimplePat = choice [symbolW "_" >> return PatAny
                    ,PatVar <$> pNameV
                    ,pNameT >>= \n -> return (PatCon n [])
                    ,parens (pLargePat `sepBy` symbolO ",") >>= \case
                        [pat] -> return pat
                        pats  -> return $ PatTup pats]

pLargePat :: Parser Pat
pLargePat = choice [PatCon <$> pNameT <*> many pSimplePat
                   ,pSimplePat]

pNum :: Parser Integer
pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive
  where pPositive = read <$> many1 digit <* aheadW

pVariable :: Parser Name
pVariable = pNameV <|> try (parens pOperator)

pName :: Parser Name
pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest

pNameV :: Parser Name
pNameV = notReserved $ liftM2 (:) (satisfy isLower) pNameRest

pNameT :: Parser Name
pNameT = notReserved $ liftM2 (:) (satisfy isUpper) pNameRest

pNameRest :: Parser Name
pNameRest = many (satisfy $ \d -> isAlphaNum d || d `elem` "_'") <* aheadW

notReserved :: Parser Name -> Parser Name
notReserved p =
    try $ p >>= \n ->
        if n `elem` reservedWords then unexpected "reserved word" else return n

pOperator :: Parser String
pOperator = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~") <* aheadO

parens :: Parser a -> Parser a
parens = between (symbolBare "(") (symbolBare ")")

braces :: Parser a -> Parser a
braces = between (symbolBare "{") (symbolBare "}")

symbolW :: String -> Parser ()
symbolW s = try (string s >> aheadW)

symbolO :: String -> Parser ()
symbolO s = try (string s >> aheadO)

symbolBare :: String -> Parser ()
symbolBare s = string s >> whitespace

aheadW :: Parser ()
aheadW = do
    void (lookAhead (space <|> satisfy (\d -> not (isAlphaNum d) && d `notElem` "_'"))) <|> eof
    whitespace

aheadO :: Parser ()
aheadO = do
    void (lookAhead (space <|> alphaNum <|> oneOf ")};")) <|> eof
    whitespace

whitespace :: Parser ()
whitespace = void $ many space

reservedWords :: [String]
reservedWords = ["case", "of", "class", "instance", "where", "let", "in"]