(*
 * a3.sml
 *
 * CSE3322 Programming Languages and Implementation, 2006,
 * B. Computer Science, B. Software Engineering, B. Science (Computer Science),
 * Faculty of Information Technology,
 * Monash University, Australia 3800
 *
 * Assignment 3 sample solution
 *
 * Cameron McCormack <cam of mcc.id.au>
 *
 * Revision 1: October 13, 2006
 *   Fixed associativity of binary operators.
 *
 * Initial version: September 21, 2006
 *)

(* -- switch code based on SMLNJ version -- *)

(* older: *)
(*
val newerSMLNJ = false;
fun inputLine f = TextIO.inputLine f;
*)

(* newer: *)
val newerSMLNJ = true;
fun inputLine f = case TextIO.inputLine f of
                      SOME s => s
                    | _      => "";

(* ---------------------------------------- *)

(* -- Q2 --

   Cmd -> IDENT ASSIGN Exp
   Cmd -> IF Exp THEN Cmd Else
   Cmd -> WHILE Exp DO Cmd
   Cmd -> BEGIN Cmds END
   Cmd -> READ Identifier
   Cmd -> PRINT Printed

   Else -> ELSE Cmd
   Else ->

   Printed -> STRING
   Printed -> Exp

   Cmds -> Cmd MoreCmds
   
   MoreCmds -> SEMICOLON Cmds
   MoreCmds ->

   ArithExp -> Term ArithExp'
   
   ArithExp' -> PlusMinus Term ArithExp'
   ArithExp' ->

   Term -> Factor Term'

   Term' -> TIMES Factor Term'
   Term' ->

   Factor -> MINUS Factor
   Factor -> LPAREN Exp RPAREN
   Factor -> IDENT
   Factor -> BIGINT

   PlusMinus -> PLUS
   PlusMinus -> MINUS

   RelExp -> ArithExp RelExp'

   RelExp' -> Comparison ArithExp
   RelExp' ->

   Comparison -> EQ
   Comparison -> NE
   Comparison -> LT
   Comparison -> LE
   Comparison -> GT
   Comparison -> GE

   Exp -> Conj Exp'

   Exp' -> OR Conj Exp'
   Exp' ->

   Conj -> Bterm Conj'

   Conj' -> AND Bterm Conj'
   Conj' ->

   Bterm -> NOT Bterm
   Bterm -> RelExp
*)

use "bil-lex.lex.sml";

open BILLex.UserDeclarations;

(* -- Q3 -- *)

datatype UnaryOp = UnaryMinus | Not;

datatype BinaryOp = Plus | Minus | Times
                  | Eq | Ne | Lt | Le | Gt | Ge 
                  | And | Or;

datatype Expression = Unary of UnaryOp * Expression
                    | Binary of BinaryOp * Expression * Expression
                    | Ident of string
                    | BigInt of string;

datatype Command = Assignment of string * Expression
                 | IfThen of Expression * Command
                 | IfThenElse of Expression * Command * Command
                 | While of Expression * Command
                 | Block of Command list
                 | Read of string
                 | PrintString of string
                 | Print of Expression;

(* takes an initial Expression tree and a list of (BinaryOp, Expression) tuples
   and returns a left-associated Expression tree of the whole thing *)
fun mkTree t []             = t
  | mkTree t ((bop, u)::ts) = mkTree (Binary (bop, t, u)) ts

(* returns whether the specified token is PLUS or MINUS *)
and isPM PLUS  = true
  | isPM MINUS = true
  | isPM _     = false

(* returns whether the specified token is one of the relational operator
   tokens *)
and isRelOp EQ = true
  | isRelOp NE = true
  | isRelOp LT = true
  | isRelOp LE = true
  | isRelOp GT = true
  | isRelOp GE = true
  | isRelOp _  = false

(* turns a binary operator token into the corresponding BinaryOp value *)
and bTokOp PLUS  = Plus
  | bTokOp MINUS = Minus
  | bTokOp EQ    = Eq
  | bTokOp NE    = Ne
  | bTokOp LT    = Lt
  | bTokOp LE    = Le
  | bTokOp GT    = Gt
  | bTokOp GE    = Ge

and Cmd ((IDENT id)::ASSIGN::rest) =  (* Cmd -> IDENT ASSIGN Exp *)
      let
        val (exp, rest1) = Exp rest;
      in
        (Assignment (id, exp), rest1)
      end
  | Cmd (IF::rest) =  (* Cmd -> IF Exp THEN Cmd | IF Exp THEN Cmd ELSE Cmd *)
      let
        val (cond, (THEN::rest1)) = Exp rest;
        val (yes, rest2) = Cmd rest1;
      in
        case rest2 of
            (ELSE::rest3) => let
                               val (no, rest4) = Cmd rest3
                             in
                               (IfThenElse (cond, yes, no), rest4)
                             end
          | _             => (IfThen (cond, yes), rest2)
      end
  | Cmd (WHILE::rest) =  (* Cmd -> WHILE Exp DO Cmd *)
      let
        val (cond, (DO::rest1)) = Exp rest;
        val (cmd, rest2) = Cmd rest1;
      in
        (While (cond, cmd), rest2)
      end
  | Cmd (BEGIN::rest) =  (* Cmd -> BEGIN Cmds END *)
      let
        val (cmds, (END::rest1)) = Cmds rest;
      in
        (Block cmds, rest1)
      end
  | Cmd (READ::(IDENT id)::rest) = (Read id, rest)  (* Cmd -> READ Identifier *)
  | Cmd (PRINT::(STRING s)::rest) = (PrintString s, rest)  (* Cmd -> PRINT STRING *)
  | Cmd (PRINT::rest) =  (* Cmd -> PRINT Exp *)
      let
        val (exp, rest1) = Exp rest
      in
        (Print exp, rest1)
      end

and Cmds rest =  (* Cmds -> Cmd SEMICOLON Cmds | Cmd *)
      let
        val (cmd, rest1) = Cmd rest;
      in
        case rest1 of
            (SEMICOLON::rest2) => let
                                    val (cmds, rest3) = Cmds rest2;
                                  in
                                    (cmd::cmds, rest3)
                                  end
          | _                  => ([cmd], rest1)
      end

and ArithExp rest =  (* ArithExp -> Term ArithExp' *)
      let
        val (term, rest1) = Term rest;
        val (terms, rest2) = ArithExp' [] rest1;
      in
        (mkTree term terms, rest2)
      end

and ArithExp' terms (rest0 as (tok::rest)) =  (* ArithExp' -> PlusMinus Term ArithExp' | <nothing> *)
      if isPM tok then
        let
          val (term, rest1) = Term rest;
        in
          ArithExp' ((bTokOp tok, term)::terms) rest1
        end
      else
        (terms, rest0)

and Term rest =  (* Term -> Factor Term' *)
      let
        val (factor, rest1) = Factor rest;
        val (factors, rest2) = Term' [] rest1;
      in
        (mkTree factor factors, rest2)
      end

and Term' factors (TIMES::rest) =  (* Term' -> TIMES Factor Term' *)
      let
        val (factor, rest1) = Factor rest;
      in
        Term' ((Times, factor)::factors) rest1
      end
  | Term' factors rest = (factors, rest)  (* Term' -> <nothing> *)

and Factor (MINUS::rest) =  (* Factor -> MINUS Factor *)
      let
        val (factor, rest1) = Factor rest;
      in
        (Unary (UnaryMinus, factor), rest1)
      end
  | Factor (LPAREN::rest) =  (* Factor -> LPAREN Exp RPAREN *)
      let
        val (exp, (RPAREN::rest1)) = Exp rest;
      in
        (exp, rest1)
      end
  | Factor ((IDENT id)::rest) = (Ident id, rest)  (* Factor -> IDENT *)
  | Factor ((BIGINT i)::rest) = (BigInt i, rest)  (* Factor -> BIGINT *)

and RelExp rest =  (* RelExp -> ArithExp RelExp' *)
      let
        val (arithExp, rest1) = ArithExp rest;
      in
        RelExp' arithExp rest1
      end

and RelExp' arithExp (rest0 as (tok::rest)) =  (* RelExp' Comparison ArithExp | <nothing> *)
      if isRelOp tok then
        let
          val (arithExp', rest1) = ArithExp rest;
        in
          (Binary (bTokOp tok, arithExp, arithExp'), rest1)
        end
      else
        (arithExp, rest0)

and Exp rest =  (* Exp -> Conj Exp' *)
      let
        val (conj, rest1) = Conj rest;
        val (conjs, rest2) = Exp' [] rest1;
      in
        (mkTree conj conjs, rest2)
      end

and Exp' conjs (OR::rest) =  (* Exp' -> OR Exp *)
      let
        val (conj, rest1) = Conj rest;
      in
        Exp' ((Or, conj)::conjs) rest1
      end
  | Exp' conjs rest = (conjs, rest)  (* Exp' -> <nothing> *)

and Conj rest =  (* Conj -> Bterm Conj' *)
      let
        val (bterm, rest1) = Bterm rest;
        val (bterms, rest2) = Conj' [] rest1;
      in
        (mkTree bterm bterms, rest2)
      end

and Conj' bterms (AND::rest) =  (* Conj' -> AND Bterm *)
      let
        val (bterm, rest1) = Bterm rest;
      in
        Conj' ((And, bterm)::bterms) rest1
      end
  | Conj' bterms rest = (bterms, rest)  (* Conj' -> <nothing> *)

and Bterm (NOT::rest) =  (* Bterm -> NOT Bterm *)
      let
        val (bterm, rest1) = Bterm rest;
      in
        (Unary (Not, bterm), rest1)
      end
  | Bterm rest = RelExp rest;  (* Bterm -> RelExp *)

(* parser driver, takes a filename and returns a Cmd *)
fun parse filename =
      let
        val f = TextIO.openIn filename;
        val l = BILLex.makeLexer (fn _ => inputLine f);

        fun allTokens () =
            case l () of
                EOF => [EOF]
              | tok => tok::(allTokens ())

        val (cmd, [EOF]) = Cmd (allTokens ());
      in
        cmd
      end;

(* -- Q4 -- *)

(* returns boilerplate header text *)
fun header filename = concat (map (fn s => s ^ "\n") [
"(* Generated from " ^ filename ^ " *)",
"",
"use \"../a1.sml\";",
"val zero = fromInt 0;",
"",
"fun set env n v =",
"      let",
"        fun set' []                    = [(n, v)]",
"          | set' ((e as (nm, va))::es) = if nm = n then (nm, v)::es",
"                                                   else e::(set' es);",
"      in",
"        set' env",
"      end;",
"",
"fun get []             n = zero",
"  | get ((nm, va)::es) n = if nm = n then va else get es n;",
"",
if newerSMLNJ then "fun inputLine f = case TextIO.inputLine f of SOME s => s | _ => \"\";"
              else "fun inputLine f = TextIO.inputLine f;",
"",
"fun toBool (Pos [0]) = false",
"  | toBool _         = true;",
"",
"fun fromBool true  = fromInt 1",
"  | fromBool false = zero;",
"",
"fun bigNot x   = fromBool (not (toBool x));",
"",
"fun bigAnd x y = fromBool ((toBool x) andalso (toBool y));",
"fun bigOr  x y = fromBool ((toBool x) orelse  (toBool y));",
"",
"fun bigEq  x y = fromBool ((compare x y) = EQUAL);",
"fun bigNe  x y = fromBool ((compare x y) <> EQUAL);",
"fun bigLt  x y = fromBool ((compare x y) = LESS);",
"fun bigLe  x y = fromBool ((compare x y) <> GREATER);",
"fun bigGt  x y = fromBool ((compare x y) = GREATER);",
"fun bigGe  x y = fromBool ((compare x y) <> LESS);",
"",
"fun printStr e s = (print (s ^ \"\\n\"); e);",
"fun printVal e x = (print ((toString 10 x) ^ \"\\n\"); e);",
"",
"fun chomp s = implode (List.filter (fn c => c <> #\"\\n\") (explode s));",
"",
"fun readVal () = fromString (chomp (inputLine TextIO.stdIn));",
"",
"fun program e ="
]) ^ "      ";

(* returns boilerplate footer text *)
fun footer () = ";\n\n(program []; ())\n";

(* returns a string comprising the specified number of spaces *)
fun ind 0 = ""
  | ind n = " " ^ (ind (n - 1));

(* translates a command, d is the indenting depth to use *)
fun tc d (Assignment (n, e))    = "set e \"" ^ n ^ "\" " ^ te e
  | tc d (Read n)               = "set e \"" ^ n ^ "\" (readVal ())"
  | tc d (PrintString s)        = "printStr e " ^ s
  | tc d (Print e)              = "printVal e " ^ te e
  | tc d (IfThen (e, t))        = "\n"
                                    ^ ind (d + 4) ^ "if toBool " ^ te e ^ " then\n"
                                    ^ ind (d + 6) ^ tc (d + 2) t ^ "\n"
                                    ^ ind (d + 4) ^ "else\n"
                                    ^ ind (d + 6) ^ "e"
  | tc d (IfThenElse (e, t, f)) = "\n"
                                    ^ ind (d + 4) ^ "if toBool " ^ te e ^ " then\n"
                                    ^ ind (d + 6) ^ tc (d + 2) t ^ "\n"
                                    ^ ind (d + 4) ^ "else\n"
                                    ^ ind (d + 6) ^ tc (d + 2) f
  | tc d (Block cs)             = "let\n"
                                    ^ concat (map (fn x => (ind (d + 2)) ^ "val e = " ^ tc (d + 2) x ^ ";\n") cs)
                                    ^ ind d ^ "in\n"
                                    ^ ind (d + 2) ^ "e\n"
                                    ^ ind d ^ "end"
  | tc d (While (e, c))         = "\n"
                                    ^ ind (d + 4) ^ "let\n"
                                    ^ ind (d + 6) ^ "fun f e =\n"
                                    ^ ind (d + 10) ^ "if not (toBool " ^ te e ^ ") then e else f\n"
                                    ^ ind (d + 12) ^ tc (d + 12) c ^ "\n"
                                    ^ ind (d + 4) ^ "in\n"
                                    ^ ind (d + 6) ^ "f e\n"
                                    ^ ind (d + 4) ^ "end"

(* translates an expression *)
and te (BigInt i)               = "(fromString \"" ^ i ^ "\")"
  | te (Ident n)                = "(get e \"" ^ n ^ "\")"
  | te (Unary (uop, e))         = "(" ^ tu uop ^ " " ^ te e ^ ")"
  | te (Binary (bop, e1, e2))   = "(" ^ tb bop ^ " " ^ te e1 ^ " " ^ te e2 ^ ")"

(* translates a unary operator *)
and tu UnaryMinus               = "negate"
  | tu Not                      = "bigNot"

(* translates a binary operator *)
and tb And                      = "bigAnd"
  | tb Or                       = "bigOr"
  | tb Plus                     = "plus"
  | tb Minus                    = "minus"
  | tb Times                    = "times"
  | tb Eq                       = "bigEq"
  | tb Ne                       = "bigNe"
  | tb Lt                       = "bigLt"
  | tb Le                       = "bigLe"
  | tb Gt                       = "bigGt"
  | tb Ge                       = "bigGe";

(* translater driver *)
fun translate () =
      let
        (* strips newlines from the specified string *)
        fun chomp s = implode (List.filter (fn c => c <> #"\n") (explode s));

        val _ = print "type file-name of a BIL program, e.g., p.bil:\n";
        val filename = chomp (inputLine TextIO.stdIn);
        val cmd = parse filename;
        val out = TextIO.openOut "obj.sml";
      in
        (print (filename ^ " is syntactically valid\ncreating obj.sml\n");
         TextIO.output (out, header filename  ^ tc 6 cmd ^ footer ());
         TextIO.closeOut out)
      end;