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

インタプリタ

* Util1 +
* 非決定性（後戻り）の導入

 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
       | let Decl in Expr
       | letrec Decl; ...; Decl in Expr
       | \ Ident -> Expr 
       | if Expr then Expr else Expr
       | amb Expr or Expr 
       | fail Expr

 Decl -> Ident = Expr

 ----------------------------------------------------------------------}

module NonDetParser where 

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

import Token
import NonDetType


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 decls expr)
		  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 "try"
		  e1 <- parseExpr
		  reserved "catch"
		  e2 <- parseExpr
		  return (Try e1 e2))
	      <|>
	      (do reserved "amb"
		  e1 <- parseExpr
		  reserved "or"
		  e2 <- parseExpr
		  return (Amb e1 e2))
	      <|>
	      (do reserved "fail"
		  e <- parseExpr
		  return (Fail 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