module ErrParser where

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr

import Token
import ErrType

parseExpr = buildExpressionParser table parseFactor <?> "expression"

op2 name = \ x y -> App (App (Var name) x) y

table = [
          [ Infix (do { try (symbol "*"); return (op2 "*")}) AssocLeft,
            Infix (do { try (symbol "/"); return (op2 "/")}) AssocLeft,
            Infix (do { try (symbol "%"); return (op2 "%")}) AssocLeft
          ],
          [ Infix (do { try (symbol "+"); return (op2 "+")}) AssocLeft,
            Infix (do { try (symbol "-"); return (op2 "-")}) AssocLeft
          ],
          [ Infix (do { try (symbol "++"); return (op2 "++")}) AssocLeft ],
          (map (\ op -> Infix (do { try (symbol op); return (op2 op)})
                              AssocNone)
           ["==", "/=", "<", "<=", ">=", ">"]),
          [ Infix (do { try (symbol "&&");
                        return (\ x y -> If x y (Const (Bool False))) })
            AssocRight
          ],
          [ Infix (do { try (symbol "||");
                        return (\ x y -> If x (Const (Bool True)) y) })
            AssocRight
          ]  
        ]


parseFactor = do 
                es <- many1 parseAtomic
                return (foldl1 App es)


parseAtomic = parens parseExpr
              <|>
                (do t <- naturalOrFloat
                    return (case t of Left i -> Const (Num (fromInteger i))
                                      Right d -> Const (Num d)))
                <|>
                (do t <- stringLiteral
                    return (Const (Str t)))
                <|>
                (do { t <- identifier; return (Var t) })
                <|>
                (do reserved "let"
                    decl <- parseDecl
                    reserved "in"
                    expr  <- parseExpr
                    return (Let decl expr))
                <|>
                (do reserved "letrec"
                    decl <- parseDecl
                    reserved "in"
                    expr  <- parseExpr
                    return (Letrec decl expr))
                <|>
                (do reservedOp "\\"
                    id <- identifier
                    reservedOp "->"
                    e <- parseExpr
                    return (Lambda id e))
                <|>
                (do reserved "if"
                    e1 <- parseExpr
                    reserved "then"
                    e2 <- parseExpr
                    reserved "else"
                    e3 <- parseExpr
                    return (If e1 e2 e3))
                <|>
                (do reserved "try"
                    e1 <- parseExpr
                    reserved "catch"
                    e2 <- parseExpr
                    return (Try e1 e2))
                <|>
                (do reserved "fail"
                    e1 <- parseExpr
                    return (Fail e1))

parseDecls = sepBy1 parseDecl semi
parseDecl = do 
              i <- identifier
              symbol "="
              e <- parseExpr
              return (i, e)

myParse :: String -> Expr
myParse str = case
                parse (do {whiteSpace; s<- parseExpr; eof; return s }) "" str
              of
            	  Left err -> Const (Str ("parse error at " ++ show err))
            	  Right x  -> x