(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2024 --  Inria - CNRS - Paris-Saclay University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

open Why3
open Format
open Gconfig
open Wstdlib
open Ide_utils
open History
open Itp_communication
module GSourceView = GSourceView3

module Main () = struct

let debug = Debug.lookup_flag "ide_info"

let () =
  (* Allow global locations to be saved for Find_ident_req *)
  Debug.set_flag Glob.flag

(***************************)
(* Debugging Json protocol *)
(***************************)

(* TODO remove print_request_json and print_notification_json *)
exception Badparsing

let print_request_json fmt (r : ide_request) =
  (try
     let s = Pp.string_of Json_util.print_request r in
     let x = Json_util.parse_request s in
     if r = x then
       ()
     else
       raise Badparsing
   with
  | _ -> Format.eprintf "Bad parsing@.");
  Json_util.print_request fmt r

let print_notification_json fmt (n : notification) =
  (try
     let x =
       Json_util.parse_notification
         (Pp.string_of Json_util.print_notification n)
     in
     if n = x then
       ()
     else
       raise Badparsing
   with
  | _ -> Format.eprintf "Bad parsing@.");
  Json_util.print_notification fmt n

let debug_json =
  Debug.register_flag "json_proto"
    ~desc:"Print@ json@ requests@ and@ notifications@"

(*******************)
(* server protocol *)
(*******************)

module Protocol_why3ide = struct
  let debug_proto =
    Debug.register_flag "ide_proto"
      ~desc:"Print@ debugging@ messages@ about@ Why3Ide@ protocol@"

  let print_request_debug r =
    Debug.dprintf debug_proto "request %a@." print_request r;
    Debug.dprintf debug_json "%a@." print_request_json r

  let print_notify_debug n =
    Debug.dprintf debug_proto "handling notification %a@." print_notify n;
    Debug.dprintf debug_json "%a@." print_notification_json n

  let list_requests : ide_request list ref = ref []

  let get_requests () =
    let n = List.length !list_requests in
    if n > 0 then Debug.dprintf debug_proto "got %d new requests@." n;
    let l = List.rev !list_requests in
    list_requests := [];
    l

  let send_request r =
    print_request_debug r;
    list_requests := r :: !list_requests

  let notification_list : notification list ref = ref []

  let notify n =
    (* too early, print when handling notifications print_notify_debug n; *)
    notification_list := n :: !notification_list

  let get_notified () =
    let n = List.length !notification_list in
    if n > 0 then Debug.dprintf debug_proto "got %d new notifications@." n;
    let l = List.rev !notification_list in
    notification_list := [];
    l
end

let get_notified = Protocol_why3ide.get_notified
let send_request r = Protocol_why3ide.send_request r

(****************************************)
(* server instance on the GTK scheduler *)
(****************************************)

(* The gtk scheduler is catching all exceptions avoiding the printing of the
   backtrace that is normally done by debug option stack_trace. To recover this
   behavior we catch exceptions ourselves. If "stack_trace" is on, we exit on
   first exception and print backtrace on standard output otherwise we raise the
   exception again (with information on error output). *)
let backtrace_and_exit f () =
  try f () with
  | e ->
    if Debug.test_flag Debug.stack_trace then (
      Printexc.print_backtrace stderr;
      Format.eprintf "exception '%a' was raised in a LablGtk callback.@."
        Exn_printer.exn_printer e;
      exit 1
    ) else (
      Format.eprintf "exception '%a' was raised in a LablGtk callback.@."
        Exn_printer.exn_printer e;
      Format.eprintf "This should not happen. Please report. @.";
      raise e
    )

module Scheduler = struct
  let blocking = false
  let multiplier = 3

  let idle ~prio f =
    let (_ : GMain.Idle.id) = GMain.Idle.add ~prio (backtrace_and_exit f) in
    ()

  let timeout ~ms f =
    let (_ : GMain.Timeout.id) =
      GMain.Timeout.add ~ms ~callback:(backtrace_and_exit f)
    in
    ()
end

module Server = Itp_server.Make (Scheduler) (Protocol_why3ide)

let when_idle (f : unit -> unit) =
  let (_ : GMain.Idle.id) =
    GMain.Idle.add (fun () ->
        f ();
        false)
  in
  ()

(************************)
(* parsing command line *)
(************************)

let files : string Queue.t = Queue.create ()
let opt_parser = ref None
let opt_batch = ref None

let spec =
  let open Getopt in
  [
    ( Key ('F', "format"),
      Hnd1 (AString, fun s -> opt_parser := Some s),
      "<format> select input format (default: \"why\")" );
    Termcode.opt_extra_expl_prefix;
    (KLong "batch", Hnd1 (AString, fun s -> opt_batch := Some s), "");
  ]

let usage_str =
  "[<file>|<session directory>]...\nOpen a graphical interface for Why3."

let env, gconfig =
  try
    let config, env =
      Whyconf.Args.initialize spec (fun f -> Queue.add f files) usage_str
    in
    if Queue.is_empty files then Whyconf.Args.exit_with_usage usage_str;
    Gconfig.load_config config;
    (env, Gconfig.config ())
  with
  | e when not (Debug.test_flag Debug.stack_trace) ->
    eprintf "Anomaly while loading configuration: %a@." Exn_printer.exn_printer
      e;
    exit 1

(********************************)
(* Source language highlighting *)
(********************************)

let warn_unknown_format = Loc.register_warning "unk_format" "Unknown source format"


let get_extra_lang =
  let main = Whyconf.get_main gconfig.config in
  let load_path = Filename.concat (Whyconf.datadir main) "lang" in
  let languages_manager = GSourceView.source_language_manager ~default:true in
  languages_manager#set_search_path (load_path :: languages_manager#search_path);
  fun shortcut name ->
    let ll = ref None in
    fun () ->
      match !ll with
      | Some _ as l -> l
      | None -> (
        match languages_manager#language shortcut with
        | None ->
            Loc.warning warn_unknown_format "Language file for '%s' not found in directory %s" name
            load_path;
          None
        | Some _ as l ->
          ll := l;
          l)

(* Borrowed from Frama-C src/gui/source_manager.ml: Try to convert a source file
   either as UTF-8 or as locale. *)
let try_convert s =
  try
    if Glib.Utf8.validate s then
      s
    else
      Glib.Convert.locale_to_utf8 s
  with
  | Glib.Convert.Error _ -> (
    try
      Glib.Convert.convert_with_fallback
        ~fallback:"#neither UTF-8 nor locale nor ISO-8859-15#"
        ~to_codeset:"UTF-8" ~from_codeset:"ISO_8859-15" s
    with
    | Glib.Convert.Error _ as e -> Printexc.to_string e)

(****************************)
(* Color handling in source *)
(****************************)

(* Generates the tag list (using the current config) *)
let color_tags_list config =
  (* The order of this list influences the priorities of tags *)
  [
    ("error_line_tag", [ `BACKGROUND config.error_line_color ]);
    (* less priority *)
    ("premise_tag", [ `BACKGROUND config.premise_color ]);
    ("neg_premise_tag", [ `BACKGROUND config.neg_premise_color ]);
    ("goal_tag", [ `BACKGROUND config.goal_color ]);
    ("error_tag", [ `BACKGROUND config.error_color_bg ]);
    ( "error_tag_msg_zone",
      [
        `BACKGROUND gconfig.error_color_msg_zone_bg;
        `FOREGROUND gconfig.error_color_msg_zone_fg;
      ] );
    ("error_font_tag", [ `FOREGROUND config.error_color_fg ]);
    ("search_tag", [ `BACKGROUND config.search_color ]);
  ]

(* For each view, we have to recreate the tags. TODO The type annotatin is
   necessary for the type inference to know that <name> is optional. *)
let create_colors config
    (v :
      < buffer :
          < create_tag : ?name:string -> GText.tag_property list -> GText.tag
          ; .. >
      ; .. >) =
  let list_tags = color_tags_list config in
  List.iter
    (fun (name, props) ->
      let (_ : GText.tag) = v#buffer#create_tag ~name props in
      ())
    list_tags

let remove_tag v tag_name =
  let tag = GtkText.TagTable.lookup v#buffer#tag_table tag_name in
  match tag with
  | None -> ()
  | Some tag -> GtkText.TagTable.remove v#buffer#tag_table tag

let remove_all_tags config v =
  List.iter (fun (s, _) -> remove_tag v s) (color_tags_list config)

(* When colors are changed in the preferences, the tag need to change so we
   remove and regenerate the tags. This works only on sourceview (not on
   message_zone where tags are not added by name *)
let update_tags config v =
  remove_all_tags config v;
  create_colors config v

(* Erase all the source location tags in a source file *)
let erase_color_loc (v : GSourceView.source_view) =
  let buf = v#buffer in
  buf#remove_tag_by_name "premise_tag" ~start:buf#start_iter ~stop:buf#end_iter;
  buf#remove_tag_by_name "neg_premise_tag" ~start:buf#start_iter
    ~stop:buf#end_iter;
  buf#remove_tag_by_name "goal_tag" ~start:buf#start_iter ~stop:buf#end_iter;
  buf#remove_tag_by_name "error_tag" ~start:buf#start_iter ~stop:buf#end_iter;
  buf#remove_tag_by_name "error_line_tag" ~start:buf#start_iter
    ~stop:buf#end_iter;
  buf#remove_tag_by_name "error_font_tag" ~start:buf#start_iter
    ~stop:buf#end_iter

(*******************)
(* Graphical tools *)
(*******************)

(* Elements needed for usage of graphical elements *)

(* Hold the node_id on which "next" was called to allow differentiating on
   automatic jump from a user jump *)
let manual_next = ref None

(* [quit_on_saved] set to true by exit function to delay quiting after Saved
   notification is received *)
let quit_on_saved = ref false

(* Exit brutally without asking anything *)
let exit_function_unsafe () =
  send_request Exit_req;
  GMain.quit ()

(* Contains triples (tab page, source_view, label_of_tab): - tab_page is a
   unique number for each pages of the notebook - source_view is the graphical
   element inside a tab - label_of_tab is the mutable title of the tab *)
let source_view_table :
    (int * GSourceView.source_view * GMisc.label * bool) Hstr.t =
  Hstr.create 14

(* The corresponding file does not have a source view *)
exception Nosourceview of string

let get_source_view_table (file : string) =
  match Hstr.find source_view_table file with
  | v -> v
  | exception Not_found -> raise (Nosourceview file)

(* Saving function for sources *)
let save_sources () =
  Hstr.iter
    (fun k (_n, (s : GSourceView.source_view), _l, read_only) ->
      if (not read_only) && s#source_buffer#modified then
        let text_to_save = s#source_buffer#get_text () in
        send_request (Save_file_req (k, text_to_save)))
    source_view_table

(* True if there exist a file which needs saving *)
let files_need_saving () =
  Hstr.fold
    (fun _k (_, s, _, read_only) acc ->
      acc || ((not read_only) && s#source_buffer#modified))
    source_view_table false

(* Ask if the user wants to save session before exit. Exit is then delayed until
   the [Saved] notification is received *)
let exit_function_safe () = send_request Check_need_saving_req

let exit_function_handler b =
  if (not b) && not (files_need_saving ()) then
    exit_function_unsafe ()
  else
    let answer =
      GToolbox.question_box ~title:"Why3 saving session and files"
        ~buttons:[ "Yes"; "No"; "Cancel" ]
        "Do you want to save the session and unsaved files?"
    in
    match answer with
    | 1 ->
      save_sources ();
      send_request Save_req;
      quit_on_saved := true
    | 2 -> exit_function_unsafe ()
    | _ -> ()

(* Erase colors in all source views *)
let erase_loc_all_view () =
  Hstr.iter (fun _ (_, v, _, _) -> erase_color_loc v) source_view_table

(* Update name of the tab when the label changes so that it has a * as prefix *)
let update_label_change (label : GMisc.label) =
  let s = label#text in
  erase_loc_all_view ();
  if not (Strings.has_prefix "*" s) then label#set_text ("*" ^ s)

(* Update name of the tab when the label is saved. Removes * prefix *)
let update_label_saved (label : GMisc.label) =
  let s = label#text in
  if Strings.has_prefix "*" s then
    label#set_text (String.sub s 1 (String.length s - 1))

let make_sources_editable b =
  Hstr.iter
    (fun _ (_, source_view, _, read_only) ->
      if not read_only then (
        source_view#set_editable b;
        source_view#set_auto_indent b
      ))
    source_view_table

(**********************)
(* Graphical elements *)
(**********************)

let initialization_complete = ref false
let warnings = Queue.create ()

let record_warning ?loc msg =
  (match loc with
  | None -> Format.eprintf "Warning: %s@." msg
  | Some l -> Format.eprintf "Warning, file %a: %s@." Loc.pp_position l msg);
  Queue.push (loc, msg) warnings

let () =
  Loc.set_warning_hook record_warning;
  let dir =
    try Server_utils.get_session_dir ~allow_mkdir:true files with
    | Invalid_argument s ->
      Format.eprintf "Error: %s@." s;
      Whyconf.Args.exit_with_usage usage_str
  in
  Server.init_server gconfig.config env dir;
  Queue.iter
    (fun f ->
      (* Sanitize the command line arguments so that they are always absolute *)
      let f = Sysutil.concat (Sys.getcwd ()) f in
      send_request (Add_file_req f))
    files;
  send_request Get_global_infos;
  Debug.dprintf debug "Init the GTK interface...@?";
  ignore (GtkMain.Main.init ());
  Debug.dprintf debug " done.@.";
  Gconfig.init ()

let window_title =
  match !opt_batch with
  | Some _ -> "Why3 Batch Mode"
  | None -> "Why3 Interactive Proof Session"

let main_window : GWindow.window =
  let w = GWindow.window ~title:window_title () in
  w#resize ~width:gconfig.window_width ~height:gconfig.window_height;
  (* callback to record the new size of the main window when changed, so that on
     restart the window size is the same as the last session *)
  let (_ : GtkSignal.id) =
    w#misc#connect#size_allocate
      ~callback:(fun { Gtk.width = w; Gtk.height = h } ->
        gconfig.window_height <- h;
        gconfig.window_width <- w)
  in
  w

(* the main window contains a vertical box, containing: 1. the menu [menubar] 2.
   an horizontal box [hb] *)

let vbox = GPack.vbox ~packing:main_window#add ()

let menubar =
  GMenu.menu_bar
    ~packing:(vbox#pack ?from:None ?expand:None ?fill:None ?padding:None)
    ()

let hb = GPack.hbox ~packing:vbox#add ()
let accel_group = GtkData.AccelGroup.create ()

(* context_tools : simplified tools menu for mouse-3 *)

let context_tools_menu = GMenu.menu ()

(****************************)
(* actions of the interface *)
(****************************)

(***********************************)
(* connection of actions to signals *)
(***********************************)

(* File menu signals *)

let send_session_config_to_server () =
  let nb = gconfig.session_nb_processes in
  send_request (Set_config_param (Max_tasks nb));
  let nb = gconfig.session_time_limit in
  send_request (Set_config_param (Timelimit nb));
  let nb = gconfig.session_mem_limit in
  send_request (Set_config_param (Memlimit nb))

let (_ : GtkSignal.id) =
  main_window#connect#destroy ~callback:exit_function_safe

let (_ : GtkSignal.id) =
  main_window#event#connect#delete ~callback:(fun _ ->
      exit_function_safe ();
      true)

(* 2. horizontal box contains: 2.1 TODO: a tool box ? 2.2 a horizontal paned
   [hp] containing: 2.2.1 a scrolled window to hold the tree view of the session
   [scrolledview] 2.2.2 a vertical paned containing [vpan222] *)

let hp = GPack.paned `HORIZONTAL ~packing:hb#add ()

(** {2 view for the session tree} *)
let scrolled_session_view =
  let sv =
    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
      ~shadow_type:`ETCHED_OUT ~packing:hp#add ()
  in
  hp#set_position gconfig.tree_width;
  let (_ : GtkSignal.id) =
    sv#misc#connect#size_allocate
      ~callback:(fun { Gtk.width = w; Gtk.height = _h } ->
        gconfig.tree_width <- w)
  in
  sv

(* Vertical pan *)
let vpan222 = GPack.paned `VERTICAL ~packing:hp#add ()

(* the scrolled window 2.2.1 [scrolled_session_view] contains a GTK tree *)

(** {3 the model for tree view} *)

let cols = new GTree.column_list

(* first column: unique id of the object *)
let node_id_column = cols#add Gobject.Data.int

(* second column: an icon identifying the object: file,theory, goal,
   transformation *)
let icon_column = cols#add Gobject.Data.gobject

(* third column: name of the object *)
let name_column = cols#add Gobject.Data.string

(* fourth column: icon status for the object: proved/unproved, unknown, timeout,
   etc. *)
let status_column = cols#add Gobject.Data.gobject

(* fifth column: extra status info: time, obsolete status, limits *)
let time_column = cols#add Gobject.Data.string
let column_status_title = "Status"
let column_time_title = "Time"
let column_goals_title = "Theories/Goals"

(* first view column: icon and name *)
let view_name_column =
  let v = GTree.view_column ~title:column_goals_title () in
  (* icon attribute *)
  let icon_renderer = GTree.cell_renderer_pixbuf [] in
  v#pack icon_renderer ~expand:false;
  v#add_attribute icon_renderer "pixbuf" icon_column;
  let name_renderer = GTree.cell_renderer_text [ `XALIGN 0. ] in
  v#pack name_renderer;
  v#add_attribute name_renderer "text" name_column;
  (* v#set_sizing `AUTOSIZE; *)
  v#set_resizable true;
  (* v#set_max_width 1000;*)
  v

(* second view column: status *)
let view_status_column =
  let status_renderer = GTree.cell_renderer_pixbuf [] in
  let v =
    GTree.view_column ~title:column_status_title
      ~renderer:(status_renderer, [ ("pixbuf", status_column) ])
      ()
  in
  v#set_resizable false;
  v#set_visible true;
  v

let view_time_column =
  let renderer = GTree.cell_renderer_text [ `XALIGN 0. ] in
  let v =
    GTree.view_column ~title:column_time_title
      ~renderer:(renderer, [ ("text", time_column) ])
      ()
  in
  v#set_resizable false;
  v#set_visible true;
  v

let goals_model, goals_view =
  Debug.dprintf debug "Creating tree model...@?";
  let model = GTree.tree_store cols in
  let view = GTree.view ~model ~packing:scrolled_session_view#add () in
  let () = view#selection#set_mode (* `SINGLE *) `MULTIPLE in
  (* let () = view#set_rules_hint true in *)
  let () = view#set_enable_search false in
  let (_ : int) = view#append_column view_status_column in
  let (_ : int) = view#append_column view_name_column in
  let (_ : int) = view#append_column view_time_column in
  view#set_expander_column (Some view_name_column);
  Debug.dprintf debug "done@.";
  (model, view)

(***********************************)
(* Mapping session to the GTK tree *)
(***********************************)

type pa_status =
  Controller_itp.proof_attempt_status
  * bool
    (* obsolete or not *)
    (* TODO *)
  * Call_provers.resource_limits

let node_id_type : node_type Hint.t = Hint.create 17
let node_id_proved : bool Hint.t = Hint.create 17
let node_id_pa : pa_status Hint.t = Hint.create 17
let node_id_detached : bool Hint.t = Hint.create 17
let get_node_type id = Hint.find node_id_type id

let get_node_proved id =
  try Hint.find node_id_proved id with
  | Not_found -> false

let get_node_id_pa id = Hint.find node_id_pa id

let get_obs (pa_st : pa_status) =
  match pa_st with
  | _, b, _ -> b

let get_proof_attempt (pa_st : pa_status) =
  match pa_st with
  | pa, _, _ -> pa

let get_node_obs id = get_obs (get_node_id_pa id)
let get_node_proof_attempt id = get_proof_attempt (get_node_id_pa id)
let get_node_id iter = goals_model#get ~row:iter ~column:node_id_column

(* To each node we have the corresponding row_reference *)
let node_id_to_gtree : GTree.row_reference Hint.t = Hint.create 42

(* TODO exception for those: *)
let get_node_row id = Hint.find node_id_to_gtree id
let get_node_detached id = Hint.find node_id_detached id

(******************************)
(* Initialization of the tree *)
(******************************)

let remove_tree goals_model =
  Hint.iter
    (fun _x i ->
      try ignore (goals_model#remove i#iter) with
      | _ -> ())
    node_id_to_gtree

let clear_tree_and_table goals_model =
  remove_tree goals_model;
  Hint.clear node_id_to_gtree;
  Hint.clear node_id_type;
  Hint.clear node_id_proved;
  Hint.clear node_id_pa;
  Hint.clear node_id_detached

(**************)
(* Menu items *)
(**************)

(* vpan222 contains: 2.2.2.1 a notebook containing view of the current task,
   source code etc 2.2.2.2 a vertical pan which contains [vbox2222] 2.2.2.2.1
   the input field to type commands 2.2.2.2.2 a scrolled window to hold the
   output of the commands *)

(* 2.2.2.2 a vertical pan which contains [vbox2222] 2.2.2.2.1 the input field to
   type commands [hbox22221] 2.2.2.2.2 a scrolled window to hold the output of
   the commands [message_zone] *)
let vbox2222 = GPack.vbox ()

(* 2.2.2.2.1 Horizontal box [hbox22221] [monitor] number of scheduled/running
   provers [command_entry] Commands to run on the session *)
let hbox22221 =
  GPack.hbox
    ~packing:(vbox2222#pack ?from:None ?expand:None ?fill:None ?padding:None)
    ()

let monitor =
  GMisc.label ~text:"  0/0/0" ~width:100 ~xalign:0.0
    ~packing:(hbox22221#pack ?from:None ?expand:None ?fill:None ?padding:None)
    ()

let command_entry =
  GEdit.entry ~placeholder_text:"type commands here" ~packing:hbox22221#add ()

(* Part 2.2.2.2.2 contains messages returned by the IDE/server *)
let messages_notebook = GPack.notebook ~packing:vbox2222#add ()

let error_page, error_view =
  let label = GMisc.label ~text:"Messages" () in
  ( 0,
    GPack.vbox ~homogeneous:false
      ~packing:(fun w ->
        ignore (messages_notebook#append_page ~tab_label:label#coerce w))
      () )

let log_view =
  let label = GMisc.label ~text:"Log" () in
  GPack.vbox ~homogeneous:false
    ~packing:(fun w ->
      ignore (messages_notebook#append_page ~tab_label:label#coerce w))
    ()

(* tab 3: edited proof *)
let edited_tab =
  let label = GMisc.label ~text:"Edited proof" () in
  GPack.vbox ~homogeneous:false
    ~packing:(fun w ->
      ignore (messages_notebook#append_page ~tab_label:label#coerce w))
    ()

let scrolled_edited_view =
  GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
    ~shadow_type:`ETCHED_OUT ~packing:edited_tab#add ()

let edited_view =
  GSourceView.source_view ~editable:false ~show_line_numbers:true
    ~packing:scrolled_edited_view#add ()

(* tab 4: prover output *)
let output_tab =
  let label = GMisc.label ~text:"Prover output" () in
  GPack.vbox ~homogeneous:false
    ~packing:(fun w ->
      ignore (messages_notebook#append_page ~tab_label:label#coerce w))
    ()

let scrolled_output_view =
  GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
    ~shadow_type:`ETCHED_OUT ~packing:output_tab#add ()

let output_view =
  GSourceView.source_view ~editable:false ~show_line_numbers:true
    ~packing:scrolled_output_view#add ()

(* tab 5: counterexample *)
let counterexample_page, counterexample_tab =
  let label = GMisc.label ~text:"Counterexample" () in
  ( 4,
    GPack.vbox ~homogeneous:false
      ~packing:(fun w ->
        ignore (messages_notebook#append_page ~tab_label:label#coerce w))
      () )

let scrolled_counterexample_view =
  GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
    ~shadow_type:`ETCHED_OUT ~packing:counterexample_tab#add ()

let counterexample_view =
  GSourceView.source_view ~editable:false ~show_line_numbers:true
    ~packing:scrolled_counterexample_view#add ()

(* Allow colors locations on counterexample view *)
let () = create_colors gconfig counterexample_view

let message_zone =
  let sv =
    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
      ~shadow_type:`ETCHED_OUT ~packing:error_view#add ()
  in
  GText.view ~editable:false ~cursor_visible:false ~packing:sv#add ()

let log_zone =
  let sv =
    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
      ~shadow_type:`ETCHED_OUT ~packing:log_view#add ()
  in
  GText.view ~editable:false ~cursor_visible:false ~packing:sv#add ()

(* Create a tag for errors in the message zone. *)
let create_msg_zone_error_tag () =
  message_zone#buffer#create_tag ~name:"error_tag_msg_zone"
    [
      `BACKGROUND gconfig.error_color_msg_zone_bg;
      `FOREGROUND gconfig.error_color_msg_zone_fg;
    ]

let message_zone_error_tag = ref (create_msg_zone_error_tag ())

(**** Message-zone printing functions *****)

let add_to_log =
  let old = ref None in
  fun notif_kind s ->
    let ((_, _, _, n) as x) =
      match !old with
      | Some (line, oldnotif_kind, olds, oldn)
        when notif_kind = oldnotif_kind && s = olds ->
        let start = log_zone#buffer#get_iter (`LINE line) in
        let stop = log_zone#buffer#end_iter in
        log_zone#buffer#delete ~start ~stop;
        (line, oldnotif_kind, olds, oldn + 1)
      | _ ->
        let line = log_zone#buffer#line_count in
        (line, notif_kind, s, 1)
    in
    old := Some x;
    log_zone#buffer#insert ("[" ^ notif_kind);
    if n > 1 then
      log_zone#buffer#insert (" (repeated " ^ string_of_int n ^ " times)");
    log_zone#buffer#insert ("] " ^ s ^ "\n");
    (* scroll to end of text. Since Gtk3 we must do it in idle() because of the
       "smooth scrolling". *)
    when_idle (fun () -> log_zone#scroll_to_mark `INSERT)

let clear_message_zone () =
  let buf = message_zone#buffer in
  buf#remove_tag_by_name "error_tag_msg_zone" ~start:buf#start_iter
    ~stop:buf#end_iter;
  buf#delete ~start:buf#start_iter ~stop:buf#end_iter

(* Function used to print stuff on the message_zone *)
let print_message ~kind ~notif_kind fmt =
  Format.kasprintf
    (fun s ->
      let s = try_convert s in
      add_to_log notif_kind s;
      let buf = message_zone#buffer in
      if kind > 0 then (
        if
          Strings.ends_with notif_kind "error"
          || Strings.ends_with notif_kind "Error"
        then
          buf#insert ~tags:[ !message_zone_error_tag ] (s ^ "\n")
        else
          buf#insert (s ^ "\n");
        messages_notebook#goto_page error_page
      ))
    fmt

let display_warnings fmt warnings =
  let nwarn = ref 0 in
  try
    Queue.iter
      (fun (loc, msg) ->
        if !nwarn = 4 then (
          Format.fprintf fmt "[%d more warnings. See stderr for details]@\n"
            (Queue.length warnings - !nwarn);
          raise Exit
        );
        incr nwarn;
        match loc with
        | None -> Format.fprintf fmt "%s@\n@\n" msg
        | Some l ->
          (* scroll_to_loc ~color:error_tag ~yalign:0.5 loc; *)
          Format.fprintf fmt "File %a: %s@\n@\n" Loc.pp_position l msg)
      warnings
  with
  | Exit -> ()

let display_warnings () =
  if Queue.is_empty warnings then
    ()
  else (
    print_message ~kind:1 ~notif_kind:"warning" "%a" display_warnings warnings;
    Queue.clear warnings
  )

let print_message ~kind ~notif_kind fmt =
  display_warnings ();
  print_message ~kind ~notif_kind fmt

(***********************************)
(*    notebook on the top 2.2.2.1  *)
(***********************************)

(* notebook is composed of a Task page and several source files pages *)
let notebook =
  GPack.notebook ~packing:(vpan222#pack1 ~resize:true ~shrink:true) ()

(* Pack vbox2222 after packing the notebook (for vertical order) *)
let () = vpan222#pack2 ~resize:false ~shrink:true vbox2222#coerce

let (_ : GtkSignal.id) =
  vpan222#set_position gconfig.task_height;
  notebook#misc#connect#size_allocate
    ~callback:(fun { Gtk.width = _w; Gtk.height = h } ->
      gconfig.task_height <- h)

(********************************)
(* Task view (part of notebook) *)
(********************************)

let scrolled_task_view =
  let label = GMisc.label ~text:"Task" () in
  GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
    ~shadow_type:`ETCHED_OUT
    ~packing:(fun w -> ignore (notebook#append_page ~tab_label:label#coerce w))
    ()

let task_view =
  GSourceView.source_view ~editable:false ~cursor_visible:true
    ~show_line_numbers:true ~packing:scrolled_task_view#add ()

let () = create_colors gconfig task_view
let why_lang = get_extra_lang "why3" "Why3"
let why3py_lang = get_extra_lang "why3py" "Why3python"
let why3c_lang = get_extra_lang "why3c" "Why3c"
let coma_lang = get_extra_lang "coma" "Coma"
let rust_lang = get_extra_lang "rust" "Rust"
let ada_lang = get_extra_lang "ada" "Ada"
let java_lang = get_extra_lang "java" "Java"
let c_lang = get_extra_lang "c" "C"

let change_lang view lang =
  let lang =
    match lang with
    | "python"  -> why3py_lang ()
    | "micro-C" -> why3c_lang ()
    | ".rs"     -> rust_lang ()
    | ".adb"    -> ada_lang ()
    | ".ads"    -> ada_lang ()
    | ".java"   -> java_lang ()
    | ".c"      -> c_lang ()
    | "coma"
    | ".coma"   -> coma_lang ()
    | ".mlw"
    | ".why"
    | "whyml"   ->  why_lang ()
    | _ ->
        Loc.warning warn_unknown_format "Unrecognized source format `%s`" lang;
        None
  in
    view#source_buffer#set_language lang

(* Create an eventbox for the title label of the notebook tab *)
let create_eventbox ~read_only file =
  let eventbox = GBin.event_box () in
  let right_click_label_menu = GMenu.menu () in
  (* Create a menu for this eventbox *)
  let () =
    let close_item = GMenu.menu_item ~label:"close" () in
    if read_only then
      let (_ : GtkSignal.id) =
        close_item#connect#activate ~callback:(fun () ->
            match Hstr.find source_view_table file with
            | exception Not_found ->
              print_message ~kind:1 ~notif_kind:"ide_error"
                "Error of the graphic interface: cannot find %s" file
            | page_number, _, _, _ ->
              notebook#remove_page page_number;
              Hstr.remove source_view_table file)
      in
      right_click_label_menu#append close_item
  in
  (* Connect the menu in the eventbox *)
  let (_ : GtkSignal.id) =
    eventbox#event#connect#button_press ~callback:(fun v ->
        let n = GdkEvent.Button.button v in
        if n = 3 then
          right_click_label_menu#popup ~button:3 ~time:(GdkEvent.Button.time v);
        false (* Allow other handlers *))
  in
  eventbox

let create_raw_source_view ~read_only f contents =
  let fl = Filename.basename f in
  let markup =
    if read_only then
      "<span font-style=\"italic\">" ^ fl ^ "</span>"
    else
      fl
  in
  let eventbox = create_eventbox ~read_only f in
  let label = GMisc.label ~packing:(fun w -> eventbox#add w) ~markup () in
  label#misc#set_tooltip_markup f;
  let scrolled_source_view =
    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
      ~shadow_type:`ETCHED_OUT (* ~packing:scrolled_source_view#add *) ()
  in
  let source_page =
    notebook#append_page ~tab_label:eventbox#coerce scrolled_source_view#coerce
  in
  let editable = gconfig.allow_source_editing && not read_only in
  let source_view =
    GSourceView.source_view ~auto_indent:editable
      ~insert_spaces_instead_of_tabs:true ~tab_width:2
      ~show_line_numbers:true
        (* ~right_margin_position:80 ~show_right_margin:true *)
        (* ~smart_home_end:true *)
      ~editable ~packing:scrolled_source_view#add ()
  in
  source_view#source_buffer#begin_not_undoable_action ();
  source_view#source_buffer#set_text contents;
  source_view#source_buffer#end_not_undoable_action ();
  source_view#source_buffer#set_modified false;
  Hstr.add source_view_table f (source_page, source_view, label, read_only);
  Gconfig.add_modifiable_mono_font_view source_view#misc;
  create_colors gconfig source_view;
  Gconfig.set_fonts ();
  (source_page, source_view)

(* Create a page with tabname [f] and buffer equal to [content] in the notebook.
   Also add a corresponding page in source_view_table. *)
let create_source_view ~read_only f content f_format =
  if not (Hstr.mem source_view_table f) then (
    let source_page, source_view =
      create_raw_source_view ~read_only f content
    in
    (* At initialization, file has not changed. When it changes, changes the
       name of the tab and update has_changed boolean. *)
    let (_ : GtkSignal.id) =
      source_view#source_buffer#connect#modified_changed ~callback:(fun () ->
          try
            let _source_page, source_view, label, read_only =
              Hstr.find source_view_table f
            in
            if not read_only then
              if source_view#source_buffer#modified then
                update_label_change label
              else
                update_label_saved label
          with
          | Not_found -> ())
    in
    change_lang source_view f_format;
    (* We have to create the tags for background colors for each view. They are
       not reusable from the other views. *)
    (* Focusing on the tabs that was just added *)
    notebook#goto_page source_page
  )

(* This returns the source_view of a file *)
let get_source_view (file : string) : GSourceView.source_view =
  if file = "Task" then
    task_view
  else
    match Hstr.find source_view_table file with
    | _, v, _, _ -> v
    | exception Not_found -> raise (Nosourceview file)

(* End of notebook *)

(**** Monitor *****)

let fan =
  let s = Bytes.of_string "\226\150\129" in
  let c = Char.code (Bytes.get s 2) in
  let a =
    Array.init 8 (fun i ->
        Bytes.set s 2 (Char.chr (c + i));
        Bytes.to_string s)
  in
  fun n ->
    let n = n mod 14 in
    let n =
      if n < 0 then
        n + 14
      else
        n
    in
    let n =
      if n >= 8 then
        14 - n
      else
        n
    in
    a.(n)

let update_monitor =
  let c = ref 0 in
  fun t s r ->
    incr c;
    let f =
      if r = 0 then
        " "
      else
        fan !c
    in
    let text = Printf.sprintf "%s %d/%d/%d" f t s r in
    monitor#set_text text

(**********************)
(* Cursor positioning *)
(**********************)

(* Current position in the source files *)
let current_cursor_loc = ref None

let move_to_line ?(character = 0) ~yalign (v : GSourceView.source_view) line =
  let line = max 0 (line - 1) in
  let line = min line v#buffer#line_count in
  (* Warning : Do not use LINECHAR here as it fails when there is not enough
     char on the line. *)
  let it = v#buffer#get_iter (`LINE line) in
  let it = it#forward_chars character in
  v#buffer#place_cursor ~where:it;
  let mark = `MARK (v#buffer#create_mark it) in
  (* Make the left side of the code always visible *)
  let xalign = 1.0 in
  v#scroll_to_mark ~use_align:true ~yalign ~xalign mark

(* Scroll to a specific locations *)
let scroll_to_loc ~force_tab_switch loc_of_goal =
  match loc_of_goal with
  | None -> ()
  | Some loc ->
    let f, l, e, _, _ = Loc.get loc in
    let n, v =
      if f = "Task" then
        (0, task_view)
      else
        try
          let n, v, _, _ = get_source_view_table f in
          (n, v)
        with
        | Nosourceview f ->
          let s =
            try Sysutil.file_contents f with
            | exn ->
              Format.asprintf "Error with scroll_to_loc to loc='%a':@ %a"
                Loc.pp_position loc Exn_printer.exn_printer exn
          in
          let n, v = create_raw_source_view ~read_only:true f s in
          change_lang v (Filename.extension f);
          (n, v)
    in

    if force_tab_switch then (
      Debug.dprintf debug "tab switch to page %d@." n;
      notebook#goto_page n
    );
    when_idle (fun () ->
        (* 0.5 to focus on the middle of the screen *)
        move_to_line ~character:e ~yalign:0.5 v l)

let scroll_to_loc_ce loc_of_goal =
  match loc_of_goal with
  | None -> ()
  | Some loc ->
    let _, l, _, _, _ = Loc.get loc in
    (* 0.5 to focus on the middle of the screen *)
    when_idle (fun () -> move_to_line ~yalign:0.5 counterexample_view l)

(* Reposition the cursor to the place it was saved *)
let reposition_ide_cursor () =
  scroll_to_loc ~force_tab_switch:false !current_cursor_loc

let find_current_file_view () =
  let n = notebook#current_page in
  if n = 0 then
    Some ("Task", task_view)
  else
    let acc = ref None in
    Hstr.iter
      (fun k (x, v, _, _) -> if x = n then acc := Some (k, v))
      source_view_table;
    !acc

(* Save the current location of the cursor to be reused after reload *)
let save_cursor_loc cursor_ref =
  let cur_fv = find_current_file_view () in
  match cur_fv with
  | None -> ()
  | Some (cur_file, view) ->
    (* Get current line *)
    let line = (view#buffer#get_iter_at_mark `INSERT)#line + 1 in
    cursor_ref := Some (Loc.user_position cur_file line 0 line 0)

(******************)
(* Reload actions *)
(******************)

let reload_unsafe () =
  save_cursor_loc current_cursor_loc;
  clear_message_zone ();
  send_request Reload_req

let save_and_reload () =
  save_sources ();
  reload_unsafe ()

let export_as_zip () =
  save_sources ();
  send_request Export_as_zip

(****************************)
(* command entry completion *)
(****************************)

let completion_cols = new GTree.column_list
let completion_col = completion_cols#add Gobject.Data.string
let completion_desc = completion_cols#add Gobject.Data.string
let completion_model = GTree.tree_store completion_cols

let command_entry_completion : GEdit.entry_completion =
  GEdit.entry_completion ~model:completion_model ()

let add_completion_entry (s, desc) =
  let row = completion_model#append () in
  completion_model#set ~row ~column:completion_col s;
  completion_model#set ~row ~column:completion_desc desc

(* We need to know when the completion popup is active for some shortcuts.
   However, we didn't find a way to know it using LablGtk functions so we have
   to use this little hack *)
let completion_popup_is_active = ref false

let match_function s iter =
  if String.length s < 2 then (
    completion_popup_is_active := false;
    false
  ) else
    let candidate = completion_model#get ~row:iter ~column:completion_col in
    try
      ignore
        (Re.Str.search_forward (Re.Str.regexp_string_case_fold s) candidate 0);
      completion_popup_is_active := true;
      true
    with
    | Not_found ->
      completion_popup_is_active := false;
      false

(* see also init_completion below *)

(*********************)
(* Terminal history  *)
(*********************)

let list_commands = create_history ()

let _ =
  command_entry#event#connect#key_press ~callback:(fun (ev : 'a Gdk.event) ->
      match GdkEvent.Key.keyval ev with
      (* Arrow up/down when the completion popup is not active *)
      | k
        when (k = GdkKeysyms._Up || k = GdkKeysyms._Down)
             && not !completion_popup_is_active -> (
        (* Set the text to the next/prev command in the command history. If
           there is none, do nothing *)
        let s =
          if k = GdkKeysyms._Up then
            print_next_command list_commands
          else
            print_prev_command list_commands
        in
        match s with
        | None -> true
        | Some s ->
          command_entry#set_text s;
          command_entry#misc#grab_focus ();
          true)
      | k when k = GdkKeysyms._Escape ->
        (* Unfocus the command entry *)
        goals_view#misc#grab_focus ();
        true
      | k when k = GdkKeysyms._Tab ->
        (* If the completion is active on a prefix, set the cursor to the end of
           this prefix in the command entry. If no completion is active, do
           nothing *)
        if !completion_popup_is_active then
          match command_entry#selection with
          | Some (_, e) ->
            command_entry#set_position e;
            true
          | _ -> true
        else
          true
      | _ -> false)

(* Small hack to avoid pasting consecutive whitespaces and newlines in the
   command entry. We remove them from the clipboard before pasting, then restore
   it *)
let saved_clip = ref ""

let _ =
  command_entry#connect#paste_clipboard ~callback:(fun () ->
      let clip = GtkBase.Clipboard.get Gdk.Atom.clipboard in
      let text = GtkBase.Clipboard.wait_for_text clip in
      match text with
      | None -> ()
      | Some text ->
        saved_clip := text;
        let whitespace = ref false in
        let s = ref "" in
        let is_whitespace c =
          c = ' ' || c = '\x0C' || c = '\n' || c = '\r' || c = '\t'
        in
        let sanitize c =
          if is_whitespace c then (
            if not !whitespace then (
              whitespace := true;
              s := !s ^ " "
            )
          ) else (
            whitespace := false;
            s := !s ^ String.make 1 c
          )
        in
        String.iter sanitize text;
        s := String.trim !s;
        GtkBase.Clipboard.set_text clip !s)

(* Restore the clipboard after pasting *)
let _ =
  command_entry#connect#after#paste_clipboard ~callback:(fun () ->
      let clip = GtkBase.Clipboard.get Gdk.Atom.clipboard in
      GtkBase.Clipboard.set_text clip !saved_clip;
      saved_clip := "")

let () = send_session_config_to_server ()

(********************)
(* Locations colors *)
(********************)

let convert_color (color : color) : string =
  match color with
  | Neg_premise_color -> "neg_premise_tag"
  | Premise_color -> "premise_tag"
  | Goal_color -> "goal_tag"
  | Error_color -> "error_tag"
  | Error_line_color -> "error_line_tag"
  | Error_font_color -> "error_font_tag"
  | Search_color -> "search_tag"

let color_line ~color loc =
  let color_line (v : GSourceView.source_view) ~color l =
    let buf = v#buffer in
    let top = buf#start_iter in
    let start = top#forward_lines (l - 1) in
    let stop = start#forward_lines 1 in
    buf#apply_tag_by_name ~start ~stop color
  in

  let f, l, _, _, _ = Loc.get loc in
  try
    let v = get_source_view f in
    let color = convert_color color in
    color_line ~color v l
  with
  | Nosourceview f ->
    (* If the file is not present do nothing *)
    print_message ~kind:0 ~notif_kind:"color_loc" "No source view for file %s" f;
    Debug.dprintf debug "color_loc: no source view for file %s@." f

(* Add a color tag on the right locations on the correct file. If the file was
   not open yet, nothing is done *)
let color_loc ?(ce = false) ~color loc =
  (* This apply a background [color] on a location given by its file view [v]
     line [l] beginning char [b] and end char [e]. *)
  let color_loc (v : GSourceView.source_view) ~color bl bc el ec =
    let buf = v#buffer in
    let top = buf#start_iter in
    let start = top#forward_lines (bl - 1) in
    let start = start#forward_chars bc in
    let stop = top#forward_lines (el - 1) in
    let stop = stop#forward_chars ec in
    buf#apply_tag_by_name ~start ~stop color
  in

  let f, bl, bc, el, ec = Loc.get loc in
  try
    let v =
      if ce then
        counterexample_view
      else
        get_source_view f
    in
    let color = convert_color color in
    color_loc ~color v bl bc el ec
  with
  | Nosourceview f ->
    (* If the file is not present do nothing *)
    print_message ~kind:0 ~notif_kind:"color_loc" "No source view for file %s" f;
    Debug.dprintf debug "color_loc: no source view for file %s@." f

(* Erase the colors and apply the colors given by l (which come from the task)
   to appropriate source files *)
let apply_loc_on_source (l : (Loc.position * color) list) loc_goal =
  erase_loc_all_view ();
  scroll_to_loc ~force_tab_switch:false loc_goal;
  List.iter (fun (loc, color) -> color_loc ~color loc) l

(* Erase the colors and apply the colors given by l (which come from the task)
   to the counterexample tab *)
let apply_loc_on_ce (l : (Loc.position * color) list) =
  erase_color_loc counterexample_view;
  List.iter (fun (loc, color) -> color_loc ~ce:true ~color loc) l

let collapse_iter iter =
  let path = goals_model#get_path iter in
  goals_view#collapse_row path

let rec collapse_proven_goals_from_iter iter =
  let node_id = get_node_id iter in
  let is_proved = get_node_proved node_id in
  if is_proved then
    collapse_iter iter
  else
    let n = goals_model#iter_n_children (Some iter) in
    for i = 0 to n - 1 do
      collapse_proven_goals_from_iter
        (goals_model#iter_children ?nth:(Some i) (Some iter))
    done

let collapse_proven_goals () =
  match goals_model#get_iter_first with
  | None -> ()
  | Some root_iter -> collapse_proven_goals_from_iter root_iter

let () =
  Gconfig.add_modifiable_sans_font_view goals_view#misc;
  Gconfig.add_modifiable_mono_font_view monitor#misc;
  Gconfig.add_modifiable_mono_font_view task_view#misc;
  Gconfig.add_modifiable_mono_font_view edited_view#misc;
  Gconfig.add_modifiable_mono_font_view output_view#misc;
  Gconfig.add_modifiable_mono_font_view counterexample_view#misc;
  Gconfig.add_modifiable_mono_font_view command_entry#misc;
  Gconfig.add_modifiable_mono_font_view message_zone#misc;
  task_view#source_buffer#set_language (why_lang ());
  counterexample_view#source_buffer#set_language (why_lang ());
  Gconfig.set_fonts ()

(******************)
(*    actions     *)
(******************)

let get_selected_row_references () =
  List.map
    (fun path -> goals_model#get_row_reference path)
    goals_view#selection#get_selected_rows

(**********************)
(* Contextual actions *)
(**********************)

(* goals_view#selection#select_iter only changes the selection for the selection
   tree, it should also change the cursor of the goal_view. The reason is that
   the cursor is used for arrow keys moves (not the selected row). *)
let select_iter iter =
  goals_view#selection#select_iter iter;
  let path = goals_model#get_path iter in
  goals_view#set_cursor path view_name_column

let expand_row () =
  let rows = get_selected_row_references () in
  match rows with
  | [ row ] ->
    let path = goals_model#get_path row#iter in
    goals_view#expand_row path ~all:(goals_view#row_expanded path)
  | _ -> ()

let collapse_row () =
  let rows = get_selected_row_references () in
  match rows with
  | [ row ] ->
    let path = goals_model#get_path row#iter in
    goals_view#collapse_row path
  | _ -> ()

let move_current_row_selection_to_parent () : unit =
  (* We hijack CTRL+left shortcut when the command entry is focused *)
  if command_entry#has_focus then (
    if command_entry#position > 0 then
      command_entry#set_position (command_entry#position - 1);
    (* Move the cursor to the beginning of the current word *)
    while
      command_entry#position > 0
      && command_entry#get_chars
           ~start:(command_entry#position - 1)
           ~stop:command_entry#position
         <> " "
    do
      command_entry#set_position (command_entry#position - 1)
    done
  ) else
    let rows = get_selected_row_references () in
    match rows with
    | [ row ] -> (
      goals_view#selection#unselect_all ();
      match goals_model#iter_parent row#iter with
      | None -> ()
      | Some iter -> select_iter iter)
    | _ -> ()

let move_current_row_selection_to_first_child () =
  let rows = get_selected_row_references () in
  match rows with
  | [ row ] ->
    let n = goals_model#iter_n_children (Some row#iter) in
    if n = 0 then
      ()
    else (
      goals_view#selection#unselect_all ();
      let iter = goals_model#iter_children ?nth:(Some 0) (Some row#iter) in
      select_iter iter
    )
  | _ -> ()

let move_current_row_selection_to_down () =
  let rows = get_selected_row_references () in
  match rows with
  | [ row ] ->
    let path = goals_model#get_path row#iter in
    GtkTree.TreePath.down path;
    goals_view#selection#unselect_all ();
    goals_view#selection#select_path path;
    goals_view#set_cursor path view_name_column
  | _ -> ()

let move_current_row_selection_to_next () =
  let rows = get_selected_row_references () in
  match rows with
  | [ row ] ->
    let path = goals_model#get_path row#iter in
    GtkTree.TreePath.next path;
    goals_view#selection#unselect_all ();
    goals_view#selection#select_path path;
    goals_view#set_cursor path view_name_column
  | _ -> ()

let move_to_next_unproven_node_id strat =
  (* We hijack CTRL+right shortcut when the command entry is focused *)
  match strat with
  | Clever when command_entry#has_focus ->
    if
      command_entry#get_chars ~start:command_entry#position
        ~stop:(command_entry#position + 1)
      <> ""
    then
      command_entry#set_position (command_entry#position + 1);
    (* Move the cursor to the end of the current word *)
    while
      command_entry#get_chars ~start:command_entry#position
        ~stop:(command_entry#position + 1)
      <> " "
      && command_entry#get_chars ~start:command_entry#position
           ~stop:(command_entry#position + 1)
         <> ""
    do
      command_entry#set_position (command_entry#position + 1)
    done
  | _ -> (
    let rows = get_selected_row_references () in
    match rows with
    | [ row ] ->
      let row_id = get_node_id row#iter in
      manual_next := Some row_id;
      send_request (Get_first_unproven_node (strat, row_id))
    | _ -> ())

(* unused let rec update_status_column_from_iter cont iter = set_status_column
   iter; match goals_model#iter_parent iter with | Some p ->
   update_status_column_from_iter cont p | None -> () *)

let clear_command_entry () = command_entry#set_text ""

let ide_command_list =
  [
    ("up", "Select the parent of the current node");
    ("down", "Select the first child of the current node");
    ("next", "Select the \"next\" unproved node");
    ("expand", "Expand the node");
    ("ex_all", "Expand the node recursively");
    ("collapse", "Collapse the node");
    ("list_ide_command", "show this help text");
  ]

let ide_command cmd = List.exists (fun x -> fst x = cmd) ide_command_list

let interp_ide cmd =
  match cmd with
  | "up" -> move_current_row_selection_to_parent ()
  | "down" -> move_current_row_selection_to_first_child ()
  | "next" -> move_to_next_unproven_node_id Clever
  | "expand" -> expand_row ()
  | "collapse" -> collapse_row ()
  | "list_ide_command" ->
    let s =
      List.fold_left
        (fun acc x -> fst x ^ ": " ^ snd x ^ "\n" ^ acc)
        "" ide_command_list
    in
    clear_command_entry ();
    print_message ~kind:1 ~notif_kind:"Info" "%s" s
  | _ ->
    clear_command_entry ();
    print_message ~kind:1 ~notif_kind:"error" "Error: %s\nPlease report." cmd

let interp cmd =
  (* TODO: do some preprocessing for queries, or leave everything to server ? *)
  message_zone#buffer#set_text "";
  clear_command_entry ();
  if ide_command cmd then
    interp_ide cmd
  else
    let rows = get_selected_row_references () in
    let ids =
      match rows with
      | [] -> [ root_node ]
      | _ -> List.map (fun n -> get_node_id n#iter) rows
    in
    List.iter (fun id -> send_request (Command_req (id, cmd))) ids
(* clear previous error message if any *)

let (_ : GtkSignal.id) =
  let callback () =
    let cmd = command_entry#text in
    match cmd with
    | "" -> goals_view#misc#grab_focus ()
    | _ ->
      add_command list_commands cmd;
      interp cmd
  in
  command_entry#connect#activate ~callback

let on_selected_row r =
  try
    let id = get_node_id r#iter in
    let typ = get_node_type id in
    match typ with
    | NGoal ->
      let c = gconfig.show_full_context in
      let show_uses_clones_metas = gconfig.show_uses_clones_metas in
      send_request (Get_task (id, c, show_uses_clones_metas, true))
    | NProofAttempt ->
      let pa, _obs, _l = Hint.find node_id_pa id in
      let output_text =
        match pa with
        | Controller_itp.Done pr -> pr.Call_provers.pr_output
        | Controller_itp.Undone -> "no result known"
        | Controller_itp.Detached ->
          "detached proof attempt: parent goal has no task"
        | Controller_itp.Interrupted -> "prover run was interrupted"
        | Controller_itp.Scheduled -> "proof scheduled but not running yet"
        | Controller_itp.Running -> "prover currently running"
        | Controller_itp.InternalFailure e ->
          Pp.sprintf "internal failure: %a" Exn_printer.exn_printer e
        | Controller_itp.Uninstalled _p -> "uninstalled prover"
        | Controller_itp.Removed _p -> "removed proof attempt"
        | Controller_itp.UpgradeProver _p -> "upgraded prover"
      in
      let output_text =
        if output_text = "" then
          "(no output known, you may consider running the prover again)"
        else
          output_text
      in
      output_view#source_buffer#set_text output_text;
      edited_view#source_buffer#set_text "(not yet available)";
      edited_view#scroll_to_mark `INSERT;
      counterexample_view#source_buffer#set_text "(not yet available)";
      counterexample_view#scroll_to_mark `INSERT;
      let c = gconfig.show_full_context in
      let show_uses_clones_metas = gconfig.show_uses_clones_metas in
      send_request (Get_task (id, c, show_uses_clones_metas, true))
    | _ ->
      let c = gconfig.show_full_context in
      let show_uses_clones_metas = gconfig.show_uses_clones_metas in
      send_request (Get_task (id, c, show_uses_clones_metas, true))
  with
  | Not_found -> task_view#source_buffer#set_text ""

let (_ : GtkSignal.id) =
  goals_view#selection#connect#after#changed ~callback:(fun () ->
      Debug.dprintf debug
        "running callback of goals_view#selection#connect#after#changed@.";
      match get_selected_row_references () with
      | [ r ] -> on_selected_row r
      | _ -> ()
      (* ; command_entry#misc#grab_focus () *))

let (_ : GtkSignal.id) =
  let callback ev =
    Debug.dprintf debug
      "running callback of goals_view#event#connect#button_press@.";
    let n = GdkEvent.Button.button ev in
    Debug.dprintf debug "button number %d was clicked on the tree view@." n;
    match n with
    | 3 ->
      (* Right click *)
      let sel = goals_view#selection in
      let x = int_of_float (GdkEvent.Button.x ev) in
      let y = int_of_float (GdkEvent.Button.y ev) in
      (match goals_view#get_path_at_pos ~x ~y with
      | Some (path, _, _, _) when not (sel#path_is_selected path) ->
        sel#unselect_all ();
        sel#select_path path
      | _ -> ());
      context_tools_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev);
      true
    | 1 ->
      (* Left click *)
      (* Call get-ce only when clicked on the Status of a proofattempt (which is
         unproved) *)
      let x = int_of_float (GdkEvent.Button.x ev) in
      let y = int_of_float (GdkEvent.Button.y ev) in
      (match goals_view#get_path_at_pos ~x ~y with
      | Some (path, col, _, _) ->
        if col#title = column_status_title then
          let node_id = get_node_id (goals_model#get_row_reference path)#iter in
          let type_id = get_node_type node_id in
          let proved_id = get_node_proved node_id in
          if type_id = NProofAttempt && not proved_id then
            send_request (Command_req (node_id, "get-ce"))
      | _ -> ());
      false
    | _ -> (* Other buttons *) false
  in
  goals_view#event#connect#button_press ~callback

let (_ : GtkSignal.id) =
  let callback ev =
    match GdkEvent.Key.keyval ev with
    | k when k = GdkKeysyms._Return ->
      command_entry#misc#grab_focus ();
      true
    | k when k = GdkKeysyms._Left ->
      collapse_row ();
      true
    | k when k = GdkKeysyms._Right ->
      expand_row ();
      true
    | _ -> false
  in
  goals_view#event#connect#key_press ~callback

(*********************************)
(* add a new file in the project *)
(*********************************)

let filter_all_files () =
  let f = GFile.filter ~name:"All" () in
  f#add_pattern "*";
  f

let filter_why_files () =
  GFile.filter ~name:"Why3 source files" ~patterns:[ "*.why"; "*.mlw" ] ()

let select_file ~request =
  let d =
    GWindow.file_chooser_dialog ~action:`OPEN ~title:"Why3: Add file in project"
      ()
  in
  d#add_button_stock `CANCEL `CANCEL;
  d#add_select_button_stock `OPEN `OPEN;
  d#add_filter (filter_why_files ());
  d#add_filter (filter_all_files ());
  (match d#run () with
  | `OPEN -> (
    match d#filename with
    | None -> ()
    | Some f -> request f)
  | `DELETE_EVENT
  | `CANCEL ->
    ());
  d#destroy ()

(*************************)
(* Notification Handling *)
(*************************)

let treat_message_notification msg =
  match msg with
  (* TODO: do something ! *)
  | Proof_error (_id, s) ->
    print_message ~kind:1 ~notif_kind:"Proof_error" "%s" s
  | Transf_error (true, _id, tr_name, _arg, _loc, msg, _doc) ->
    (* When the error reported by the transformation is fatal, we notify the
       user with a popup. *)
    let msg =
      Format.sprintf "Please report:\nTransformation %s failed: \n%s\n" tr_name
        msg
    in
    GToolbox.message_box ~title:"Why3 fatal error" msg
  | Transf_error (false, _id, tr_name, arg, loc, msg, doc) ->
    if arg = "" then
      print_message ~kind:1 ~notif_kind:"Transformation Error"
        "%s\nTransformation failed: \n%s\n\n%s" msg tr_name doc
    else
      let buf = message_zone#buffer in
      print_message ~kind:1 ~notif_kind:"Transformation Error"
        "%s\nTransformation failed. \nOn argument: \n%s \n%s\n\n%s" tr_name arg
        msg doc;
      (* remove all coloration in message_zone before coloring *)
      buf#remove_tag_by_name "error_tag" ~start:buf#start_iter
        ~stop:buf#end_iter;
      let color = "error_tag" in
      let _, bline, bchar, eline, echar = Loc.get loc in
      (* FIXME: explain why do we add 3 *)
      let start = buf#start_iter#forward_lines (3 + bline) in
      let start = start#forward_chars bchar in
      let stop = buf#start_iter#forward_lines (3 + eline) in
      let stop = stop#forward_chars echar in
      buf#apply_tag_by_name ~start ~stop color
  | Strat_error (_id, s) ->
    print_message ~kind:1 ~notif_kind:"Strat_error" "%s" s
  | Replay_Info s -> print_message ~kind:0 ~notif_kind:"Replay_info" "%s" s
  | Query_Info (_id, s) -> print_message ~kind:1 ~notif_kind:"Query_info" "%s" s
  | Query_Error (_id, s) ->
    print_message ~kind:1 ~notif_kind:"Query_error" "%s" s
  | Information s -> print_message ~kind:1 ~notif_kind:"Information" "%s" s
  | Task_Monitor (t, s, r) -> update_monitor t s r
  | Open_File_Error s ->
    print_message ~kind:0 ~notif_kind:"Open_File_Error" "%s" s
  | Parse_Or_Type_Error (loc, _rel_loc, s) ->
    if gconfig.allow_source_editing || !initialization_complete then (
      scroll_to_loc ~force_tab_switch:true (Some loc);
      color_line ~color:Error_line_color loc;
      color_loc ~color:Error_color loc;
      color_loc ~color:Error_font_color loc;
      print_message ~kind:1 ~notif_kind:"Parse_Or_Type_Error" "%s" s
    ) else (
      Format.eprintf "File %a: %s@." Loc.pp_position loc s;
      exit 1
    )
  | File_Saved f -> (
    try
      let _source_page, source_view, _, _ = Hstr.find source_view_table f in
      source_view#source_buffer#set_modified false;
      print_message ~kind:1 ~notif_kind:"File_Saved" "%s was saved" f
    with
    | Not_found ->
      print_message ~kind:1 ~notif_kind:"File_Saved"
        "Please report: %s was not found in IDE but was saved in session" f)
  | Error s ->
    print_message ~kind:1 ~notif_kind:"General request failure" "%s" s

let is_selected_alone id =
  match get_selected_row_references () with
  | [ r ] ->
    let i = get_node_id r#iter in
    i = id
  | _ -> false

(**************************)
(* Graphical proof status *)
(**************************)

let image_of_pa_status ~obsolete pa =
  match pa with
  | Controller_itp.Undone
  | Controller_itp.Interrupted ->
    !image_undone
  | Controller_itp.Scheduled -> !image_scheduled
  | Controller_itp.Running -> !image_running
  | Controller_itp.InternalFailure _e -> !image_failure
  | Controller_itp.Detached -> !image_undone (* TODO !image_detached *)
  | Controller_itp.Uninstalled _p -> !image_undone (* TODO !image_uninstalled *)
  | Controller_itp.Removed _p -> !image_undone (* TODO !image_removed *)
  | Controller_itp.UpgradeProver _p -> !image_undone
  | Controller_itp.Done r -> (
    let pr_answer = r.Call_provers.pr_answer in
    match pr_answer with
    | Call_provers.Valid ->
      if obsolete then
        !image_valid_obs
      else
        !image_valid
    | Call_provers.Invalid ->
      if obsolete then
        !image_invalid_obs
      else
        !image_invalid
    | Call_provers.Timeout ->
      if obsolete then
        !image_timeout_obs
      else
        !image_timeout
    | Call_provers.OutOfMemory ->
      if obsolete then
        !image_outofmemory_obs
      else
        !image_outofmemory
    | Call_provers.StepLimitExceeded ->
      if obsolete then
        !image_steplimitexceeded_obs
      else
        !image_steplimitexceeded
    | Call_provers.Unknown _ ->
      if obsolete then
        !image_unknown_obs
      else
        !image_unknown
    | Call_provers.Failure _ ->
      if obsolete then
        !image_failure_obs
      else
        !image_failure
    | Call_provers.HighFailure _ ->
      if obsolete then
        !image_failure_obs
      else
        !image_failure)

module C = Controller_itp

(* Returns true if the current row is an ancestor of the selected row *)
let selected_ancestor row =
  match get_selected_row_references () with
  | [ selected_row ] ->
    not (goals_model#is_ancestor ~iter:row#iter ~descendant:selected_row#iter)
  | _ -> false

let set_status_and_time_column ?limit row =
  let id = get_node_id row#iter in
  let proved = get_node_proved id in
  let detached = get_node_detached id in
  let image =
    match get_node_type id with
    | NRoot -> assert false
    | NFile
    | NTheory
    | NTransformation
    | NGoal ->
      if detached then (
        goals_model#set ~row:row#iter ~column:time_column "(detached)";
        !image_valid_obs
      ) else if proved then (
        Debug.dprintf debug "Collapsing row for proved node %d@." id;
        (* We should only collapse if it does not collapse the selected row
           because collapsing unselects the focused row in this case. *)
        if selected_ancestor row then
          goals_view#collapse_row (goals_model#get_path row#iter);
        !image_valid
      ) else
        (* goals_view#expand_row (goals_model#get_path row#iter); *)
        !image_unknown
    | NProofAttempt ->
      let pa = get_node_proof_attempt id in
      let obs = get_node_obs id in
      let t =
        match pa with
        | C.Done r ->
          let time = r.Call_provers.pr_time in
          let steps = r.Call_provers.pr_steps in
          let s =
            if gconfig.show_time_limit then
              match limit with
              | Some l ->
                Format.sprintf "%.2f [%.2f]" time l.Call_provers.limit_time
              | None -> Format.sprintf "%.2f" time
            else
              Format.sprintf "%.2f" time
          in
          if steps >= 0 then
            Format.sprintf "%s (steps: %d)" s steps
          else
            s
        | C.InternalFailure _ -> "(internal failure)"
        | C.Interrupted -> "(interrupted)"
        | C.Undone -> "(undone)"
        | C.Uninstalled _ -> "(uninstalled prover)"
        | C.UpgradeProver _ -> "(upgraded prover)"
        | C.Removed _ -> "(removed prover)"
        | C.Scheduled -> "(scheduled)"
        | C.Running -> "(running)"
        | C.Detached -> "(detached)"
      in
      let t =
        match pa with
        | C.Scheduled
        | C.Running -> (
          match limit with
          | Some l ->
            t
            ^ Format.sprintf " [limit=%.2f sec., %d M]"
                l.Call_provers.limit_time l.Call_provers.limit_mem
          | None -> t ^ " [no limit known]")
        | _ -> t
      in
      let t =
        if obs then
          t ^ " (obsolete)"
        else
          t
      in
      let t =
        if detached then
          t ^ " (detached)"
        else
          t
      in
      goals_model#set ~row:row#iter ~column:time_column t;
      image_of_pa_status ~obsolete:obs pa
  in
  goals_model#set ~row:row#iter ~column:status_column image

let new_node ?parent id name typ detached =
  if not (Hint.mem node_id_to_gtree id) then (
    Hint.add node_id_type id typ;
    Hint.add node_id_detached id detached;
    (* The tree does not have a root by default so the task is a forest with
       several root files *)
    let iter =
      match parent with
      | None -> goals_model#append ()
      | Some p -> goals_model#append ~parent:p#iter ()
    in
    goals_model#set ~row:iter ~column:name_column name;
    goals_model#set ~row:iter ~column:node_id_column id;
    goals_model#set ~row:iter ~column:icon_column
      (match typ with
      | NGoal -> !image_goal
      | NRoot
      | NFile ->
        !image_file
      | NTheory -> !image_theory
      | NTransformation -> !image_transf
      | NProofAttempt -> !image_prover);
    let path = goals_model#get_path iter in
    let new_ref = goals_model#get_row_reference path in
    Hint.add node_id_to_gtree id new_ref;
    set_status_and_time_column new_ref;
    new_ref
  ) else
    Hint.find node_id_to_gtree id

let on_selected_rows ~multiple ~notif_kind ~action f () =
  match get_selected_row_references () with
  | [] ->
    print_message ~kind:1 ~notif_kind
      "Select at least one node to perform the '%s' action" action
  | _ :: _ :: _ when not multiple ->
    print_message ~kind:1 ~notif_kind
      "Select at most one node to perform the '%s' action" action
  | l -> List.iter (fun r -> send_request (f (get_node_id r#iter))) l

(**************************)
(* Helpers for menu items *)
(**************************)

let remove_mnemonic s =
  try
    let j = ref (String.index s '_') in
    let i = ref 0 in
    let n = String.length s in
    let b = Buffer.create n in
    try
      while true do
        Buffer.add_substring b s !i (!j - !i);
        i := !j + 1;
        if !i = n then raise Not_found;
        Buffer.add_char b s.[!i];
        incr i;
        j := String.index_from s !i '_'
      done;
      assert false
    with
    | Not_found ->
      Buffer.add_substring b s !i (n - !i);
      Buffer.contents b
  with
  | Not_found -> s

class menu_factory ~accel_path:menu_path ~accel_group:menu_group menu =
  object (self)
    method add_item ?accel_path ?(accel_group = menu_group) ?modi ?key
        ?(use_mnemonic = true) ?(add_accel = true) ?tooltip ?callback label =
      let item = GtkMenu.MenuItem.create ~use_mnemonic ~label () in
      let item = new GMenu.menu_item item in
      item#misc#show ();
      menu#append item;
      if add_accel || accel_path <> None then (
        let accel_path =
          match accel_path with
          | None ->
            menu_path
            ^
            if use_mnemonic then
              remove_mnemonic label
            else
              label
          | Some ap -> ap
        in
        if add_accel then GtkData.AccelMap.add_entry accel_path ?key ?modi;
        GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group
      );
      Option.iter
        (fun callback ->
          let _ = item#connect#activate ~callback in
          ())
        callback;
      Option.iter item#misc#set_tooltip_markup tooltip;
      item

    method add_separator () =
      let item = GtkMenu.MenuItem.separator_create () in
      let item = new GMenu.menu_item item in
      item#misc#show ();
      menu#append item;
      ()

    method add_submenu ?use_mnemonic label =
      let m = GtkMenu.Menu.create [] in
      let m = new GMenu.menu m in
      m#misc#show ();
      let item = self#add_item ?use_mnemonic ~add_accel:false label in
      item#set_submenu m;
      m
  end

(*****************************************************************)
(* "Tools" submenus for strategies, provers, and transformations *)
(*****************************************************************)

let string_of_desc desc =
  let print_trans_desc fmt (x, r) =
    fprintf fmt "@[<hov 2>%s@\n%a@]" x Pp.formatted r
  in
  Glib.Markup.escape_text (Pp.string_of print_trans_desc desc)

let parse_shortcut_as_key s =
  let ((key, modi) as r) = GtkData.AccelGroup.parse s in
  (if key = 0 then
     Debug.dprintf debug "Shortcut '%s' cannot be parsed as a key@." s
   else
     let name = GtkData.AccelGroup.name ~key ~modi in
     Debug.dprintf debug "Shortcut '%s' parsed as key '%s'@." s name);
  r

let add_submenu_strategy (str_fac : menu_factory) (con_fac : menu_factory)
    (shortcut, strategy) =
  let callback () =
    Debug.dprintf debug "interp command '%s'@." strategy;
    interp strategy
  in
  let name =
    String.map
      (function
        | '_' -> ' '
        | c -> c)
      strategy
  in
  let tooltip = "run strategy " ^ strategy ^ " on selected goal" in
  let accel_path = "<Why3-Main>/Tools/Strategies/" ^ name in
  let key, modi = parse_shortcut_as_key shortcut in
  let (_ : GMenu.menu_item) =
    str_fac#add_item name ~use_mnemonic:false ~accel_path ~key ~modi ~tooltip
      ~callback
  in
  let (_ : GMenu.menu_item) =
    con_fac#add_item name ~use_mnemonic:false ~accel_path ~add_accel:false
      ~tooltip ~callback
  in
  ()

let hide_context_provers, add_submenu_prover =
  (* Set of context provers menu items *)
  let context_provers = Hstr.create 16 in
  (* After preferences for hidden provers are set, actualize provers allowed in
     the context_factory *)
  let hide_context_provers () =
    Hstr.iter
      (fun k i ->
        if List.mem k gconfig.hidden_provers then
          i#misc#hide ()
        else
          i#misc#show ())
      context_provers
  in
  let add_submenu_prover (pro_fac : menu_factory) (con_fac : menu_factory)
      (shortcut, prover_name, prover_parseable_name) =
    let callback () =
      Debug.dprintf debug "interp command '%s'@." prover_parseable_name;
      interp prover_parseable_name
    in
    let tooltip = "run prover " ^ prover_name ^ " on selected goal" in
    let accel_path = "<Why3-Main>/Tools/Provers/" ^ prover_name in
    let key, modi = parse_shortcut_as_key shortcut in
    let (_ : GMenu.menu_item) =
      pro_fac#add_item prover_name ~use_mnemonic:false ~accel_path ~key ~modi
        ~tooltip ~callback
    in
    let (i : GMenu.menu_item) =
      con_fac#add_item prover_name ~use_mnemonic:false ~accel_path
        ~add_accel:false ~tooltip ~callback
    in
    Hstr.add context_provers prover_parseable_name i;
    if List.mem prover_parseable_name gconfig.hidden_provers then i#misc#hide ()
  in
  (hide_context_provers, add_submenu_prover)

(*************)
(* Main menu *)
(*************)

(* Use the command key (⌘) for shortcuts when on mac *)
let primary_modifiers = snd (GtkData.AccelGroup.parse "<Primary>A")
let tools_accel_group = GtkData.AccelGroup.create ()
let factory = new menu_factory ~accel_path:"<Why3-Main>/" ~accel_group menubar

let context_factory =
  new menu_factory
    context_tools_menu ~accel_path:"" ~accel_group:tools_accel_group

let connect_menu_item i ~callback =
  let (_ : GtkSignal.id) = i#connect#activate ~callback in
  ()

(* "File" menu items *)

let file_menu = factory#add_submenu "_File"

let file_factory =
  new menu_factory file_menu ~accel_path:"<Why3-Main>/File/" ~accel_group

let (_ : GMenu.menu_item) =
  file_factory#add_item "Add file to session"
    ~tooltip:"Insert another file in the current session" ~callback:(fun () ->
      select_file ~request:(fun f -> send_request (Add_file_req f)))

let (_ : GMenu.menu_item) =
  let callback () =
    Gconfig.preferences ~parent:main_window gconfig;
    (* hide/show provers in contextual menu *)
    hide_context_provers ();
    (* Source view tags *)
    Option.iter (fun (_, v) -> update_tags gconfig v) (find_current_file_view ());
    (* Update message zone tags *)
    remove_all_tags gconfig message_zone;
    message_zone_error_tag := create_msg_zone_error_tag ();
    make_sources_editable gconfig.allow_source_editing;
    send_session_config_to_server ()
  in
  file_factory#add_item "Preferences" ~tooltip:"Open Preferences Window"
    ~callback

let (_ : GMenu.menu_item) =
  file_factory#add_item "Save session"
    ~tooltip:"Save the current proof session on disk" ~callback:(fun () ->
      send_request Save_req)

let (_ : GMenu.menu_item) =
  file_factory#add_item "Save files"
    ~tooltip:"Save the edited source files on disk" ~callback:save_sources

let (_ : GMenu.menu_item) =
  file_factory#add_item "_Save session and files" ~modi:primary_modifiers
    ~key:GdkKeysyms._S
    ~tooltip:"Save the current proof session and the source files"
    ~callback:(fun () ->
      save_sources ();
      send_request Save_req)

let (_ : GMenu.menu_item) =
  file_factory#add_item "Save all and _Refresh session" ~modi:primary_modifiers
    ~key:GdkKeysyms._R
    ~tooltip:
      "Save the current proof session and the source files, then refresh the \
       proof session with updated source files"
    ~callback:save_and_reload

let (_ : GMenu.menu_item) =
  file_factory#add_item "Export session as zip file"
    ~tooltip:"Produces a zip archive of the current proof session"
    ~callback:export_as_zip

let (_ : GMenu.menu_item) =
  file_factory#add_item "_Quit" ~modi:primary_modifiers ~key:GdkKeysyms._Q
    ~tooltip:
      "See the Preferences for setting the policy on automatic file saving at \
       exit."
    ~callback:exit_function_safe

(* Remove a specific color at a specific location *)
let uncolor ~color loc =
  match loc with
  | None -> ()
  | Some loc -> (
    let f, bl, bc, el, ec = Loc.get loc in
    try
      let v = get_source_view f in
      let color = convert_color color in
      let buf = v#buffer in
      let top = buf#start_iter in
      (* removing 1 because first line number is 0 in Gtk source views *)
      let start = top#forward_lines (bl - 1) in
      let start = start#forward_chars bc in
      let stop = top#forward_lines (el - 1) in
      let stop = stop#forward_chars ec in
      buf#remove_tag_by_name ~start ~stop color
    with
    | Nosourceview _ -> ())

let search_forward =
  let last_search = ref "" in
  let last_colored = ref None in
  let search_forward ~forward () =
    let cur_fv = find_current_file_view () in
    match cur_fv with
    | None ->
      print_message ~kind:0 ~notif_kind:"Search"
        "Cannot search. No current file view exist"
    | Some (cur_file, view) -> (
      (* Get current line *)
      let iter = view#buffer#get_iter_at_mark `SEL_BOUND in
      let search_string =
        let find =
          if forward then
            "Forward search"
          else
            "Backward search"
        in
        GToolbox.input_string ~title:find ~ok:"Search" ~cancel:"Cancel"
          ~text:!last_search "Type a string to find in the current document"
      in
      match search_string with
      | None -> uncolor ~color:Search_color !last_colored
      | Some search -> (
        last_search := search;
        let searched =
          if forward then
            GtkText.Iter.forward_search iter#as_iter search None
          else
            GtkText.Iter.backward_search iter#as_iter search None
        in
        match searched with
        | None ->
          uncolor ~color:Search_color !last_colored;
          print_message ~kind:1 ~notif_kind:"Search"
            "Searched string not found in the rest of the document"
        | Some (iter_begin, iter_end) ->
          let n1 = GtkText.Iter.get_line iter_begin in
          let l1 = GtkText.Iter.get_line_index iter_begin in
          let n2 = GtkText.Iter.get_line iter_end in
          let l2 = GtkText.Iter.get_line_index iter_end in
          let loc1 = Loc.user_position cur_file (n1 + 1) l1 (n2 + 1) l2 in
          color_loc ~color:Search_color loc1;
          if not (Option.equal Loc.equal !last_colored (Some loc1)) then
            uncolor ~color:Search_color !last_colored;
          last_colored := Some loc1;
          (* Get to the line after to be able to call Ctrl+F on the same string
             right away *)
          let loc2 =
            if forward then
              Loc.user_position cur_file n2 l2 n2 l2
            else
              Loc.user_position cur_file n1 l1 n1 l1
          in
          scroll_to_loc ~force_tab_switch:false (Some loc2)))
  in
  search_forward

let edit_menu = factory#add_submenu "_Edit"

let edit_factory =
  new menu_factory edit_menu ~accel_path:"<Why3-Main>/Edit/" ~accel_group

let (_ : GMenu.menu_item) =
  edit_factory#add_item "Search forward" ~modi:primary_modifiers
    ~key:GdkKeysyms._F ~tooltip:"Search in the source file."
    ~callback:(search_forward ~forward:true)

let (_ : GMenu.menu_item) =
  edit_factory#add_item "Search backward" ~modi:primary_modifiers
    ~key:GdkKeysyms._B ~tooltip:"Search backward in the source file."
    ~callback:(search_forward ~forward:false)

exception SearchLimit

(* Use a specific function to read words under cursor (for Ctrl+L) because GTK
   functions for forward_word_end/backward_word_start does not skip "_" in
   particular. *)
let get_word_around_iter iter =
  let is_letter c =
    match c with
    | '0' .. '9'
    | 'a' .. 'z'
    | 'A' .. 'Z'
    | '_'
    | '\'' ->
      true
    | _ -> false
  in

  let get_right_words (iter : GText.iter) =
    let rec get_words n start_iter =
      if n = 0 then raise SearchLimit;
      (* Forbid too long search *)
      let incr_iter = start_iter#forward_char in
      let s = start_iter#get_text ~stop:incr_iter in
      if not (is_letter s.[0]) then
        start_iter
      else
        get_words (n - 1) incr_iter
    in
    get_words 80 iter
  in

  let get_left_words (iter : GText.iter) =
    let rec get_words n (end_iter : GText.iter) =
      if n = 0 then raise SearchLimit;
      (* Forbid too long search *)
      let incr_iter = end_iter#backward_char in
      let s = incr_iter#get_text ~stop:incr_iter#forward_char in
      if not (is_letter s.[0]) then
        incr_iter#forward_char
      else
        get_words (n - 1) incr_iter
    in
    get_words 80 iter
  in

  let start_iter = get_left_words iter in
  let end_iter = get_right_words iter in
  let text = start_iter#get_text ~stop:end_iter in
  (start_iter, text, end_iter)

(* find_cursor_ident: finds the ident under cursor and scroll to its definition
   get_back_loc: returns to the last position of a searched ident. *)
let find_cursor_ident, get_back_loc =
  let last_loc = ref None in
  ( (fun () ->
      save_cursor_loc last_loc;
      match find_current_file_view () with
      | None ->
        print_message ~notif_kind:"Ide_error" ~kind:1
          "Cannot determine current source file"
      | Some (file, view) -> (
        try
          if file = "Task" then
            let iter = view#buffer#get_iter `SEL_BOUND in
            let _, text, _ = get_word_around_iter iter in
            interp ("locate " ^ text)
          else
            let iter = view#buffer#get_iter `SEL_BOUND in
            let start_iter, text, end_iter = get_word_around_iter iter in
            if text = "" then
              ()
            else
              (* adding 1 because first line number is 0 in Gtk source views *)
              let bl = start_iter#line + 1 in
              let bc = start_iter#line_offset in
              let el = end_iter#line + 1 in
              let ec = end_iter#line_offset in
              let f = file in
              let loc = Loc.user_position f bl bc el ec in
              send_request (Find_ident_req loc)
        with
        | SearchLimit ->
          print_message ~notif_kind:"Ide_error" ~kind:1
            "Search limit overflow: the word is too long")),
    fun () -> scroll_to_loc ~force_tab_switch:true !last_loc )

let (_ : GMenu.menu_item) =
  edit_factory#add_item "Find cursor ident" ~modi:primary_modifiers
    ~key:GdkKeysyms._L
    ~tooltip:"This finds the definition of the ident under user cursor"
    ~callback:find_cursor_ident

let (_ : GMenu.menu_item) =
  edit_factory#add_item "Back" ~modi:primary_modifiers
    ~key:GdkKeysyms._ampersand (* & *)
    ~tooltip:"After find cursor ident, return back to cursor"
    ~callback:get_back_loc

(* "Tools" menu items *)

let tools_menu = factory#add_submenu "_Tools"

let tools_factory =
  new menu_factory
    tools_menu ~accel_path:"<Why3-Main>/Tools/" ~accel_group:tools_accel_group

let strategies_factory =
  let tools_submenu_strategies = tools_factory#add_submenu "Strategies" in
  tools_factory#add_separator ();
  new menu_factory
    tools_submenu_strategies ~accel_path:"<Why3-Main>/Tools/Strategies/"
    ~accel_group:tools_accel_group

let provers_factory =
  let tools_submenu_provers = tools_factory#add_submenu "Provers" in
  tools_factory#add_separator ();
  new menu_factory
    tools_submenu_provers ~accel_path:"<Why3-Main>/Tools/Provers/"
    ~accel_group:tools_accel_group

(* "View" menu items *)

let view_menu = factory#add_submenu "_View"

let view_factory =
  new menu_factory ~accel_path:"<Why3-Main>/View/" ~accel_group view_menu

let (_ : GMenu.menu_item) =
  view_factory#add_item "Enlarge font" ~modi:primary_modifiers
    ~key:GdkKeysyms._plus ~callback:enlarge_fonts

let (_ : GMenu.menu_item) =
  view_factory#add_item "Reduce font" ~modi:primary_modifiers
    ~key:GdkKeysyms._minus ~callback:reduce_fonts

let (_ : GMenu.menu_item) =
  view_factory#add_item "Collapse proved goals" ~accel_group:tools_accel_group
    ~key:GdkKeysyms._exclam
    ~tooltip:"Collapse all the proven nodes under the current node"
    ~callback:collapse_proven_goals

let (_ : GMenu.menu_item) =
  view_factory#add_item "Expand all"
    ~tooltip:"Expand all nodes of the tree view" ~callback:goals_view#expand_all

let (_ : GMenu.menu_item) =
  view_factory#add_item "Collapse current node" ~accel_group:tools_accel_group
    ~key:GdkKeysyms._minus ~callback:collapse_row

let (_ : GMenu.menu_item) =
  view_factory#add_item "Expand current node" ~accel_group:tools_accel_group
    ~key:GdkKeysyms._plus
    ~tooltip:"Expand current node, or its children when already expanded"
    ~callback:expand_row

let (_ : GMenu.menu_item) =
  view_factory#add_item "Go to parent node" ~modi:primary_modifiers
    ~key:GdkKeysyms._Left ~callback:move_current_row_selection_to_parent

let (_ : GMenu.menu_item) =
  view_factory#add_item "Go to first child"
    ~callback:move_current_row_selection_to_first_child

let (_ : GMenu.menu_item) =
  view_factory#add_item "Select next unproven goal" ~modi:primary_modifiers
    ~key:GdkKeysyms._Right ~callback:(fun () ->
      move_to_next_unproven_node_id Clever)

let (_ : GMenu.menu_item) =
  view_factory#add_item "Go down (skipping proved goals)"
    ~modi:primary_modifiers ~key:GdkKeysyms._Down ~callback:(fun () ->
      move_to_next_unproven_node_id Next)

let (_ : GMenu.menu_item) =
  view_factory#add_item "Go up (skipping proved goals)" ~modi:primary_modifiers
    ~key:GdkKeysyms._Up ~callback:(fun () -> move_to_next_unproven_node_id Prev)

(* "Help" menu items *)

let help_menu = factory#add_submenu "_Help"

let help_factory =
  new menu_factory help_menu ~accel_path:"<Why3-Main>/Help/" ~accel_group

let (_ : GMenu.menu_item) =
  help_factory#add_item "Legend"
    ~callback:(show_legend_window ~parent:main_window)

let (_ : GMenu.menu_item) =
  help_factory#add_item "About"
    ~callback:(show_about_window ~parent:main_window)

let init_completion provers transformations strategies commands =
  (* add the names of all the the transformations *)
  List.iter add_completion_entry transformations;
  (* add the name of the commands *)
  List.iter (fun s -> add_completion_entry (s, "command")) commands;

  (* todo: add queries *)

  (* add provers *)
  let all_strings =
    List.fold_left
      (fun acc (s, _, p) ->
        Debug.dprintf debug "string for completion: '%s' '%s'@." s p;
        let acc = (p, "prover") :: acc in
        if s = "" then
          acc
        else
          (s, "shortcut for prover " ^ p) :: acc)
      [] provers
  in
  List.iter add_completion_entry all_strings;
  let provers_sorted =
    List.sort
      (fun (_, h1, _) (_, h2, _) ->
        String.compare (Strings.lowercase h1) (Strings.lowercase h2))
      provers
  in
  (* Remove counterexample provers from the menu *)
  let menu_provers =
    List.filter
      (fun (_, _, s) -> not (Strings.ends_with s "counterexamples"))
      provers_sorted
  in
  List.iter (add_submenu_prover provers_factory context_factory) menu_provers;
  context_factory#add_separator ();
  let all_strings =
    List.fold_left
      (fun acc (shortcut, strategy) ->
        Debug.dprintf debug "string for completion: '%s' '%s'@." shortcut
          strategy;
        let acc = (strategy, "strategy") :: acc in
        if shortcut = "" then
          acc
        else
          (shortcut, "shortcut for strategy " ^ strategy) :: acc)
      [] strategies
  in
  List.iter add_completion_entry all_strings;
  List.iter (add_submenu_strategy strategies_factory context_factory) strategies;
  (* Add goal oriented stategies in strategies menu *)
  let strategies = Strategy.list_strats () in
  let strategies =
    List.map
      (fun (strat, desc) ->
        let desc = string_of_desc (strat, desc) in
        (strat, desc))
      strategies
  in
  strategies_factory#add_separator ();
  context_factory#add_separator ();
  List.iter (add_submenu_strategy strategies_factory context_factory) strategies;
  List.iter add_completion_entry strategies;
  command_entry_completion#set_text_column completion_col;
  (* Adding a column which contains the description of the
     prover/transformation/strategy. *)
  let name_renderer = GTree.cell_renderer_text [] in
  name_renderer#set_properties [ `BACKGROUND "lightgrey" ];
  command_entry_completion#pack name_renderer;
  command_entry_completion#add_attribute name_renderer "text" completion_desc;

  command_entry_completion#set_match_func match_function;
  command_entry_completion#misc#set_property "inline_completion" (`BOOL false);
  command_entry#set_completion command_entry_completion

let () =
  let transformations = Server_utils.list_transforms () in
  let add_submenu_transform name filter =
    let submenu = tools_factory#add_submenu name in
    let submenu =
      new menu_factory
        submenu
        ~accel_path:("<Why3-Main>/Tools/" ^ name ^ "/")
        ~accel_group:tools_accel_group
    in
    let iter ((name, _) as desc) =
      let (_ : GMenu.menu_item) =
        submenu#add_item (Glib.Markup.escape_text name)
          ~use_mnemonic:false ~tooltip:(string_of_desc desc)
          ~callback:(fun () -> interp name)
      in
      ()
    in
    let trans = List.filter filter transformations in
    List.iter iter trans
  in
  add_submenu_transform "Transformations (a-e)" (fun (x, _) -> x < "eliminate");
  add_submenu_transform "Transformations (eliminate)" (fun (x, _) ->
      x >= "eliminate" && x < "eliminatf");
  add_submenu_transform "Transformations (e-r)" (fun (x, _) ->
      x >= "eliminatf" && x < "s");
  add_submenu_transform "Transformations (s-z)" (fun (x, _) -> x >= "s");
  tools_factory#add_separator ()

(* complete the tools menu *)

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Edit error" ~action:"edit"
      (fun id -> Command_req (id, "edit"))
  in
  tools_factory#add_item "_Edit" ~key:GdkKeysyms._E
    ~tooltip:"View or edit proof script" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"get-ce error"
      ~action:"Get Counterexamples" (fun id -> Command_req (id, "get-ce"))
  in
  tools_factory#add_item "_Get Counterexamples" ~key:GdkKeysyms._G
    ~tooltip:"Launch the prover with counterexamples" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Replay error" ~action:"replay"
      (fun id -> Command_req (id, "replay"))
  in
  tools_factory#add_item "_Replay valid obsolete proofs" ~key:GdkKeysyms._R
    ~tooltip:"Replay valid obsolete proofs under the current node" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Replay error"
      ~action:"replay all" (fun id -> Command_req (id, "replay all"))
  in
  tools_factory#add_item "Replay all obsolete proofs"
    ~tooltip:"Replay all obsolete proofs under the current node" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Clean error" ~action:"clean"
      (fun id -> Command_req (id, "clean"))
  in
  tools_factory#add_item "_Clean node" ~key:GdkKeysyms._C
    ~tooltip:
      "Remove unsuccessful proofs or transformations that are under a proved \
       goal"
    ~callback

let (_ : GMenu.menu_item) =
  (* This is considered risky command so it is intentionally not added to the
     context menu. It also trigger the apparition of a popup. *)
  let callback () =
    let answer =
      GToolbox.question_box ~default:2 ~title:"Launching unsafe command"
        ~buttons:[ "Yes"; "No" ]
        "Do you really want to remove all proofs from this session ?"
    in
    match answer with
    | 1 -> send_request Reset_proofs_req
    | _ -> ()
  in
  tools_factory#add_item "Reset proofs"
    ~tooltip:"Remove all proofs attempts or transformations" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:true ~notif_kind:"Remove_subtree error"
      ~action:"remove" (fun id -> Remove_subtree id)
  in
  tools_factory#add_item "Remove node" ~key:GdkKeysyms._Delete
    ~tooltip:"Remove the selected proof attempts or transformations" ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:true ~notif_kind:"Mark_obsolete error"
      ~action:"mark obsolete" (fun id -> Command_req (id, "mark"))
  in
  tools_factory#add_item "Mark _obsolete" ~key:GdkKeysyms._O
    ~tooltip:"Mark all proof attempts under the current node as obsolete"
    ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:true ~notif_kind:"Interrupt error"
      ~action:"interrupt" (fun id -> Command_req (id, "interrupt"))
  in
  tools_factory#add_item "_Interrupt" ~tooltip:"Stop all running proof attempts"
    ~callback

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Bisect error" ~action:"bisect"
      (fun id -> Command_req (id, "bisect"))
  in
  tools_factory#add_item "_Bisect hypotheses"
    ~tooltip:"Remove useless hypotheses from a proved goal by bisection"
    ~callback

let () = tools_factory#add_separator ()

let (_ : GMenu.menu_item) =
  let callback =
    on_selected_rows ~multiple:false ~notif_kind:"Focus_req error"
      ~action:"focus" (fun id -> Command_req (id, "Focus"))
  in
  tools_factory#add_item "_Focus" ~tooltip:"Focus view on the current node"
    ~callback

let (_ : GMenu.menu_item) =
  let callback () = send_request Unfocus_req in
  tools_factory#add_item "_Unfocus" ~callback

let () = tools_factory#add_separator ()

let copy_item =
  tools_factory#add_item "Copy node" ~modi:primary_modifiers ~key:GdkKeysyms._C
    ~tooltip:"Copy the current node"

let paste_item =
  tools_factory#add_item "Paste node" ~modi:primary_modifiers ~key:GdkKeysyms._V
    ~tooltip:"Paste the copied node below the current node"

(* complete the contextual menu (but only after provers and strategies, hence
   the function) *)

let complete_context_menu () =
  context_factory#add_separator ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:false ~notif_kind:"Edit error" ~action:"edit"
        (fun id -> Command_req (id, "edit"))
    in
    context_factory#add_item "_Edit" ~accel_path:"<Why3-Main>/Tools/Edit"
      ~add_accel:false ~tooltip:"View or edit proof script" ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:false ~notif_kind:"get-ce error"
        ~action:"Get Counterexamples" (fun id -> Command_req (id, "get-ce"))
    in
    context_factory#add_item "_Get Counterexamples"
      ~accel_path:"<Why3-Main>/Tools/Get Counterexamples" ~add_accel:false
      ~tooltip:"Launch the prover with counterexamples" ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:false ~notif_kind:"Replay error"
        ~action:"replay" (fun id -> Command_req (id, "replay"))
    in
    context_factory#add_item "_Replay valid obsolete proofs"
      ~accel_path:"<Why3-Main>/Tools/Replay valid obsolete proofs"
      ~add_accel:false
      ~tooltip:"Replay valid obsolete proofs under the current node" ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:false ~notif_kind:"Replay error"
        ~action:"replay all" (fun id -> Command_req (id, "replay all"))
    in
    context_factory#add_item "Replay all obsolete proofs"
      ~accel_path:"<Why3-Main>/Tools/Replay all obsolete proofs"
      ~add_accel:false
      ~tooltip:"Replay all obsolete proofs under the current node" ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:false ~notif_kind:"Clean error" ~action:"clean"
        (fun id -> Command_req (id, "clean"))
    in
    context_factory#add_item "_Clean node"
      ~accel_path:"<Why3-Main>/Tools/Clean node" ~add_accel:false
      ~tooltip:
        "Remove unsuccessful proofs or transformations that are under a proved \
         goal"
      ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:true ~notif_kind:"Remove_subtree error"
        ~action:"remove" (fun id -> Remove_subtree id)
    in
    context_factory#add_item "Remove node"
      ~accel_path:"<Why3-Main>/Tools/Remove node" ~add_accel:false
      ~tooltip:"Remove the selected proof attempts or transformations" ~callback
  in
  ();

  let (_ : GMenu.menu_item) =
    let callback =
      on_selected_rows ~multiple:true ~notif_kind:"Interrupt error"
        ~action:"interrupt" (fun id -> Command_req (id, "interrupt"))
    in
    context_factory#add_item "_Interrupt"
      ~accel_path:"<Why3-Main>/Tools/Interrupt" ~add_accel:false
      ~tooltip:"Stop all running proof attempts" ~callback
  in
  ()

(*************************************)
(* Copy paste                        *)
(*************************************)

(* Current copied node *)
let saved_copy = ref None

let copy () =
  match get_selected_row_references () with
  | [ r ] ->
    let n = get_node_id r#iter in
    saved_copy := Some n;
    paste_item#misc#set_sensitive true
  | _ ->
    saved_copy := None;
    paste_item#misc#set_sensitive false

let paste () =
  match get_selected_row_references () with
  | [ r ] -> (
    let m = get_node_id r#iter in
    match !saved_copy with
    | Some n -> send_request (Copy_paste (n, m))
    | None -> ())
  | _ -> ()

let () =
  paste_item#misc#set_sensitive false;
  connect_menu_item copy_item ~callback:copy;
  connect_menu_item paste_item ~callback:paste

(**********************************)
(* Notification handling (part 2) *)
(**********************************)

let check_uninstalled_prover =
  let uninstalled_prover_seen = Whyconf.Hprover.create 3 in
  fun p ->
    if not (Whyconf.Hprover.mem uninstalled_prover_seen p) then (
      Whyconf.Hprover.add uninstalled_prover_seen p ();
      let callback p u = send_request (Set_prover_policy (p, u)) in
      uninstalled_prover_dialog ~parent:main_window ~callback gconfig p
    )

let treat_notification n =
  Protocol_why3ide.print_notify_debug n;
  (match n with
  | Reset_whole_tree -> clear_tree_and_table goals_model
  | Node_change (id, uinfo) -> (
    match uinfo with
    | Proved b ->
      let old =
        try
          let o = Hint.find node_id_proved id in
          Hint.replace node_id_proved id b;
          o
        with
        | Not_found ->
          Hint.add node_id_proved id b;
          (* new node, then expand it if not proved *)
          not b
      in
      if old <> b then (
        set_status_and_time_column (get_node_row id);
        Debug.dprintf debug "proved status changed to %b for %d@." b id;
        if b then (
          if
            (* if the node newly proved is selected, then force moving the
               selection the next unproved goal *)
            is_selected_alone id
          then
            send_request (Get_first_unproven_node (Clever, id))
        ) else
          try
            let row = Hint.find node_id_to_gtree id in
            let path = row#path in
            Debug.dprintf debug "Expanding row for unproved node %d@." id;
            goals_view#expand_to_path path
          with
          | Not_found ->
            Debug.dprintf debug "Warning: no gtk row registered for node %d@."
              id
      )
    | Name_change n ->
      let row = get_node_row id in
      goals_model#set ~row:row#iter ~column:name_column n
    | Proof_status_change (pa, obs, l) -> (
      let r = get_node_row id in
      Hint.replace node_id_pa id (pa, obs, l);
      set_status_and_time_column ~limit:l r;
      match pa with
      | Controller_itp.Uninstalled p -> check_uninstalled_prover p
      | _ -> ()))
  | Next_Unproven_Node_Id (asked_id, next_unproved_id) ->
    if
      is_selected_alone asked_id
      && (* The user manually asked for next node from this one *)
      (!manual_next = Some asked_id
      || (* or auto next is on *)
      gconfig.auto_next)
    then (
      manual_next := None;
      (* Unselect the potentially selected goal to avoid having two tasks
         selected at once when a prover successfully end. To continue the proof,
         it is better to only have the new goal selected *)
      goals_view#selection#unselect_all ();
      let row = get_node_row next_unproved_id in
      goals_view#expand_to_path row#path;
      select_iter row#iter
    )
  | New_node (id, parent_id, typ, name, detached) -> (
    try
      let parent = get_node_row parent_id in
      ignore (new_node ~parent id name typ detached);
      match typ with
      | NTransformation ->
        (* if this new node is a transformation, and its parent goal is
           selected, then ask for the next goal to prove. *)
        if is_selected_alone parent_id then
          send_request (Get_first_unproven_node (Clever, parent_id))
      | _ -> ()
    with
    | Not_found -> ignore (new_node id name typ detached))
  | Remove id ->
    let n = get_node_row id in
    (if get_node_detached id then (
       let path = goals_model#get_path n#iter in
       ignore (GtkTree.TreePath.prev path);
       goals_view#set_cursor path view_name_column
     ) else
       (* In the case where id is an ancestor of a selected node, this node will
          be erased. So we try to select the parent. *)
       let is_ancestor =
         List.exists
           (fun row ->
             let row_id = get_node_id row#iter in
             row_id = id
             || goals_model#is_ancestor ~iter:n#iter ~descendant:row#iter)
           (get_selected_row_references ())
       in
       if is_ancestor then
         match goals_model#iter_parent n#iter with
         | None -> goals_view#selection#unselect_all ()
         | Some parent ->
           goals_view#selection#unselect_all ();
           select_iter parent
     (* TODO Go to the next unproved goal ? let parent_id = get_node_id parent
        in send_request (Get_first_unproven_node parent_id)*));
    ignore (goals_model#remove n#iter);
    Hint.remove node_id_to_gtree id;
    Hint.remove node_id_type id;
    Hint.remove node_id_proved id;
    Hint.remove node_id_pa id
  | Initialized g_info ->
    initialization_complete := true;
    main_window#show ();
    display_warnings ();
    init_completion g_info.provers g_info.transformations g_info.strategies
      g_info.commands;
    complete_context_menu ();
    Option.iter select_iter goals_model#get_iter_first
  | Saved ->
    print_message ~kind:1 ~notif_kind:"Saved action info" "Session saved.";
    if !quit_on_saved = true then exit_function_safe ()
  | Saving_needed b -> exit_function_handler b
  | Message msg -> treat_message_notification msg
  | Task (id, s, list_loc, goal_loc, lang) ->
    if is_selected_alone id then (
      change_lang task_view lang;
      task_view#source_buffer#set_text s;
      (* Avoid erasing colors at startup when selecting the first node. In all
         other cases, it should change nothing. *)
      if list_loc != [] then
        apply_loc_on_source list_loc goal_loc
      else (
        erase_loc_all_view ();
        (* Still scroll to the ident (for example for modules) *)
        scroll_to_loc ~force_tab_switch:true goal_loc
      );
      (* Scroll to the end of task text without any animation. We cannot use the
         scroll_to methods, as they eventually call
         gtk_adjustment_animate_to_value in GTK3. So, we manually call
         gtk_adjustment_set_value (through get_adjustment_clamp_page, because of
         GTK2). We cannot do that immediately though, as the vertical adjustment
         does not yet reflect the new content. *)
      when_idle (fun () ->
          let a = scrolled_task_view#vadjustment in
          a#clamp_page ~lower:a#upper ~upper:a#upper)
    )
  | File_contents (file_name, content, f_format, read_only) -> (
    let content = try_convert content in
    try
      let _, sc_view, _, _source_view_is_read_only =
        Hstr.find source_view_table file_name
      in
      (* read_only means it was sent by ctrl+l not by reload. So, if the file
         already exists, we dont want to erase users changes. *)
      if not read_only then (
        sc_view#source_buffer#begin_not_undoable_action ();
        sc_view#source_buffer#set_text content;
        sc_view#source_buffer#end_not_undoable_action ();
        sc_view#source_buffer#set_modified false;
        reposition_ide_cursor ()
      )
    with
    | Not_found -> create_source_view ~read_only file_name content f_format)
  | Source_and_ce (content, list_loc, goal_loc, f_format) ->
    messages_notebook#goto_page counterexample_page;
    counterexample_view#source_buffer#set_text content;
    change_lang counterexample_view f_format;
    apply_loc_on_ce list_loc;
    scroll_to_loc_ce goal_loc
  | Dead _ ->
    print_message ~kind:1 ~notif_kind:"Server Dead ?"
      "Server sent the notification '%a'. Please report." print_notify n
  | Ident_notif_loc loc -> scroll_to_loc ~force_tab_switch:true (Some loc));
  ()

(***********************************)
(* accel group switching           *)
(* when entering/leaving tree view *)
(***********************************)

let () =
  let (_ : GtkSignal.id) =
    goals_view#event#connect#focus_in ~callback:(fun _ ->
        main_window#add_accel_group tools_accel_group;
        true)
  in
  let (_ : GtkSignal.id) =
    goals_view#event#connect#focus_out ~callback:(fun _ ->
        GtkWindow.Window.remove_accel_group main_window#as_window
          tools_accel_group;
        true)
  in
  ()

(***************************************************)
(* simulate some user actions and take screenshots *)
(***************************************************)

let pos_cursor_and_color (v : GSourceView.source_view) =
  let buf = v#source_buffer in
  let iter = buf#get_iter_at_mark `INSERT in
  let line, column = (iter#line + 1, iter#line_index) in
  (* This is the line that corresponds to the goal *)
  Format.printf "Cursor is placed at position: (%d, %d)@." line column;
  let iter = ref buf#start_iter in
  Format.printf "Recorded colors on the source code are:@.";
  while not !iter#is_end do
    let l = !iter#get_toggled_tags true in
    if l = [] then
      ()
    else
      List.iter
        (fun (tag : GText.tag) ->
          let tag_name = tag#get_property GtkText.Tag.P.name in
          if tag_name <> "" then
            let iter2 = !iter#forward_to_tag_toggle (Some tag) in
            Format.printf "Color \"%s\" from (%d, %d) to (%d, %d)@." tag_name
              !iter#line !iter#line_index iter2#line iter2#line_index)
        l;
    iter := !iter#forward_char
  done;
  Format.printf "End color@."

let batch s =
  let cmd = ref (Strings.split ';' s) in
  let last = ref (Sys.time ()) in
  fun () ->
    let t = Sys.time () in
    if (not !initialization_complete) || t -. !last < 0.2 then
      true
    else
      match !cmd with
      | c :: tl ->
        cmd := tl;
        last := t;
        (match Strings.split ' ' c with
        | [ "" ] -> ()
        | [ "down" ] -> move_current_row_selection_to_down ()
        | [ "next" ] -> move_current_row_selection_to_next ()
        | [ "view"; "task" ] -> notebook#goto_page 0
        | [ "view"; "source" ] -> notebook#goto_page 1
        | [ "wait"; w ] ->
          let w = int_of_string w in
          if w > 0 then cmd := Printf.sprintf "wait %d" (w - 1) :: !cmd
        | "faketype" :: cmd ->
          let cmd = Strings.join " " cmd in
          command_entry#misc#grab_focus ();
          command_entry#set_text cmd
        | "type" :: cmd ->
          let cmd = Strings.join " " cmd in
          command_entry#misc#grab_focus ();
          add_command list_commands cmd;
          interp cmd
        | "snap" :: cmd ->
          let cmd = Strings.join " " cmd in
          let cmd =
            Printf.sprintf
              "import -window \"%s\" -define png:include-chunk=none %s"
              window_title cmd
          in
          if Sys.command cmd <> 0 then
            Printf.eprintf "Batch command failed: %s\n%!" cmd
        | "color" :: cmd ->
          let cmd = Strings.join " " cmd in
          let v =
            Hstr.fold
              (fun _ x acc ->
                match (acc, x) with
                | None, (sp, sv, _, _) when sp = 1 -> Some sv
                | _ -> acc)
              source_view_table None
          in
          Option.iter pos_cursor_and_color v;
          interp cmd
        | [ "save" ] -> send_request Save_req
        | _ -> Printf.eprintf "Unrecognized batch command: %s\n%!" c);
        true
      | _ ->
        exit_function_unsafe ();
        false

(***********************)
(* start the interface *)
(***********************)

let () =
  Scheduler.timeout ~ms:Controller_itp.default_delay_ms (fun () ->
      List.iter treat_notification (get_notified ());
      true);
  main_window#add_accel_group accel_group;
  main_window#set_icon (Some !Gconfig.why_icon);
  print_message ~kind:1 ~notif_kind:"Info"
    "Welcome to Why3 IDE\ntype 'help' for help\n";
  (match !opt_batch with
  | Some s ->
    let (_ : GMain.Idle.id) =
      GMain.Idle.add ~prio:300 (backtrace_and_exit (batch s))
    in
    ()
  | None -> ());
  GMain.main ()

end

let () = Whyconf.register_command "ide" (module Main)
