(* Lecture 21: Evaluation *)

(*
use "stream.sml";
use "mstream-io.sml";
use "rational.sml";
*)


signature LEXER =
sig
  datatype token =
    INTEGER of int
  | PLUS | MINUS | STAR | SLASH
  | LPAREN | RPAREN | SEMICOLON

  exception Error of string
  val lex : char MStream.stream -> token MStream.stream
end;

functor Lexer () :> LEXER =
struct
  datatype token =
    INTEGER of int
  | PLUS | MINUS | STAR | SLASH
  | LPAREN | RPAREN | SEMICOLON

  exception Error of string

  val ord0 = Char.ord(#"0")
  fun charVal (c) = Char.ord(c)-ord0

  structure S = MStream (* abbrev *)

  fun lex (s) = S.delay (fn () => lex' (S.expose s))
  and lex' (f as S.Cons (c, s)) =
      if Char.isSpace(c) (* Space, Newline, Tab, Formfeed *)
	then lex' (S.expose s)
      else if Char.isDigit(c)
	     then lexInt' (f,0)
	   else lexSym' f
    | lex' (S.Empty) = S.Empty
      (* lexSym' (f:char front)  where f not Empty *)
  and lexSym' (S.Cons(#"+",s)) = S.Cons(PLUS, lex s)
    | lexSym' (S.Cons(#"-",s)) = S.Cons(MINUS, lex s)
    | lexSym' (S.Cons(#"*",s)) = S.Cons(STAR, lex s)
    | lexSym' (S.Cons(#"/",s)) = S.Cons(SLASH, lex s)
    | lexSym' (S.Cons(#"(",s)) = S.Cons(LPAREN, lex s)
    | lexSym' (S.Cons(#")",s)) = S.Cons(RPAREN, lex s)
    | lexSym' (S.Cons(#";",s)) = S.Cons(SEMICOLON, lex s)
    | lexSym' (S.Cons(c,s)) =
        raise Error ("Illegal character: " ^ Char.toString(c))
  and lexInt' (f as S.Cons(c,s),n) =
        if Char.isDigit(c)
	  then lexInt' (S.expose s, 10*n + charVal(c))
	else S.Cons(INTEGER(n), S.delay (fn () => lex' f))
    | lexInt' (S.Empty,n) = S.Cons(INTEGER(n), S.empty)

end;  (* functor Lexer *)

signature PARSER =
sig
  structure Lexer : LEXER		(* parameter *)

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  exception Error of string

  val parse : Lexer.token MStream.stream -> exp MStream.stream
  val toString : exp -> string
end;  (* signature PARSER *)

functor Parser (structure Lexer : LEXER) :> PARSER =
struct
  structure Lexer = Lexer

  datatype exp =
    Integer of int
  | Plus of exp * exp
  | Minus of exp * exp
  | Times of exp * exp
  | Divide of exp * exp
  | Neg of exp

  exception Error of string

  (* Grammar:
     <exp> ::= <sum> SEMICOLON
     <sum> ::= <sum> PLUS <product>
             | <sum> MINUS <product>
             | <product>
     <product> ::= <product> STAR <negatom>
                 | <product> SLASH <negatom>
                 | <negatom>
     <negatom> ::= MINUS <negatom>
                 | atom
     <atom> ::= INTEGER(n)
              | LPAREN <sum> RPAREN
  *)

  (* precedence of operators *)
  type prec = int

  datatype stackItem =
    Exp of exp
  | BinOp of prec * (exp * exp -> exp)
  | UnOp of prec * (exp -> exp)

  (* Stack invariant, refinements of stackItem list *)
  (* <p> ::= nil | <pExp> | <pOp>
     <pExp> ::= Exp _ :: nil
              | Exp _ :: <pOp>
     <pOp> ::= BinOp _ :: <pExp>
             | UnOp _ :: <p>
     <pExp+> ::= Exp _ :: <pOp>
  *)

  structure S = MStream
  structure L = Lexer

  (* Enforcing stack invariant *)
  (* val shift : stackItem * <p> -> <p> *)
  fun shift (Exp _, Exp _::p') =
        raise Error ("Missing operator")
    | shift (BinOp _, BinOp _::p') =
	raise Error ("Consective infix operators")
    | shift (BinOp _, UnOp _::p') =
        raise Error ("Infix operator following prefix operator")
    | shift (BinOp _, nil) =
	raise Error ("Leading infix operator")
    | shift (opr,p) = opr::p

  (* val reduce : <pExp+> -> <p> *)
  fun reduce (Exp(e2)::BinOp(_,con)::Exp(e1)::p') =
         Exp(con(e1,e2))::p'
    | reduce (Exp(e)::UnOp(_,con)::p') = Exp(con(e))::p'
    (* no other cases should be possible by stack invariant *)

  (* val reduceAll : <p> -> exp *)
  fun reduceAll (Exp(e)::nil) = e
    | reduceAll (BinOp _::p') =
        raise Error ("Incomplete infix expression")
    | reduceAll (UnOp _::p') =
	raise Error ("Incomplete prefix expression")
    | reduceAll (nil) = raise Error ("Empty expression")
    | reduceAll (p) = reduceAll (reduce p)

  (* val parseExp : L.token front * <p> -> exp * L.token front *)
  fun parseExp (S.Cons(L.INTEGER(n), s), p) =
         parseExp (S.expose s, shift(Exp(Integer(n)),p))

    | parseExp (S.Cons(L.PLUS, s), p) =
         decideOpr (BinOp (1, Plus), s, p)
    | parseExp (S.Cons(L.MINUS, s), p as (Exp(_)::p')) =
	 (* binary minus *)
         decideOpr (BinOp (1, Minus), s, p)
    | parseExp (S.Cons(L.MINUS, s), p) =
	 (* unary minus, shift *)
	 (* p = nil  or p : <pOp> *)
	 parseExp (S.expose s, shift(UnOp(3,Neg), p))
    | parseExp (S.Cons(L.STAR, s), p) =
         decideOpr (BinOp (2, Times), s, p)
    | parseExp (S.Cons(L.SLASH, s), p) =
         decideOpr (BinOp (2, Divide), s, p)

    | parseExp (S.Cons(L.LPAREN, s), p) =
	 decideRParen (parseExp (S.expose s, nil), p)
    | parseExp (f as S.Cons(L.RPAREN, s), p) =
	 (reduceAll p, f)
    | parseExp (f as S.Cons(L.SEMICOLON, s), p) =
         (reduceAll p, f)
    | parseExp (S.Empty, p) =
	 raise Error ("Unexpected end of stream")

  and decideRParen ((e, S.Cons(L.RPAREN, s)), p) =
         parseExp (S.expose s, shift(Exp(e),p))
    | decideRParen ((e, _), _) =
	 raise Error ("Unmatched left parenthesis")

  and decideOpr (opr as BinOp (prec, _), s,
		 p as (Exp(_)::BinOp(prec',_)::Exp(_)::p')) =
        if prec > prec'
	  then parseExp (S.expose s, shift(opr,p)) (* shift *)
	else decideOpr (opr, s, reduce(p)) (* reduce *)
    | decideOpr (opr as BinOp (prec, _), s,
		 p as (Exp(_)::UnOp(prec', _)::p')) =
	if prec > prec'
	  then parseExp (S.expose s, shift(opr,p)) (* shift *)
	else decideOpr (opr, s, reduce(p)) (* reduce *)
    | decideOpr (opr, s, p) =
	parseExp (S.expose s, shift(opr,p)) (* shift *)

  (* val parse : L.token MStream.stream -> exp MStream.stream *)
  fun parse (s) =
        S.delay (fn () => parse' (S.expose s))
  and parse' (f as S.Cons _) = decideSemi (parseExp (f, nil))
    | parse' (S.Empty) = S.Empty

  and decideSemi (e, S.Cons(L.SEMICOLON, s)) =
        S.Cons(e, parse s)
    | decideSemi (e, S.Cons(L.RPAREN, s)) =
        raise Error ("Unmatched right parenthesis")
    | decideSemi (e, S.Empty) =
        raise Error ("Expression terminated by end of file")
    (* no other cases should be possible *)

  (* Convert to string with all parentheses *)
  fun toString (Integer(n)) = Int.toString (n)
    | toString (Plus(e1,e2)) =
        "(" ^ toString e1 ^ "+" ^ toString e2 ^ ")"
    | toString (Minus(e1,e2)) =
	"(" ^ toString e1 ^ "-" ^ toString e2 ^ ")"
    | toString (Times(e1,e2)) =
	"(" ^ toString e1 ^ "*" ^ toString e2 ^ ")"
    | toString (Divide(e1,e2)) =
	"(" ^ toString e1 ^ "/" ^ toString e2 ^ ")"
    | toString (Neg(e)) =
	"(" ^ "-" ^ toString e ^ ")"

end;  (* functor Parser *)

signature EVAL =
sig
  structure Parser : PARSER

  datatype value = Rational of Rat.rat
  val toString : value -> string
  val toReal : value -> real

  exception Error of string
  val eval : Parser.exp -> value
end;

functor Eval (structure Parser : PARSER) :> EVAL =
struct

  structure Parser = Parser
  structure P = Parser			(* abbreviation *)

  datatype value = Rational of Rat.rat

  exception Error of string

  fun intToString (p) =
      if p < 0 then "-" ^ Int.toString(~p) else Int.toString(p)
  fun toString' (p,1) = intToString p
    | toString' (p,q) = intToString p ^ "/" ^ intToString q
  fun toString (Rational(r)) = toString' (Rat.toInts r)
  fun toReal (Rational(r)) = Rat.toReal r

  fun eval' (P.Integer(n)) = Rat.//(n,1)
    | eval' (P.Plus(e1,e2)) = Rat.+(eval' e1, eval' e2)
    | eval' (P.Minus(e1,e2)) = Rat.-(eval' e1, eval' e2)
    | eval' (P.Times(e1,e2)) = Rat.*(eval' e1, eval' e2)
    | eval' (P.Divide(e1,e2)) = Rat./(eval' e1, eval' e2)
    | eval' (P.Neg(e)) = Rat.~(eval' e)
  fun eval (e) = (Rational (eval' e)
                  handle Div => raise Error ("Division by Zero")
		       | Overflow => raise Error ("Arithmetic Overflow"))

end;

signature TOP =
sig
  val top : unit -> unit
  val parseFile : string -> unit
end;  (* signature TOP *)

functor Top (structure MStreamIO : MSTREAM_IO
	     structure Eval : EVAL) :> TOP =
struct
  structure Parser = Eval.Parser
  structure Lexer = Parser.Lexer

  fun parseAndPrint (charStream, closeFun) =
    let
      val tokenStream = Lexer.lex charStream
      val expStream = Parser.parse tokenStream
      fun loop (s) = loop' (MStream.expose s)
      and loop' (MStream.Cons(e,s)) =
	  let val _ = print (Parser.toString (e) ^ " >=> ")
	      val v = Eval.eval e
	      val _ = print (Eval.toString v ^ " [approx "
			     ^ Real.toString (Eval.toReal v) 
			     ^ "]\n")
	  in loop (s) end
	| loop' (MStream.Empty) = ()
    in
      ( loop (expStream)
        handle Lexer.Error (msg) =>
	         print ("Lexing Error: " ^ msg ^ "\n")
	     | Parser.Error (msg) =>
		 print ("Parsing Error: " ^ msg ^ "\n")
             | Eval.Error (msg) =>
		 print ("Evaluation Error: " ^ msg ^ "\n")
	     | exn => ( print ("Unrecognized Error\n") ;
		        closeFun () ; raise exn ) ;
        closeFun () )
    end

  fun top () = parseAndPrint (MStreamIO.readTerminal "# ",
			      fn () => ())

  fun parseFile (fileName) =
        parseAndPrint (MStreamIO.readFile (fileName))

end;  (* functor Top *)

structure Lexer :> LEXER = Lexer ();

structure Parser :> PARSER =
  Parser (structure Lexer = Lexer);

structure Eval :> EVAL =
  Eval (structure Parser = Parser);

structure Top :> TOP =
  Top (structure MStreamIO = MStreamIO
       structure Eval = Eval);

(*
MLWorks> Top.top ();
# 2/6;
(2/6) >=> 1/3 [approx 0.333333333333]
# 3+5*8/3;
(3+((5*8)/3)) >=> 49/3 [approx 16.3333333333]
# 3-4-5;
((3-4)-5) >=> -6 [approx ~6.0]
# ;
Parsing Error: Empty expression
val it : unit = ()
MLWorks> 
*)