module Haskell.Parser where

import Control.Monad
import Control.Monad.Identity
import Haskell.AST
import Haskell.Parser.Def
import Text.Parsec
-- import Text.Parsec.IndentParsec.Combinator
import Text.Parsec.IndentParsec.Prim


type Parser a = GenIndentParsecT HaskellLike String () Identity a

parseAST :: String -> String -> Either ParseError AST
parseAST fname source = runIdentity $ runGIPT pAST () fname source

pAST :: Parser AST
pAST = do
    whiteSpace
    tops <- pToplevel `sepBy` someNewline
    eof
    return $ AST tops

pToplevel :: Parser Toplevel
pToplevel = choice [TopClass <$> pClass
                   ,TopInst <$> pInst
                   ,TopData <$> pData
                   ,TopDecl <$> pDecl
                   ,TopDef <$> pDef]

pData :: Parser Data
pData = do
    reserved "data"
    n <- typeident
    vars <- many varident
    ty <- choice [do reservedOp "="
                     pConstr `sepBy` reservedOp "|"
                 ,return []]
    return $ Data n vars ty
  where
    pConstr = liftM2 (,) typeident (many pType)

pClass :: Parser Class
pClass = do
    reserved "class"
    n <- typeident
    vars <- many varident
    reserved "where"
    decls <- bracesBlock (semiSepOrFoldedLines pDecl)
    return $ Class n vars decls

pInst :: Parser Inst
pInst = do
    reserved "instance"
    (n, ty) <- pType >>= \case
        TyRef n [ty] -> return (n, ty)
        _            -> fail "invalid instance head"
    reserved "where"
    decls <- bracesBlock (semiSepOrFoldedLines pDef)
    return $ Inst n ty decls

pDecl :: Parser Decl
pDecl = do
    n <- try (varident <* reservedOp "::")
    ty <- pType
    return $ Decl n ty

pDef :: Parser Def
pDef = do
    n <- varident
    args <- many varident
    reservedOp "="
    body <- pExpr
    case args of
        [] -> return $ Def n body
        _  -> return $ Def n (Lam args body)

pType :: Parser Type
pType = foldr1 TyFun <$> pSimpleType `sepBy` reservedOp "->"
  where
    pSimpleType :: Parser Type
    pSimpleType = choice [do n <- typeident
                             args <- many pAtomicType
                             return (TyRef n args)
                         ,pAtomicType]

    pAtomicType :: Parser Type
    pAtomicType = choice [typeident >>= \n -> return (TyRef n [])
                         ,TyVar <$> varident
                         ,parens (pType `sepBy` comma) >>= \case
                            [ty] -> return ty
                            tys  -> return (TyTup tys)]

pExpr :: Parser Expr
pExpr = pLam <|> pCase <|> pApp
  where
    pSimpleExpr = choice [Num <$> integer
                         ,Ref <$> (identifier <|> try (parens operator))
                         ,parens pExpr]

    pLam = do
        reservedOp "\\"
        args <- many1 varident
        body <- pExpr
        return $ Lam args body

    pApp = App <$> pSimpleExpr <*> many pSimpleExpr

    pCase = do
        reserved "case"
        e <- pExpr
        reserved "of"
        arms <- bracesBlock (semiSepOrFoldedLines pCaseArm)
        return $ Case e arms

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

pSimplePat :: Parser Pat
pSimplePat = choice [lexeme (string "_") >> return PatAny
                    ,PatVar <$> varident
                    ,typeident >>= \n -> return (PatCon n [])
                    ,parens pLargePat]

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

someNewline :: Parser ()
someNewline = many (oneOf " \t") >> char '\n' >> whiteSpace