(* This is the main file of gnatwhy3 *)

(* Gnatwhy3 does the following:
   - it reads a .gnat-json file that was generated by gnat2why
   - it computes the VCs
   - it runs the selected provers on each VC.
   - it generates a summary of what was proved and not proved in JSON format
 and outputs this JSON format to stdout (for gnat2why to read).

   See gnat_objectives.mli for the notion of check and goal.

   See gnat_report.mli for the JSON format

   gnat_main can be seen as the "driver" for gnatwhy3. Much of the
   functionality is elsewhere.
   Specifically, this file does:
      - compute the check that belongs to a goal/VC
      - drive the scheduling of VCs, and handling of results
      - output the messages
*)

open Why3
open Gnat_scheduler

module C = Gnat_checks.Make (Gnat_scheduler)

let warn_gnat_rac_not_done = Loc.register_warning "gnat_rac_not_done" "Warn if RAC could not be completed"

let rec is_trivial fml =
   let open Term in
   (* Check wether the formula is trivial.  *)
   match fml.t_node with
   | Ttrue -> true
   | Tquant (_,tq) ->
         let _,_,t = t_open_quant tq in
         is_trivial t
   | Tlet (_,tb) ->
         let _, t = t_open_bound tb in
         is_trivial t
   | Tbinop (Timplies,_,t2) ->
         is_trivial t2
   | Tcase (_,tbl) ->
         List.for_all (fun b ->
            let _, t = t_open_branch b in
            is_trivial t) tbl
   | _ -> false

let register_goal cont goal_id =
  (* Register the goal by extracting the explanation and trace. If the goal is
   * trivial, do not register. For trivial goals, we register a dummy proof
   * attempt that succeeded. *)
  let s = cont.Controller_itp.controller_session in
  let task = Session_itp.get_task s goal_id in
  let fml = Task.task_goal_fmla task in
  let is_trivial = is_trivial fml in
  if is_trivial then Gnat_checks.add_trivial_proof s goal_id;
  match is_trivial, Gnat_expl.search_labels fml with
  | true, None ->
      Gnat_checks.set_not_interesting goal_id
  | false, None ->
      let base_msg = "Task has no tracability label" in
      let msg =
        if Gnat_config.debug then
          Pp.sprintf "%s: %a.@." base_msg Pretty.print_term fml
        else base_msg in
      Gnat_util.abort_with_message ~internal:true msg
  | _, Some c ->
      begin
        if c.Gnat_expl.check.Gnat_expl.already_proved then
          Gnat_checks.set_not_interesting goal_id
        else
          Gnat_checks.add_to_check c goal_id
      end

let rec handle_vc_result c goal result =
   (* This function is called when the prover has returned from a VC.
       goal           is the VC that the prover has dealt with
       result         a boolean, true if the prover has proved the VC
       prover_result  the actual proof result, to extract statistics
   *)
   let check, status = C.register_result c goal result in
   match status with
   | Gnat_checks.Proved -> ()
   | Gnat_checks.Not_Proved -> ()
   | Gnat_checks.Work_Left ->
       List.iter (create_manual_or_schedule c check) (Gnat_checks.next check)
   | Gnat_checks.Counter_Example ->
     (* In this case, counterexample prover and VC will be never None *)
     let prover_ce = (Option.get Gnat_config.prover_ce) in
     match Gnat_checks.ce_goal check with
     | None -> assert false
     | Some g ->
       C.schedule_goal_with_prover c ~callback:(interpret_result c) g prover_ce

and interpret_result c pa pas =
   (* callback function for the scheduler, here we filter if an interesting
      goal has been dealt with, and only then pass on to handle_vc_result *)
   match pas with
   | Controller_itp.Done r ->
     let session = c.Controller_itp.controller_session in
     let goal = Session_itp.get_proof_attempt_parent session pa in
     let answer = r.Call_provers.pr_answer in
     if Gnat_config.debug_prover_errors &&
        match answer with
        | Call_provers.HighFailure _ -> true
        | _ -> false &&
        not (Gnat_config.is_ce_prover session pa) then
       Gnat_report.add_warning r.Call_provers.pr_output;
     handle_vc_result c goal (answer = Call_provers.Valid)
   | Controller_itp.InternalFailure e ->
       let s = Format.asprintf "Internal Why3 unexpected error during \
                                elaboration of prover file:\n %a"
           Exn_printer.exn_printer e in
       Gnat_report.add_warning s
   | _ ->
         ()

and create_manual_or_schedule (c: Controller_itp.controller) _obj goal =
  let s = c.Controller_itp.controller_session in
  match Gnat_config.manual_prover with
  | Some _ when C.goal_has_splits s goal &&
                not (Session_itp.pn_proved c.Controller_itp.controller_session goal) ->
                  handle_vc_result c goal false
  | _ -> schedule_goal c goal

and schedule_goal (c: Controller_itp.controller) (g : Session_itp.proofNodeID) =
   (* schedule a goal for proof - the goal may not be scheduled actually,
      because we detect that it is not necessary. This may have several
      reasons:
         * command line given to skip proofs
         * goal already proved
         * goal already attempted with identical options
   *)
   if (Gnat_config.manual_prover <> None
       && not (Session_itp.pn_proved c.Controller_itp.controller_session g)) then begin
       actually_schedule_goal c g
   (* then implement reproving logic *)
   end else begin
     (* Maybe the goal is already proved *)
      if Session_itp.pn_proved c.Controller_itp.controller_session g then begin
         handle_vc_result c g true
      (* Maybe there was a previous proof attempt with identical parameters *)
      end else if Gnat_checks.all_provers_tried c.Controller_itp.controller_session g then begin
         (* the proof attempt was necessarily false *)
         handle_vc_result c g false
      end else begin
         actually_schedule_goal c g
      end;
   end

and actually_schedule_goal c g =
  C.schedule_goal ~callback:(interpret_result c) c g

let handle_obj c check =
   if Gnat_checks.check_status check <> Gnat_checks.Proved then begin
     match Gnat_checks.next check with
      | [] -> ()
      | l ->
         List.iter (create_manual_or_schedule c check) l
   end

let all_split_subp c subp =
  let s = c.Controller_itp.controller_session in
   C.init_subp_vcs c subp;
   Gnat_checks.iter_leaf_goals s subp (register_goal c);
   C.all_split_leaf_goals ();
   Gnat_checks.clear ()

let maybe_giant_step_rac ctr parent models =
  let th =
    parent |> Session_itp.find_th ctr.Controller_itp.controller_session |>
    Session_itp.theory_name |> Theory.restore_theory in
  let pm = Pmodule.restore_module th in
  if not Gnat_config.giant_step_rac then
    begin match Check_ce.last_nonempty_model th.Theory.th_known models with
    | None -> []
    | Some m -> [(m, None)]
    end
  else (
    Debug.dprintf Check_ce.debug_check_ce_categorization "Running giant-step RAC@.";
    let Controller_itp.{controller_config= cnf; controller_env= env} = ctr in
    let rac_limits =
      match Gnat_config.prover_ce with
      | Some pr -> Gnat_config.limit ~prover:pr ~warning:false
      | None -> Call_provers.empty_limits
    in
    let rac_limits =
      match Option.map float_of_int Gnat_config.rac_timelimit with
      | None -> rac_limits
      | Some t -> {rac_limits with Call_provers.limit_time = t}
    in
    let why_prover = Option.map (fun p -> (p, rac_limits)) Gnat_config.rac_prover in
    let check_term = Rac.Why.mk_check_term_lit cnf env ~why_prover () in
    let compute_term = Rac.Why.mk_compute_term_lit env () in
    let rac = Pinterp.mk_rac check_term in
    let models = Check_ce.models_from_giant_step  ~limits:rac_limits ~compute_term
        rac env pm models in
    List.map (fun model ->
    match model with
    | (m, Check_ce.RAC_not_done reason) -> (
        if Gnat_config.debug then Loc.warning warn_gnat_rac_not_done "%s@." reason;
        (Gnat_counterexamples.post_clean#model m, None)
      )
    | (m, Check_ce.RAC_done (res_state, res_log)) -> (
        let res = Check_ce.RAC_done (res_state, res_log) in
        Debug.dprintf Check_ce.debug_check_ce_rac_results "%a@."
          (Check_ce.print_rac_result ?verb_lvl:None) res;
        let m = Gnat_counterexamples.post_clean#model m in
        (* Format.eprintf "Model of exec log:@ %a@." (Model_parser.print_model ~print_attrs:false) m; *)
        (m, Some res))
  ) models)

let report_messages c check =
  let s = c.Controller_itp.controller_session in
  let result =
    if C.session_proved_status c check then
      let (stats, stat_checker) = C.Save_VCs.extract_stats c check in
      Gnat_report.Proved (stats, stat_checker)
    else
      let models =
        let ce_pa = C.session_find_ce_pa c check in
        match ce_pa with
        | None -> []
        | Some pa ->
          let ce_pan = Session_itp.get_proof_attempt_node s pa in
          match ce_pan.Session_itp.proof_state with
          | None -> []
          | Some pr ->
            let not_step_limit (pa,_) = pa <> Call_provers.StepLimitExceeded in
            let models = List.filter not_step_limit pr.Call_provers.pr_models in
            maybe_giant_step_rac c ce_pan.Session_itp.parent models
      in
      let unproved_pa = C.session_find_unproved_pa c check in
      let manual_info = Opt.bind unproved_pa (Gnat_manual.manual_proof_info s) in
      let unproved_goal =
        (* In some cases (replay) no proofattempt proves the goal but we still
           want a task to be able to extract the expl from it. *)
        match unproved_pa with
        | None -> C.session_find_unproved_goal c check
        | Some pa -> Some (Session_itp.get_proof_attempt_parent s pa)
      in
      let extra_info =
        let default = { Gnat_expl.pretty_node = None; inlined = None } in
        match unproved_goal with
        | None -> default
        | Some g ->
            (* In some cases (CE goals in replay) the goal might not be
               properly registered. In that case, we attempt to find a parent
               goal that is registered. *)
            try
              Gnat_checks.get_extra_info g
            with Not_found ->
              if C.is_ce_goal s g then
                match Session_itp.get_proof_parent s g with
                | Session_itp.Theory _ -> default
                | Session_itp.Trans t ->
                  try Gnat_checks.get_extra_info (Session_itp.get_trans_parent s t)
                  with Not_found -> default
              else { Gnat_expl.pretty_node = None; inlined = None }
      in
      let answer_status = C.Save_VCs.unproved_prover_answer s unproved_goal check in
      Gnat_report.Not_Proved (extra_info, models, manual_info, answer_status) in
  Gnat_report.register check (C.Save_VCs.check_to_json s check) result

(* Escaping all debug printings *)
let escape_buffer = Buffer.create 42
let escape_formatter = Format.formatter_of_buffer escape_buffer
let () = Debug.set_debug_formatter escape_formatter

(* This is to be executed when scheduling ends *)
let ending c () =
  Debug.Stats.record_timing "gnatwhy3.run_vcs"
    (fun () -> C.remove_all_valid_ce_attempt c.Controller_itp.controller_session);
  Debug.Stats.record_timing "gnatwhy3.save_session" (fun () -> C.save_session c);
  Gnat_checks.iter (report_messages c);
  let s = Buffer.contents escape_buffer in
  if s <> "" then
    Gnat_report.add_warning s;
  Gnat_report.print_messages ();
  (* Dump profiling data (when compiled with profiling enabled) to file whose
     name is based on the processed .mlw file; otherwise profile data from
     several compilation would be written to a single gmon.out file and
     overwrite each other. When compiled with profiling disabled it has no
     visible effect. Note: we set the filename just before the program exit
     to not interfere with profiling of provers.
   *)
  let basename =
    Filename.chop_extension
      (Filename.basename Gnat_config.filename) in
  Unix.putenv "GMON_OUT_PREFIX" (basename ^ "_gnatwhy3_gmon.out")

let normal_handle_one_subp c subp =
   C.init_subp_vcs c subp;
   let s = c.Controller_itp.controller_session in
   Gnat_checks.iter_leaf_goals s subp (register_goal c)

(* save session on interrupt initiated by the user *)
let save_session_and_exit c signum =
  (* Ignore all SIGINT, SIGHUP and SIGTERM, which may be received when
     gnatprove is called in GNATStudio, so that the session file is always
     saved. Wrap in exception block as some signals are not supported on
     windows. *)
  begin try
    Sys.set_signal Sys.sigint Sys.Signal_ignore;
    Sys.set_signal Sys.sighup Sys.Signal_ignore;
    Sys.set_signal Sys.sigterm Sys.Signal_ignore;
  with Invalid_argument _ -> () end;
  C.save_session c;
  exit signum

 (* This is the main code. We read the file into the session if not already
    done, we apply the split_goal transformation when needed, and we schedule
    the first VC of all check. When done, we save the session.
 *)

let _ =
  if Gnat_config.debug then Debug.(set_flag (lookup_flag "gnat_ast"));
  Debug.set_flag Pinterp.debug_disable_builtin_mach;
  Debug.set_flag Debug.stats;
  List.iter Introduction.add_unique_prefix
    ["GP_Check:"; "GP_Pretty_Ada:"; "GP_Shape:"; "GP_Sloc:";
     "GP_Already_Proved"; "GP_Inline"; "GP_Inlined"];
  ( try
      let log = Sys.getenv "GNATWHY3LOG" in
      let out = open_out_gen [Open_text; Open_creat; Open_append] 0o666 log in
      let fmt = Format.formatter_of_out_channel out in
      Debug.set_debug_formatter fmt;
      Format.fprintf fmt "@.@.===== %s@." Gnat_config.filename;
      Loc.set_warning_hook (fun ?loc:_ line -> Format.fprintf fmt "%s@." line)
    with Not_found -> () );
  try
    let c = Debug.Stats.record_timing "gnatwhy3.init" Gnat_checks.init_cont in
    (* This has to be done after initialization of controller. Otherwise we
       don't have session. *)
    Sys.set_signal Sys.sigint (Sys.Signal_handle (save_session_and_exit c));
    begin match Gnat_config.proof_mode with
    | Gnat_config.Progressive
    | Gnat_config.Per_Path
    | Gnat_config.Per_Check ->
        Debug.Stats.record_timing "gnatwhy3.register_vcs"
         (fun () -> C.iter_subps c (normal_handle_one_subp c));
        if Gnat_config.replay then begin
          C.replay c (*;
          Gnat_checks.do_scheduled_jobs (fun _ _ -> ());*)
        end else begin
          Debug.Stats.record_timing "gnatwhy3.schedule_vcs"
           (fun () -> Gnat_checks.iter (handle_obj c));
        end;
     | Gnat_config.All_Split ->
        C.iter_subps c (all_split_subp c)
     | Gnat_config.No_WP ->
        (* we should never get here *)
        ()
    end;
    Gnat_scheduler.main_loop (ending c)
  with e when Debug.test_flag Debug.stack_trace -> raise e
  | Out_of_memory as e -> raise e
  | e ->
      let s = Pp.sprintf "%a.@." Exn_printer.exn_printer e in
      Gnat_util.abort_with_message ~internal:true s
