interpreterFinal.ml

type name = string

type term =
  (* lambda calculus *)
  | Name  of name
  | Fun   of name * name * term
  | App   of term * term
  (* extensions *)
  | Ifgz  of term * term * term
  | LetIn of name * term * term
  | Unit
  | Int   of int
  | Add   of term * term
  | Sub   of term * term
  | Mul   of term * term
  | Div   of term * term
  | Trace of term

type value =
  | IntVal of int
  | FunVal of name * name * term * env
  | UnitVal

and env = (string * value) list

type error =
  | TypeError
  | DivByZeroError
  | UnboundError

type result =
  | Value of value
  | Error of error

let string_of_value v =
  match v with
  | IntVal n -> string_of_int n
  | FunVal _ -> "<fun>"
  | UnitVal  -> "()"

let string_of_error err =
  match err with
  | TypeError      -> "TypeError"
  | DivByZeroError -> "DivByZeroError"
  | UnboundError   -> "UnboundError"

let string_of_result res =
  match res with
  | Value v -> string_of_value v
  | Error err -> string_of_error err

let string_of_log log = 
  let log =
    (List.fold_left 
       (fun acc log -> 
          if acc = ""
          then log
          else log ^ "; " ^ acc )
       "" log)
  in
  "[" ^ log ^ "]"

let string_of_env env =
  (List.fold_left
     (fun acc (s, v) ->
        if acc = "" 
        then s ^ ":=" ^ (string_of_value v)
        else s ^ ":=" ^ (string_of_value v) ^ "; " ^ acc))
    "" env

let rec string_of_term t =
  match t with
  | Name x -> x
  | Fun (fn, arg, e) -> 
    "Fun (" ^ fn ^ ", " ^ arg ^ ", " ^ (string_of_term e) ^ ")"
  | App (e1, e2) -> 
    "App (" ^ (string_of_term e1) ^ ", " ^ (string_of_term e2) ^ ")"
  (* extensions *)
  | Ifgz (cond, e1, e2) ->
    let cond = string_of_term cond in
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "Ifgz (" ^ cond ^ ", " ^ e1 ^ ", " ^ e2 ^ ")"
  | LetIn (x, e1, e2) ->
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "LetIn (" ^ x ^ ", " ^ e1 ^ ", " ^ e2 ^ ")"
  | Unit -> "Unit"
  | Int n -> "Int (" ^ (string_of_int n) ^ ")"
  | Add (e1, e2) ->
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "Add (" ^ e1 ^ ", " ^ e2 ^ ")"
  | Sub (e1, e2) ->
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "Sub (" ^ e1 ^ ", " ^ e2 ^ ")"
  | Mul (e1, e2) ->
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "Mul (" ^ e1 ^ ", " ^ e2 ^ ")"
  | Div (e1, e2) ->
    let e1 = string_of_term e1 in
    let e2 = string_of_term e2 in
    "Div (" ^ e1 ^ ", " ^ e2 ^ ")"
  | Trace e ->
    "Trace (" ^ (string_of_term e) ^ ")"


let rec interp env t log = 
  match t with
  | Name n -> (
      match List.assoc_opt n env with
      | Some v -> (Value v, log)
      | None -> 
        let _ = print_endline n in
        (Error UnboundError, log))
  | Fun (fn, arg, bod) -> (Value (FunVal (fn, arg, bod, env)), log)
  | App (f, a) -> (
      match interp env f log with
      | (Value (FunVal (fn, arg, e, env')), log) -> (
          match interp env a log with
          | (Value v, log) -> 
            let env' = (fn, FunVal (fn, arg, e, env')) :: env' in
            let env' = (arg, v) :: env' in
            interp env' e log
          | (error, log) -> (error, log))
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | Ifgz (cond, e1, e2) -> (
      match interp env cond log with
      | (Value (IntVal n), log) -> 
        if n > 0
        then interp env e1 log 
        else interp env e2 log
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | LetIn (name, e1, e2) -> (
      match interp env e1 log with
      | (Value v, log) -> interp ((name, v) :: env) e2 log
      | (error, log) -> (error, log))
  | Unit -> (Value UnitVal, log)
  | Int n -> (Value (IntVal n), log)
  | Add (e1, e2) -> (
      match interp env e1 log with
      | (Value (IntVal v1), log) -> (
          match interp env e2 log with
          | (Value (IntVal v2), log) -> (Value (IntVal (v1 + v2)), log)
          | (Value _, log) -> (Error TypeError, log)
          | (error, log) -> (error, log))
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | Sub (e1, e2) -> (
      match interp env e1 log with
      | (Value (IntVal v1), log) -> (
          match interp env e2 log with
          | (Value (IntVal v2), log) -> (Value (IntVal (v1 - v2)), log)
          | (Value _, log) -> (Error TypeError, log)
          | (error, log) -> (error, log))
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | Mul (e1, e2) -> (
      match interp env e1 log with
      | (Value (IntVal v1), log) -> (
          match interp env e2 log with
          | (Value (IntVal v2), log) -> (Value (IntVal (v1 * v2)), log)
          | (Value _, log) -> (Error TypeError, log)
          | (error, log) -> (error, log))
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | Div (e1, e2) -> (
      match interp env e1 log with
      | (Value (IntVal v1), log) -> (
          match interp env e2 log with
          | (Value (IntVal 0), log) -> (Error DivByZeroError, log)
          | (Value (IntVal v2), log) -> (Value (IntVal (v1 / v2)), log)
          | (Value _, log) -> (Error TypeError, log)
          | (error, log) -> (error, log))
      | (Value _, log) -> (Error TypeError, log)
      | (error, log) -> (error, log))
  | Trace e -> (
      match interp env e log with
      | (Value v, log) -> (Value UnitVal, string_of_value v :: log)
      | (error, log) -> (error, log))

let run e = 
  let res, log = interp [] e [] in
  match res with
  | Value v -> (string_of_value v, log)
  | Error _ -> ("Error", [])

(* parser for term language *)

(* util functions *)

let is_lower_case c =
  'a' <= c && c <= 'z'

let is_upper_case c =
  'A' <= c && c <= 'Z'

let is_alpha c =
  is_lower_case c || is_upper_case c

let is_digit c =
  '0' <= c && c <= '9'

let is_alphanum c =
  is_lower_case c ||
  is_upper_case c ||
  is_digit c

let is_blank c =
  String.contains " \012\n\r\t" c

let explode s =
  List.of_seq (String.to_seq s)

let implode ls =
  String.of_seq (List.to_seq ls)

let readlines (file : string) : string =
  let fp = open_in file in
  let rec loop () =
    match input_line fp with
    | s -> s ^ "\n" ^ (loop ())
    | exception End_of_file -> ""
  in
  let res = loop () in
  let () = close_in fp in
  res


type 'a parser = char list -> ('a * char list) option

let parse (p : 'a parser) (s : string) : ('a * char list) option =
  p (explode s)

let pure (x : 'a) : 'a parser =
  fun ls -> Some (x, ls)

let fail : 'a parser = fun ls -> None

let bind (p : 'a parser) (q : 'a -> 'b parser) : 'b parser =
  fun ls ->
  match p ls with
  | Some (a, ls) -> q a ls
  | None -> None

let (>>=) = bind
let (let*) = bind

let read : char parser =
  fun ls ->
  match ls with
  | x :: ls -> Some (x, ls)
  | _ -> None

let satisfy (f : char -> bool) : char parser =
  fun ls ->
  match ls with
  | x :: ls ->
    if f x then Some (x, ls)
    else None
  | _ -> None

let char (c : char) : char parser =
  satisfy (fun x -> x = c)

let seq (p1 : 'a parser) (p2 : 'b parser) : 'b parser =
  fun ls ->
  match p1 ls with
  | Some (_, ls) -> p2 ls
  | None -> None

let (>>) = seq

let seq' (p1 : 'a parser) (p2 : 'b parser) : 'a parser =
  fun ls ->
  match p1 ls with
  | Some (x, ls) ->
    (match p2 ls with
     | Some (_, ls) -> Some (x, ls)
     | None -> None)
  | None -> None

let (<<) = seq'

let alt (p1 : 'a parser) (p2 : 'a parser) : 'a parser =
  fun ls ->
  match p1 ls with
  | Some (x, ls)  -> Some (x, ls)
  | None -> p2 ls

let (<|>) = alt

let map (p : 'a parser) (f : 'a -> 'b) : 'b parser =
  fun ls ->
  match p ls with
  | Some (a, ls) -> Some (f a, ls)
  | None -> None

let (>|=) = map

let (>|) = fun p c -> map p (fun _ -> c)

let rec many (p : 'a parser) : ('a list) parser =
  fun ls ->
  match p ls with
  | Some (x, ls) ->
    (match many p ls with
     | Some (xs, ls) -> Some (x :: xs, ls)
     | None -> Some (x :: [], ls))
  | None -> Some ([], ls)

let rec many1 (p : 'a parser) : ('a list) parser =
  fun ls ->
  match p ls with
  | Some (x, ls) ->
    (match many p ls with
     | Some (xs, ls) -> Some (x :: xs, ls)
     | None -> Some (x :: [], ls))
  | None -> None

let rec many' (p : unit -> 'a parser) : ('a list) parser =
  fun ls ->
  match p () ls with
  | Some (x, ls) ->
    (match many' p ls with
     | Some (xs, ls) -> Some (x :: xs, ls)
     | None -> Some (x :: [], ls))
  | None -> Some ([], ls)

let rec many1' (p : unit -> 'a parser) : ('a list) parser =
  fun ls ->
  match p () ls with
  | Some (x, ls) ->
    (match many' p ls with
     | Some (xs, ls) -> Some (x :: xs, ls)
     | None -> Some (x :: [], ls))
  | None -> None

let whitespace : unit parser =
  fun ls ->
  match ls with
  | c :: ls ->
    if String.contains " \012\n\r\t" c
    then Some ((), ls)
    else None
  | _ -> None

let ws : unit parser =
  (many whitespace) >| ()

let ws1 : unit parser =
  (many1 whitespace) >| ()

let digit : char parser =
  satisfy is_digit

let natural : int parser =
  fun ls ->
  match many1 digit ls with
  | Some (xs, ls) ->
    Some (int_of_string (implode xs), ls)
  | _ -> None

let literal (s : string) : unit parser =
  fun ls ->
  let cs = explode s in
  let rec loop cs ls =
    match cs, ls with
    | [], _ -> Some ((), ls)
    | c :: cs, x :: xs ->
      if x = c
      then loop cs xs
      else None
    | _ -> None
  in loop cs ls

let keyword (s : string) : unit parser =
  (literal s) >> ws >| ()


let reserved = [
  "fun";
  "if";
  "then";
  "else";
  "let";
  "rec";
  "in";
  "trace";
  "main";
]

let name : string parser =
  let* xs1 = many1 (satisfy (fun c -> is_alpha c || c = '_')) in
  let* xs2 = 
    many (satisfy (fun c ->
        is_alphanum c ||
        (c = '_') ||
        (c = '\'')))
  in
  let s = (implode xs1) ^ (implode xs2) in
  if List.exists (fun x -> x = s) reserved
  then fail
  else pure s << ws

let name_parser () =
  let* n = name in
  pure (Name n)

let unit_parser () =
  let* _ = keyword "()" in
  pure (Unit)

let int_parser () =
  let* n = natural in
  pure (Int n) << ws

let rec term_parser0 () =
  let* _ = pure () in
  (name_parser ()) <|>
  (unit_parser ()) <|>
  (int_parser ()) <|>
  (keyword "(" >> term_parser () << keyword ")")

and term_parser1 () =
  let* es = many1 (term_parser0 ()) in
  match es with
  | e :: es ->
    pure (List.fold_left (fun acc e -> App (acc, e)) e es)
  | _ -> fail

and term_parser2 () =
  let* e = term_parser1 () in
  let opr () = 
    (let* _ = keyword "*" in
     let* e = term_parser1 () in
     pure ((fun e1 e2 -> Mul (e1, e2)), e))
    <|>
    (let* _ = keyword "/" in
     let* e = term_parser1 () in
     pure ((fun e1 e2 -> Div (e1, e2)), e))
  in
  let* es = many (opr ()) in
  pure (List.fold_left (fun acc (f, e) -> f acc e) e es)

and term_parser3 () =
  let* e = term_parser2 () in
  let opr () = 
    (let* _ = keyword "+" in
     let* e = term_parser2 () in
     pure ((fun e1 e2 -> Add (e1, e2)), e))
    <|>
    (let* _ = keyword "-" in
     let* e = term_parser2 () in
     pure ((fun e1 e2 -> Sub (e1, e2)), e))
  in
  let* es = many (opr ()) in
  pure (List.fold_left (fun acc (f, e) -> f acc e) e es)

and term_parser () = 
  let* _ = pure () in
  (keyword "trace" >> term_parser3 () >|= (fun e -> Trace e)) <|>
  (fun_parser ()) <|>
  (iflz_parser ()) <|>
  (letrec_parser ()) <|>
  (letin_parser ()) <|>
  (term_parser3 ())

and fun_parser () =
  let* _ = keyword "fun" in
  let* a = name in
  let* _ = keyword "->" in
  let* e = term_parser () in
  pure (Fun ("_", a, e))

and iflz_parser () =
  let* _ = keyword "if" in
  let* cond = term_parser () in
  let* _ = keyword "then" in
  let* e1 = term_parser () in
  let* _ = keyword "else" in
  let* e2 = term_parser () in
  pure (Ifgz (cond, e1, e2))

and letin_parser () =
  let* _ = keyword "let" in
  let* n = name in
  let* _ = keyword "=" in
  let* e1 = term_parser () in
  let* _ = keyword "in" in
  let* e2 = term_parser () in
  pure (LetIn (n, e1, e2))

and letrec_parser () =
  let* _ = keyword "let" in
  let* _ = keyword "rec" in
  let* n = name in
  let* args = many1 name in
  let* _ = keyword "=" in
  let* e1 = term_parser () in
  let (e1, _) =
    List.fold_right
      (fun arg (acc, len) ->
         let fn = if len = 1 then n else "_" in
         (Fun (fn, arg, acc), len - 1))
      args (e1, List.length args)
  in
  let* _ = keyword "in" in
  let* e2 = term_parser () in
  pure (LetIn (n, e1, e2))

let parse_prog (s : string) : (term * char list) option = 
  parse (ws >> term_parser ()) s


let compiler (src : string) : string =
  match parse_prog src with
    Some (expr,[]) -> (
      let rec compile (ex:term) : string = 
        match ex with
          Name s -> "Push" ^ " " ^ s

        |
          LetIn (s,v,e)-> "Begin" ^ " " ^ "Push" ^ " " ^s^ " " ^ compile v ^ " " ^"Let" ^ " " ^ (match  e with Name s -> compile e ^ " " ^ "Lookup" | _->compile e) ^ " " ^ "End"
        |
          Unit -> "Push ()"
        |
          Int i-> "Push"^ " " ^(string_of_int i)
        |
          Add (expr1,expr2) -> (match expr1 with 
              Name s -> compile expr1 ^ " " ^"Lookup"
            |
              _ -> compile expr1
          ) ^" " 
                               ^ (match expr2 with 
                                     Name s -> compile expr2 ^ " " ^"Lookup"
                                   |
                                     _ -> compile expr2
                                 ) ^ " " ^ "Add"
        |
          Sub (expr1,expr2) -> (match expr1 with 
              Name s -> compile expr1 ^ " " ^"Lookup"
            |
              _ -> compile expr1
          )
                               ^" "        ^ (match expr2 with 
                                     Name s -> compile expr2 ^ " " ^"Lookup"
                                   |
                                     _ -> compile expr2
                                 ) ^ " " ^"Sub"
        |
          Mul (expr1,expr2) -> (match expr1 with 
              Name s -> compile expr1 ^ " " ^"Lookup"
            |
              _ -> compile expr1
          )
                               ^" "          ^ (match expr2 with 
                                     Name s -> compile expr2 ^ " " ^"Lookup"
                                   |
                                     _ -> compile expr2
                                 ) ^ " " ^"Mul"
        |
          Div (expr1,expr2) -> (match expr1 with 
              Name s -> compile expr1 ^ " " ^"Lookup"
            |
              _ -> compile expr1
          )
                               ^" "              ^ (match expr2 with 
                                     Name s -> compile expr2 ^ " " ^"Lookup"
                                   |
                                     _ -> compile expr2
                                 ) ^ " " ^"Div"
        |
          Trace t-> (match t with 
              Name s -> compile t ^ " " ^"Lookup"
            |
              _ -> compile t
          ) ^ " " ^ "Trace"
        |
          Fun (fname,arg,expr)-> "Fun" ^ " " ^ fname ^ " " ^ arg ^ " " ^ (match expr with 
          Name s -> compile expr ^ " " ^"Lookup"
        |
          _ -> compile expr
      ) ^ " " ^ "End" ^  " " ^ "Push" ^ " " ^ fname ^ " " ^ "Lookup"
         |
          App(expr1,expr2) -> (match expr1 with 
          Name s -> compile expr1 ^ " " ^"Lookup" 
        |
          _ -> compile expr1
      ) ^ " "^(match expr2 with 
      Name s -> compile expr2 ^ " " ^"Lookup"
    |
      _ -> compile expr2
  ) ^" " ^"Call"
        |
          Ifgz (t1,t2,t3) -> (match t1 with Name s -> compile t1 ^ " " ^ "Lookup" | _->compile t1) ^ " " ^ "If" ^ " " ^ "Begin" ^ " " ^ (match t2 with Name s -> compile t2 ^ " " ^ "Lookup" | _->compile t2) ^ " " ^ "End" ^ " " ^ "Else" ^ " " ^ "Begin"^ " " ^  (match t3 with Name s -> compile t3 ^ " " ^ "Lookup" | _->compile t3) ^ " " ^ "End" ^ " " ^ "End"
    in compile expr
    )
  |
    _ -> "Error"