Source file interpreter.ml

let state env : int =
  match TableParser.MenhirInterpreter.top env with
  | Some (TableParser.MenhirInterpreter.Element (s, _, _, _)) -> TableParser.MenhirInterpreter.number s
  | None -> 0

type result =
  | Continue of Environment.env
  | Continue_Error
  | Stop

type readline_result =
  | Eof
  | Empty
  | Buffer of Sedlexing.lexbuf

let readline_base command_str env =
  match Readline.readline ~prompt:UtilsLib.Error.base_prompt ~completion_fun:(Completion.complete env "") () with
  | None -> Eof
  | Some "" -> Empty
  | Some input ->
    let () = command_str := input in
    let () = Readline.add_history input in
    let lexbuf = Sedlexing.Utf8.from_string input in
    let () = Sedlexing.set_position lexbuf
      { Lexing.pos_cnum = 0 ; Lexing.pos_bol = 0 ; Lexing.pos_lnum = 1 ; Lexing.pos_fname = "" } in
      Buffer lexbuf

let readline_cont command_str cont_line pstart env =
  match Readline.readline ~prompt:UtilsLib.Error.cont_prompt ~completion_fun:(Completion.complete env (!command_str ^ "\n")) () with
  | None -> Eof
  | Some input ->
    let () = command_str := !command_str ^ "\n" ^ input in
    let () = Readline.append_to_last_entry ("\n" ^ input) in
    let lexbuf = Sedlexing.Utf8.from_string (cont_line ^ "\n" ^ input) in
    let () = Sedlexing.set_position lexbuf pstart in
      Buffer lexbuf

(* This loop parses the user input in lexbuf, and ask for more input if it may
 * be correct but incomplete. This happends in two cases : an unfinished token
 * from the lexer (represented by a special token), or an incomplete word of
 * the grammar (a parsing error when the next token is EOI). *)
let rec interactive_loop env checkpoint last_checkpoint last_token lexbuf line_num command_str =
  match checkpoint with
  | TableParser.MenhirInterpreter.InputNeeded _ -> (
      match Lexer.lex lexbuf with
      | Lexer.PartialToken (str, err) -> (
          let pstart, pend = Sedlexing.lexing_positions lexbuf in
          match readline_cont command_str str pstart env with
          | Eof | Empty -> Errors.LexingErrors.emit err ~loc:(pstart, pend)
          | Buffer lexbuf ->
              interactive_loop env checkpoint last_checkpoint last_token lexbuf (line_num + 1) command_str)
      | Lexer.Token (tok, _) ->
          let pstart, pend = Sedlexing.lexing_positions lexbuf in
          let new_checkpoint =
            TableParser.MenhirInterpreter.offer checkpoint (tok, pstart, pend)
          in
            interactive_loop env new_checkpoint checkpoint (Some tok) lexbuf line_num command_str)
  | TableParser.MenhirInterpreter.Shifting _
  | TableParser.MenhirInterpreter.AboutToReduce _ ->
      let checkpoint = TableParser.MenhirInterpreter.resume checkpoint in
      interactive_loop env checkpoint last_checkpoint last_token lexbuf line_num command_str
  | TableParser.MenhirInterpreter.HandlingError s_env ->
      if last_token = Some Parser.EOI then
        let (pstart, pend) = Sedlexing.lexing_positions lexbuf in
        match readline_cont command_str "" pstart env with
        | Eof | Empty -> Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError (state s_env)) ~loc:(pstart, pend))
        | Buffer lexbuf ->
            interactive_loop env last_checkpoint last_checkpoint None lexbuf (line_num + 1) command_str
      else
        let loc = Sedlexing.lexing_positions lexbuf in
        Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError (state s_env)) ~loc)
  | TableParser.MenhirInterpreter.Accepted f ->
      (match Lexer.lex lexbuf with
      | Lexer.Token (Parser.EOI, _) -> f
      | _ -> let loc = Sedlexing.lexing_positions lexbuf in
          Errors.(SyntaxErrors.emit Syntax_l.TrailingChars ~loc))
  | TableParser.MenhirInterpreter.Rejected -> assert false

let rec interactive env =
  let command_str = ref "" in
  try
    match readline_base command_str env with
    | Eof -> Stop
    | Empty -> interactive env
    | Buffer lexbuf ->
        let start =
          TableParser.Incremental.interactive_command
            (fst (Sedlexing.lexing_positions lexbuf))
        in
        let command = interactive_loop env start start None lexbuf 1 command_str in
        let () = UtilsLib.Utils.sterm_set_size (); UtilsLib.Utils.term_set_size () in
        let res_val_list, res_env = command env in
        let () = Option.iter (Value.print true) res_val_list in
        Continue { res_env with Environment.last_value =
          if res_val_list = None then res_env.Environment.last_value else res_val_list }
  with
  | Sys.Break ->
      interactive env
  | e -> UtilsLib.Error.print_error e (Some !command_str); Continue_Error

let script lexbuf env =
  let parser =
    MenhirLib.Convert.Simplified.traditional2revised CodeParser.script_command in

  let rec parse () =
    try
      let command_str = ref "" in
      let command_o = parser
        (fun () -> match Lexer.lex lexbuf with
        | Lexer.Token (tok, str) -> command_str := !command_str ^ str;
            let pstart, pend = Sedlexing.lexing_positions lexbuf in
            tok, pstart, pend
        | Lexer.PartialToken (_, err) ->
            let loc = Sedlexing.lexing_positions lexbuf in
            Errors.LexingErrors.emit err ~loc) in
      match command_o with
      | Some command -> (command, !command_str) :: parse ()
      | None -> []
    with
      | CodeParser.Error s ->
        let loc = Sedlexing.lexing_positions lexbuf in
          Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError s) ~loc) in

  let command_list =
    try
      parse ()
    with
    | e -> UtilsLib.Error.print_error_fatal e None in

  let env = List.fold_left
    (fun env (command, command_str) ->
      try
        if env.Environment.config.Config.step_by_step then
          (Printf.printf "%s\n" command_str; ignore (read_line ()));
        let (value_o, env) = command env in
        let () = Option.iter (Value.print env.Environment.config.Config.step_by_step) value_o in
        (if env.Environment.config.Config.step_by_step && value_o <> None then
          ignore (read_line ()));
        env
      with
      | e -> UtilsLib.Error.print_error e None; env)
    env
    command_list in
  env