X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fsoftware%2Fmatita%2FmatitaGui.ml;h=6b1f24743295df187a4d625afa5822e7180b84be;hb=a1f4ef3daaeed7a3121a40afe55f321565669da8;hp=e9a84c9b475179cd4b588388a511bda3959ebddb;hpb=a89868740968d139dd4e1d621663bcd4d69d0265;p=helm.git
diff --git a/helm/software/matita/matitaGui.ml b/helm/software/matita/matitaGui.ml
index e9a84c9b4..6b1f24743 100644
--- a/helm/software/matita/matitaGui.ml
+++ b/helm/software/matita/matitaGui.ml
@@ -70,47 +70,50 @@ let clean_current_baseuri grafite_status =
with GrafiteTypes.Option_error _ -> ()
let ask_and_save_moo_if_needed parent fname lexicon_status grafite_status =
- let baseuri = DependenciesParser.baseuri_of_script ~include_paths:[] fname in
- let moo_fname =
- LibraryMisc.obj_file_of_baseuri ~must_exist:false ~baseuri ~writable:true in
- let save () =
- let metadata_fname =
- LibraryMisc.metadata_file_of_baseuri
- ~must_exist:false ~baseuri ~writable:true in
- let lexicon_fname =
- LibraryMisc.lexicon_file_of_baseuri
- ~must_exist:false ~baseuri ~writable:true
- in
- GrafiteMarshal.save_moo moo_fname
- grafite_status.GrafiteTypes.moo_content_rev;
- LibraryNoDb.save_metadata metadata_fname
- lexicon_status.LexiconEngine.metadata;
- LexiconMarshal.save_lexicon lexicon_fname
- lexicon_status.LexiconEngine.lexicon_content_rev
+ let baseuri =
+ try Some (GrafiteTypes.get_string_option grafite_status "baseuri")
+ with GrafiteTypes.Option_error _ -> None
in
if (MatitaScript.current ())#eos &&
- grafite_status.GrafiteTypes.proof_status = GrafiteTypes.No_proof
+ grafite_status.GrafiteTypes.proof_status = GrafiteTypes.No_proof &&
+ baseuri <> None
then
- begin
- let rc =
- MatitaGtkMisc.ask_confirmation
- ~title:"A .moo can be generated"
- ~message:(Printf.sprintf
- "%s can be generated for %s.\nShould I generate it?"
- (Filename.basename moo_fname) (Filename.basename fname))
- ~parent ()
- in
- let b =
- match rc with
- | `YES -> true
- | `NO -> false
- | `CANCEL -> raise MatitaTypes.Cancel
+ begin
+ let baseuri = match baseuri with Some b -> b | None -> assert false in
+ let moo_fname =
+ LibraryMisc.obj_file_of_baseuri ~must_exist:false ~baseuri
+ ~writable:true in
+ let save () =
+ let lexicon_fname =
+ LibraryMisc.lexicon_file_of_baseuri
+ ~must_exist:false ~baseuri ~writable:true
in
- if b then
- save ()
- else
- clean_current_baseuri grafite_status
- end
+ GrafiteMarshal.save_moo moo_fname
+ grafite_status.GrafiteTypes.moo_content_rev;
+ LexiconMarshal.save_lexicon lexicon_fname
+ lexicon_status.LexiconEngine.lexicon_content_rev
+ in
+ begin
+ let rc =
+ MatitaGtkMisc.ask_confirmation
+ ~title:"A .moo can be generated"
+ ~message:(Printf.sprintf
+ "%s can be generated for %s.\nShould I generate it?"
+ (Filename.basename moo_fname) (Filename.basename fname))
+ ~parent ()
+ in
+ let b =
+ match rc with
+ | `YES -> true
+ | `NO -> false
+ | `CANCEL -> raise MatitaTypes.Cancel
+ in
+ if b then
+ save ()
+ else
+ clean_current_baseuri grafite_status
+ end
+ end
else
clean_current_baseuri grafite_status
@@ -121,6 +124,255 @@ let ask_unsaved parent =
"Do you want to save the script before continuing?")
()
+class interpErrorModel =
+ let cols = new GTree.column_list in
+ let id_col = cols#add Gobject.Data.string in
+ let dsc_col = cols#add Gobject.Data.string in
+ let interp_no_col = cols#add Gobject.Data.caml in
+ let tree_store = GTree.tree_store cols in
+ let id_renderer = GTree.cell_renderer_text [], ["text", id_col] in
+ let dsc_renderer = GTree.cell_renderer_text [], ["text", dsc_col] in
+ let id_view_col = GTree.view_column ~renderer:id_renderer () in
+ let dsc_view_col = GTree.view_column ~renderer:dsc_renderer () in
+ fun (tree_view: GTree.view) choices ->
+ object
+ initializer
+ tree_view#set_model (Some (tree_store :> GTree.model));
+ ignore (tree_view#append_column id_view_col);
+ ignore (tree_view#append_column dsc_view_col);
+ tree_store#clear ();
+ let idx1 = ref ~-1 in
+ List.iter
+ (fun _,lll ->
+ incr idx1;
+ let loc_row =
+ if List.length choices = 1 then
+ None
+ else
+ (let loc_row = tree_store#append () in
+ begin
+ match lll with
+ [passes,envs_and_diffs,_,_] ->
+ tree_store#set ~row:loc_row ~column:id_col
+ ("Error location " ^ string_of_int (!idx1+1) ^
+ ", error message " ^ string_of_int (!idx1+1) ^ ".1" ^
+ " (in passes " ^
+ String.concat " " (List.map string_of_int passes) ^
+ ")");
+ tree_store#set ~row:loc_row ~column:interp_no_col
+ (!idx1,Some 0,None);
+ | _ ->
+ tree_store#set ~row:loc_row ~column:id_col
+ ("Error location " ^ string_of_int (!idx1+1));
+ tree_store#set ~row:loc_row ~column:interp_no_col
+ (!idx1,None,None);
+ end ;
+ Some loc_row) in
+ let idx2 = ref ~-1 in
+ List.iter
+ (fun passes,envs_and_diffs,_,_ ->
+ incr idx2;
+ let msg_row =
+ if List.length lll = 1 then
+ loc_row
+ else
+ let msg_row = tree_store#append ?parent:loc_row () in
+ (tree_store#set ~row:msg_row ~column:id_col
+ ("Error message " ^ string_of_int (!idx1+1) ^ "." ^
+ string_of_int (!idx2+1) ^
+ " (in passes " ^
+ String.concat " " (List.map string_of_int passes) ^
+ ")");
+ tree_store#set ~row:msg_row ~column:interp_no_col
+ (!idx1,Some !idx2,None);
+ Some msg_row) in
+ let idx3 = ref ~-1 in
+ List.iter
+ (fun (passes,env,_) ->
+ incr idx3;
+ let interp_row =
+ match envs_and_diffs with
+ _::_::_ ->
+ let interp_row = tree_store#append ?parent:msg_row () in
+ tree_store#set ~row:interp_row ~column:id_col
+ ("Interpretation " ^ string_of_int (!idx3+1) ^
+ " (in passes " ^
+ String.concat " " (List.map string_of_int passes) ^
+ ")");
+ tree_store#set ~row:interp_row ~column:interp_no_col
+ (!idx1,Some !idx2,Some !idx3);
+ Some interp_row
+ | [_] -> msg_row
+ | [] -> assert false
+ in
+ List.iter
+ (fun (_, id, dsc) ->
+ let row = tree_store#append ?parent:interp_row () in
+ tree_store#set ~row ~column:id_col id;
+ tree_store#set ~row ~column:dsc_col dsc;
+ tree_store#set ~row ~column:interp_no_col
+ (!idx1,Some !idx2,Some !idx3)
+ ) env
+ ) envs_and_diffs
+ ) lll ;
+ if List.length lll > 1 then
+ HExtlib.iter_option
+ (fun p -> tree_view#expand_row (tree_store#get_path p))
+ loc_row
+ ) choices
+
+ method get_interp_no tree_path =
+ let iter = tree_store#get_iter tree_path in
+ tree_store#get ~row:iter ~column:interp_no_col
+ end
+
+
+let rec interactive_error_interp ?(all_passes=false) (source_buffer:GSourceView.source_buffer) notify_exn offset errorll script_fname
+=
+ (* hook to save a script for each disambiguation error *)
+ if false then
+ (let text =
+ source_buffer#get_text ~start:source_buffer#start_iter
+ ~stop:source_buffer#end_iter () in
+ let md5 = Digest.to_hex (Digest.string text) in
+ let filename = match script_fname with Some s -> s | None -> "unnamed.ma" in
+ let filename =
+ Filename.chop_extension filename ^ ".error." ^ md5 ^ ".ma" in
+ let ch = open_out filename in
+ output_string ch text;
+ close_out ch
+ );
+ assert (List.flatten errorll <> []);
+ let errorll' =
+ let remove_non_significant =
+ List.filter (fun (_env,_diff,_loc,_msg,significant) -> significant) in
+ let annotated_errorll () =
+ List.rev
+ (snd
+ (List.fold_left (fun (pass,res) item -> pass+1,(pass+1,item)::res) (0,[])
+ errorll)) in
+ if all_passes then annotated_errorll () else
+ let safe_list_nth l n = try List.nth l n with Failure _ -> [] in
+ (* We remove passes 1,2 and 5,6 *)
+ let res =
+ (1,[])::(2,[])
+ ::(3,remove_non_significant (safe_list_nth errorll 2))
+ ::(4,remove_non_significant (safe_list_nth errorll 3))
+ ::(5,[])::(6,[])::[]
+ in
+ if List.flatten (List.map snd res) <> [] then res
+ else
+ (* all errors (if any) are not significant: we keep them *)
+ let res =
+ (1,[])::(2,[])
+ ::(3,(safe_list_nth errorll 2))
+ ::(4,(safe_list_nth errorll 3))
+ ::(5,[])::(6,[])::[]
+ in
+ if List.flatten (List.map snd res) <> [] then
+ begin
+ HLog.warn
+ "All disambiguation errors are not significant. Showing them anyway." ;
+ res
+ end
+ else
+ begin
+ HLog.warn
+ "No errors in phases 2 and 3. Showing all errors in all phases" ;
+ annotated_errorll ()
+ end
+ in
+ let choices = MatitaExcPp.compact_disambiguation_errors all_passes errorll' in
+ match choices with
+ [] -> assert false
+ | [loffset,[_,envs_and_diffs,msg,significant]] ->
+ let _,env,diff = List.hd envs_and_diffs in
+ notify_exn
+ (GrafiteDisambiguator.DisambiguationError
+ (offset,[[env,diff,loffset,msg,significant]]));
+ | _::_ ->
+ let dialog = new disambiguationErrors () in
+ dialog#check_widgets ();
+ if all_passes then
+ dialog#disambiguationErrorsMoreErrors#misc#set_sensitive false;
+ let model = new interpErrorModel dialog#treeview choices in
+ dialog#disambiguationErrors#set_title "Disambiguation error";
+ dialog#disambiguationErrorsLabel#set_label
+ "Click on an error to see the corresponding message:";
+ ignore (dialog#treeview#connect#cursor_changed
+ (fun _ ->
+ let tree_path =
+ match fst (dialog#treeview#get_cursor ()) with
+ None -> assert false
+ | Some tp -> tp in
+ let idx1,idx2,idx3 = model#get_interp_no tree_path in
+ let loffset,lll = List.nth choices idx1 in
+ let _,envs_and_diffs,msg,significant =
+ match idx2 with
+ Some idx2 -> List.nth lll idx2
+ | None ->
+ [],[],lazy "Multiple error messages. Please select one.",true
+ in
+ let _,env,diff =
+ match idx3 with
+ Some idx3 -> List.nth envs_and_diffs idx3
+ | None -> [],[],[] (* dymmy value, used *) in
+ let script = MatitaScript.current () in
+ let error_tag = script#error_tag in
+ source_buffer#remove_tag error_tag
+ ~start:source_buffer#start_iter
+ ~stop:source_buffer#end_iter;
+ notify_exn
+ (GrafiteDisambiguator.DisambiguationError
+ (offset,[[env,diff,loffset,msg,significant]]))
+ ));
+ let return _ =
+ dialog#disambiguationErrors#destroy ();
+ GMain.Main.quit ()
+ in
+ let fail _ = return () in
+ ignore(dialog#disambiguationErrors#event#connect#delete (fun _ -> true));
+ connect_button dialog#disambiguationErrorsOkButton
+ (fun _ ->
+ let tree_path =
+ match fst (dialog#treeview#get_cursor ()) with
+ None -> assert false
+ | Some tp -> tp in
+ let idx1,idx2,idx3 = model#get_interp_no tree_path in
+ let diff =
+ match idx2,idx3 with
+ Some idx2, Some idx3 ->
+ let _,lll = List.nth choices idx1 in
+ let _,envs_and_diffs,_,_ = List.nth lll idx2 in
+ let _,_,diff = List.nth envs_and_diffs idx3 in
+ diff
+ | _,_ -> assert false
+ in
+ let newtxt =
+ String.concat "\n"
+ ("" ::
+ List.map
+ (fun k,value ->
+ DisambiguatePp.pp_environment
+ (DisambiguateTypes.Environment.add k value
+ DisambiguateTypes.Environment.empty))
+ diff) ^ "\n"
+ in
+ source_buffer#insert
+ ~iter:
+ (source_buffer#get_iter_at_mark
+ (`NAME "beginning_of_statement")) newtxt ;
+ return ()
+ );
+ connect_button dialog#disambiguationErrorsMoreErrors
+ (fun _ -> return () ;
+ interactive_error_interp ~all_passes:true source_buffer notify_exn
+ offset errorll script_fname);
+ connect_button dialog#disambiguationErrorsCancelButton fail;
+ dialog#disambiguationErrors#show ();
+ GtkThread.main ()
+
+
(** Selection handling
* Two clipboards are used: "clipboard" and "primary".
* "primary" is used by X, when you hit the middle button mouse is content is
@@ -407,17 +659,89 @@ class gui () =
let lock_world _ =
main#buttonsToolbar#misc#set_sensitive false;
develList#buttonsHbox#misc#set_sensitive false;
+ main#scriptMenu#misc#set_sensitive false;
source_view#set_editable false
in
let unlock_world _ =
main#buttonsToolbar#misc#set_sensitive true;
develList#buttonsHbox#misc#set_sensitive true;
- source_view#set_editable true
+ main#scriptMenu#misc#set_sensitive true;
+ source_view#set_editable true;
+ (*The next line seems sufficient to avoid some unknown race condition *)
+ GtkThread.sync (fun () -> ()) ()
in
- let locker f =
+ let worker_thread = ref None in
+ let notify_exn exn =
+ let floc, msg = MatitaExcPp.to_string exn in
+ begin
+ match floc with
+ None -> ()
+ | Some floc ->
+ let (x, y) = HExtlib.loc_of_floc floc in
+ let script = MatitaScript.current () in
+ let locked_mark = script#locked_mark in
+ let error_tag = script#error_tag in
+ let baseoffset =
+ (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in
+ let x' = baseoffset + x in
+ let y' = baseoffset + y in
+ let x_iter = source_buffer#get_iter (`OFFSET x') in
+ let y_iter = source_buffer#get_iter (`OFFSET y') in
+ source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter;
+ let id = ref None in
+ id := Some (source_buffer#connect#changed ~callback:(fun () ->
+ source_buffer#remove_tag error_tag
+ ~start:source_buffer#start_iter
+ ~stop:source_buffer#end_iter;
+ match !id with
+ | None -> assert false (* a race condition occurred *)
+ | Some id ->
+ (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id));
+ source_buffer#place_cursor
+ (source_buffer#get_iter (`OFFSET x'));
+ end;
+ HLog.error msg in
+ let locker f () =
+ let thread_main =
fun () ->
lock_world ();
- try f ();unlock_world () with exc -> unlock_world (); raise exc in
+ try
+ f ();
+ unlock_world ()
+ with
+ | GrafiteDisambiguator.DisambiguationError (offset,errorll) ->
+ (try
+ interactive_error_interp source_buffer notify_exn offset
+ errorll script_fname
+ with
+ exc -> notify_exn exc);
+ unlock_world ()
+ | exc ->
+ notify_exn exc;
+ unlock_world ()
+ in
+ (*thread_main ();*)
+ worker_thread := Some (Thread.create thread_main ())
+ in
+ let kill_worker =
+ (* the following lines are from Xavier Leroy: http://alan.petitepomme.net/cwn/2005.11.08.html *)
+ let interrupt = ref None in
+ let old_callback = ref (function _ -> ()) in
+ let force_interrupt n =
+ (* This function is called just before the thread's timeslice ends *)
+ !old_callback n;
+ if Some(Thread.id(Thread.self())) = !interrupt then
+ (interrupt := None; raise Sys.Break) in
+ let _ =
+ match Sys.signal Sys.sigvtalrm (Sys.Signal_handle force_interrupt) with
+ Sys.Signal_handle f -> old_callback := f
+ | Sys.Signal_ignore
+ | Sys.Signal_default -> assert false
+ in
+ fun () ->
+ match !worker_thread with
+ None -> assert false
+ | Some t -> interrupt := Some (Thread.id t) in
let keep_focus f =
fun () ->
try
@@ -473,15 +797,27 @@ class gui () =
(fun () -> MatitamakeLib.clean_development_in_bg refresh d)
in
ignore(clean ())));
+ (* publish button hidden, use command line
connect_button develList#publishButton
(locker (fun () ->
match get_devel_selected () with
| None -> ()
| Some d ->
- let clean = locker
- (fun () -> MatitamakeLib.publish_development_in_bg refresh d)
- in
- ignore(clean ())));
+ let publish = locker (fun () ->
+ MatitamakeLib.publish_development_in_bg refresh d) in
+ ignore(publish ())));
+ *)
+ develList#publishButton#misc#hide ();
+ connect_button develList#graphButton (fun () ->
+ match get_devel_selected () with
+ | None -> ()
+ | Some d ->
+ (match MatitamakeLib.dot_for_development d with
+ | None -> ()
+ | Some _ ->
+ let browser = MatitaMathView.cicBrowser () in
+ browser#load (`Development
+ (MatitamakeLib.name_for_development d))));
connect_button develList#closeButton
(fun () -> develList#toplevel#misc#hide());
ignore(develList#toplevel#event#connect#delete
@@ -495,6 +831,8 @@ class gui () =
| None -> true
| Some path ->
let is_prefix_of d1 d2 =
+ let d1 = MatitamakeLib.normalize_path d1 in
+ let d2 = MatitamakeLib.normalize_path d2 in
let len1 = String.length d1 in
let len2 = String.length d2 in
if len2 < len1 then
@@ -566,59 +904,32 @@ class gui () =
ignore (adj#connect#changed
(fun _ -> adj#set_value (adj#upper -. adj#page_size)));
console#message (sprintf "\tMatita version %s\n" BuildTimeConf.version);
- (* toolbar *)
- let module A = GrafiteAst in
- let hole = CicNotationPt.UserInput in
- let loc = HExtlib.dummy_floc in
- let tac ast _ =
- if (MatitaScript.current ())#onGoingProof () then
- (MatitaScript.current ())#advance
- ~statement:("\n"
- ^ GrafiteAstPp.pp_tactical ~term_pp:CicNotationPp.pp_term
- ~lazy_term_pp:CicNotationPp.pp_term (A.Tactic (loc, ast)))
- ()
- in
- let tac_w_term ast _ =
- if (MatitaScript.current ())#onGoingProof () then
- let buf = source_buffer in
- buf#insert ~iter:(buf#get_iter_at_mark (`NAME "locked"))
- ("\n"
- ^ GrafiteAstPp.pp_tactic ~term_pp:CicNotationPp.pp_term
- ~lazy_term_pp:CicNotationPp.pp_term ast)
- in
- let tbar = main in
- connect_button tbar#introsButton (tac (A.Intros (loc, None, [])));
- connect_button tbar#applyButton (tac_w_term (A.Apply (loc, hole)));
- connect_button tbar#exactButton (tac_w_term (A.Exact (loc, hole)));
- connect_button tbar#elimButton (tac_w_term
- (A.Elim (loc, hole, None, None, [])));
- connect_button tbar#elimTypeButton (tac_w_term
- (A.ElimType (loc, hole, None, None, [])));
- connect_button tbar#splitButton (tac (A.Split loc));
- connect_button tbar#leftButton (tac (A.Left loc));
- connect_button tbar#rightButton (tac (A.Right loc));
- connect_button tbar#existsButton (tac (A.Exists loc));
- connect_button tbar#reflexivityButton (tac (A.Reflexivity loc));
- connect_button tbar#symmetryButton (tac (A.Symmetry loc));
- connect_button tbar#transitivityButton
- (tac_w_term (A.Transitivity (loc, hole)));
- connect_button tbar#assumptionButton (tac (A.Assumption loc));
- connect_button tbar#cutButton (tac_w_term (A.Cut (loc, None, hole)));
- connect_button tbar#autoButton (tac (A.Auto (loc,None,None,None,None)));
- MatitaGtkMisc.toggle_widget_visibility
- ~widget:(main#tacticsButtonsHandlebox :> GObj.widget)
- ~check:main#tacticsBarMenuItem;
+ (* TO BE REMOVED *)
+ main#tacticsButtonsHandlebox#misc#hide ();
+ main#tacticsBarMenuItem#misc#hide ();
+ main#scriptNotebook#remove_page 1;
+ main#scriptNotebook#set_show_tabs false;
+ (* / TO BE REMOVED *)
let module Hr = Helm_registry in
- if
- not (Hr.get_opt_default Hr.bool ~default:false "matita.tactics_bar")
- then
- main#tacticsBarMenuItem#set_active false;
- MatitaGtkMisc.toggle_callback
+ MatitaGtkMisc.toggle_callback ~check:main#fullscreenMenuItem
~callback:(function
| true -> main#toplevel#fullscreen ()
- | false -> main#toplevel#unfullscreen ())
- ~check:main#fullscreenMenuItem;
+ | false -> main#toplevel#unfullscreen ());
main#fullscreenMenuItem#set_active false;
+ MatitaGtkMisc.toggle_callback ~check:main#ppNotationMenuItem
+ ~callback:(function
+ | true ->
+ CicNotation.set_active_notations
+ (List.map fst (CicNotation.get_all_notations ()))
+ | false ->
+ CicNotation.set_active_notations []);
+ MatitaGtkMisc.toggle_callback ~check:main#hideCoercionsMenuItem
+ ~callback:(fun enabled -> Acic2content.hide_coercions := enabled);
+ MatitaGtkMisc.toggle_callback ~check:main#unicodeAsTexMenuItem
+ ~callback:(fun enabled ->
+ Helm_registry.set_bool "matita.paste_unicode_as_tex" enabled);
+ main#unicodeAsTexMenuItem#set_active
+ (Helm_registry.get_bool "matita.paste_unicode_as_tex");
(* log *)
HLog.set_log_callback self#console#log_callback;
GtkSignal.user_handler :=
@@ -626,35 +937,7 @@ class gui () =
| MatitaScript.ActionCancelled s -> HLog.error s
| exn ->
if not (Helm_registry.get_bool "matita.debug") then
- let floc, msg = MatitaExcPp.to_string exn in
- begin
- match floc with
- None -> ()
- | Some floc ->
- let (x, y) = HExtlib.loc_of_floc floc in
- let script = MatitaScript.current () in
- let locked_mark = script#locked_mark in
- let error_tag = script#error_tag in
- let baseoffset =
- (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in
- let x' = baseoffset + x in
- let y' = baseoffset + y in
- let x_iter = source_buffer#get_iter (`OFFSET x') in
- let y_iter = source_buffer#get_iter (`OFFSET y') in
- source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter;
- let id = ref None in
- id := Some (source_buffer#connect#changed ~callback:(fun () ->
- source_buffer#remove_tag error_tag
- ~start:source_buffer#start_iter
- ~stop:source_buffer#end_iter;
- match !id with
- | None -> assert false (* a race condition occurred *)
- | Some id ->
- (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id));
- source_buffer#place_cursor
- (source_buffer#get_iter (`OFFSET x'));
- end;
- HLog.error msg
+ notify_exn exn
else raise exn);
(* script *)
ignore (source_buffer#connect#mark_set (fun _ _ -> next_ligatures <- []));
@@ -781,6 +1064,7 @@ class gui () =
connect_button main#scriptTopButton top;
connect_button main#scriptBottomButton bottom;
connect_button main#scriptJumpButton jump;
+ connect_button main#scriptAbortButton kill_worker;
connect_menu_item main#scriptAdvanceMenuItem advance;
connect_menu_item main#scriptRetractMenuItem retract;
connect_menu_item main#scriptTopMenuItem top;
@@ -790,14 +1074,23 @@ class gui () =
connect_menu_item main#saveMenuItem saveScript;
connect_menu_item main#saveAsMenuItem saveAsScript;
connect_menu_item main#newMenuItem newScript;
+ connect_menu_item main#showCoercionsGraphMenuItem
+ (fun _ ->
+ let c = MatitaMathView.cicBrowser () in
+ c#load (`About `Coercions));
+ connect_menu_item main#showAutoGuiMenuItem
+ (fun _ -> MatitaAutoGui.auto_dialog Auto.get_auto_status);
(* script monospace font stuff *)
self#updateFontSize ();
(* debug menu *)
main#debugMenu#misc#hide ();
- (* status bar *)
+ (* HBUGS *)
+ main#hintNotebook#misc#hide ();
+ (*
main#hintLowImage#set_file (image_path "matita-bulb-low.png");
main#hintMediumImage#set_file (image_path "matita-bulb-medium.png");
main#hintHighImage#set_file (image_path "matita-bulb-high.png");
+ *)
(* focus *)
self#sourceView#misc#grab_focus ();
(* main win dimension *)
@@ -895,7 +1188,7 @@ class gui () =
source_buffer#insert ~iter:(source_buffer#get_iter_at_mark `INSERT) s
in
let get_ligature word =
- let len = MatitaGtkMisc.utf8_string_length word in
+ let len = String.length word in
let aux_tex () =
try
for i = len - 1 downto 0 do
@@ -999,23 +1292,43 @@ class gui () =
method loadScript file =
let script = MatitaScript.current () in
script#reset ();
- script#assignFileName file;
- let content =
- if Sys.file_exists file then file
- else BuildTimeConf.script_template
- in
- source_view#source_buffer#begin_not_undoable_action ();
- script#loadFromFile content;
- source_view#source_buffer#end_not_undoable_action ();
- console#message ("'"^file^"' loaded.");
- self#_enableSaveTo file
+ if Pcre.pmatch ~pat:"\\.p$" file then
+ begin
+ let tptppath =
+ Helm_registry.get_opt_default Helm_registry.string ~default:"./"
+ "matita.tptppath"
+ in
+ let data = Matitaprover.p_to_ma ~filename:file ~tptppath () in
+ let filename = Pcre.replace ~pat:"\\.p$" ~templ:".ma" file in
+ script#assignFileName filename;
+ source_view#source_buffer#begin_not_undoable_action ();
+ script#loadFromString data;
+ source_view#source_buffer#end_not_undoable_action ();
+ console#message ("'"^filename^"' loaded.");
+ self#_enableSaveTo filename
+ end
+ else
+ begin
+ script#assignFileName file;
+ let content =
+ if Sys.file_exists file then file
+ else BuildTimeConf.script_template
+ in
+ source_view#source_buffer#begin_not_undoable_action ();
+ script#loadFromFile content;
+ source_view#source_buffer#end_not_undoable_action ();
+ console#message ("'"^file^"' loaded.");
+ self#_enableSaveTo file
+ end
method setStar name b =
- let l = main#scriptLabel in
+ let w = main#toplevel in
+ let set x = w#set_title x in
+ let name = "Matita - " ^ name in
if b then
- l#set_text (name ^ " *")
+ set (name ^ " *")
else
- l#set_text (name)
+ set (name)
method private _enableSaveTo file =
script_fname <- Some file;
@@ -1047,11 +1360,6 @@ class gui () =
dialog#check_widgets ();
dialog
- method newRecordDialog () =
- let dialog = new recordChoiceDialog () in
- dialog#check_widgets ();
- dialog
-
method newConfirmationDialog () =
let dialog = new confirmationDialog () in
dialog#check_widgets ();
@@ -1256,34 +1564,129 @@ class interpModel =
tree_store#get ~row:iter ~column:interp_no_col
end
-let interactive_interp_choice () choices =
+let interactive_string_choice
+ text prefix_len ?(title = "") ?(msg = "") () ~id locs uris
+=
let gui = instance () in
- assert (choices <> []);
- let dialog = gui#newRecordDialog () in
- let model = new interpModel dialog#recordChoiceTreeView choices in
- dialog#recordChoiceDialog#set_title "Interpretation choice";
- dialog#recordChoiceDialogLabel#set_label "Choose an interpretation:";
- let interp_no = ref None in
- let return _ =
- dialog#recordChoiceDialog#destroy ();
- GMain.Main.quit ()
+ let dialog = gui#newUriDialog () in
+ dialog#uriEntryHBox#misc#hide ();
+ dialog#uriChoiceSelectedButton#misc#hide ();
+ dialog#uriChoiceAutoButton#misc#hide ();
+ dialog#uriChoiceConstantsButton#misc#hide ();
+ dialog#uriChoiceTreeView#selection#set_mode
+ (`SINGLE :> Gtk.Tags.selection_mode);
+ let model = new stringListModel dialog#uriChoiceTreeView in
+ let choices = ref None in
+ dialog#uriChoiceDialog#set_title title;
+ let hack_len = MatitaGtkMisc.utf8_string_length text in
+ let rec colorize acc_len = function
+ | [] ->
+ let floc = HExtlib.floc_of_loc (acc_len,hack_len) in
+ fst(MatitaGtkMisc.utf8_parsed_text text floc)
+ | he::tl ->
+ let start, stop = HExtlib.loc_of_floc he in
+ let floc1 = HExtlib.floc_of_loc (acc_len,start) in
+ let str1,_=MatitaGtkMisc.utf8_parsed_text text floc1 in
+ let str2,_ = MatitaGtkMisc.utf8_parsed_text text he in
+ str1 ^ "" ^ str2 ^ "" ^ colorize stop tl
+ in
+(* List.iter (fun l -> let start, stop = HExtlib.loc_of_floc l in
+ Printf.eprintf "(%d,%d)" start stop) locs; *)
+ let locs =
+ List.sort
+ (fun loc1 loc2 ->
+ fst (HExtlib.loc_of_floc loc1) - fst (HExtlib.loc_of_floc loc2))
+ locs
+ in
+(* prerr_endline "XXXXXXXXXXXXXXXXXXXX";
+ List.iter (fun l -> let start, stop = HExtlib.loc_of_floc l in
+ Printf.eprintf "(%d,%d)" start stop) locs;
+ prerr_endline "XXXXXXXXXXXXXXXXXXXX2"; *)
+ dialog#uriChoiceLabel#set_use_markup true;
+ let txt = colorize 0 locs in
+ let txt,_ = MatitaGtkMisc.utf8_parsed_text txt
+ (HExtlib.floc_of_loc (prefix_len,MatitaGtkMisc.utf8_string_length txt))
+ in
+ dialog#uriChoiceLabel#set_label txt;
+ List.iter model#easy_append uris;
+ let return v =
+ choices := v;
+ dialog#uriChoiceDialog#destroy ();
+ GMain.Main.quit ()
+ in
+ ignore (dialog#uriChoiceDialog#event#connect#delete (fun _ -> true));
+ connect_button dialog#uriChoiceForwardButton (fun _ ->
+ match model#easy_selection () with
+ | [] -> ()
+ | uris -> return (Some uris));
+ connect_button dialog#uriChoiceAbortButton (fun _ -> return None);
+ dialog#uriChoiceDialog#show ();
+ GtkThread.main ();
+ (match !choices with
+ | None -> raise MatitaTypes.Cancel
+ | Some uris -> uris)
+
+let interactive_interp_choice () text prefix_len choices =
+(*List.iter (fun l -> prerr_endline "==="; List.iter (fun (_,id,dsc) -> prerr_endline (id ^ " = " ^ dsc)) l) choices;*)
+ let filter_choices filter =
+ let rec is_compatible filter =
+ function
+ [] -> true
+ | ([],_,_)::tl -> is_compatible filter tl
+ | (loc::tlloc,id,dsc)::tl ->
+ try
+ if List.assoc (loc,id) filter = dsc then
+ is_compatible filter ((tlloc,id,dsc)::tl)
+ else
+ false
+ with
+ Not_found -> true
in
- let fail _ = interp_no := None; return () in
- ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true));
- connect_button dialog#recordChoiceOkButton (fun _ ->
- match !interp_no with None -> () | Some _ -> return ());
- connect_button dialog#recordChoiceCancelButton fail;
- ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ ->
- interp_no := Some (model#get_interp_no path);
- return ()));
- let selection = dialog#recordChoiceTreeView#selection in
- ignore (selection#connect#changed (fun _ ->
- match selection#get_selected_rows with
- | [path] -> interp_no := Some (model#get_interp_no path)
- | _ -> assert false));
- dialog#recordChoiceDialog#show ();
- GtkThread.main ();
- (match !interp_no with Some row -> [row] | _ -> raise MatitaTypes.Cancel)
+ List.filter (fun (_,interp) -> is_compatible filter interp)
+ in
+ let rec get_choices loc id =
+ function
+ [] -> []
+ | (_,he)::tl ->
+ let _,_,dsc =
+ List.find (fun (locs,id',_) -> id = id' && List.mem loc locs) he
+ in
+ dsc :: (List.filter (fun dsc' -> dsc <> dsc') (get_choices loc id tl))
+ in
+ let example_interp =
+ match choices with
+ [] -> assert false
+ | he::_ -> he in
+ let ask_user id locs choices =
+ interactive_string_choice
+ text prefix_len
+ ~title:"Ambiguous input"
+ ~msg:("Choose an interpretation for " ^ id) () ~id locs choices
+ in
+ let rec classify ids filter partial_interpretations =
+ match ids with
+ [] -> List.map fst partial_interpretations
+ | ([],_,_)::tl -> classify tl filter partial_interpretations
+ | (loc::tlloc,id,dsc)::tl ->
+ let choices = get_choices loc id partial_interpretations in
+ let chosen_dsc =
+ match choices with
+ [] -> prerr_endline ("NO CHOICES FOR " ^ id); assert false
+ | [dsc] -> dsc
+ | _ ->
+ match ask_user id [loc] choices with
+ [x] -> x
+ | _ -> assert false
+ in
+ let filter = ((loc,id),chosen_dsc)::filter in
+ let compatible_interps = filter_choices filter partial_interpretations in
+ classify ((tlloc,id,dsc)::tl) filter compatible_interps
+ in
+ let enumerated_choices =
+ let idx = ref ~-1 in
+ List.map (fun interp -> incr idx; !idx,interp) choices
+ in
+ classify example_interp [] enumerated_choices
let _ =
(* disambiguator callbacks *)