{----------------------------------------------------------------------

インタプリタ

* Continuationのモナド（breakとcontinue）

 Expr -> Expr || Expr | Expr && Expr
       | Expr == Expr | Expr /= Expr | Expr < Expr | Expr <= Expr
       | Expr >= Expr | Expr > Expr
       | Expr ++ Expr
       | Expr * Expr | Expr / Expr 
       | Expr + Expr | Expr + Expr
       | Expr Expr 
       | Const
       | ( Expr )
       | Ident
       | set | get
       | let Ident = Expr in Expr
       | letrec Decl in Expr
       | \ Ident -> Expr 
       | if Expr then Expr else Expr
       | while Expr do Expr
       | begin LabeledExprSeq 
       | break | continue | abort
       | goto Ident
       | callcc Expr

  LabeledExprSeq -> LabeledExpr end
                  | LabeledExpr; LabeledExprSeq

  LabeledExpr -> Expr | Ident : Expr 
 ----------------------------------------------------------------------}

module ContParser where {

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

import ContType;

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 "setY";
		   e <- parseExpr;
		   return (SetY e)
		  })
	      <|>
	      (do {
		   reserved "setZ";
		   e <- parseExpr;
		   return (SetZ e)
		  })
	      <|>
	      (do {
		   reserved "getX";
		   return GetX
		  })	      
	      <|>
	      (do {
		   reserved "getY";
		   return GetY
		  })	      
	      <|>
	      (do {
		   reserved "getZ";
		   return GetZ
		  })	      
	      <|>
	      (do {
		   reserved "while";
		   e1 <- parseExpr;
		   reserved "do";
		   e2 <- parseExpr;
		   return (While e1 e2)
		  })
	      <|>
	      (do {
		   reserved "begin";
		   es <- parseLabeledExprs;
		   reserved "end";
		   return (Begin es)
		  })
	      <|>
	      (do {
		   reserved "break";
		   return Break
		  })
	      <|>
	      (do {
		   reserved "continue";
		   return Continue
		  })
	      <|>
	      (do {
		   reserved "abort";
		   return Abort
		  })
	      <|>
	      (do {
		   reserved "goto";
   	           id <- identifier;
                   return (Goto id)
		  })
	      <|>
	      (do {
		   reserved "callcc";
	           e <- parseExpr;
                   return (Callcc e)
		  })
;

parseLabeledExprs = sepBy1 parseLabeledExpr semi;

parseLabeledExpr = try (do { id <- identifier;
                         reservedOp ":";
                         e  <- parseExpr;
                         return (Just id, e)
                    })
	           <|>
                   (do { e  <- parseExpr;
                         return (Nothing, e)
                    })
;

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
	      }
;

}