lci/bin/miniFunPolyInterpreter.ml

open MiniFun
open Lexing

(* -------------------------------------------------------------------------- *)
(*                             Command Arguments                              *)

let () =
  Clap.description "Interpreter for MiniFun language.";

  let files = Clap.section ~description: "Files to consider." "FILES" in
  let values = Clap.section ~description: "Input values." "VALUES" in

  let input = Clap.mandatory_string
      ~description: "Input file."
      ~placeholder: "FILENAME"
      ~section: files
      ~long: "input"
      ~short: 'i'
      ()
  in

  let inputval = Clap.optional_int
      ~description: "Optional input value to feed to the program. \
                     If not specified it is read from stdin."
      ~placeholder: "INT"
      ~section: values
      ~long: "value"
      ~short: 'v'
      ()
  in

  let evalb = Clap.flag
      ~description: "Optional flag for evaluating the generated risc code."
      ~section: values
      ~set_long: "eval"
      ~set_short: 'e'
      false
  in

  let output = Clap.optional_string
      ~description: "Output file. If not specified output is printed on stdout."
      ~placeholder: "FILENAME"
      ~section: files
      ~long: "output"
      ~long_synonyms: ["out"; "result"]
      ~short: 'o'
      ()
  in

  Clap.close ();

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

  let print_position outx lexbuf =
    let pos = lexbuf.lex_curr_p in
    Printf.fprintf outx "Encountered \"%s\" at %s:%d:%d"
      (Lexing.lexeme lexbuf) pos.pos_fname
      pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
  in

  let interpret_file inch (inval: int) outch =
    let lexbuf = Lexing.from_channel inch in
    let program =
      try Parser.prg Lexer.read lexbuf with
      | Lexer.LexingError msg ->
        Printf.fprintf stderr "%a: %s\n" print_position lexbuf msg;
        exit (-1)
      | Parser.Error ->
        Printf.fprintf stderr "%a: syntax error\n" print_position lexbuf;
        exit (-1)
    in
    let ty_program =
      match TypeChecker.typecheck_polymorphic_unbound program with
      | Ok ty -> ty
      | Error (`AbsentAssignment msg)
      | Error (`WrongTypeSpecification msg)
      | Error (`RecursionNotImplemented msg)
      | Error (`WrongType msg) ->
        Printf.fprintf stderr "%s\n" msg;
        exit (-1)
    in
    let return_value =
      if evalb then
        match Semantics.reduce program inval with
          Ok o -> Some o
        | Error (`AbsentAssignment msg)
        | Error (`DivisionByZero msg)
        | Error (`WrongType msg) ->
          Printf.fprintf stderr "%s\n" msg;
          exit (-1)
      else
        None
    in

    Printf.fprintf outch "Type of the program: %s\n" (Types.pp_type_f ty_program);
    match return_value with
    | Some v -> Printf.fprintf outch "%d\n" v
    | None -> ()
  in


  let inx = In_channel.open_text input in
  let outx = match output with
      None -> stdout
    | Some f -> Out_channel.open_text f
  in

  let inputval = match inputval with
      None -> (
        Printf.fprintf stdout "Provide the input: ";
        read_int ()
      )
    | Some o -> o
  in
  interpret_file inx inputval outx;

  Out_channel.close outx