let make_panel (main_ui:main_window_extension_points) =
let container = GPack.vbox () in
let paned = GPack.paned `VERTICAL
~packing:(container#pack ~expand:true ~fill:true)
()
in
let _ = paned#event#connect#button_release
~callback:(fun _ ->
Gtk_helper.save_paned_ratio "po_navigator_paned" paned; false)
in
let module L = struct
type t = row
let column_list = new GTree.column_list
let custom_value (_:Gobject.g_type) _t ~column:_ : Gobject.basic =
assert false
end
in
let module MODEL = Gtk_helper.MAKE_CUSTOM_LIST(L) in
let model = MODEL.custom_list () in
let model_age = ref 0 in
let append m =
incr model_age;
if m.visible then model#insert m
in
let clear () = incr model_age; model#clear () in
let sc =
GBin.scrolled_window
~vpolicy:`AUTOMATIC
~hpolicy:`AUTOMATIC
~packing:paned#add1
()
in
let view =
GTree.view ~rules_hint:true ~headers_visible:true ~packing:sc#add ()
in
ignore
(view#connect#row_activated
~callback:(fun path col ->
match model#custom_get_iter path,Prover_Column.get col with
| Some ({MODEL.finfo= {wpo=wpo}} as custom), Some prover
->
let path = GtkTree.TreePath.copy path in
Gui_parameters.debug "Activate %s prover:%a"
wpo.Wpo.po_name Wpo.pp_prover prover ;
let current_model_age = !model_age in
let callout _wpo _prover _result =
if current_model_age = !model_age then
begin
model#custom_row_changed path custom;
Gui_parameters.debug "Custom row changed";
end;
main_ui#rehighlight ()
in
Wpo.set_result wpo prover Wpo.Computing ;
model#custom_row_changed path custom ;
let server = Prover.server () in
let task =
Prover.prove ~callout wpo
~interactive:true prover
in
Task.spawn server task ;
Task.launch server
| _ -> ()));
view#selection#set_select_function
(fun path currently_selected ->
if not currently_selected then
begin match model#custom_get_iter path with
| Some {MODEL.finfo = {wpo=wpo};} ->
Gui_parameters.debug "Select %s@." wpo.Wpo.po_name;
SelectionHook.apply wpo
| None -> ()
end;
true);
let top = `YALIGN 0.0 in
let add_text_column ~title f =
let name_renderer = GTree.cell_renderer_text [top] in
let m_name_renderer renderer (lmodel:GTree.model) iter =
let (path:Gtk.tree_path) = lmodel#get_path iter in
match model#custom_get_iter path with
| Some {MODEL.finfo={wpo=wpo}} ->
renderer#set_properties [`TEXT (f wpo)]
| None -> ()
in
let cview = GTree.view_column
~title ~renderer:(name_renderer,[])
()
in
cview#set_resizable true;
cview#set_cell_data_func
name_renderer (m_name_renderer name_renderer);
ignore (view#append_column cview)
in
add_text_column
~title:"Module"
(fun wpo ->
((fst(Kernel_function.get_location wpo.Wpo.po_fun)).Lexing.pos_fname))
;
add_text_column
~title:"Function"
(fun wpo -> (Kernel_function.get_name wpo.Wpo.po_fun));
add_text_column
~title:"Behavior"
(fun wpo -> match wpo.Wpo.po_bhv with
| None -> ""
| Some b -> b);
add_text_column
~title:"Origin"
(fun wpo -> let property = WpAnnot.property_of_id wpo.Wpo.po_pid in
Pretty_utils.to_string Property.pretty property);
add_text_column
~title:"Model"
(fun wpo -> wpo.Wpo.po_model);
add_text_column
~title:"Kind"
(fun wpo -> WpAnnot.label_of_prop_id wpo.Wpo.po_pid);
let make_prover_status prover =
let renderer = GTree.cell_renderer_pixbuf [top] in
let m_renderer renderer (lmodel:GTree.model) iter =
let (path:Gtk.tree_path) = lmodel#get_path iter in
match model#custom_get_iter path with
| Some {MODEL.finfo={wpo=wpo}} ->
begin
match Wpo.get_result wpo prover with
| Some r ->
let icon = match r with
| Wpo.Valid -> "gtk-yes"
| Wpo.Failed _ -> "gtk-dialog-error"
| Wpo.Unknown -> "gtk-dialog-question"
| Wpo.Timeout -> "gtk-cut"
| Wpo.Invalid -> "gtk-no"
| Wpo.Computing -> "gtk-execute"
in
renderer#set_properties [ `STOCK_ID icon]
| None ->
if Wpo.get_result wpo Wpo.WP = Some Wpo.Valid
then renderer#set_properties [ `STOCK_ID "gtk-apply" ]
else renderer#set_properties [ `STOCK_ID "" ]
end
| None -> ()
in
let cview = GTree.view_column
~title:(Pretty_utils.to_string Wpo.pp_prover prover)
~renderer:(renderer,[])
()
in
cview#set_cell_data_func
renderer (m_renderer renderer);
cview#set_resizable true;
cview#set_clickable true;
ignore (cview#connect#clicked
(fun () ->
Gui_parameters.debug "Clicked on column %a" Wpo.pp_prover prover)) ;
ignore (view#append_column cview);
Prover_Column.register cview prover
in
List.iter make_prover_status Wpo.gui_provers ;
let last_column = GTree.view_column ~title:"" () in
ignore (view#append_column last_column);
view#set_model (Some model#coerce);
let information_window = Source_manager.make ~packing:paned#add2 in
SelectionHook.extend
(fun wpo ->
Source_manager.load_file information_window
~title:wpo.Wpo.po_name
~filename:(Wpo.file_for_body ~gid:wpo.Wpo.po_gid)
~line:(-1));
let hb = GPack.hbox ~packing:container#pack () in
let fill_model () =
Wpo.iter ~on_goal:(fun wpo -> append {wpo=wpo; visible=true}) ()
in
let refresh_button = GButton.button ~label:"Refresh" ~packing:hb#add () in
let (_:GtkSignal.id) = refresh_button#connect#released
~callback:(fun _ -> main_ui#protect ~cancelable:false
(fun () -> clear (); fill_model ()))
in
let (_:GtkSignal.id) = view#misc#connect#after#realize
(fun () ->
Gtk_helper.place_paned paned
(Gtk_helper.Configuration.find_float
~default:0.60
"po_navigator_paned");
fill_model ())
in
ignore (main_ui#lower_notebook#append_page
~tab_label:(GMisc.label ~text:"WP Proof Obligations" ())#coerce
(container#coerce))