module STParser where 

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

import Token
import STType

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 "getX"
                  return GetX)          
              <|>
              (do reserved "setY"
                  e <- parseExpr
                  return (SetY e))
              <|>
              (do reserved "getY"
                  return GetY)          
              <|>
              (do reserved "while"
                  e1 <- parseExpr
                  reserved "do"
                  e2 <- parseExpr
                  return (While e1 e2))
              <|>
              (do reserved "begin"
                  es <- parseExprs
                  reserved "end"
                  return (Begin es))


parseExprs = sepBy1 parseExpr semi

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