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
                }
  ;
}