module Language.Kiff.Parser (parseFile) where

import Language.Kiff.Syntax    
    
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as T
import qualified Text.ParserCombinators.Parsec.Language as L
import qualified Text.ParserCombinators.Parsec.IndentParser.Token as IT
import qualified Text.ParserCombinators.Parsec.IndentParser as IP

import Control.Monad
import Data.Char
import Data.Either

lexer = T.makeTokenParser $ L.haskellStyle {
          T.reservedNames = ["if", "then", "else", "True", "False", "let", "in", "data", "type", "lambda"],
          T.reservedOpNames = ["::", "->", "=", "\\", "_", "|",
                               "*", "/", "+", "-", "%",
                               "!", "&&", "||",
                               "==", "<", ">", "<=", ">="]
         }
    
brackets   = IT.brackets lexer
colon      = IT.colon lexer              
comma      = IT.comma lexer
semi       = IT.semi lexer
parens     = IT.parens lexer
integer    = IT.integer lexer
natural    = IT.natural lexer
reserved   = IT.reserved lexer
reservedOp = IT.reservedOp lexer
identifier = IT.identifier lexer
whiteSpace = IT.whiteSpace lexer
symbol     = IT.symbol lexer
             
conname = do name@(n:_) <- identifier
             if isUpper n then return name else fail []

varname = do name@(n:_) <- identifier
             if isLower n then return name else fail []

boollit = (reserved "True" >> return True) <|>
          (reserved "False" >> return False)
                
ty = do tys <- ty' `sepBy1` (reservedOp "->")
        return $ foldr1 TyFun tys 
    where ty' = buildExpressionParser table term <?> "type expression"
              where  table = [[Infix (whiteSpace >> return TyApp) AssocRight]]
                     term =  parens ty <|> listTy <|> try primitiveTy <|> try tyVar <|> dataTy

                     listTy = TyList <$> brackets ty
                     tyVar = TyVar <$> TvName <$> varname
                     dataTy = TyData <$> conname                     
                     primitiveTy = (reserved "Int" >> return (TyPrimitive TyInt)) <|>
                                   (reserved "Bool" >> return (TyPrimitive TyBool))
                                   
expr = buildExpressionParser table term <?> "expression"
    where table = [[Infix (whiteSpace >> return (App ())) AssocLeft],
                   [Infix (reservedOp ":" >> return listcons) AssocRight],
                   [binary "*" OpMul, binary "/" OpDiv],
                   [binary "+" OpAdd, binary "-" OpSub, Prefix (reservedOp "-" >> return (UnaryMinus ()))],
                   [binary "%" OpMod],
                   [binary "==" OpEq, binary "<=" OpLe, binary "<" OpLt, binary ">" OpGt, binary ">=" OpGe],
                   [Prefix (reservedOp "!" >> return (Not ()))],
                   [binary "||" OpOr],
                   [binary "&&" OpAnd]]
                  -- TODO: ==, <=, ..
              where binary op cb = Infix (reservedOp op >> return (PrimBinOp () cb)) AssocLeft
                    listcons left right = App () (App () (Con () "cons") left) right
                  
          term = parens expr <|> list <|> intLit <|> boolLit <|> varref <|> con <|> lam <|> vars

          vars = do reserved "let"
                    defs <- IP.block $ many1 $ def
                    reserved "in"
                    body <- expr
                    return $ Let () defs body
                    
                 
          list = do elems <- brackets $ expr `sepBy` comma
                    return $ foldr (\x xs -> App () (App () (Con () "cons") x) xs) (Con () "nil") elems
                 
          intLit = IntLit () <$> fromInteger <$> natural -- TODO: integerl fscks up "-" and "+"                             
          boolLit = BoolLit () <$> boollit
          varref = Var () <$> varname
          con = Con () <$> conname

          lam = do reservedOp "\\" <|> reserved "lambda"
                   pats <- many1 (try pat)
                   reservedOp "->"
                   body <- expr
                   return $ Lam () pats body

          ifthenelse = do reserved "if"
                          cond <- expr
                          reserved "then"
                          thn <- expr
                          reserved "else"
                          els <- expr
                          return $ IfThenElse () cond thn els

pat = buildExpressionParser table term <?> "pattern"
    where table = [[Infix (reservedOp ":" >> return listcons) AssocRight]]
          term = try (parens conpat) <|> list <|> wildcard <|> varpat <|> intpat <|> boolpat <|> parens pat

          conpat = do con <- conname
                      pats <- many pat
                      return $ PApp () con pats
                              
          varpat = PVar () <$> varname

          wildcard = do reservedOp "_"
                        return $ Wildcard ()
                             
          intpat = IntPat () <$> fromInteger <$> integer

          boolpat = BoolPat () <$> boollit

          listcons head rest = PApp () "cons" [head, rest]
                               
          list = do pats <- brackets $ pat `sepBy` comma
                    return $ foldr listcons (PApp () "nil" []) pats
                    

defEq varname = do _ <- try $ reserved varname
                   pats <- many pat
                   reservedOp "="
                   body <- expr
                   return $ DefEq () pats body

def = do
        msig <- optionMaybe $ try $ IP.lineFold signature
        case msig of
          Just (v, sig)  -> do  eqs <- defEqs v
                                return $ Def () v (Just sig) eqs
          Nothing        -> do  v <- lookAhead varname
                                eqs <- defEqs v
                                return $ Def () v Nothing eqs

    where signature = do v <- varname
                         reservedOp "::"
                         t <- ty
                         return $ (v, t)

          defEqs v = many1 $ IP.lineFold $ defEq v                     

typedecl = datadecl <|> typealias <?> "Type declaration"
    where datadecl = do reserved "data"
                        n <- conname
                        tvs <- many varname
                        reservedOp "="
                        cons <- IP.lineFold $ datacon `sepBy` (reservedOp "|")
                        return $ DataDecl n tvs cons
                               
          typealias = do reserved "type"
                         n <- conname
                         tvs <- many varname
                         reservedOp "="
                         ty <- IP.lineFold $ ty
                         return $ TypeAlias n tvs ty
                                
          datacon = do n <- conname
                       tys <- many ty
                       return $ DataCon n tys

program = do (decls, defs) <- liftM partitionEithers $ many $ whiteSpace >> (decl <|> vardef)
             return $ Program decls defs
                  
    where decl = Left <$> typedecl                           
          vardef = Right <$> def

parseFile = IP.parseFromFile parseWhole
    where parseWhole = do prog <- program
                          eof
                          return prog
