(* Lecture 20: Parsing *)

(*
use "/afs/andrew/scs/cs/15-212-X/code/stream.sml";
use "/afs/andrew/scs/cs/15-212-X/code/rational.sml";
*)

signature MSTREAM_IO =
sig
  val readTerminal : string -> char MStream.stream
  (* readFile (fileName) >=> (charStream, closeFun) *)
  (* closeFun should be called to close the input stream *)
  (* only if the end of the file is never reached *)
  val readFile : string -> char MStream.stream * (unit -> unit)
end;

structure MStreamIO :> MSTREAM_IO =
struct

  fun fromLine f nil = MStream.delay f
    | fromLine f (c::cs) = MStream.cons (c, fromLine f cs)

  fun readTerminal (prompt) =
      let
	fun getLine () =
	   ( TextIO.output (TextIO.stdOut, prompt) ;
	     TextIO.flushOut (TextIO.stdOut) ;
	     if TextIO.endOfStream TextIO.stdIn
	       then MStream.Empty
	     else
	       MStream.expose
	       (fromLine getLine 
		(String.explode (TextIO.inputLine TextIO.stdIn)))
	   )
      in
	MStream.delay getLine
      end

  fun readFile (fileName) =
      let
	val instream = TextIO.openIn fileName
        fun getLine () =
               if TextIO.endOfStream instream
		 then ( TextIO.closeIn instream ; MStream.Empty )
	       else
                 MStream.expose
		 (fromLine getLine
		  (String.explode (TextIO.inputLine instream)))
      in
	 (MStream.delay getLine, (fn () => TextIO.closeIn instream))
      end
end;  (* structure MStreamIO *)

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 toReal : exp -> real
  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 () => decideSemi(parseExp(S.expose s, nil)))

  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 a value to a floating point number *)
  fun toReal (Integer(n)) = real (n)
    | toReal (Neg(e)) = ~(toReal(e))
    | toReal (Divide(e1,e2)) = toReal(e1)/toReal(e2)

  (* 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
  val eval : Parser.exp -> Parser.exp
end;

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

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

  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 fromInt (p) = if p >= 0 then P.Integer(p)
		    else P.Neg(P.Integer(~p))
  fun fromRat (p,q) = P.Divide(fromInt(p),fromInt(q))
  fun eval e = fromRat (Rat.toInts (eval' e))
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 (Parser.toString v ^ " [approx "
			     ^ Real.toString (Parser.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")
	     | Overflow => print ("Arithmetic Overflow\n")
	     | Div => print ("Division by Zero\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)/1) [approx ~6.0]
# ;
Parsing Error: Empty expression
val it : unit = ()
MLWorks> 
*)