module Parser where

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

import Target
import ParserCommon
import Expr

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

コンパイラ（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 | Expr . Ident
       | Expr Expr
       | Const
       | ( Expr )
       | Ident
       | val Decl in Expr
       | let Decls in Expr
       | letGlobal Decls in Expr  -- global mutable state
       | letLocal  Decls in Expr  -- local mutable state
       | begin Exprs end
       | \ Ident -> Expr
       | if Expr then Expr else Expr
       | while Expr do Expr
       | try Expr catch Expr
       | amb Expr or Expr
       | begin LabeledExprSeq
       | break | continue
       | goto Ident

 Exprs -> Expr
        | Exprs; Expr

 Decl  -> Ident = Expr

 Decls -> Decl
        | Decls; Decl

 Bind  -> Ident <- Expr

 Binds -> Bind
        | Binds; Bind

 LabeledExprSeq -> LabeledExpr end
                 | LabeledExpr; LabeledExprSeq

 LabeledExpr -> Expr | Ident : Expr

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

parseExpr = buildExpressionParser table parseFactor <?> "expression"

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

table = [ [ Infix (do { try (reservedOp ".");  return (op2 ".")})  AssocRight
          , Infix (do { try (reservedOp "!!"); return (op2 "!!")}) AssocLeft  ]
        , [ Prefix (do { try (reservedOp "&"); return (op1 "&")})             ]
        , [ Infix (do { try (reservedOp "**"); return (op2 "**")}) AssocRight
          , Infix (do { try (reservedOp "^^"); return (op2 "^^")}) AssocRight
          , 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 ]
        , [ Infix (do { try (reservedOp "$");  return (op2 "$")})  AssocRight ]
        , [ Infix (do { try (reservedOp ":="); return (op2 ":=")}) AssocRight ]
        ]

listLiteral []     = Var "[]"
listLiteral (x:xs) = op2 ":" x (listLiteral xs)

tupleLiteral []  = Var "()"
tupleLiteral [x] = x
tupleLiteral [x,y] = App (App (Var "(,)") x) y
-- tupleLiteral [x,y,z] = App (App (App (Var "triple") x) y) z
tupleLiteral xs  = let n    = length xs
                       name = mkTupleCon n
                     in foldl App (Var name) xs  

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

parseAtomic =     try (do symbol "("
                          es <- parseExpr `sepBy` symbol ","
                          symbol ")"
                          return (tupleLiteral es))
              <|> do symbol "["
                     es <- parseExpr `sepBy` symbol ","
                     symbol "]"
                     return (listLiteral es)
              <|> 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 "letGlobal"
                     decls <- parseDecls
                     reserved "in"
                     expr  <- parseExpr
                     return (LetGlobal decls expr)
              <|> do reserved "letLocal"
                     decls <- parseDecls
                     reserved "in"
                     expr  <- parseExpr
                     return (LetLocal decls expr)
              <|> do reserved "val"
                     binds <- parseBinds
                     reserved "in"
                     expr  <- parseExpr
                     return (foldr Val expr binds)
              <|> 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 <- 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
                     es1 <- many1 (do reserved "or"
                                      parseExpr)
                     return $ foldr1 (\ x y -> App (App (Var "mplus") (Delay x)) (Delay y)) (e1:es1)
              <|> 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
               ids <- many identifier
               reservedOp "="
               e <- parseExpr
               return (i, foldr Lambda e ids)

parseBinds = sepBy1 parseBind semi
parseBind  = do i <- identifier
                (reservedOp "<-" <|> reservedOp "=") -- for backward compatibility
                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 -> (PImports, Decls)
myParseDecls str =
  case parse (do { whiteSpace; is <- parsePImports; ds<- parseDecls; eof; return (is, ds) }) "" str of
    Left err -> ([], [("_", Const (TLit (Str ("parse error at " ++ show err))))])
    Right x  -> x