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

インタプリタ

* 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 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