module ContParser where 

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

import Target
import ContType

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

コンパイラ（Continuation）

 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
       | val Decl in Expr
       | let Decls in Expr
       | \ Ident -> Expr 
       | if Expr then Expr else Expr
       | while Expr do Expr
       | begin LabeledExprSeq 
       | break | continue
       | goto Ident

 Decl -> Ident = Expr

 Decls -> Decl
        | Decls; Decl

 LabeledExprSeq -> LabeledExpr end
                 | LabeledExpr; LabeledExprSeq

 LabeledExpr -> Expr | Ident : Expr 

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

parseExpr = buildExpressionParser table parseFactor <?> "expression"

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

table = [ [ Infix (do { try (reservedOp "**"); return (op2 "**")}) AssocRight
          ]
        , [ 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 ]
        , [ Infix (do { try (reservedOp "++"); return (op2 "++")}) AssocRight
          , Infix (do { try (reservedOp ":");  return (op2 ":")})  AssocRight ]
        , (map (\ op -> Infix (do { try (reservedOp op); return (op2 op) })
                            AssocNone)
               ["==", "/=", "<", "<=", ">=", ">"])
        , [ Infix (do { try (reservedOp "&&");
                        return (\ x y -> If x y (Const (TVar "False"))) })
                   AssocRight ]
        , [ Infix (do { try (reservedOp "||");
                        return (\ x y -> If x (Const (TVar "True")) y) })
                   AssocRight ] ]

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

parseAtomic =     try (do symbol "("
                          symbol ")"
                          return (Var "()"))
              <|> parens parseExpr
              <|> (do symbol "["
                      symbol "]"
                      return (Var "[]"))
              <|> do t <- naturalOrFloat
                     return (case t of  Left i  -> Const (TLit (Int i))
                                        Right d -> Const (TLit (Frac d)))
              <|> do t <- stringLiteral
                     return (Const (TLit (Str t)))
              <|> do { t <- identifier; return (Var t) }
              <|> do reserved "let"
                     decls <- parseDecls
                     reserved "in"
                     expr  <- parseExpr
                     return (Let decls expr)
              <|> do reserved "val"
                     decl <- parseDecl
                     reserved "in"
                     expr  <- parseExpr
                     return (Val 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 "while"
                     e1 <- parseExpr
                     reserved "do"
                     e2 <- parseExpr
                     return (While e1 e2)
              <|> do reserved "begin"
                     es <- parseLabeledExprs
                     reserved "end"
                     return (Begin es)
	      <|> do reserved "try"
		     e1 <- parseExpr
                     reserved "catch"
                     e2 <- parseExpr
		     return (App (App (Var "mplus") (Delay e1)) (Delay e2))
  	      <|> do reserved "amb"
  		     e1 <- parseExpr
  		     reserved "or"
  		     e2 <- parseExpr
  		     return (App (App (Var "mplus") (Delay e1)) (Delay e2))
	      <|> do reserved "break"
		     return Break
	      <|> do reserved "continue"
		     return Continue
	      <|> do reserved "goto"
   	             id <- identifier
                     return (Goto id)

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 (TLit (Str ("parse error at " ++ show err)))
    Right x  -> x

myParseDecls :: String -> Decls
myParseDecls str = 
  case parse (do { whiteSpace; s<- parseDecls; eof; return s }) "" str of 
    Left err -> [("_", Const (TLit (Str ("parse error at " ++ show err))))]
    Right x  -> x