module CatchParser where

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

import Target
import RecType

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

コンパイラ（Err + エラー処理（catch））

 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
       | begin Exprs end
       | \ Ident -> Expr
       | if Expr then Expr else Expr
       | try Expr catch Expr
       | amb Expr or Expr

 Exprs -> Expr
        | Expr; Exprs

 Decl  -> Ident = Expr

 Decls -> Decl
        | Decls; Decl

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

parseExpr = buildExpressionParser table parseFactor <?> "expression"

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

table = [ [ Infix (do { try (reservedOp "==="); return (op2 "===")}) AssocNone
          ]
        , [ 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 "\\"
                     ids <- many1 identifier
                     reservedOp "->"
                     e <- parseExpr
                     return $ foldr Lambda e ids
              <|> 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 <- parseExprs
                     reserved "end"
                     return (Begin es)
              <|> do reserved "try"
                     e1 <- parseExpr
                     es1 <- many1 (do reserved "catch"
                                      parseExpr)
                     let es = map Delay (e1:es1)
                     return $ foldr1 (\ x y -> App (App (Var "mplus") x) y) es
              <|> do reserved "amb"
                     e1 <- parseExpr
                     es1 <- many1 (do reserved "or"
                                      parseExpr)
                     let es = map Delay (e1:es1)
                     return $ foldr1 (\ x y -> App (App (Var "mplus") x) y) es

parseExprs = sepBy1 parseExpr semi

parseDecls = sepBy1 parseDecl semi

parseDecl = do i <- identifier
               ids <- many identifier
               reservedOp "="
               e <- parseExpr
               return (i, foldr Lambda e ids)

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