module IOParser where {

import Text.ParserCombinators.Parsec;
import Text.ParserCombinators.Parsec.Expr;
import Token;
import IOType;

parseExpr = buildExpressionParser table parseFactor <?> "expression";

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

table = [
	 [ Infix (do { try (reservedOp "*"); return (op2 "*")}) AssocLeft,
	   Infix (do { try (reservedOp "/"); return (op2 "/")}) AssocLeft,
	   Infix (do { try (reservedOp "%"); return (op2 "%")}) AssocLeft
	 ],
	 [ Infix (do { try (reservedOp "+"); return (op2 "+")}) AssocLeft,
	   Infix (do { try (reservedOp "-"); return (op2 "-")}) AssocLeft
	 ],
	 [ Infix (do { try (reservedOp "++"); return (op2 "++")}) AssocLeft ],
	 (map (\ op -> Infix (do { try (reservedOp op); return (op2 op)})
	                     AssocNone)
	  ["==", "/=", "<", "<=", ">=", ">"]),
	 [ Infix (do { try (reservedOp "&&");
		       return (\ x y -> If x y (Const (Bool False))) })
	   AssocRight
	 ],
	 [ Infix (do { try (reservedOp "||");
		       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";
--		    decls <- parseDecls;
		    decl <- parseDecl;
		    reserved "in";
		    expr  <- parseExpr;
--		    return (Let decls expr)
		    return (Let decl expr)
		  })
	      <|>
	      (do { reserved "letrec";
--		    decls <- parseDecls;
		    decl <- parseDecl;
		    reserved "in";
		    expr  <- parseExpr;
		    return (Letrec decl expr)
		  })
	      <|>
	      (do { (reserved "fn" <|> 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 "setX";
		   e <- parseExpr;
		   return (SetX e)
		  })
	      <|>
	      (do {
		   reserved "getX";
		   return GetX
		  })	      
	      <|>
	      (do {
		   reserved "setY";
		   e <- parseExpr;
		   return (SetY e)
		  })
	      <|>
	      (do {
		   reserved "getY";
		   return GetY
		  })
	      <|>
	      (do {
		   reserved "while";
		   e1 <- parseExpr;
		   reserved "do";
		   e2 <- parseExpr;
		   return (While e1 e2)
		  })
	      <|>
	      (do {
		   reserved "begin";
		   es <- parseExprs;
		   reserved "end";
		   return (Begin es)
		  })
	      <|>
	      (do {
		   reserved "read";
		   return Read
		  })

	      <|>
	      (do {
		   reserved "write";
		   e <- parseExpr;
		   return (Write e)
		  })

;

parseExprs = sepBy1 parseExpr semi;

parseDecls = sepBy1 parseDecl semi;
parseDecl = do {
		i <- identifier;
		reservedOp "=";
		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
	      }
;

}