From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- ide/.coqide-gtk2rc | 49 - ide/FAQ | 24 +- ide/command_windows.ml | 34 +- ide/command_windows.mli | 12 +- ide/config_lexer.mll | 39 +- ide/config_parser.mly | 43 - ide/coq.ml | 863 ++----- ide/coq.mli | 100 +- ide/coq_commands.ml | 8 +- ide/coq_lex.mll | 199 +- ide/coq_tactics.ml | 131 - ide/coq_tactics.mli | 12 - ide/coqide-gtk2rc | 49 + ide/coqide.ml | 5121 ++++++++++++++++++--------------------- ide/coqide.mli | 38 +- ide/coqide_main.ml4 | 105 + ide/coqide_ui.ml | 151 ++ ide/gtk_parsing.ml | 18 +- ide/highlight.mll | 215 -- ide/ide.mllib | 5 +- ide/ide_mac_stubs.c | 85 + ide/ide_win32_stubs.c | 49 + ide/ideproof.ml | 137 ++ ide/ideutils.ml | 143 +- ide/ideutils.mli | 19 +- ide/mac_default_accel_map | 372 +++ ide/minilib.ml | 174 ++ ide/minilib.mli | 44 + ide/preferences.ml | 233 +- ide/preferences.mli | 17 +- ide/project_file.ml4 | 190 ++ ide/tags.ml | 6 +- ide/typed_notebook.ml | 43 +- ide/uim/coqide-custom.scm | 99 - ide/uim/coqide-rules.scm | 1142 --------- ide/uim/coqide.scm | 277 --- ide/undo.ml | 6 +- ide/undo_lablgtk_ge212.mli | 4 +- ide/undo_lablgtk_ge26.mli | 4 +- ide/undo_lablgtk_lt26.mli | 4 +- ide/utf8_convert.mll | 4 +- ide/utils/config_file.ml | 2 - ide/utils/configwin.ml | 4 +- ide/utils/configwin.mli | 8 +- ide/utils/configwin_ihm.ml | 460 ++-- ide/utils/configwin_messages.ml | 2 +- ide/utils/configwin_types.ml | 4 +- 47 files changed, 4614 insertions(+), 6134 deletions(-) delete mode 100644 ide/.coqide-gtk2rc delete mode 100644 ide/config_parser.mly delete mode 100644 ide/coq_tactics.ml delete mode 100644 ide/coq_tactics.mli create mode 100644 ide/coqide-gtk2rc create mode 100644 ide/coqide_main.ml4 create mode 100644 ide/coqide_ui.ml delete mode 100644 ide/highlight.mll create mode 100644 ide/ide_mac_stubs.c create mode 100644 ide/ide_win32_stubs.c create mode 100644 ide/ideproof.ml create mode 100644 ide/mac_default_accel_map create mode 100644 ide/minilib.ml create mode 100644 ide/minilib.mli create mode 100644 ide/project_file.ml4 delete mode 100644 ide/uim/coqide-custom.scm delete mode 100644 ide/uim/coqide-rules.scm delete mode 100644 ide/uim/coqide.scm (limited to 'ide') diff --git a/ide/.coqide-gtk2rc b/ide/.coqide-gtk2rc deleted file mode 100644 index 11c53dad..00000000 --- a/ide/.coqide-gtk2rc +++ /dev/null @@ -1,49 +0,0 @@ -# Some default functions for CoqIde. You may copy the file in your HOME and -# edit as you want. See -# http://developer.gnome.org/doc/API/2.0/gtk/gtk-Resource-Files.html -# for a complete set of options -# To set the font of the text windows, edit the .coqiderc file through the menus. - -gtk-key-theme-name = "Emacs" - -#pixmap_path "/home/" - -binding "text" { - bind "k" { "set-anchor" () - "move-cursor" (display-line-ends,1,0) - "move-cursor" (visual-positions,1,0) - "cut-clipboard" () - } - bind "w" { "cut-clipboard" () } - -# For UTF-8 inputs ! -# bind "F11" {"insert-at-cursor" ("∀")} -# bind "F12" {"insert-at-cursor" ("∃")} -} -class "GtkTextView" binding "text" - - -style "views" { -base[NORMAL] = "CornSilk" -# bg_pixmap[NORMAL] = "background.jpg" -} -class "GtkTextView" style "views" - -widget "*.*.*.*.*.ScriptWindow" style "views" -widget "*.*.*.*.GoalWindow" style "views" -widget "*.*.*.*.MessageWindow" style "views" - -gtk-font-name = "Sans 12" - -style "location" { -font_name = "Sans 10" -} -widget "*location*" style "location" - - -gtk-can-change-accels = 1 - -style "men" { -# -} -widget "GtkMenu" style "men" diff --git a/ide/FAQ b/ide/FAQ index 2079ef6c..f07f229f 100644 --- a/ide/FAQ +++ b/ide/FAQ @@ -6,8 +6,8 @@ R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more i Q1) How to enable Emacs keybindings? R1: Insert gtk-key-theme-name = "Emacs" - in your ".coqide-gtk2rc" file. It may be in the current dir - or in $HOME dir. This is done by default. + in your "coqide-gtk2rc" file. It should be in $XDG_CONFIG_DIRS/coq dir. + This is done by default. Q2) How to enable antialiased fonts? R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2. @@ -41,7 +41,7 @@ R5)-First solution : type "2200" to enter a forall in the script and then to add bind "F13" {"insert-at-cursor" ("∀")} bind "F14" {"insert-at-cursor" ("∃")} - to your "binding "text"" section in .coqiderc-gtk2rc. + to your "binding "text"" section in coqiderc-gtk2rc. The strange ("∀") argument is the UTF-8 encoding for 0x2200. You can compute these encodings using the lablgtk2 toplevel with @@ -49,21 +49,15 @@ R5)-First solution : type "2200" to enter a forall in the script Further symbols can be bound on higher Fxx keys or on even on other keys you do not need . -Q6) How to build a custom CoqIde with user ml code? -R6) Use - coqmktop -ide -byte m1.cmo...mi.cmo - or - coqmktop -ide -opt m1.cmx...mi.cmx - -Q7) How to customize the shortcuts for menus? -R7) Two solutions are offered: - - Edit $HOME/.coqide.keys by hand or - - Add "gtk-can-change-accels = 1" in your .coqide-gtk2rc file. Then +Q6) How to customize the shortcuts for menus? +R6) Two solutions are offered: + - Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or + - Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then from CoqIde, you may select a menu entry and press the desired shortcut. -Q8) What encoding should I use? What is this \x{iiii} in my file? -R8) The encoding option is related to the way files are saved. +Q7) What encoding should I use? What is this \x{iiii} in my file? +R7) The encoding option is related to the way files are saved. Keep it as UTF-8 until it becomes important for you to exchange files with non UTF-8 aware applications. If you choose something else than UTF-8, then missing characters will diff --git a/ide/command_windows.ml b/ide/command_windows.ml index 1df83803..939238d3 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + ("Error while interpreting "^phrase^":\n"^str) + | Interface.Good results -> + ("Result for command " ^ phrase ^ ":\n" ^ results)) with e -> - let (s,loc) = Coq.process_exn e in + let s = Printexc.to_string e in assert (Glib.Utf8.validate s); result#buffer#set_text s in @@ -137,14 +135,6 @@ object(self) self#frame#misc#show () initializer - ignore (new_page_menu#connect#clicked self#new_command); + ignore (new_page_menu#connect#clicked ~callback:self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) end - -let command_window = ref None - -let main () = command_window := Some (new command_window ()) - -let command_window () = match !command_window with - | None -> failwith "No command window." - | Some c -> c diff --git a/ide/command_windows.mli b/ide/command_windows.mli index 0f5c208b..8c7319aa 100644 --- a/ide/command_windows.mli +++ b/ide/command_windows.mli @@ -1,22 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + Coq.coqtop ref -> Preferences.pref ref -> object method new_command : ?command:string -> ?term:string -> unit -> unit method frame : GBin.frame end - - val main : unit -> unit - -val command_window : unit -> command_window - - diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 3724f2bf..57699c68 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -1,19 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* s)) } +rule prefs m = parse + |ignore* (ident as id) ignore* '=' { let conf = str_list [] lexbuf in + prefs (Stringmap.add id conf m) lexbuf } | _ { let c = lexeme_start lexbuf in - eprintf ".coqiderc: invalid character (%d)\n@." c; - token lexbuf } - | eof { EOF } + eprintf "coqiderc: invalid character (%d)\n@." c; + prefs m lexbuf } + | eof { m } + +and str_list l = parse + | ignore* '"' { Buffer.reset string_buffer; + Buffer.add_char string_buffer '"'; + string lexbuf; + let s = Buffer.contents string_buffer in + str_list ((Scanf.sscanf s "%S" (fun s -> s))::l) lexbuf } + |ignore+ { List.rev l} and string = parse | '"' { Buffer.add_char string_buffer '"' } | '\\' '"' | _ { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf } - | eof { eprintf ".coqiderc: unterminated string\n@." } + | eof { eprintf "coqiderc: unterminated string\n@." } { let load_file f = let c = open_in f in let lb = from_channel c in - let m = Config_parser.prefs token lb in + let m = prefs Stringmap.empty lb in close_in c; m diff --git a/ide/config_parser.mly b/ide/config_parser.mly deleted file mode 100644 index d49e22eb..00000000 --- a/ide/config_parser.mly +++ /dev/null @@ -1,43 +0,0 @@ -/************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* IDENT STRING -%token EQUAL EOF - -%type <(string list) Util.Stringmap.t> prefs -%start prefs - -%% - -prefs: - pref_list EOF { $1 } -; - -pref_list: - pref_list pref { let (k,d) = $2 in Stringmap.add k d $1 } - | /* epsilon */ { Stringmap.empty } -; - -pref: - IDENT EQUAL string_list { ($1, List.rev $3) } -; - -string_list: - string_list STRING { $2 :: $1 } - | /* epsilon */ { [] } -; - diff --git a/ide/coq.ml b/ide/coq.ml index 1c6229b4..16a07b01 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -1,53 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* " in try - let ch = open_in (Coq_config.coqsrc^"/revision") in + (* the following makes sense only when running with local layout *) + let coqroot = Filename.concat + (Filename.dirname Sys.executable_name) + Filename.parent_dir_name + in + let ch = open_in (Filename.concat coqroot "revision") in let ver = input_line ch in let rev = input_line ch in (ver,rev) @@ -71,656 +37,191 @@ let version () = "The Coq Proof Assistant, version %s (%s)\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ - \nThis is the %s version (%s is the best one for this architecture and OS)\ + \nThis is %s (%s is the best one for this architecture and OS)\ \n" ver date Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) - (if Mltop.is_native then "native" else "bytecode") - (if Coq_config.best="opt" then "native" else "bytecode") - -let is_in_coq_lib dir = - prerr_endline ("Is it a coq theory ? : "^dir); - let is_same_file = same_file dir in - List.exists - (fun s -> - let fdir = - Filename.concat (Envars.coqlib ()) (Filename.concat "theories" s) in - prerr_endline (" Comparing to: "^fdir); - if is_same_file fdir then (prerr_endline " YES";true) - else (prerr_endline"NO";false)) - Coq_config.theories_dirs - -let is_in_loadpath dir = - Library.is_in_load_paths (System.physical_path_of_string dir) - -let is_in_coq_path f = + (Filename.basename Sys.executable_name) + Coq_config.best + + +(** * Initial checks by launching test coqtop processes *) + +let rec read_all_lines in_chan = + try + let arg = input_line in_chan in + arg::(read_all_lines in_chan) + with End_of_file -> [] + +let filter_coq_opts args = + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in + let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in + let filtered_args = read_all_lines oc in + let message = read_all_lines ec in + match Unix.close_process_full (oc,ic,ec) with + | Unix.WEXITED 0 -> true,filtered_args + | Unix.WEXITED 2 -> false,filtered_args + | _ -> false,message + +exception Coqtop_output of string list + +let check_connection args = try - let base = Filename.chop_extension (Filename.basename f) in - let _ = Library.locate_qualified_library false - (Libnames.make_qualid Names.empty_dirpath - (Names.id_of_string base)) in - prerr_endline (f ^ " is in coq path"); - true - with _ -> - prerr_endline (f ^ " is NOT in coq path"); - false - -let is_in_proof_mode () = - match Decl_mode.get_current_mode () with - Decl_mode.Mode_none -> false - | _ -> true - -let user_error_loc l s = - raise (Stdpp.Exc_located (l, Util.UserError ("CoqIde", s))) - -type printing_state = { - mutable printing_implicit : bool; - mutable printing_coercions : bool; - mutable printing_raw_matching : bool; - mutable printing_no_notation : bool; - mutable printing_all : bool; - mutable printing_evar_instances : bool; - mutable printing_universes : bool; - mutable printing_full_all : bool + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in + let ic = Unix.open_process_in cmd in + let lines = read_all_lines ic in + match Unix.close_process_in ic with + | Unix.WEXITED 0 -> prerr_endline "coqtop seems ok" + | _ -> raise (Coqtop_output lines) + with + | End_of_file -> + Minilib.safe_prerr_endline "Cannot start connection with coqtop"; + exit 1 + | Coqtop_output lines -> + Minilib.safe_prerr_endline "Connection with coqtop failed:"; + List.iter Minilib.safe_prerr_endline lines; + exit 1 + +(** * The structure describing a coqtop sub-process *) + +type coqtop = { + pid : int; (* Unix process id *) + cout : in_channel ; + cin : out_channel ; + sup_args : string list; } -let printing_state = { - printing_implicit = false; - printing_coercions = false; - printing_raw_matching = false; - printing_no_notation = false; - printing_all = false; - printing_evar_instances = false; - printing_universes = false; - printing_full_all = false; -} +(** * Count of all active coqtops *) -let printing_implicit_data = ["Printing";"Implicit"], false -let printing_coercions_data = ["Printing";"Coercions"], false -let printing_raw_matching_data = ["Printing";"Matching"], true -let printing_no_synth_data = ["Printing";"Synth"], true -let printing_no_notation_data = ["Printing";"Notations"], true -let printing_all_data = ["Printing";"All"], false -let printing_evar_instances_data = ["Printing";"Existential";"Instances"],false -let printing_universes_data = ["Printing";"Universes"], false - -let known_options = ref [] - -let prepare_option (l,dft) = - known_options := l :: !known_options; - let set = (String.concat " " ("Set"::l)) ^ "." in - let unset = (String.concat " " ("Unset"::l)) ^ "." in - if dft then unset,set else set,unset - -let coqide_known_option table = List.mem table !known_options - -let with_printing_implicit = prepare_option printing_implicit_data -let with_printing_coercions = prepare_option printing_coercions_data -let with_printing_raw_matching = prepare_option printing_raw_matching_data -let with_printing_no_synth = prepare_option printing_no_synth_data -let with_printing_no_notation = prepare_option printing_no_notation_data -let with_printing_all = prepare_option printing_all_data -let with_printing_evar_instances = prepare_option printing_evar_instances_data -let with_printing_universes = prepare_option printing_universes_data - -let make_option_commands () = - let p = printing_state in - (if p.printing_implicit then [with_printing_implicit] else [])@ - (if p.printing_coercions then [with_printing_coercions] else [])@ - (if p.printing_raw_matching then [with_printing_raw_matching;with_printing_no_synth] else [])@ - (if p.printing_no_notation then [with_printing_no_notation] else [])@ - (if p.printing_all then [with_printing_all] else [])@ - (if p.printing_evar_instances then [with_printing_evar_instances] else [])@ - (if p.printing_universes then [with_printing_universes] else [])@ - (if p.printing_full_all then [with_printing_all;with_printing_evar_instances;with_printing_universes] else []) - -let make_option_commands () = - let l = make_option_commands () in - List.iter (fun (a,b) -> prerr_endline a; prerr_endline b) l; - l - -type command_attribute = - NavigationCommand | QueryCommand | DebugCommand | KnownOptionCommand - | OtherStatePreservingCommand | GoalStartingCommand | SolveCommand - | ProofEndingCommand - -let rec attribute_of_vernac_command = function - (* Control *) - | VernacTime com -> attribute_of_vernac_command com - | VernacTimeout(_,com) -> attribute_of_vernac_command com - | VernacFail com -> attribute_of_vernac_command com - | VernacList _ -> [] (* unsupported *) - | VernacLoad _ -> [] - - (* Syntax *) - | VernacTacticNotation _ -> [] - | VernacSyntaxExtension _ -> [] - | VernacDelimiters _ -> [] - | VernacBindScope _ -> [] - | VernacOpenCloseScope _ -> [] - | VernacArgumentsScope _ -> [] - | VernacInfix _ -> [] - | VernacNotation _ -> [] - - (* Gallina *) - | VernacDefinition (_,_,DefineBody _,_) -> [] - | VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand] - | VernacStartTheoremProof _ -> [GoalStartingCommand] - | VernacEndProof _ -> [ProofEndingCommand] - | VernacExactProof _ -> [ProofEndingCommand] - - | VernacAssumption _ -> [] - | VernacInductive _ -> [] - | VernacFixpoint _ -> [] - | VernacCoFixpoint _ -> [] - | VernacScheme _ -> [] - | VernacCombinedScheme _ -> [] - - (* Modules *) - | VernacDeclareModule _ -> [] - | VernacDefineModule _ -> [] - | VernacDeclareModuleType _ -> [] - | VernacInclude _ -> [] - - (* Gallina extensions *) - | VernacBeginSection _ -> [] - | VernacEndSegment _ -> [] - | VernacRequire _ -> [] - | VernacImport _ -> [] - | VernacCanonical _ -> [] - | VernacCoercion _ -> [] - | VernacIdentityCoercion _ -> [] - - (* Type classes *) - | VernacInstance _ -> [] - | VernacContext _ -> [] - | VernacDeclareInstance _ -> [] - | VernacDeclareClass _ -> [] - - (* Solving *) - | VernacSolve _ -> [SolveCommand] - | VernacSolveExistential _ -> [SolveCommand] - - (* MMode *) - | VernacDeclProof -> [SolveCommand] - | VernacReturn -> [SolveCommand] - | VernacProofInstr _ -> [SolveCommand] - - (* Auxiliary file and library management *) - | VernacRequireFrom _ -> [] - | VernacAddLoadPath _ -> [] - | VernacRemoveLoadPath _ -> [] - | VernacAddMLPath _ -> [] - | VernacDeclareMLModule _ -> [] - | VernacChdir _ -> [OtherStatePreservingCommand] - - (* State management *) - | VernacWriteState _ -> [] - | VernacRestoreState _ -> [] - - (* Resetting *) - | VernacRemoveName _ -> [NavigationCommand] - | VernacResetName _ -> [NavigationCommand] - | VernacResetInitial -> [NavigationCommand] - | VernacBack _ -> [NavigationCommand] - | VernacBackTo _ -> [NavigationCommand] - - (* Commands *) - | VernacDeclareTacticDefinition _ -> [] - | VernacCreateHintDb _ -> [] - | VernacHints _ -> [] - | VernacSyntacticDefinition _ -> [] - | VernacDeclareImplicits _ -> [] - | VernacDeclareReduction _ -> [] - | VernacReserve _ -> [] - | VernacGeneralizable _ -> [] - | VernacSetOpacity _ -> [] - | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand] - | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) -> - if coqide_known_option o then [KnownOptionCommand] else [] - | VernacSetOption _ -> [] - | VernacRemoveOption _ -> [] - | VernacAddOption _ -> [] - | VernacMemOption _ -> [QueryCommand] - - | VernacPrintOption _ -> [QueryCommand] - | VernacCheckMayEval _ -> [QueryCommand] - | VernacGlobalCheck _ -> [QueryCommand] - | VernacPrint _ -> [QueryCommand] - | VernacSearch _ -> [QueryCommand] - | VernacLocate _ -> [QueryCommand] - - | VernacComments _ -> [OtherStatePreservingCommand] - | VernacNop -> [OtherStatePreservingCommand] - - (* Proof management *) - | VernacGoal _ -> [GoalStartingCommand] - - | VernacAbort _ -> [] - | VernacAbortAll -> [NavigationCommand] - | VernacRestart -> [NavigationCommand] - | VernacSuspend -> [NavigationCommand] - | VernacResume _ -> [NavigationCommand] - | VernacUndo _ -> [NavigationCommand] - | VernacUndoTo _ -> [NavigationCommand] - | VernacBacktrack _ -> [NavigationCommand] - - | VernacFocus _ -> [SolveCommand] - | VernacUnfocus -> [SolveCommand] - | VernacGo _ -> [] - | VernacShow _ -> [OtherStatePreservingCommand] - | VernacCheckGuard -> [OtherStatePreservingCommand] - | VernacProof (Tacexpr.TacId []) -> [OtherStatePreservingCommand] - | VernacProof _ -> [] - - (* Toplevel control *) - | VernacToplevelControl _ -> [] - - (* Extensions *) - | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand] - | VernacExtend _ -> [] - -let is_vernac_goal_starting_command com = - List.mem GoalStartingCommand (attribute_of_vernac_command com) - -let is_vernac_navigation_command com = - List.mem NavigationCommand (attribute_of_vernac_command com) - -let is_vernac_query_command com = - List.mem QueryCommand (attribute_of_vernac_command com) - -let is_vernac_known_option_command com = - List.mem KnownOptionCommand (attribute_of_vernac_command com) - -let is_vernac_debug_command com = - List.mem DebugCommand (attribute_of_vernac_command com) - -let is_vernac_goal_printing_command com = - let attribute = attribute_of_vernac_command com in - List.mem GoalStartingCommand attribute or - List.mem SolveCommand attribute - -let is_vernac_state_preserving_command com = - let attribute = attribute_of_vernac_command com in - List.mem OtherStatePreservingCommand attribute or - List.mem QueryCommand attribute - -let is_vernac_tactic_command com = - List.mem SolveCommand (attribute_of_vernac_command com) - -let is_vernac_proof_ending_command com = - List.mem ProofEndingCommand (attribute_of_vernac_command com) - -type undo_info = identifier list - -let undo_info () = Pfedit.get_all_proof_names () - -type reset_mark = Libnames.object_name - -type reset_status = - | NoReset - | ResetAtSegmentStart of Names.identifier - | ResetAtRegisteredObject of reset_mark - -type reset_info = { - status : reset_status; - proofs : identifier list; - cur_prf : (identifier * int) option; - loc_ast : Util.loc * Vernacexpr.vernac_expr; -} +let toplvl_ctr = ref 0 + +let toplvl_ctr_mtx = Mutex.create () -let compute_reset_info loc_ast = - let status,cur_prf = match snd loc_ast with - | com when is_vernac_proof_ending_command com -> NoReset,None - | VernacEndSegment _ -> NoReset,None - | com when is_vernac_tactic_command com -> - NoReset,Some (Pfedit.get_current_proof_name (), Pfedit.current_proof_depth ()) - | _ -> - (match Lib.has_top_frozen_state () with - | Some sp -> - prerr_endline ("On top of state "^Libnames.string_of_path (fst sp)); - ResetAtRegisteredObject sp,None - | None -> NoReset,None) - in - { status = status; - proofs = Pfedit.get_all_proof_names (); - cur_prf = cur_prf; - loc_ast = loc_ast; - } - -let reset_initial () = - prerr_endline "Reset initial called"; - Vernacentries.abort_refine Lib.reset_initial () - -let reset_to sp = - prerr_endline - ("Reset called with state "^(Libnames.string_of_path (fst sp))); - Lib.reset_to_state sp - -let raw_interp s = - Vernac.raw_do_vernac (Pcoq.Gram.parsable (Stream.of_string s)) - -let interp_with_options verbosely options s = - prerr_endline "Starting interp..."; - prerr_endline s; - let pa = Pcoq.Gram.parsable (Stream.of_string s) in - let pe = Pcoq.Gram.Entry.parse Pcoq.main_entry pa in - (* Temporary hack to make coqide.byte work (WTF???) - now with less screen - * pollution *) - (try Pervasives.prerr_string " \r"; Pervasives.flush stderr with _ -> ()); - match pe with - | None -> assert false - | Some((loc,vernac) as last) -> - if is_vernac_debug_command vernac then - user_error_loc loc (str "Debug mode not available within CoqIDE"); - if is_vernac_navigation_command vernac then - user_error_loc loc (str "Use CoqIDE navigation instead"); - if is_vernac_known_option_command vernac then - user_error_loc loc (str "Use CoqIDE display menu instead"); - if is_vernac_query_command vernac then - flash_info - "Warning: query commands should not be inserted in scripts"; - if not (is_vernac_goal_printing_command vernac) then - (* Verbose if in small step forward and not a tactic *) - Flags.make_silent (not verbosely); - let reset_info = compute_reset_info last in - List.iter (fun (set_option,_) -> raw_interp set_option) options; - raw_interp s; - Flags.make_silent true; - List.iter (fun (_,unset_option) -> raw_interp unset_option) options; - prerr_endline ("...Done with interp of : "^s); - reset_info - -let interp verbosely phrase = - interp_with_options verbosely (make_option_commands ()) phrase - -let interp_and_replace s = - let result = interp false s in - let msg = read_stdout () in - result,msg - -let rec is_pervasive_exn = function - | Out_of_memory | Stack_overflow | Sys.Break -> true - | Error_in_file (_,_,e) -> is_pervasive_exn e - | Stdpp.Exc_located (_,e) -> is_pervasive_exn e - | DuringCommandInterp (_,e) -> is_pervasive_exn e - | _ -> false - -let print_toplevel_error exc = - let (dloc,exc) = - match exc with - | DuringCommandInterp (loc,ie) -> - if loc = dummy_loc then (None,ie) else (Some loc, ie) - | _ -> (None, exc) - in - let (loc,exc) = - match exc with - | Stdpp.Exc_located (loc, ie) -> (Some loc),ie - | Error_in_file (s, (_,fname, loc), ie) -> None, ie - | _ -> dloc,exc - in - match exc with - | End_of_input -> str "Please report: End of input",None - | Vernacexpr.Drop -> str "Drop is not allowed by coqide!",None - | Vernacexpr.Quit -> str "Quit is not allowed by coqide! Use menus.",None - | _ -> - (try Cerrors.explain_exn exc with e -> - str "Failed to explain error. This is an internal Coq error. Please report.\n" - ++ str (Printexc.to_string e)), - (if is_pervasive_exn exc then None else loc) - -let process_exn e = let s,loc= print_toplevel_error e in (msgnl s,loc) - -let interp_last last = - prerr_string "*"; +let coqtop_zombies () = + Mutex.lock toplvl_ctr_mtx; + let res = !toplvl_ctr in + Mutex.unlock toplvl_ctr_mtx; + res + + +(** * Starting / signaling / ending a real coqtop sub-process *) + +(** We simulate a Unix.open_process that also returns the pid of + the created process. Note: this uses Unix.create_process, which + doesn't call bin/sh, so args shouldn't be quoted. The process + cannot be terminated by a Unix.close_process, but rather by a + kill of the pid. + + >--ide2top_w--[pipe]--ide2top_r--> + coqide coqtop + <--top2ide_r--[pipe]--top2ide_w--< + + Note: we use Unix.stderr in Unix.create_process to get debug + messages from the coqtop's Ide_slave loop. +*) + +let open_process_pid prog args = + let (ide2top_r,ide2top_w) = Unix.pipe () in + let (top2ide_r,top2ide_w) = Unix.pipe () in + let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in + assert (pid <> 0); + Unix.close ide2top_r; + Unix.close top2ide_w; + let oc = Unix.out_channel_of_descr ide2top_w in + let ic = Unix.in_channel_of_descr top2ide_r in + set_binary_mode_out oc true; + set_binary_mode_in ic true; + (pid,ic,oc) + +let spawn_coqtop sup_args = + Mutex.lock toplvl_ctr_mtx; try - vernac_com Vernacentries.interp last; - Lib.add_frozen_state() + let prog = !Minilib.coqtop_path in + let args = Array.of_list (prog :: "-ideslave" :: sup_args) in + let (pid,ic,oc) = open_process_pid prog args in + incr toplvl_ctr; + Mutex.unlock toplvl_ctr_mtx; + { pid = pid; cin = oc; cout = ic ; sup_args = sup_args } with e -> - let s,_ = process_exn e in prerr_endline ("Replay during undo failed because: "^s); + Mutex.unlock toplvl_ctr_mtx; raise e -let push_phrase cmd_stk reset_info ide_payload = - Stack.push (ide_payload,reset_info) cmd_stk - -type backtrack = - | BacktrackToNextActiveMark - | BacktrackToMark of reset_mark - | NoBacktrack - -let apply_reset = function - | BacktrackToMark mark -> reset_to mark - | NoBacktrack -> () - | BacktrackToNextActiveMark -> assert false - -let rewind sequence cmd_stk = - let undo_ops = Hashtbl.create 31 in - let current_proofs = undo_info () in - let pop_state cont seq coq reset_op prev_proofs curprf = - prerr_endline "pop"; - let curprf = - Option.map - (fun (curprf,depth) -> - (if Hashtbl.mem undo_ops curprf then Hashtbl.replace else Hashtbl.add) - undo_ops curprf depth; - curprf) - coq.cur_prf in - let reset_op = - match coq.status with - | ResetAtRegisteredObject mark -> - BacktrackToMark mark - | _ when is_vernac_state_preserving_command (snd coq.loc_ast) -> - reset_op - | _ when is_vernac_tactic_command (snd coq.loc_ast) -> - reset_op - | _ -> - BacktrackToNextActiveMark in - cont seq reset_op coq.proofs curprf - in - let rec do_rewind seq reset_op prev_proofs curprf = - match seq with - | [] when ((reset_op <> BacktrackToNextActiveMark) && - (Util.list_subset prev_proofs current_proofs)) -> - begin - Hashtbl.iter - (fun id depth -> - if List.mem id prev_proofs then begin - Pfedit.resume_proof (Util.dummy_loc,id); - Pfedit.undo_todepth depth - end) - undo_ops; - prerr_endline "OK for undos"; - Option.iter (fun id -> if List.mem id prev_proofs then - Pfedit.resume_proof (Util.dummy_loc,id)) curprf; - prerr_endline "OK for focusing"; - List.iter - (fun id -> Pfedit.delete_proof (Util.dummy_loc,id)) - (Util.list_subtract current_proofs prev_proofs); - prerr_endline "OK for aborts"; - apply_reset reset_op; - prerr_endline "OK for reset" - end - | [] -> - begin - try - let ide,coq = Stack.pop cmd_stk in - pop_state do_rewind [] coq reset_op prev_proofs curprf; - prerr_endline "push"; - let reset_info = compute_reset_info coq.loc_ast in - interp_last coq.loc_ast; - push_phrase cmd_stk reset_info ide - with Stack.Empty -> reset_initial () - end - | coq::rem -> - pop_state do_rewind rem coq reset_op prev_proofs curprf - in - do_rewind sequence NoBacktrack current_proofs None - -type tried_tactic = - | Interrupted - | Success of int (* nb of goals after *) - | Failed - -type hyp = env * evar_map * - ((identifier * string) * constr option * constr) * - (string * string) -type concl = env * evar_map * constr * string -type meta = env * evar_map * string -type goal = hyp list * concl - -let prepare_hyp sigma env ((i,c,d) as a) = - env, sigma, - ((i,string_of_id i),c,d), - (msg (pr_var_decl env a), msg (pr_ltype_env env d)) - -let prepare_hyps sigma env = - assert (rel_context env = []); - let hyps = - fold_named_context - (fun env d acc -> let hyp = prepare_hyp sigma env d in hyp :: acc) - env ~init:[] - in - List.rev hyps - -let prepare_goal_main sigma g = - let env = evar_env g in - (prepare_hyps sigma env, - (env, sigma, g.evar_concl, msg (pr_ltype_env_at_top env g.evar_concl))) - -let prepare_goal sigma g = - let options = make_option_commands () in - List.iter (fun (set_option,_) -> raw_interp set_option) options; - let x = prepare_goal_main sigma g in - List.iter (fun (_,unset_option) -> raw_interp unset_option) options; - x - -let get_current_pm_goal () = - let pfts = get_pftreestate () in - let gls = try nth_goal_of_pftreestate 1 pfts with _ -> raise Not_found in - let sigma= sig_sig gls in - let gl = sig_it gls in - prepare_goal sigma gl - -let get_current_goals () = - let pfts = get_pftreestate () in - let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in - let sigma = Tacmach.evc_of_pftreestate pfts in - List.map (prepare_goal sigma) gls - -let print_no_goal () = - (* Fall back on standard coq goal printer for completed goal printing *) - msg (pr_open_subgoals ()) - -let hyp_menu (env, sigma, ((coqident,ident),_,ast),(s,pr_ast)) = - [("clear "^ident),("clear "^ident^"."); - - ("apply "^ident), - ("apply "^ident^"."); - - ("exact "^ident), - ("exact "^ident^"."); - - ("generalize "^ident), - ("generalize "^ident^"."); - - ("absurd <"^ident^">"), - ("absurd "^ - pr_ast - ^".") ] @ - - (if is_equality_type ast then - [ "discriminate "^ident, "discriminate "^ident^"."; - "injection "^ident, "injection "^ident^"." ] - else - []) @ - - (let _,t = splay_prod env sigma ast in - if is_equality_type t then - [ "rewrite "^ident, "rewrite "^ident^"."; - "rewrite <- "^ident, "rewrite <- "^ident^"." ] - else - []) @ - - [("elim "^ident), - ("elim "^ident^"."); - - ("inversion "^ident), - ("inversion "^ident^"."); - - ("inversion clear "^ident), - ("inversion_clear "^ident^".")] - -let concl_menu (_,_,concl,_) = - let is_eq = is_equality_type concl in - ["intro", "intro."; - "intros", "intros."; - "intuition","intuition." ] @ - - (if is_eq then - ["reflexivity", "reflexivity."; - "discriminate", "discriminate."; - "symmetry", "symmetry." ] - else - []) @ - - ["assumption" ,"assumption."; - "omega", "omega."; - "ring", "ring."; - "auto with *", "auto with *."; - "eauto with *", "eauto with *."; - "tauto", "tauto."; - "trivial", "trivial."; - "decide equality", "decide equality."; - - "simpl", "simpl."; - "subst", "subst."; - - "red", "red."; - "split", "split."; - "left", "left."; - "right", "right."; - ] - - -let id_of_name = function - | Names.Anonymous -> id_of_string "x" - | Names.Name x -> x - -let make_cases s = - let qualified_name = Libnames.qualid_of_string s in - let glob_ref = Nametab.locate qualified_name in - match glob_ref with - | Libnames.IndRef i -> - let {Declarations.mind_nparams = np}, - {Declarations.mind_consnames = carr ; - Declarations.mind_nf_lc = tarr } - = Global.lookup_inductive i - in - Util.array_fold_right2 - (fun n t l -> - let (al,_) = Term.decompose_prod t in - let al,_ = Util.list_chop (List.length al - np) al in - let rec rename avoid = function - | [] -> [] - | (n,_)::l -> - let n' = next_ident_away_in_goal - (id_of_name n) - avoid - in (string_of_id n')::(rename (n'::avoid) l) - in - let al' = rename [] (List.rev al) in - (string_of_id n :: al') :: l - ) - carr - tarr - [] - | _ -> raise Not_found - -let current_status () = - let path = msg (Libnames.pr_dirpath (Lib.cwd ())) in - let path = if path = "Top" then "Ready" else "Ready in " ^ String.sub path 4 (String.length path - 4) in - try - path ^ ", proving " ^ (Names.string_of_id (Pfedit.get_current_proof_name ())) - with _ -> path +let respawn_coqtop coqtop = spawn_coqtop coqtop.sup_args + +let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint) +let killer = ref (fun pid -> Unix.kill pid Sys.sigkill) +let break_coqtop coqtop = + try !interrupter coqtop.pid + with _ -> prerr_endline "Error while sending Ctrl-C" + +let kill_coqtop coqtop = + let pid = coqtop.pid in + begin + try !killer pid + with _ -> prerr_endline "Kill -9 failed. Process already terminated ?" + end; + try + ignore (Unix.waitpid [] pid); + Mutex.lock toplvl_ctr_mtx; decr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx + with _ -> prerr_endline "Error while waiting for child" + +(** * Calls to coqtop *) + +(** Cf [Ide_intf] for more details *) + +let p = Xml_parser.make () +let () = Xml_parser.check_eof p false + +let eval_call coqtop (c:'a Ide_intf.call) = + Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c); + flush coqtop.cin; + let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in + (Ide_intf.to_answer xml : 'a Interface.value) + +let interp coqtop ?(raw=false) ?(verbose=true) s = + eval_call coqtop (Ide_intf.interp (raw,verbose,s)) +let rewind coqtop i = eval_call coqtop (Ide_intf.rewind i) +let inloadpath coqtop s = eval_call coqtop (Ide_intf.inloadpath s) +let mkcases coqtop s = eval_call coqtop (Ide_intf.mkcases s) +let status coqtop = eval_call coqtop Ide_intf.status +let hints coqtop = eval_call coqtop Ide_intf.hints + +module PrintOpt = +struct + type t = string list + let implicit = ["Printing"; "Implicit"] + let coercions = ["Printing"; "Coercions"] + let raw_matching = ["Printing"; "Matching"; "Synth"] + let notations = ["Printing"; "Notations"] + let all_basic = ["Printing"; "All"] + let existential = ["Printing"; "Existential"; "Instances"] + let universes = ["Printing"; "Universes"] + + let state_hack = Hashtbl.create 11 + let _ = List.iter (fun opt -> Hashtbl.add state_hack opt false) + [ implicit; coercions; raw_matching; notations; all_basic; existential; universes ] + + let set coqtop options = + let () = List.iter (fun (name, v) -> Hashtbl.replace state_hack name v) options in + let options = List.map (fun (name, v) -> (name, Interface.BoolValue v)) options in + match eval_call coqtop (Ide_intf.set_options options) with + | Interface.Good () -> () + | _ -> raise (Failure "Cannot set options.") + + let enforce_hack coqtop = + let elements = Hashtbl.fold (fun opt v acc -> (opt, v) :: acc) state_hack [] in + set coqtop elements + +end + +let goals coqtop = + let () = PrintOpt.enforce_hack coqtop in + eval_call coqtop Ide_intf.goals + +let evars coqtop = + let () = PrintOpt.enforce_hack coqtop in + eval_call coqtop Ide_intf.evars diff --git a/ide/coq.mli b/ide/coq.mli index 9dec52c6..9d64da6c 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -1,84 +1,70 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string val version : unit -> string -type printing_state = { - mutable printing_implicit : bool; - mutable printing_coercions : bool; - mutable printing_raw_matching : bool; - mutable printing_no_notation : bool; - mutable printing_all : bool; - mutable printing_evar_instances : bool; - mutable printing_universes : bool; - mutable printing_full_all : bool -} +(** * Initial checks by launching test coqtop processes *) -val printing_state : printing_state +val filter_coq_opts : string list -> bool * string list -type reset_info +(** A mock coqtop launch, checking in particular that initial.coq is found *) +val check_connection : string list -> unit -val reset_initial : unit -> unit +(** * The structure describing a coqtop sub-process *) -val init : unit -> string list -val interp : bool -> string -> reset_info -val interp_last : Util.loc * Vernacexpr.vernac_expr -> unit -val interp_and_replace : string -> - reset_info * string +type coqtop -val push_phrase : ('a * reset_info) Stack.t -> reset_info -> 'a -> unit +(** * Count of all active coqtops *) -val rewind : reset_info list -> ('a * reset_info) Stack.t -> unit +val coqtop_zombies : unit -> int -val is_vernac_tactic_command : Vernacexpr.vernac_expr -> bool -val is_vernac_state_preserving_command : Vernacexpr.vernac_expr -> bool -val is_vernac_goal_starting_command : Vernacexpr.vernac_expr -> bool -val is_vernac_proof_ending_command : Vernacexpr.vernac_expr -> bool +(** * Starting / signaling / ending a real coqtop sub-process *) -(* type hyp = (identifier * constr option * constr) * string *) +val spawn_coqtop : string list -> coqtop +val respawn_coqtop : coqtop -> coqtop +val kill_coqtop : coqtop -> unit +val break_coqtop : coqtop -> unit -type hyp = env * evar_map * - ((identifier*string) * constr option * constr) * (string * string) -type meta = env * evar_map * string -type concl = env * evar_map * constr * string -type goal = hyp list * concl +(** In win32, we'll use a different kill function than Unix.kill *) -val get_current_goals : unit -> goal list +val killer : (int -> unit) ref +val interrupter : (int -> unit) ref -val get_current_pm_goal : unit -> goal +(** * Calls to Coqtop, cf [Ide_intf] for more details *) -val print_no_goal : unit -> string +val interp : + coqtop -> ?raw:bool -> ?verbose:bool -> string -> string Interface.value +val rewind : coqtop -> int -> int Interface.value +val status : coqtop -> Interface.status Interface.value +val goals : coqtop -> Interface.goals option Interface.value +val evars : coqtop -> Interface.evar list option Interface.value +val hints : coqtop -> (Interface.hint list * Interface.hint) option Interface.value +val inloadpath : coqtop -> string -> bool Interface.value +val mkcases : coqtop -> string -> string list list Interface.value -val process_exn : exn -> string*(Util.loc option) +(** A specialized version of [raw_interp] dedicated to + set/unset options. *) -val hyp_menu : hyp -> (string * string) list -val concl_menu : concl -> (string * string) list +module PrintOpt : +sig + type t + val implicit : t + val coercions : t + val raw_matching : t + val notations : t + val all_basic : t + val existential : t + val universes : t -val is_in_coq_lib : string -> bool -val is_in_coq_path : string -> bool -val is_in_loadpath : string -> bool - -val make_cases : string -> string list list - - -type tried_tactic = - | Interrupted - | Success of int (* nb of goals after *) - | Failed - -(* Message to display in lower status bar. *) - -val current_status : unit -> string + val set : coqtop -> (t * bool) list -> unit +end diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index d41bcf29..b9e14145 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Hashtbl.add h s ()) - [ "Add" ; "Check"; "Eval"; "Extraction" ; - "Load" ; "Undo"; "Goal"; - "Proof" ; "Print";"Save" ; - "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" - ]; - Hashtbl.mem h - - let is_constr_kw = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; - "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type" ]; - Hashtbl.mem h - (* Without this table, the automaton would be too big and - ocamllex would fail *) - let is_one_word_declaration = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) - [ (* Definitions *) - "Definition" ; "Let" ; "Example" ; "SubClass" ; - "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ; - (* Assumptions *) - "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ; - "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters"; - (* Inductive *) - "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; - (* Other *) - "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" - ]; - Hashtbl.mem h - - let is_proof_declaration = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) + let tag_of_ident = + let one_word_commands = + [ "Add" ; "Check"; "Eval"; "Extraction" ; + "Load" ; "Undo"; "Goal"; + "Proof" ; "Print";"Save" ; + "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ] + in + let one_word_declarations = + [ (* Definitions *) + "Definition" ; "Let" ; "Example" ; "SubClass" ; + "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ; + (* Assumptions *) + "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ; + "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters"; + (* Inductive *) + "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; + (* Other *) + "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ] + in + let proof_declarations = [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ; - "Proposition" ; "Property" ]; - Hashtbl.mem h - - let is_proof_end = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) - [ "Qed" ; "Defined" ; "Admitted"; "Abort" ]; - Hashtbl.mem h + "Proposition" ; "Property" ] + in + let proof_ends = + [ "Qed" ; "Defined" ; "Admitted"; "Abort" ] + in + let constr_keywords = + [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; + "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return"; + "Prop"; "Set"; "Type" ] + in + let h = Hashtbl.create 97 in (* for vernac *) + let h' = Hashtbl.create 97 in (* for constr *) + List.iter (fun s -> Hashtbl.add h s Keyword) one_word_commands; + List.iter (fun s -> Hashtbl.add h s Declaration) one_word_declarations; + List.iter (fun s -> Hashtbl.add h s ProofDeclaration) proof_declarations; + List.iter (fun s -> Hashtbl.add h s Qed) proof_ends; + List.iter (fun s -> Hashtbl.add h' s Keyword) constr_keywords; + (fun initial id -> Hashtbl.find (if initial then h else h') id) + + exception Unterminated + + let here f lexbuf = f (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) - let start = ref true } let space = - [' ' '\010' '\013' '\009' '\012'] + [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *) let firstchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] @@ -82,12 +75,14 @@ let identchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let ident = firstchar identchar* -let sentence_sep = '.' [ ' ' '\n' '\t' ] +let undotted_sep = [ '{' '}' '-' '+' '*' ] + +let dot_sep = '.' (space | eof) let multiword_declaration = "Module" (space+ "Type")? | "Program" space+ ident -| "Existing" space+ "Instance" +| "Existing" space+ "Instance" "s"? | "Canonical" space+ "Structure" let locality = ("Local" space+)? @@ -130,65 +125,75 @@ rule coq_string = parse and comment = parse | "(*" { ignore (comment lexbuf); comment lexbuf } | "\"" { ignore (coq_string lexbuf); comment lexbuf } - | "*)" { Lexing.lexeme_end lexbuf } - | eof { Lexing.lexeme_end lexbuf } + | "*)" { (true, Lexing.lexeme_start lexbuf + 2) } + | eof { (false, Lexing.lexeme_end lexbuf) } | _ { comment lexbuf } -and sentence stamp = parse - | space+ { sentence stamp lexbuf } +and sentence initial stamp = parse | "(*" { let comm_start = Lexing.lexeme_start lexbuf in - let comm_end = comment lexbuf in + let trully_terminated,comm_end = comment lexbuf in stamp comm_start comm_end Comment; - sentence stamp lexbuf + if not trully_terminated then raise Unterminated; + (* A comment alone is a sentence. + A comment in a sentence doesn't terminate the sentence. + Note: comm_end is the first position _after_ the comment, + as required when tagging a zone, hence the -1 to locate the + ")" terminating the comment. + *) + if initial then comm_end - 1 else sentence false stamp lexbuf } | "\"" { let str_start = Lexing.lexeme_start lexbuf in let str_end = coq_string lexbuf in stamp str_start str_end String; - start := false; - sentence stamp lexbuf + sentence false stamp lexbuf } | multiword_declaration { - if !start then begin - start := false; - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Declaration - end; - sentence stamp lexbuf + if initial then here stamp lexbuf Declaration; + sentence false stamp lexbuf } | multiword_command { - if !start then begin - start := false; - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword - end; - sentence stamp lexbuf } + if initial then here stamp lexbuf Keyword; + sentence false stamp lexbuf + } | ident as id { - if !start then begin - start := false; - if id <> "Time" then begin - if is_proof_end id then - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Qed - else if is_one_word_command id then - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword - else if is_one_word_declaration id then - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Declaration - else if is_proof_declaration id then - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) ProofDeclaration - end - end else begin - if is_constr_kw id then - stamp (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf) Keyword - end; - sentence stamp lexbuf } - | ".." - | _ { sentence stamp lexbuf} - | sentence_sep { } - | eof { raise Not_found } + (try here stamp lexbuf (tag_of_ident initial id) with Not_found -> ()); + sentence false stamp lexbuf } + | ".." { + (* We must have a particular rule for parsing "..", where no dot + is a terminator, even if we have a blank afterwards + (cf. for instance the syntax for recursive notation). + This rule and the following one also allow to treat the "..." + special case, where the third dot is a terminator. *) + sentence false stamp lexbuf + } + | dot_sep { Lexing.lexeme_start lexbuf } (* The usual "." terminator *) + | undotted_sep { + (* Separators like { or } and bullets * - + are only active + at the start of a sentence *) + if initial then Lexing.lexeme_start lexbuf + else sentence false stamp lexbuf + } + | space+ { + (* Parsing spaces is the only situation preserving initiality *) + sentence initial stamp lexbuf + } + | _ { + (* Any other characters *) + sentence false stamp lexbuf + } + | eof { raise Unterminated } { - let find_end_offset stamp slice = - let lb = Lexing.from_string slice in - start := true; - sentence stamp lb; - Lexing.lexeme_end lb + + (** Parse a sentence in string [slice], tagging relevant parts with + function [stamp], and returning the position of the first + sentence delimitor (either "." or "{" or "}" or the end of a comment). + It will raise [Unterminated] when no end of sentence is found. + *) + + let delimit_sentence stamp slice = + sentence true stamp (Lexing.from_string slice) + } diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml deleted file mode 100644 index 568594bd..00000000 --- a/ide/coq_tactics.ml +++ /dev/null @@ -1,131 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* "; - "Dependent Rewrite <-"; - "Derive Inversion"; - "Destruct"; - "Discriminate"; - "DiscrR"; - "Do"; - "Double Induction"; - "EApply"; - "EAuto"; - "Elim ... using"; - "Elim ... with"; - "ElimType"; - "Exact"; - "Exists"; - "Fail"; - "Field"; - "First"; - "Fold"; - "Fourier"; - "Generalize"; - "Generalize Dependent"; - "Print Hint"; - "Hnf"; - "Idtac"; - "Induction"; - "Info"; - "Injection"; - "Intro"; - "Intro ... after"; - "Intro after"; - "Intros"; - "Intros pattern"; - "Intros until"; - "Intuition"; - "Inversion"; - "Inversion ... in"; - "Inversion ... using"; - "Inversion ... using ... in"; - "Inversion_clear"; - "Inversion_clear ... in"; - "LApply"; - "Lazy"; - "Left"; - "LetTac"; - "Move"; - "NewDestruct"; - "NewInduction"; - "Omega"; - "Orelse"; - "Pattern"; - "Pose"; - "Prolog"; - "Quote"; - "Red"; - "Refine"; - "Reflexivity"; - "Rename"; - "Repeat"; - "Replace ... with"; - "Rewrite"; - "Rewrite ->"; - "Rewrite -> ... in"; - "Rewrite <-"; - "Rewrite <- ... in"; - "Rewrite ... in"; - "Right"; - "Ring"; - "Setoid_replace"; - "Setoid_rewrite"; - "Simpl"; - "Simple Inversion"; - "Simplify_eq"; - "Solve"; - "Split"; - "SplitAbsolu"; - "SplitRmult"; - "Subst"; - "Symmetry"; - "Tacticals"; - "Tauto"; - "Transitivity"; - "Trivial"; - "Try"; - "tactic macros"; - "Unfold"; - "Unfold ... in"; -] diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli deleted file mode 100644 index 4c583d3a..00000000 --- a/ide/coq_tactics.mli +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* k" { "set-anchor" () + "move-cursor" (display-line-ends,1,0) + "move-cursor" (visual-positions,1,0) + "cut-clipboard" () + } + bind "w" { "cut-clipboard" () } + +# For UTF-8 inputs ! +# bind "F11" {"insert-at-cursor" ("∀")} +# bind "F12" {"insert-at-cursor" ("∃")} +} +class "GtkTextView" binding "text" + + +style "views" { +base[NORMAL] = "CornSilk" +# bg_pixmap[NORMAL] = "background.jpg" +} +class "GtkTextView" style "views" + +widget "*.*.*.*.*.ScriptWindow" style "views" +widget "*.*.*.*.GoalWindow" style "views" +widget "*.*.*.*.MessageWindow" style "views" + +gtk-font-name = "Sans 12" + +style "location" { +font_name = "Sans 10" +} +widget "*location*" style "location" + + +gtk-can-change-accels = 1 + +style "men" { +# +} +widget "GtkMenu" style "men" diff --git a/ide/coqide.ml b/ide/coqide.ml index 162728ad..009a1989 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1,16 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tags.Script.processed + | Unsafe -> Tags.Script.unjustified class type analyzed_views= -object('self) +object val mutable act_id : GtkSignal.id option val mutable deact_id : GtkSignal.id option val input_buffer : GText.buffer @@ -32,7 +36,8 @@ object('self) val message_view : GText.view val proof_buffer : GText.buffer val proof_view : GText.view - val cmd_stack : (ide_info * Coq.reset_info) Stack.t + val cmd_stack : ide_info Stack.t + val mycoqtop : Coq.coqtop ref val mutable is_active : bool val mutable read_only : bool val mutable filename : string option @@ -47,7 +52,6 @@ object('self) method filename : string option method stats : Unix.stats option - method set_filename : string option -> unit method update_stats : unit method revert : unit method auto_save : unit @@ -61,31 +65,25 @@ object('self) method backtrack_to : GText.iter -> unit method backtrack_to_no_lock : GText.iter -> unit method clear_message : unit - method deactivate : unit -> unit method disconnected_keypress_handler : GdkEvent.Key.t -> bool - method electric_handler : GtkSignal.id method find_phrase_starting_at : GText.iter -> (GText.iter * GText.iter) option method get_insert : GText.iter method get_start_of_input : GText.iter method go_to_insert : unit method indent_current_line : unit + method go_to_next_occ_of_cur_word : unit + method go_to_prev_occ_of_cur_word : unit method insert_command : string -> string -> unit method tactic_wizard : string list -> unit method insert_message : string -> unit - method insert_this_phrase_on_success : - bool -> bool -> bool -> string -> string -> bool - method process_next_phrase : bool -> bool -> bool -> bool + method process_next_phrase : bool -> unit method process_until_iter_or_error : GText.iter -> unit method process_until_end_or_error : unit method recenter_insert : unit method reset_initial : unit - method send_to_coq : - bool -> bool -> string -> - bool -> bool -> bool -> - (bool*reset_info) option + method force_reset_initial : unit method set_message : string -> unit - method show_pm_goal : unit method show_goals : unit method show_goals_full : unit method undo_last_step : unit @@ -102,72 +100,71 @@ type viewable_script = proof_view : GText.view; message_view : GText.view; analyzed_view : analyzed_views; - command_stack : (ide_info * Coq.reset_info) Stack.t; + toplvl : Coq.coqtop ref; + command : Command_windows.command_window; } - -let notebook_page_of_session {script=script;tab_label=bname;proof_view=proof;message_view=message} = - let session_paned = - GPack.paned `HORIZONTAL ~border_width:5 () in - let script_frame = - GBin.frame ~shadow_type:`IN ~packing:session_paned#add1 () in - let script_scroll = - GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in - let state_paned = - GPack.paned `VERTICAL ~packing:session_paned#add2 () in - let proof_frame = - GBin.frame ~shadow_type:`IN ~packing:state_paned#add1 () in - let proof_scroll = - GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_frame#add () in - let message_frame = - GBin.frame ~shadow_type:`IN ~packing:state_paned#add2 () in - let message_scroll = - GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:message_frame#add () in - let session_tab = - GPack.hbox ~homogeneous:false () in - let img = - GMisc.image ~packing:session_tab#pack ~icon_size:`SMALL_TOOLBAR () in +let kill_session s = + s.analyzed_view#kill_detached_views (); + Coq.kill_coqtop !(s.toplvl) + +let build_session s = + let session_paned = GPack.paned `VERTICAL () in + let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 + ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in + let script_frame = GBin.frame ~shadow_type:`IN + ~packing:eval_paned#add1 () in + let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC + ~packing:script_frame#add () in + let state_paned = GPack.paned `VERTICAL + ~packing:eval_paned#add2 () in + let proof_frame = GBin.frame ~shadow_type:`IN + ~packing:state_paned#add1 () in + let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC + ~packing:proof_frame#add () in + let message_frame = GBin.frame ~shadow_type:`IN + ~packing:state_paned#add2 () in + let message_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC + ~packing:message_frame#add () in + let session_tab = GPack.hbox ~homogeneous:false () in + let img = GMisc.image ~icon_size:`SMALL_TOOLBAR + ~packing:session_tab#pack () in let _ = - script#buffer#connect#modified_changed - ~callback:(fun () -> if script#buffer#modified - then img#set_stock `SAVE - else img#set_stock `YES) in + s.script#buffer#connect#modified_changed + ~callback:(fun () -> if s.script#buffer#modified + then img#set_stock `SAVE + else img#set_stock `YES) in let _ = - session_paned#misc#connect#size_allocate + eval_paned#misc#connect#size_allocate + ~callback: (let old_paned_width = ref 2 in let old_paned_height = ref 2 in - (fun {Gtk.width=paned_width;Gtk.height=paned_height} -> - if !old_paned_width <> paned_width || !old_paned_height <> paned_height then ( - session_paned#set_position (session_paned#position * paned_width / !old_paned_width); - state_paned#set_position (state_paned#position * paned_height / !old_paned_height); - old_paned_width := paned_width; - old_paned_height := paned_height; - ))) in - script_scroll#add script#coerce; - proof_scroll#add proof#coerce; - message_scroll#add message#coerce; - session_tab#pack bname#coerce; - img#set_stock `YES; - session_paned#set_position 1; - state_paned#set_position 1; - (Some session_tab#coerce,None,session_paned#coerce) + (fun {Gtk.width=paned_width;Gtk.height=paned_height} -> + if !old_paned_width <> paned_width || !old_paned_height <> paned_height then ( + eval_paned#set_position (eval_paned#position * paned_width / !old_paned_width); + state_paned#set_position (state_paned#position * paned_height / !old_paned_height); + old_paned_width := paned_width; + old_paned_height := paned_height; + ))) + in + session_paned#pack2 ~shrink:false ~resize:false (s.command#frame#coerce); + script_scroll#add s.script#coerce; + proof_scroll#add s.proof_view#coerce; + message_scroll#add s.message_view#coerce; + session_tab#pack s.tab_label#coerce; + img#set_stock `YES; + eval_paned#set_position 1; + state_paned#set_position 1; + (Some session_tab#coerce,None,session_paned#coerce) let session_notebook = - Typed_notebook.create notebook_page_of_session ~border_width:2 ~show_border:false ~scrollable:true () - -let active_view = ref (~-1) - -let on_active_view f = - if !active_view < 0 - then failwith "no active view !" - else f (session_notebook#get_nth_term !active_view) + Typed_notebook.create build_session kill_session + ~border_width:2 ~show_border:false ~scrollable:true () let cb = GData.clipboard Gdk.Atom.primary - let last_cb_content = ref "" - let update_notebook_pos () = let pos = match !current.vertical_tabs, !current.opposite_tabs with @@ -178,21 +175,13 @@ let update_notebook_pos () = in session_notebook#set_tab_pos pos - -let set_active_view i = - prerr_endline "entering set_active_view"; - (try on_active_view (fun {tab_label=lbl} -> lbl#set_text lbl#text) with _ -> ()); - session_notebook#goto_page i; - let s = session_notebook#current_term in - s.tab_label#set_use_markup true; - s.tab_label#set_label (""^s.tab_label#text^""); - active_view := i; - prerr_endline "exiting set_active_view" - +let to_do_on_page_switch = ref [] -let to_do_on_page_switch = ref [] +(** * Coqide's handling of signals *) +(** We ignore Ctrl-C, and for most of the other catchable signals + we launch an emergency save of opened files and then exit *) let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; Sys.sigill; Sys.sigpipe; Sys.sigquit; @@ -200,75 +189,80 @@ let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; let crash_save i = (* ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*) - safe_prerr_endline "Trying to save all buffers in .crashcoqide files"; + Minilib.safe_prerr_endline "Trying to save all buffers in .crashcoqide files"; let count = ref 0 in - List.iter - (function {script=view; analyzed_view = av } -> - (let filename = match av#filename with - | None -> - incr count; - "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide" - | Some f -> f^".crashcoqide" - in - try - if try_export filename (view#buffer#get_text ()) then - safe_prerr_endline ("Saved "^filename) - else safe_prerr_endline ("Could not save "^filename) - with _ -> safe_prerr_endline ("Could not save "^filename)) - ) - session_notebook#pages; - safe_prerr_endline "Done. Please report."; - if i <> 127 then exit i + List.iter + (function {script=view; analyzed_view = av } -> + (let filename = match av#filename with + | None -> + incr count; + "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide" + | Some f -> f^".crashcoqide" + in + try + if try_export filename (view#buffer#get_text ()) then + Minilib.safe_prerr_endline ("Saved "^filename) + else Minilib.safe_prerr_endline ("Could not save "^filename) + with _ -> Minilib.safe_prerr_endline ("Could not save "^filename)) + ) + session_notebook#pages; + Minilib.safe_prerr_endline "Done. Please report."; + if i <> 127 then exit i let ignore_break () = List.iter (fun i -> - try Sys.set_signal i (Sys.Signal_handle crash_save) - with _ -> prerr_endline "Signal ignored (normal if Win32)") + try Sys.set_signal i (Sys.Signal_handle crash_save) + with _ -> prerr_endline "Signal ignored (normal if Win32)") signals_to_crash; Sys.set_signal Sys.sigint Sys.Signal_ignore + +(** * Locks *) + (* Locking machinery for Coq kernel *) let coq_computing = Mutex.create () (* To prevent Coq from interrupting during undoing...*) let coq_may_stop = Mutex.create () +(* To prevent a force_reset_initial during a force_reset_initial *) +let resetting = Mutex.create () + +exception RestartCoqtop +exception Unsuccessful + +let force_reset_initial () = + prerr_endline "Reset Initial"; + session_notebook#current_term.analyzed_view#force_reset_initial + let break () = - prerr_endline "User break received:"; - if not (Mutex.try_lock coq_computing) then - begin - prerr_endline " trying to stop computation:"; - if Mutex.try_lock coq_may_stop then begin - Util.interrupt := true; - prerr_endline " interrupt flag set. Computation should stop soon..."; - Mutex.unlock coq_may_stop - end else prerr_endline " interruption refused (may not stop now)"; - end - else begin - Mutex.unlock coq_computing; - prerr_endline " ignored (not computing)" - end + prerr_endline "User break received"; + Coq.break_coqtop !(session_notebook#current_term.toplvl) let do_if_not_computing text f x = let threaded_task () = - (* Beware: mutexes must be locked and unlocked in the same thread - on at least FreeBSD (see bug #2431) *) if Mutex.try_lock coq_computing then begin - prerr_endline "Getting lock"; - try - f x; - prerr_endline "Releasing lock"; - Mutex.unlock coq_computing; - with e -> - prerr_endline "Releasing lock (on error)"; - Mutex.unlock coq_computing; - raise e + prerr_endline "Getting lock"; + List.iter + (fun elt -> try f elt with + | RestartCoqtop -> elt.analyzed_view#reset_initial + | Sys_error str -> + elt.analyzed_view#reset_initial; + elt.analyzed_view#set_message + ("Unable to communicate with coqtop, restarting coqtop.\n"^ + "Error was: "^str) + | e -> + Mutex.unlock coq_computing; + elt.analyzed_view#set_message + ("Unknown error, please report:\n"^(Printexc.to_string e))) + x; + prerr_endline "Releasing lock"; + Mutex.unlock coq_computing; end else - prerr_endline - "Discarded order (computations are ongoing)" + prerr_endline "Discarded order (computations are ongoing)" in prerr_endline ("Launching thread " ^ text); ignore (Glib.Timeout.add ~ms:300 ~callback: @@ -277,69 +271,77 @@ let do_if_not_computing text f x = else (pbar#pulse (); true))); ignore (Thread.create threaded_task ()) -(* XXX - 1 appel *) -let kill_input_view i = - let v = session_notebook#get_nth_term i in - v.analyzed_view#kill_detached_views (); - v.script#destroy (); - v.tab_label#destroy (); - v.proof_view#destroy (); - v.message_view#destroy (); - session_notebook#remove_page i - let warning msg = GToolbox.message_box ~title:"Warning" ~icon:(let img = GMisc.image () in - img#set_stock `DIALOG_WARNING; - img#set_icon_size `DIALOG; - img#coerce) + img#set_stock `DIALOG_WARNING; + img#set_icon_size `DIALOG; + img#coerce) msg -(* -(* XXX - beaucoups d'appels, a garder *) -let get_current_view = - focused_session - *) let remove_current_view_page () = let do_remove () = let c = session_notebook#current_page in - kill_input_view c + session_notebook#remove_page c in let current = session_notebook#current_term in - if not current.script#buffer#modified then do_remove () - else - match GToolbox.question_box ~title:"Close" - ~buttons:["Save Buffer and Close"; - "Close without Saving"; - "Don't Close"] - ~default:0 - ~icon:(let img = GMisc.image () in - img#set_stock `DIALOG_WARNING; - img#set_icon_size `DIALOG; - img#coerce) - "This buffer has unsaved modifications" - with - | 1 -> - begin match current.analyzed_view#filename with - | None -> - begin match select_file_for_save ~title:"Save file" () with - | None -> () - | Some f -> - if current.analyzed_view#save_as f then begin - flash_info ("File " ^ f ^ " saved") ; - do_remove () - end else - warning ("Save Failed (check if " ^ f ^ " is writable)") - end + if not current.script#buffer#modified then do_remove () + else + match GToolbox.question_box ~title:"Close" + ~buttons:["Save Buffer and Close"; + "Close without Saving"; + "Don't Close"] + ~default:0 + ~icon:(let img = GMisc.image () in + img#set_stock `DIALOG_WARNING; + img#set_icon_size `DIALOG; + img#coerce) + "This buffer has unsaved modifications" + with + | 1 -> + begin match current.analyzed_view#filename with + | None -> + begin match select_file_for_save ~title:"Save file" () with + | None -> () | Some f -> - if current.analyzed_view#save f then begin - flash_info ("File " ^ f ^ " saved") ; - do_remove () - end else - warning ("Save Failed (check if " ^ f ^ " is writable)") + if current.analyzed_view#save_as f then begin + flash_info ("File " ^ f ^ " saved") ; + do_remove () + end else + warning ("Save Failed (check if " ^ f ^ " is writable)") end - | 2 -> do_remove () - | _ -> () + | Some f -> + if current.analyzed_view#save f then begin + flash_info ("File " ^ f ^ " saved") ; + do_remove () + end else + warning ("Save Failed (check if " ^ f ^ " is writable)") + end + | 2 -> do_remove () + | _ -> () + +module Opt = Coq.PrintOpt + +let print_items = [ + ([Opt.implicit],"Display implicit arguments","Display _implicit arguments", + "i",false); + ([Opt.coercions],"Display coercions","Display _coercions","c",false); + ([Opt.raw_matching],"Display raw matching expressions", + "Display raw _matching expressions","m",true); + ([Opt.notations],"Display notations","Display _notations","n",true); + ([Opt.all_basic],"Display all basic low-level contents", + "Display _all basic low-level contents","a",false); + ([Opt.existential],"Display existential variable instances", + "Display _existential variable instances","e",false); + ([Opt.universes],"Display universe levels","Display _universe levels", + "u",false); + ([Opt.all_basic;Opt.existential;Opt.universes], "Display all low-level contents", + "Display all _low-level contents","l",false) +] + +let setopts ct opts v = + let opts = List.map (fun o -> (o, v)) opts in + Coq.PrintOpt.set ct opts (* Reset this to None on page change ! *) let (last_completion:(string*int*int*bool) option ref) = ref None @@ -351,64 +353,64 @@ let rec complete input_buffer w (offset:int) = match !last_completion with | Some (lw,loffset,lpos,backward) when lw=w && loffset=offset -> - begin - let iter = input_buffer#get_iter (`OFFSET lpos) in - if backward then - match complete_backward w iter with - | None -> - last_completion := - Some (lw,loffset, - (find_word_end - (input_buffer#get_iter (`OFFSET loffset)))#offset , - false); - None - | Some (ss,start,stop) as result -> - last_completion := - Some (w,offset,ss#offset,true); - result - else - match complete_forward w iter with - | None -> - last_completion := None; - None - | Some (ss,start,stop) as result -> - last_completion := - Some (w,offset,ss#offset,false); - result - end - | _ -> begin - match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with + begin + let iter = input_buffer#get_iter (`OFFSET lpos) in + if backward then + match complete_backward w iter with | None -> - last_completion := - Some (w,offset,(find_word_end (input_buffer#get_iter - (`OFFSET offset)))#offset,false); - complete input_buffer w offset + last_completion := + Some (lw,loffset, + (find_word_end + (input_buffer#get_iter (`OFFSET loffset)))#offset , + false); + None | Some (ss,start,stop) as result -> - last_completion := Some (w,offset,ss#offset,true); - result + last_completion := + Some (w,offset,ss#offset,true); + result + else + match complete_forward w iter with + | None -> + last_completion := None; + None + | Some (ss,start,stop) as result -> + last_completion := + Some (w,offset,ss#offset,false); + result end + | _ -> begin + match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with + | None -> + last_completion := + Some (w,offset,(find_word_end (input_buffer#get_iter + (`OFFSET offset)))#offset,false); + complete input_buffer w offset + | Some (ss,start,stop) as result -> + last_completion := Some (w,offset,ss#offset,true); + result + end let get_current_word () = match session_notebook#current_term,cb#text with | {script=script; analyzed_view=av;},None -> - prerr_endline "None selected"; - let it = av#get_insert in - let start = find_word_start it in - let stop = find_word_end start in - script#buffer#move_mark `SEL_BOUND start; - script#buffer#move_mark `INSERT stop; - script#buffer#get_text ~slice:true ~start ~stop () - | _,Some t -> - prerr_endline "Some selected"; - prerr_endline t; - t + prerr_endline "None selected"; + let it = av#get_insert in + let start = find_word_start it in + let stop = find_word_end start in + script#buffer#move_mark `SEL_BOUND ~where:start; + script#buffer#move_mark `INSERT ~where:stop; + script#buffer#get_text ~slice:true ~start ~stop () + | _,Some t -> + prerr_endline "Some selected"; + prerr_endline t; + t let input_channel b ic = let buf = String.create 1024 and len = ref 0 in - while len := input ic buf 0 1024; !len > 0 do - Buffer.add_substring b buf 0 !len - done + while len := input ic buf 0 1024; !len > 0 do + Buffer.add_substring b buf 0 !len + done let with_file handler name ~f = try @@ -416,116 +418,138 @@ let with_file handler name ~f = try f ic; close_in ic with e -> close_in ic; raise e with Sys_error s -> handler s - -(* For electric handlers *) -exception Found - (* For find_phrase_starting_at *) exception Stop of int -(* XXX *) -let activate_input i = - prerr_endline "entering activate_input"; - (try on_active_view (fun {analyzed_view=a_v} -> a_v#reset_initial; a_v#deactivate ()) - with _ -> ()); - (session_notebook#get_nth_term i).analyzed_view#activate (); - set_active_view i; - prerr_endline "exiting activate_input" +let tag_of_sort = function + | Coq_lex.Comment -> Tags.Script.comment + | Coq_lex.Keyword -> Tags.Script.kwd + | Coq_lex.Declaration -> Tags.Script.decl + | Coq_lex.ProofDeclaration -> Tags.Script.proof_decl + | Coq_lex.Qed -> Tags.Script.qed + | Coq_lex.String -> failwith "No tag" let apply_tag (buffer:GText.buffer) orig off_conv from upto sort = - let conv_and_apply start stop tag = + try + let tag = tag_of_sort sort in let start = orig#forward_chars (off_conv from) in let stop = orig#forward_chars (off_conv upto) in buffer#apply_tag ~start ~stop tag - in match sort with - | Coq_lex.Comment -> - conv_and_apply from upto Tags.Script.comment - | Coq_lex.Keyword -> - conv_and_apply from upto Tags.Script.kwd - | Coq_lex.Declaration -> - conv_and_apply from upto Tags.Script.decl - | Coq_lex.ProofDeclaration -> - conv_and_apply from upto Tags.Script.proof_decl - | Coq_lex.Qed -> - conv_and_apply from upto Tags.Script.qed - | Coq_lex.String -> () + with _ -> () let remove_tags (buffer:GText.buffer) from upto = List.iter (buffer#remove_tag ~start:from ~stop:upto) [ Tags.Script.comment; Tags.Script.kwd; Tags.Script.decl; Tags.Script.proof_decl; Tags.Script.qed ] +(** Cut a part of the buffer in sentences and tag them. + May raise [Coq_lex.Unterminated] when the zone ends with + an unterminated sentence. *) + let split_slice_lax (buffer:GText.buffer) from upto = remove_tags buffer from upto; - buffer#remove_tag ~start:from ~stop:upto Tags.Script.lax_end; + buffer#remove_tag ~start:from ~stop:upto Tags.Script.sentence; let slice = buffer#get_text ~start:from ~stop:upto () in - let slice = slice ^ " " in let rec split_substring str = let off_conv = byte_offset_to_char_offset str in let slice_len = String.length str in - let sentence_len = Coq_lex.find_end_offset (apply_tag buffer from off_conv) str in - - let stop = from#forward_chars (pred (off_conv sentence_len)) in - let start = stop#backward_char in - buffer#apply_tag ~start ~stop Tags.Script.lax_end; - - if 1 < slice_len - sentence_len then begin (* remember that we added a trailing space *) - ignore (from#nocopy#forward_chars (off_conv sentence_len)); - split_substring (String.sub str sentence_len (slice_len - sentence_len)) + let end_off = Coq_lex.delimit_sentence (apply_tag buffer from off_conv) str + in + let start = from#forward_chars (off_conv end_off) in + let stop = start#forward_char in + buffer#apply_tag ~start ~stop Tags.Script.sentence; + let next = end_off + 1 in + if next < slice_len then begin + ignore (from#nocopy#forward_chars (off_conv next)); + split_substring (String.sub str next (slice_len - next)) end in split_substring slice -let rec grab_safe_sentence_start (iter:GText.iter) soi = - let lax_back = iter#backward_char#has_tag Tags.Script.lax_end in - let on_space = List.mem iter#char [0x09;0x0A;0x20] in - let full_ending = iter#is_start || (lax_back & on_space) in - if full_ending then iter - else if iter#compare soi <= 0 then raise Not_found - else - let prev = iter#backward_to_tag_toggle (Some Tags.Script.lax_end) in - (if prev#has_tag Tags.Script.lax_end then - ignore (prev#nocopy#backward_to_tag_toggle (Some Tags.Script.lax_end))); - grab_safe_sentence_start prev soi - -let grab_sentence_end_from (start:GText.iter) = - let stop = start#forward_to_tag_toggle (Some Tags.Script.lax_end) in - stop#forward_char - -let get_sentence_bounds (iter:GText.iter) = - let start = iter#backward_to_tag_toggle (Some Tags.Script.lax_end) in - (if start#has_tag Tags.Script.lax_end then ignore ( - start#nocopy#backward_to_tag_toggle (Some Tags.Script.lax_end))); - let stop = start#forward_to_tag_toggle (Some Tags.Script.lax_end) in - let stop = stop#forward_char in - start,stop - -let end_tag_present end_iter = - end_iter#backward_char#has_tag Tags.Script.lax_end +(** Searching forward and backward a position fulfilling some condition *) + +let rec forward_search cond (iter:GText.iter) = + if iter#is_end || cond iter then iter + else forward_search cond iter#forward_char + +let rec backward_search cond (iter:GText.iter) = + if iter#is_start || cond iter then iter + else backward_search cond iter#backward_char + +let is_sentence_end s = s#has_tag Tags.Script.sentence +let is_char s c = s#char = Char.code c + +(** Search backward the first character of a sentence, starting at [iter] + and going at most up to [soi] (meant to be the end of the locked zone). + Raise [Not_found] when no proper sentence start has been found, + in particular when the final "." of the locked zone is followed + by a non-blank character outside the locked zone. This non-blank + character will be signaled as erroneous in [tag_on_insert] below. *) + +let grab_sentence_start (iter:GText.iter) soi = + let cond iter = + if iter#compare soi < 0 then raise Not_found; + let prev = iter#backward_char in + is_sentence_end prev && + (not (is_char prev '.') || + List.exists (is_char iter) [' ';'\n';'\r';'\t']) + in + backward_search cond iter + +(** Search forward the first character immediately after a sentence end *) + +let rec grab_sentence_stop (start:GText.iter) = + (forward_search is_sentence_end start)#forward_char + +(** Search forward the first character immediately after a "." sentence end + (and not just a "{" or "}" or comment end *) + +let rec grab_ending_dot (start:GText.iter) = + let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in + (forward_search is_ending_dot start)#forward_char + +(** Retag a zone that has been edited *) let tag_on_insert = + (* possible race condition here : editing two buffers with a timedelta smaller + * than 1.5s might break the error recovery mechanism. *) let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *) fun buffer -> - try + try + (* the start of the non-locked zone *) + let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in + (* the inserted zone is between [prev_insert] and [insert] *) let insert = buffer#get_iter_at_mark `INSERT in - let start = grab_safe_sentence_start insert - (buffer#get_iter_at_mark (`NAME "start_of_input")) in - let stop = grab_sentence_end_from insert in + let prev_insert = buffer#get_iter_at_mark (`NAME "prev_insert") in + (* [prev_insert] is normally always before [insert] even when deleting. + Let's check this nonetheless *) + let prev_insert = + if insert#compare prev_insert < 0 then insert else prev_insert + in + let start = grab_sentence_start prev_insert soi in + (** The status of "{" "}" as sentence delimiters is too fragile. + We retag up to the next "." instead. *) + let stop = grab_ending_dot insert in let skip_curr = ref true in (* shall the callback be skipped ? by default yes*) (!skip_last) := true; (* skip the previously created callback *) skip_last := skip_curr; try split_slice_lax buffer start stop - with Not_found -> + with Coq_lex.Unterminated -> skip_curr := false; - ignore (Glib.Timeout.add ~ms:1500 - ~callback:(fun () -> if not !skip_curr then ( - try split_slice_lax buffer start buffer#end_iter with _ -> ()); false)) + let callback () = + if not !skip_curr then begin + try split_slice_lax buffer start buffer#end_iter + with Coq_lex.Unterminated -> () + end; false + in + ignore (Glib.Timeout.add ~ms:1500 ~callback) with Not_found -> let err_pos = buffer#get_iter_at_mark (`NAME "start_of_input") in buffer#apply_tag Tags.Script.error ~start:err_pos ~stop:err_pos#forward_char let force_retag buffer = - try split_slice_lax buffer buffer#start_iter buffer#end_iter with _ -> () + try split_slice_lax buffer buffer#start_iter buffer#end_iter + with Coq_lex.Unterminated -> () let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) = (* move back twice if not into proof_decl, @@ -537,8 +561,8 @@ let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) = ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl)); let decl_start = cursor in let prf_end = decl_start#forward_to_tag_toggle (Some Tags.Script.qed) in - let decl_end = grab_sentence_end_from decl_start in - let prf_end = grab_sentence_end_from prf_end in + let decl_end = grab_ending_dot decl_start in + let prf_end = grab_ending_dot prf_end in let prf_end = prf_end#forward_char in if decl_start#has_tag Tags.Script.folded then ( buffer#remove_tag ~start:decl_start ~stop:decl_end Tags.Script.folded; @@ -547,7 +571,12 @@ let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) = buffer#apply_tag ~start:decl_start ~stop:decl_end Tags.Script.folded; buffer#apply_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden) -class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs = +(** The arguments that will be passed to coqtop. No quoting here, since + no /bin/sh when using create_process instead of open_process. *) +let custom_project_files = ref [] +let sup_args = ref [] + +class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs _ct _fn = object(self) val input_view = _script val input_buffer = _script#buffer @@ -556,13 +585,15 @@ object(self) val message_view = _mv val message_buffer = _mv#buffer val cmd_stack = _cs + val mycoqtop = _ct val mutable is_active = false val mutable read_only = false - val mutable filename = None + val mutable filename = _fn val mutable stats = None val mutable last_modification_time = 0. val mutable last_auto_save_time = 0. val mutable detached_views = [] + val mutable find_forward_instead_of_backward = false val mutable auto_complete_on = !current.auto_complete val hidden_proofs = Hashtbl.create 32 @@ -572,10 +603,10 @@ object(self) method set_auto_complete t = auto_complete_on <- t method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x -> let old = auto_complete_on in - self#set_auto_complete false; - let y = f x in - self#set_auto_complete old; - y + self#set_auto_complete false; + let y = f x in + self#set_auto_complete old; + y method add_detached_view (w:GWindow.window) = detached_views <- w::detached_views method remove_detached_view (w:GWindow.window) = @@ -587,12 +618,6 @@ object(self) method filename = filename method stats = stats - method set_filename f = - filename <- f; - match f with - | Some f -> stats <- my_stat f - | None -> () - method update_stats = match filename with | Some f -> stats <- my_stat f @@ -601,44 +626,44 @@ object(self) method revert = match filename with | Some f -> begin - let do_revert () = begin - push_info "Reverting buffer"; - try - if is_active then self#reset_initial; - let b = Buffer.create 1024 in - with_file flash_info f ~f:(input_channel b); - let s = try_convert (Buffer.contents b) in - input_buffer#set_text s; - self#update_stats; - input_buffer#place_cursor input_buffer#start_iter; - input_buffer#set_modified false; - pop_info (); - flash_info "Buffer reverted"; - force_retag input_buffer; - with _ -> - pop_info (); - flash_info "Warning: could not revert buffer"; - end - in - if input_buffer#modified then - match (GToolbox.question_box - ~title:"Modified buffer changed on disk" - ~buttons:["Revert from File"; - "Overwrite File"; - "Disable Auto Revert"] - ~default:0 - ~icon:(stock_to_widget `DIALOG_WARNING) - "Some unsaved buffers changed on disk" - ) - with 1 -> do_revert () - | 2 -> if self#save f then flash_info "Overwritten" else - flash_info "Could not overwrite file" - | _ -> - prerr_endline "Auto revert set to false"; - !current.global_auto_revert <- false; - disconnect_revert_timer () - else do_revert () + let do_revert () = begin + push_info "Reverting buffer"; + try + if is_active then self#force_reset_initial; + let b = Buffer.create 1024 in + with_file flash_info f ~f:(input_channel b); + let s = try_convert (Buffer.contents b) in + input_buffer#set_text s; + self#update_stats; + input_buffer#place_cursor ~where:input_buffer#start_iter; + input_buffer#set_modified false; + pop_info (); + flash_info "Buffer reverted"; + force_retag input_buffer; + with _ -> + pop_info (); + flash_info "Warning: could not revert buffer"; end + in + if input_buffer#modified then + match (GToolbox.question_box + ~title:"Modified buffer changed on disk" + ~buttons:["Revert from File"; + "Overwrite File"; + "Disable Auto Revert"] + ~default:0 + ~icon:(stock_to_widget `DIALOG_WARNING) + "Some unsaved buffers changed on disk" + ) + with 1 -> do_revert () + | 2 -> if self#save f then flash_info "Overwritten" else + flash_info "Could not overwrite file" + | _ -> + prerr_endline "Auto revert set to false"; + !current.global_auto_revert <- false; + disconnect_revert_timer () + else do_revert () + end | None -> () method save f = @@ -647,8 +672,8 @@ object(self) input_buffer#set_modified false; stats <- my_stat f; (match self#auto_save_name with - | None -> () - | Some fn -> try Sys.remove fn with _ -> ()); + | None -> () + | Some fn -> try Sys.remove fn with _ -> ()); true end else false @@ -657,31 +682,31 @@ object(self) match filename with | None -> None | Some f -> - let dir = Filename.dirname f in - let base = (fst !current.auto_save_name) ^ - (Filename.basename f) ^ - (snd !current.auto_save_name) - in Some (Filename.concat dir base) + let dir = Filename.dirname f in + let base = (fst !current.auto_save_name) ^ + (Filename.basename f) ^ + (snd !current.auto_save_name) + in Some (Filename.concat dir base) method private need_auto_save = input_buffer#modified && - last_modification_time > last_auto_save_time + last_modification_time > last_auto_save_time method auto_save = if self#need_auto_save then begin match self#auto_save_name with | None -> () | Some fn -> - try - last_auto_save_time <- Unix.time(); - prerr_endline ("Autosave time : "^(string_of_float (Unix.time()))); - if try_export fn (input_buffer#get_text ()) then begin - flash_info ~delay:1000 "Autosaved" - end - else warning - ("Autosave failed (check if " ^ fn ^ " is writable)") - with _ -> - warning ("Autosave: unexpected error while writing "^fn) + try + last_auto_save_time <- Unix.time(); + prerr_endline ("Autosave time : "^(string_of_float (Unix.time()))); + if try_export fn (input_buffer#get_text ()) then begin + flash_info ~delay:1000 "Autosaved" + end + else warning + ("Autosave failed (check if " ^ fn ^ " is writable)") + with _ -> + warning ("Autosave: unexpected error while writing "^fn) end method save_as f = @@ -690,16 +715,16 @@ object(self) ~buttons:["Overwrite"; "Cancel";] ~default:1 - ~icon: - (let img = GMisc.image () in - img#set_stock `DIALOG_WARNING; - img#set_icon_size `DIALOG; - img#coerce) - ("File "^f^"already exists") + ~icon: + (let img = GMisc.image () in + img#set_stock `DIALOG_WARNING; + img#set_icon_size `DIALOG; + img#coerce) + ("File "^f^" already exists") ) with 1 -> self#save f | _ -> false - else self#save f + else self#save f method set_read_only b = read_only<-b method read_only = read_only @@ -721,9 +746,9 @@ object(self) method recenter_insert = (* BUG : to investigate further: - FIXED : Never call GMain.* in thread ! - PLUS : GTK BUG ??? Cannot be called from a thread... - ADDITION: using sync instead of async causes deadlock...*) + FIXED : Never call GMain.* in thread ! + PLUS : GTK BUG ??? Cannot be called from a thread... + ADDITION: using sync instead of async causes deadlock...*) ignore (GtkThread.async ( input_view#scroll_to_mark ~use_align:false @@ -737,229 +762,139 @@ object(self) let it = it#copy in let nb_sep = ref 0 in let continue = ref true in - while !continue do - if it#char = space then begin - incr nb_sep; - if not it#nocopy#forward_char then continue := false; - end else continue := false - done; - !nb_sep + while !continue do + if it#char = space then begin + incr nb_sep; + if not it#nocopy#forward_char then continue := false; + end else continue := false + done; + !nb_sep in let previous_line = self#get_insert in - if previous_line#nocopy#backward_line then begin - let previous_line_spaces = get_nb_space previous_line in + if previous_line#nocopy#backward_line then begin + let previous_line_spaces = get_nb_space previous_line in + let current_line_start = self#get_insert#set_line_offset 0 in + let current_line_spaces = get_nb_space current_line_start in + if input_buffer#delete_interactive + ~start:current_line_start + ~stop:(current_line_start#forward_chars current_line_spaces) + () + then let current_line_start = self#get_insert#set_line_offset 0 in - let current_line_spaces = get_nb_space current_line_start in - if input_buffer#delete_interactive - ~start:current_line_start - ~stop:(current_line_start#forward_chars current_line_spaces) - () - then - let current_line_start = self#get_insert#set_line_offset 0 in - input_buffer#insert - ~iter:current_line_start - (String.make previous_line_spaces ' ') - end + input_buffer#insert + ~iter:current_line_start + (String.make previous_line_spaces ' ') + end - method show_pm_goal = - proof_buffer#insert - (Printf.sprintf " *** Declarative Mode ***\n"); - try - let (hyps,concl) = get_current_pm_goal () in - List.iter - (fun ((_,_,_,(s,_)) as _hyp) -> - proof_buffer#insert (s^"\n")) - hyps; - proof_buffer#insert - (String.make 38 '_' ^ "\n"); - let (_,_,_,s) = concl in - proof_buffer#insert ("thesis := \n "^s^"\n"); - let my_mark = `NAME "end_of_conclusion" in - proof_buffer#move_mark - ~where:((proof_buffer#get_iter_at_mark `INSERT)) - my_mark; - ignore (proof_view#scroll_to_mark my_mark) - with Not_found -> - match Decl_mode.get_end_command (Pfedit.get_pftreestate ()) with - Some endc -> - proof_buffer#insert - ("Subproof completed, now type "^endc^".") - | None -> - proof_buffer#insert "Proof completed." + method go_to_next_occ_of_cur_word = + let cv = session_notebook#current_term in + let av = cv.analyzed_view in + let b = (cv.script)#buffer in + let start = find_word_start (av#get_insert) in + let stop = find_word_end start in + let text = b#get_text ~start ~stop () in + match stop#forward_search text with + | None -> () + | Some(start, _) -> + (b#place_cursor start; + self#recenter_insert) + + method go_to_prev_occ_of_cur_word = + let cv = session_notebook#current_term in + let av = cv.analyzed_view in + let b = (cv.script)#buffer in + let start = find_word_start (av#get_insert) in + let stop = find_word_end start in + let text = b#get_text ~start ~stop () in + match start#backward_search text with + | None -> () + | Some(start, _) -> + (b#place_cursor start; + self#recenter_insert) val mutable full_goal_done = true method show_goals_full = if not full_goal_done then - begin - try - proof_buffer#set_text ""; - match Decl_mode.get_current_mode () with - Decl_mode.Mode_none -> () - | Decl_mode.Mode_tactic -> - begin - match Coq.get_current_goals () with - [] -> proof_buffer#insert (Coq.print_no_goal()) - | ((hyps,concl)::r) as s -> - let last_shown_area = Tags.Proof.highlight - in - let goal_nb = List.length s in - proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" - goal_nb - (if goal_nb<=1 then "" else "s")); - let coq_menu commands = - let tag = proof_buffer#create_tag [] - in - ignore - (tag#connect#event ~callback: - (fun ~origin ev it -> - match GdkEvent.get_type ev with - | `BUTTON_PRESS -> - let ev = (GdkEvent.Button.cast ev) in - if (GdkEvent.Button.button ev) = 3 - then ( - let loc_menu = GMenu.menu () in - let factory = - new GMenu.factory loc_menu in - let add_coq_command (cp,ip) = - ignore - (factory#add_item cp - ~callback: - (fun () -> ignore - (self#insert_this_phrase_on_success - true - true - false - ("progress "^ip^"\n") - (ip^"\n")) - ) - ) - in - List.iter add_coq_command commands; - loc_menu#popup - ~button:3 - ~time:(GdkEvent.Button.time ev); - true) - else false - | `MOTION_NOTIFY -> - proof_buffer#remove_tag - ~start:proof_buffer#start_iter - ~stop:proof_buffer#end_iter - last_shown_area; - prerr_endline "Before find_tag_limits"; - - let s,e = find_tag_limits tag - (new GText.iter it) - in - prerr_endline "After find_tag_limits"; - proof_buffer#apply_tag - ~start:s - ~stop:e - last_shown_area; - - prerr_endline "Applied tag"; - false - | _ -> - false - ) - ); - tag - in - List.iter - (fun ((_,_,_,(s,_)) as hyp) -> - let tag = coq_menu (hyp_menu hyp) in - proof_buffer#insert ~tags:[tag] (s^"\n")) - hyps; - proof_buffer#insert - (String.make 38 '_' ^"(1/"^ - (string_of_int goal_nb)^ - ")\n") - ; - let tag = coq_menu (concl_menu concl) in - let _,_,_,sconcl = concl in - proof_buffer#insert ~tags:[tag] sconcl; - proof_buffer#insert "\n"; - let my_mark = `NAME "end_of_conclusion" in - proof_buffer#move_mark - ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark; - proof_buffer#insert "\n\n"; - let i = ref 1 in - List.iter - (function (_,(_,_,_,concl)) -> - incr i; - proof_buffer#insert - (String.make 38 '_' ^"("^ - (string_of_int !i)^ - "/"^ - (string_of_int goal_nb)^ - ")\n"); - proof_buffer#insert concl; - proof_buffer#insert "\n\n"; - ) - r; - ignore (proof_view#scroll_to_mark my_mark) ; - full_goal_done <- true - end - | Decl_mode.Mode_proof -> - self#show_pm_goal - with e -> prerr_endline (Printexc.to_string e) - end + proof_view#buffer#set_text ""; + begin + let menu_callback = if !current.contextual_menus_on_goal then + (fun s () -> ignore (self#insert_this_phrase_on_success + true true false ("progress "^s) s)) + else + (fun _ _ -> ()) in + try + begin match Coq.goals !mycoqtop with + | Interface.Fail (l, str) -> + self#set_message ("Error in coqtop :\n"^str) + | Interface.Good goals -> + begin match Coq.evars !mycoqtop with + | Interface.Fail (l, str) -> + self#set_message ("Error in coqtop :\n"^str) + | Interface.Good evs -> + let hints = match Coq.hints !mycoqtop with + | Interface.Fail (_, _) -> None + | Interface.Good hints -> hints + in + Ideproof.display + (Ideproof.mode_tactic menu_callback) + proof_view goals hints evs + end + end + with + | e -> prerr_endline (Printexc.to_string e) + end method show_goals = self#show_goals_full - - method send_to_coq verbosely replace phrase show_output show_error localize = + method private send_to_coq ct verbose phrase show_output show_error localize = let display_output msg = self#insert_message (if show_output then msg else "") in - let display_error e = - let (s,loc) = Coq.process_exn e in - assert (Glib.Utf8.validate s); - self#insert_message s; - message_view#misc#draw None; - if localize then - (match Option.map Util.unloc loc with - | None -> () - | Some (start,stop) -> - let convert_pos = byte_offset_to_char_offset phrase in - let start = convert_pos start in - let stop = convert_pos stop in - let i = self#get_start_of_input in - let starti = i#forward_chars start in - let stopi = i#forward_chars stop in - input_buffer#apply_tag Tags.Script.error - ~start:starti - ~stop:stopi; - input_buffer#place_cursor starti) in - try - full_goal_done <- false; - prerr_endline "Send_to_coq starting now"; - Decl_mode.clear_daimon_flag (); - if replace then begin - let r,info = Coq.interp_and_replace ("info " ^ phrase) in - let is_complete = not (Decl_mode.get_daimon_flag ()) in - let msg = read_stdout () in - sync display_output msg; - Some (is_complete,r) - end else begin - let r = Coq.interp verbosely phrase in - let is_complete = not (Decl_mode.get_daimon_flag ()) in - let msg = read_stdout () in - sync display_output msg; - Some (is_complete,r) + let display_error (loc,s) = + if show_error then begin + if not (Glib.Utf8.validate s) then + flash_info "This error is so nasty that I can't even display it." + else begin + self#insert_message s; + message_view#misc#draw None; + if localize then + (match loc with + | None -> () + | Some (start,stop) -> + let convert_pos = byte_offset_to_char_offset phrase in + let start = convert_pos start in + let stop = convert_pos stop in + let i = self#get_start_of_input in + let starti = i#forward_chars start in + let stopi = i#forward_chars stop in + input_buffer#apply_tag Tags.Script.error + ~start:starti + ~stop:stopi; + input_buffer#place_cursor ~where:starti) end - with e -> - if show_error then sync display_error e; - None + end in + try + full_goal_done <- false; + prerr_endline "Send_to_coq starting now"; + (* It's important here to work with [ct] and not [!mycoqtop], otherwise + we could miss a restart of coqtop and continue sending it orders. *) + match Coq.interp ct ~verbose phrase with + | Interface.Fail (l,str) -> sync display_error (l,str); None + | Interface.Good msg -> sync display_output msg; Some Safe + (* TODO: Restore someday the access to Decl_mode.get_damon_flag, + and also detect the use of admit, and then return Unsafe *) + with + | End_of_file -> (* Coqtop has died, let's trigger a reset_initial. *) + raise RestartCoqtop + | e -> sync display_error (None, Printexc.to_string e); None method find_phrase_starting_at (start:GText.iter) = try - let start = grab_safe_sentence_start start self#get_start_of_input in - let stop = grab_sentence_end_from start in - if stop#backward_char#has_tag Tags.Script.lax_end then - Some (start,stop) - else - None + let start = grab_sentence_start start self#get_start_of_input in + let stop = grab_sentence_stop start in + if is_sentence_end stop#backward_char then Some (start,stop) + else None with Not_found -> None method complete_at_offset (offset:int) = @@ -967,236 +902,269 @@ object(self) let it () = input_buffer#get_iter (`OFFSET offset) in let iit = it () in let start = find_word_start iit in - if ends_word iit then - let w = input_buffer#get_text - ~start - ~stop:iit - () - in - if String.length w <> 0 then begin - prerr_endline ("Completion of prefix : '" ^ w^"'"); - match complete input_buffer w start#offset with - | None -> false - | Some (ss,start,stop) -> - let completion = input_buffer#get_text ~start ~stop () in - ignore (input_buffer#delete_selection ()); - ignore (input_buffer#insert_interactive completion); - input_buffer#move_mark `SEL_BOUND (it())#backward_char; - true - end else false - else false + if ends_word iit then + let w = input_buffer#get_text + ~start + ~stop:iit + () + in + if String.length w <> 0 then begin + prerr_endline ("Completion of prefix : '" ^ w^"'"); + match complete input_buffer w start#offset with + | None -> false + | Some (ss,start,stop) -> + let completion = input_buffer#get_text ~start ~stop () in + ignore (input_buffer#delete_selection ()); + ignore (input_buffer#insert_interactive completion); + input_buffer#move_mark `SEL_BOUND ~where:(it())#backward_char; + true + end else false + else false - method process_next_phrase verbosely display_goals do_highlight = + method private process_one_phrase ct verbosely display_goals do_highlight = let get_next_phrase () = self#clear_message; - prerr_endline "process_next_phrase starting now"; + prerr_endline "process_one_phrase starting now"; if do_highlight then begin push_info "Coq is computing"; input_view#set_editable false; end; match self#find_phrase_starting_at self#get_start_of_input with | None -> - if do_highlight then begin - input_view#set_editable true; - pop_info (); - end; - None + if do_highlight then begin + input_view#set_editable true; + pop_info (); + end; + None | Some(start,stop) -> - prerr_endline "process_next_phrase : to_process highlight"; - if do_highlight then begin - input_buffer#apply_tag Tags.Script.to_process ~start ~stop; - prerr_endline "process_next_phrase : to_process applied"; - end; - prerr_endline "process_next_phrase : getting phrase"; - Some((start,stop),start#get_slice ~stop) in + prerr_endline "process_one_phrase : to_process highlight"; + if do_highlight then begin + input_buffer#apply_tag Tags.Script.to_process ~start ~stop; + prerr_endline "process_one_phrase : to_process applied"; + end; + prerr_endline "process_one_phrase : getting phrase"; + Some((start,stop),start#get_slice ~stop) in let remove_tag (start,stop) = if do_highlight then begin input_buffer#remove_tag Tags.Script.to_process ~start ~stop; input_view#set_editable true; pop_info (); end in - let mark_processed reset_info is_complete (start,stop) = + let mark_processed safe (start,stop) = let b = input_buffer in b#move_mark ~where:stop (`NAME "start_of_input"); - b#apply_tag - (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop; - if (self#get_insert#compare) stop <= 0 then - begin - b#place_cursor stop; - self#recenter_insert - end; - let ide_payload = { start = `MARK (b#create_mark start); - stop = `MARK (b#create_mark stop); } in - push_phrase - cmd_stack - reset_info - ide_payload; - if display_goals then self#show_goals; - remove_tag (start,stop) in - begin - match sync get_next_phrase () with - None -> false - | Some (loc,phrase) -> - (match self#send_to_coq verbosely false phrase true true true with - | Some (is_complete,reset_info) -> - sync (mark_processed reset_info is_complete) loc; true - | None -> sync remove_tag loc; false) - end + b#apply_tag (safety_tag safe) ~start ~stop; + if (self#get_insert#compare) stop <= 0 then + begin + b#place_cursor ~where:stop; + self#recenter_insert + end; + let ide_payload = { start = `MARK (b#create_mark start); + stop = `MARK (b#create_mark stop); } in + Stack.push ide_payload cmd_stack; + if display_goals then self#show_goals; + remove_tag (start,stop) + in + match sync get_next_phrase () with + | None -> raise Unsuccessful + | Some ((_,stop) as loc,phrase) -> + if stop#backward_char#has_tag Tags.Script.comment + then sync mark_processed Safe loc + else try match self#send_to_coq ct verbosely phrase true true true with + | Some safe -> sync mark_processed safe loc + | None -> sync remove_tag loc; raise Unsuccessful + with + | RestartCoqtop -> sync remove_tag loc; raise RestartCoqtop - method insert_this_phrase_on_success - show_output show_msg localize coqphrase insertphrase = - let mark_processed reset_info is_complete = + method process_next_phrase verbosely = + try self#process_one_phrase !mycoqtop verbosely true true + with Unsuccessful -> () + + method private insert_this_phrase_on_success + show_output show_msg localize coqphrase insertphrase = + let mark_processed safe = let stop = self#get_start_of_input in - if stop#starts_line then - input_buffer#insert ~iter:stop insertphrase - else input_buffer#insert ~iter:stop ("\n"^insertphrase); - let start = self#get_start_of_input in - input_buffer#move_mark ~where:stop (`NAME "start_of_input"); - input_buffer#apply_tag - (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop; - if (self#get_insert#compare) stop <= 0 then - input_buffer#place_cursor stop; - let ide_payload = { start = `MARK (input_buffer#create_mark start); - stop = `MARK (input_buffer#create_mark stop); } in - push_phrase cmd_stack reset_info ide_payload; - self#show_goals; - (*Auto insert save on success... - try (match Coq.get_current_goals () with - | [] -> - (match self#send_to_coq "Save.\n" true true true with - | Some ast -> - begin - let stop = self#get_start_of_input in - if stop#starts_line then - input_buffer#insert ~iter:stop "Save.\n" - else input_buffer#insert ~iter:stop "\nSave.\n"; - let start = self#get_start_of_input in - input_buffer#move_mark ~where:stop (`NAME"start_of_input"); - input_buffer#apply_tag_by_name "processed" ~start ~stop; - if (self#get_insert#compare) stop <= 0 then - input_buffer#place_cursor stop; - let start_of_phrase_mark = - `MARK (input_buffer#create_mark start) in - let end_of_phrase_mark = - `MARK (input_buffer#create_mark stop) in - push_phrase - reset_info start_of_phrase_mark end_of_phrase_mark ast - end - | None -> ()) - | _ -> ()) - with _ -> ()*) in - match self#send_to_coq false false coqphrase show_output show_msg localize with - | Some (is_complete,reset_info) -> - sync (mark_processed reset_info) is_complete; true - | None -> - sync - (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase)) - (); - false + if stop#starts_line then + input_buffer#insert ~iter:stop insertphrase + else input_buffer#insert ~iter:stop ("\n"^insertphrase); + let start = self#get_start_of_input in + input_buffer#move_mark ~where:stop (`NAME "start_of_input"); + input_buffer#apply_tag (safety_tag safe) ~start ~stop; + if (self#get_insert#compare) stop <= 0 then + input_buffer#place_cursor ~where:stop; + let ide_payload = { start = `MARK (input_buffer#create_mark start); + stop = `MARK (input_buffer#create_mark stop); } in + Stack.push ide_payload cmd_stack; + self#show_goals; + (*Auto insert save on success... + try (match Coq.get_current_goals () with + | [] -> + (match self#send_to_coq "Save.\n" true true true with + | Some ast -> + begin + let stop = self#get_start_of_input in + if stop#starts_line then + input_buffer#insert ~iter:stop "Save.\n" + else input_buffer#insert ~iter:stop "\nSave.\n"; + let start = self#get_start_of_input in + input_buffer#move_mark ~where:stop (`NAME"start_of_input"); + input_buffer#apply_tag_by_name "processed" ~start ~stop; + if (self#get_insert#compare) stop <= 0 then + input_buffer#place_cursor stop; + let start_of_phrase_mark = + `MARK (input_buffer#create_mark start) in + let end_of_phrase_mark = + `MARK (input_buffer#create_mark stop) in + push_phrase + reset_info start_of_phrase_mark end_of_phrase_mark ast + end + | None -> ()) + | _ -> ()) + with _ -> ()*) in + match self#send_to_coq !mycoqtop false coqphrase show_output show_msg localize with + | Some safe -> sync mark_processed safe; true + | None -> + sync + (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase)) + (); + false method process_until_iter_or_error stop = let stop' = `OFFSET stop#offset in let start = self#get_start_of_input#copy in let start' = `OFFSET start#offset in + sync (fun _ -> + input_buffer#apply_tag Tags.Script.to_process ~start ~stop; + input_view#set_editable false) (); + push_info "Coq is computing"; + let get_current () = + if !current.stop_before then + match self#find_phrase_starting_at self#get_start_of_input with + | None -> self#get_start_of_input + | Some (_, stop2) -> stop2 + else begin + self#get_start_of_input + end + in + let unlock () = sync (fun _ -> - input_buffer#apply_tag Tags.Script.to_process ~start ~stop; - input_view#set_editable false) (); - push_info "Coq is computing"; - let get_current () = - if !current.stop_before then - match self#find_phrase_starting_at self#get_start_of_input with - | None -> self#get_start_of_input - | Some (_, stop2) -> stop2 - else begin - self#get_start_of_input - end - in - (try - while ((stop#compare (get_current())>=0) - && (self#process_next_phrase false false false)) - do Util.check_for_interrupt () done - with Sys.Break -> - prerr_endline "Interrupted during process_until_iter_or_error"); - sync (fun _ -> - self#show_goals; - (* Start and stop might be invalid if an eol was added at eof *) - let start = input_buffer#get_iter start' in - let stop = input_buffer#get_iter stop' in - input_buffer#remove_tag Tags.Script.to_process ~start ~stop; - input_view#set_editable true) (); - pop_info() + self#show_goals; + (* Start and stop might be invalid if an eol was added at eof *) + let start = input_buffer#get_iter start' in + let stop = input_buffer#get_iter stop' in + input_buffer#remove_tag Tags.Script.to_process ~start ~stop; + input_view#set_editable true) () + in + (* All the [process_one_phrase] below should be done with the same [ct] + instead of accessing multiple time [mycoqtop]. Otherwise a restart of + coqtop could go unnoticed, and the new coqtop could receive strange + things. *) + let ct = !mycoqtop in + (try + while stop#compare (get_current()) >= 0 + do self#process_one_phrase ct false false false done + with + | Unsuccessful -> () + | RestartCoqtop -> unlock (); raise RestartCoqtop); + unlock (); + pop_info() method process_until_end_or_error = self#process_until_iter_or_error input_buffer#end_iter method reset_initial = - sync (fun _ -> - Stack.iter - (function (inf,_) -> - let start = input_buffer#get_iter_at_mark inf.start in - let stop = input_buffer#get_iter_at_mark inf.stop in - input_buffer#move_mark ~where:start (`NAME "start_of_input"); - input_buffer#remove_tag Tags.Script.processed ~start ~stop; - input_buffer#remove_tag Tags.Script.unjustified ~start ~stop; - input_buffer#delete_mark inf.start; - input_buffer#delete_mark inf.stop; - ) - cmd_stack; - Stack.clear cmd_stack; - self#clear_message)(); - Coq.reset_initial () + mycoqtop := Coq.respawn_coqtop !mycoqtop; + sync (fun () -> + Stack.iter + (function inf -> + let start = input_buffer#get_iter_at_mark inf.start in + let stop = input_buffer#get_iter_at_mark inf.stop in + input_buffer#move_mark ~where:start (`NAME "start_of_input"); + input_buffer#remove_tag Tags.Script.processed ~start ~stop; + input_buffer#remove_tag Tags.Script.unjustified ~start ~stop; + input_buffer#delete_mark inf.start; + input_buffer#delete_mark inf.stop; + ) + cmd_stack; + Stack.clear cmd_stack; + self#clear_message) () + + method force_reset_initial = + (* Do nothing if a force_reset_initial is already ongoing *) + if Mutex.try_lock resetting then begin + Coq.kill_coqtop !mycoqtop; + (* If a computation is ongoing, an exception will trigger + the reset_initial in do_if_not_computing, not here. *) + if Mutex.try_lock coq_computing then begin + self#reset_initial; + Mutex.unlock coq_computing + end; + Mutex.unlock resetting + end + + (* Internal method for dialoging with coqtop about a backtrack. + The ide's cmd_stack has already been cleared up to the desired point. + The [finish] function is used to handle minor differences between + [go_to_insert] and [undo_last_step] *) + + method private do_backtrack finish n = + (* pop n more commands if coqtop has said so (e.g. for undoing a proof) *) + let rec n_pop n = + if n = 0 then () + else + let phrase = Stack.pop cmd_stack in + let stop = input_buffer#get_iter_at_mark phrase.stop in + if stop#backward_char#has_tag Tags.Script.comment + then n_pop n + else n_pop (pred n) + in + match Coq.rewind !mycoqtop n with + | Interface.Good n -> + n_pop n; + sync (fun _ -> + let start = + if Stack.is_empty cmd_stack then input_buffer#start_iter + else input_buffer#get_iter_at_mark (Stack.top cmd_stack).stop in + let stop = self#get_start_of_input in + input_buffer#remove_tag Tags.Script.processed ~start ~stop; + input_buffer#remove_tag Tags.Script.unjustified ~start ~stop; + input_buffer#move_mark ~where:start (`NAME "start_of_input"); + self#show_goals; + self#clear_message; + finish start) () + | Interface.Fail (l,str) -> + sync self#set_message + ("Error while backtracking :\n" ^ str ^ "\n" ^ + "CoqIDE and coqtop may be out of sync, you may want to use Restart.") (* backtrack Coq to the phrase preceding iterator [i] *) method backtrack_to_no_lock i = prerr_endline "Backtracking_to iter starts now."; + full_goal_done <- false; (* pop Coq commands until we reach iterator [i] *) - let rec pop_cmds popped = - if Stack.is_empty cmd_stack then - popped - else - let (ide,coq) = Stack.pop cmd_stack in - if i#compare (input_buffer#get_iter_at_mark ide.stop) < 0 then - begin - prerr_endline "popped command"; - pop_cmds (coq::popped) - end - else - begin - Stack.push (ide,coq) cmd_stack; - popped - end + let rec n_step n = + if Stack.is_empty cmd_stack then n else + let phrase = Stack.top cmd_stack in + let stop = input_buffer#get_iter_at_mark phrase.stop in + if i#compare stop >= 0 then n + else begin + ignore (Stack.pop cmd_stack); + if stop#backward_char#has_tag Tags.Script.comment + then n_step n + else n_step (succ n) + end in - let seq = List.rev (pop_cmds []) in - prerr_endline "Popped commands"; - if 0 < List.length seq then - begin - try - rewind seq cmd_stack; - sync (fun _ -> - let start = - if Stack.is_empty cmd_stack then input_buffer#start_iter - else input_buffer#get_iter_at_mark (fst (Stack.top cmd_stack)).stop in - prerr_endline "Removing (long) processed tag..."; - input_buffer#remove_tag - Tags.Script.processed - ~start - ~stop:self#get_start_of_input; - input_buffer#remove_tag - Tags.Script.unjustified - ~start - ~stop:self#get_start_of_input; - prerr_endline "Moving (long) start_of_input..."; - input_buffer#move_mark ~where:start (`NAME "start_of_input"); - full_goal_done <- false; - self#show_goals; - clear_stdout (); - self#clear_message) - (); - with _ -> - push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state. - Please restart and report NOW."; - end - else prerr_endline "backtrack_to : discarded (...)" + begin + try + self#do_backtrack (fun _ -> ()) (n_step 0); + (* We may have backtracked too much: let's replay *) + self#process_until_iter_or_error i + with _ -> + push_info + ("WARNING: undo failed badly.\n" ^ + "Coq might be in an inconsistent state.\n" ^ + "Please restart and report."); + end method backtrack_to i = if Mutex.try_lock coq_may_stop then @@ -1207,41 +1175,26 @@ object(self) method go_to_insert = let point = self#get_insert in - if point#compare self#get_start_of_input>=0 - then self#process_until_iter_or_error point - else self#backtrack_to point + if point#compare self#get_start_of_input>=0 + then self#process_until_iter_or_error point + else self#backtrack_to point method undo_last_step = + full_goal_done <- false; if Mutex.try_lock coq_may_stop then (push_info "Undoing last step..."; (try - let (ide_ri,_) = Stack.top cmd_stack in - let start = input_buffer#get_iter_at_mark ide_ri.start in - let update_input () = - prerr_endline "Removing processed tag..."; - input_buffer#remove_tag - Tags.Script.processed - ~start - ~stop:(input_buffer#get_iter_at_mark ide_ri.stop); - input_buffer#remove_tag - Tags.Script.unjustified - ~start - ~stop:(input_buffer#get_iter_at_mark ide_ri.stop); - prerr_endline "Moving start_of_input"; - input_buffer#move_mark - ~where:start - (`NAME "start_of_input"); - input_buffer#place_cursor start; - self#recenter_insert; - full_goal_done <- false; - self#show_goals; - self#clear_message - in - let _,coq = Stack.pop cmd_stack in - rewind [coq] cmd_stack; - sync update_input () - with - | Stack.Empty -> (* flash_info "Nothing to Undo"*)() + let phrase = Stack.pop cmd_stack in + let stop = input_buffer#get_iter_at_mark phrase.stop in + let count = + if stop#backward_char#has_tag Tags.Script.comment then 0 else 1 + in + let finish where = + input_buffer#place_cursor ~where; + self#recenter_insert; + in + self#do_backtrack finish count + with Stack.Empty -> () ); pop_info (); Mutex.unlock coq_may_stop) @@ -1257,231 +1210,233 @@ object(self) ignore (List.exists (fun p -> - self#insert_this_phrase_on_success true false false - ("progress "^p^".\n") (p^".\n")) l) + self#insert_this_phrase_on_success true false false + ("progress "^p^".\n") (p^".\n")) l) method active_keypress_handler k = let state = GdkEvent.Key.state k in - begin - match state with - | l when List.mem `MOD1 l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Return=k - then ignore( - if (input_buffer#insert_interactive "\n") then - begin - let i= self#get_insert#backward_word_start in - prerr_endline "active_kp_hf: Placing cursor"; - self#process_until_iter_or_error i - end); - true - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Break=k - then break (); - false - | l -> - if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin - prerr_endline "active_kp_handler for Tab"; - self#indent_current_line; - true - end else false - end + begin + match state with + | l when List.mem `MOD1 l -> + let k = GdkEvent.Key.keyval k in + if GdkKeysyms._Return=k + then ignore( + if (input_buffer#insert_interactive "\n") then + begin + let i= self#get_insert#backward_word_start in + prerr_endline "active_kp_hf: Placing cursor"; + self#process_until_iter_or_error i + end); + true + | l when List.mem `CONTROL l -> + let k = GdkEvent.Key.keyval k in + if GdkKeysyms._Break=k + then break (); + false + | l -> + if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin + prerr_endline "active_kp_handler for Tab"; + self#indent_current_line; + true + end else false + end method disconnected_keypress_handler k = match GdkEvent.Key.state k with | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._c=k - then break (); - false + let k = GdkEvent.Key.keyval k in + if GdkKeysyms._c=k + then break (); + false | l -> false val mutable deact_id = None val mutable act_id = None - method deactivate () = - is_active <- false; - (match act_id with None -> () - | Some id -> - reset_initial (); - input_view#misc#disconnect id; - prerr_endline "DISCONNECTED old active : "; - print_id id; - )(*; - deact_id <- Some - (input_view#event#connect#key_press self#disconnected_keypress_handler); - prerr_endline "CONNECTED inactive : "; - print_id (Option.get deact_id)*) - - (* XXX *) - method activate () = - is_active <- true;(* - (match deact_id with None -> () - | Some id -> input_view#misc#disconnect id; - prerr_endline "DISCONNECTED old inactive : "; - print_id id - );*) + method activate () = if not is_active then begin + is_active <- true; act_id <- Some - (input_view#event#connect#key_press self#active_keypress_handler); + (input_view#event#connect#key_press ~callback:self#active_keypress_handler); prerr_endline "CONNECTED active : "; - print_id (Option.get act_id); - match - filename - with + print_id (match act_id with Some x -> x | None -> assert false); + match filename with | None -> () - | Some f -> let dir = Filename.dirname f in - if not (is_in_loadpath dir) then - begin - ignore (Coq.interp false - (Printf.sprintf "Add LoadPath \"%s\". " dir)) - end - - method electric_handler = - input_buffer#connect#insert_text ~callback: - (fun it x -> - begin try - if last_index then begin - last_array.(0)<-x; - if (last_array.(1) ^ last_array.(0) = ".\n") then raise Found - end else begin - last_array.(1)<-x; - if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found - end - with Found -> - begin - ignore (self#process_next_phrase false true true) - end; - end; - last_index <- not last_index;) + | Some f -> + let dir = Filename.dirname f in + let ct = !mycoqtop in + match Coq.inloadpath ct dir with + | Interface.Fail (_,str) -> + self#set_message + ("Could not determine lodpath, this might lead to problems:\n"^str) + | Interface.Good true -> () + | Interface.Good false -> + let cmd = Printf.sprintf "Add LoadPath \"%s\". " dir in + match Coq.interp ct cmd with + | Interface.Fail (l,str) -> + self#set_message ("Couln't add loadpath:\n"^str) + | Interface.Good _ -> () + end method private electric_paren tag = - let oparen_code = Glib.Utf8.to_unichar "(" (ref 0) in - let cparen_code = Glib.Utf8.to_unichar ")" (ref 0) in - ignore (input_buffer#connect#insert_text ~callback: - (fun it x -> - input_buffer#remove_tag - ~start:input_buffer#start_iter - ~stop:input_buffer#end_iter - tag; - if x = "" then () else - match x.[String.length x - 1] with - | ')' -> - let hit = self#get_insert in - let count = ref 0 in - if hit#nocopy#backward_find_char - (fun c -> - if c = oparen_code && !count = 0 then true - else if c = cparen_code then - (incr count;false) - else if c = oparen_code then - (decr count;false) - else false - ) - then - begin - prerr_endline "Found matching parenthesis"; - input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char - end - else () - | _ -> ()) - ) + let oparen_code = Glib.Utf8.to_unichar "(" ~pos:(ref 0) in + let cparen_code = Glib.Utf8.to_unichar ")" ~pos:(ref 0) in + ignore (input_buffer#connect#insert_text ~callback: + (fun it x -> + input_buffer#remove_tag + ~start:input_buffer#start_iter + ~stop:input_buffer#end_iter + tag; + if x = "" then () else + match x.[String.length x - 1] with + | ')' -> + let hit = self#get_insert in + let count = ref 0 in + if hit#nocopy#backward_find_char + (fun c -> + if c = oparen_code && !count = 0 then true + else if c = cparen_code then + (incr count;false) + else if c = oparen_code then + (decr count;false) + else false + ) + then + begin + prerr_endline "Found matching parenthesis"; + input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char + end + else () + | _ -> ()) + ) method help_for_keyword () = - browse_keyword (self#insert_message) (get_current_word ()) +(** NB: Events during text edition: + + - [begin_user_action] + - [insert_text] (or [delete_range] when deleting) + - [changed] + - [end_user_action] + + When pasting a text containing tags (e.g. the sentence terminators), + there is actually many [insert_text] and [changed]. For instance, + for "a. b.": + + - [begin_user_action] + - [insert_text] (for "a") + - [changed] + - [insert_text] (for ".") + - [changed] + - [apply_tag] (for the tag of ".") + - [insert_text] (for " b") + - [changed] + - [insert_text] (for ".") + - [changed] + - [apply_tag] (for the tag of ".") + - [end_user_action] + + Since these copy-pasted tags may interact badly with the retag mechanism, + we now don't monitor the "changed" event, but rather the "begin_user_action" + and "end_user_action". We begin by setting a mark at the initial cursor + point. At the end, the zone between the mark and the cursor is to be + untagged and then retagged. *) + initializer ignore (message_buffer#connect#insert_text ~callback:(fun it s -> ignore - (message_view#scroll_to_mark - ~use_align:false - ~within_margin:0.49 - `INSERT))); + (message_view#scroll_to_mark + ~use_align:false + ~within_margin:0.49 + `INSERT))); ignore (input_buffer#connect#insert_text ~callback:(fun it s -> - if (it#compare self#get_start_of_input)<0 - then GtkSignal.stop_emit (); - if String.length s > 1 then - (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor it))); + if (it#compare self#get_start_of_input)<0 + then GtkSignal.stop_emit (); + if String.length s > 1 then + (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor ~where:it))); ignore (input_buffer#connect#after#apply_tag ~callback:(fun tag ~start ~stop -> - if (start#compare self#get_start_of_input)>=0 - then - begin - input_buffer#remove_tag - Tags.Script.processed - ~start - ~stop; - input_buffer#remove_tag - Tags.Script.unjustified - ~start - ~stop - end + if (start#compare self#get_start_of_input)>=0 + then + begin + input_buffer#remove_tag + Tags.Script.processed + ~start + ~stop; + input_buffer#remove_tag + Tags.Script.unjustified + ~start + ~stop + end ) ); ignore (input_buffer#connect#after#insert_text ~callback:(fun it s -> - if auto_complete_on && - String.length s = 1 && s <> " " && s <> "\n" - then - let v = session_notebook#current_term.analyzed_view - in - let has_completed = - v#complete_at_offset - ((input_view#buffer#get_iter `SEL_BOUND)#offset) - in - if has_completed then - input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char; - - + if auto_complete_on && + String.length s = 1 && s <> " " && s <> "\n" + then + let v = session_notebook#current_term.analyzed_view + in + let has_completed = + v#complete_at_offset + ((input_view#buffer#get_iter `SEL_BOUND)#offset) + in + if has_completed then + input_buffer#move_mark `SEL_BOUND ~where:(input_buffer#get_iter `SEL_BOUND)#forward_char; ) ); - ignore (input_buffer#connect#changed + ignore (input_buffer#connect#begin_user_action + ~callback:(fun () -> + let here = input_buffer#get_iter_at_mark `INSERT in + input_buffer#move_mark (`NAME "prev_insert") here + ) + ); + ignore (input_buffer#connect#end_user_action ~callback:(fun () -> - last_modification_time <- Unix.time (); - let r = input_view#visible_rect in - let stop = - input_view#get_iter_at_location - ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r) - ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r) - in - input_buffer#remove_tag - Tags.Script.error - ~start:self#get_start_of_input - ~stop; - tag_on_insert input_buffer + last_modification_time <- Unix.time (); + let r = input_view#visible_rect in + let stop = + input_view#get_iter_at_location + ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r) + ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r) + in + input_buffer#remove_tag + Tags.Script.error + ~start:self#get_start_of_input + ~stop; + tag_on_insert input_buffer ) ); ignore (input_buffer#add_selection_clipboard cb); ignore (proof_buffer#add_selection_clipboard cb); ignore (message_buffer#add_selection_clipboard cb); - self#electric_paren Tags.Script.paren; - ignore (input_buffer#connect#after#mark_set - ~callback:(fun it (m:Gtk.text_mark) -> - !set_location - (Printf.sprintf - "Line: %5d Char: %3d" (self#get_insert#line + 1) - (self#get_insert#line_offset + 1)); - match GtkText.Mark.get_name m with - | Some "insert" -> - input_buffer#remove_tag - ~start:input_buffer#start_iter - ~stop:input_buffer#end_iter - Tags.Script.paren; - | Some s -> - prerr_endline (s^" moved") - | None -> () ) - ); - ignore (input_buffer#connect#insert_text - (fun it s -> - prerr_endline "Should recenter ?"; - if String.contains s '\n' then begin - prerr_endline "Should recenter : yes"; - self#recenter_insert - end)); + self#electric_paren Tags.Script.paren; + ignore (input_buffer#connect#after#mark_set + ~callback:(fun it (m:Gtk.text_mark) -> + !set_location + (Printf.sprintf + "Line: %5d Char: %3d" (self#get_insert#line + 1) + (self#get_insert#line_offset + 1)); + match GtkText.Mark.get_name m with + | Some "insert" -> + input_buffer#remove_tag + ~start:input_buffer#start_iter + ~stop:input_buffer#end_iter + Tags.Script.paren; + | Some s -> + prerr_endline (s^" moved") + | None -> () ) + ); + ignore (input_buffer#connect#insert_text + ~callback:(fun it s -> + prerr_endline "Should recenter ?"; + if String.contains s '\n' then begin + prerr_endline "Should recenter : yes"; + self#recenter_insert + end)); end let last_make = ref "";; @@ -1498,9 +1453,9 @@ let search_next_error () = and e = int_of_string (Str.matched_group 4 !last_make) and msg_index = Str.match_beginning () in - last_make_index := Str.group_end 4; - (f,l,b,e, - String.sub !last_make msg_index (String.length !last_make - msg_index)) + last_make_index := Str.group_end 4; + (f,l,b,e, + String.sub !last_make msg_index (String.length !last_make - msg_index)) @@ -1508,7 +1463,7 @@ let search_next_error () = (* session creation and primitive handling *) (**********************************************************************) -let create_session () = +let create_session file = let script = Undo.undoable_view ~buffer:(GText.buffer ~tag_table:Tags.Script.table ()) @@ -1521,70 +1476,87 @@ let create_session () = GText.view ~buffer:(GText.buffer ~tag_table:Tags.Message.table ()) ~editable:false ~wrap_mode:`WORD () in - let basename = - GMisc.label ~text:"*scratch*" () in - let stack = - Stack.create () in - let legacy_av = - new analyzed_view script proof message stack in + let basename = GMisc.label ~text:(match file with + |None -> "*scratch*" + |Some f -> (Glib.Convert.filename_to_utf8 (Filename.basename f)) + ) () in + let stack = Stack.create () in + let coqtop_args = match file with + |None -> !sup_args + |Some the_file -> match !current.read_project with + |Ignore_args -> !sup_args + |Append_args -> (Project_file.args_from_project the_file !custom_project_files !current.project_file_name) + @(!sup_args) + |Subst_args -> Project_file.args_from_project the_file !custom_project_files !current.project_file_name + in + let ct = ref (Coq.spawn_coqtop coqtop_args) in + let command = new Command_windows.command_window ct current in + let legacy_av = new analyzed_view script proof message stack ct file in + let () = legacy_av#update_stats in let _ = script#buffer#create_mark ~name:"start_of_input" script#buffer#start_iter in + let _ = + script#buffer#create_mark ~name:"prev_insert" script#buffer#start_iter in let _ = proof#buffer#create_mark ~name:"end_of_conclusion" proof#buffer#start_iter in let _ = GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in + let () = + List.iter (fun (opts,_,_,_,dflt) -> setopts !ct opts dflt) print_items in + let _ = legacy_av#activate () in let _ = proof#event#connect#motion_notify ~callback: (fun e -> - let win = match proof#get_window `WIDGET with - | None -> assert false - | Some w -> w in - let x,y = Gdk.Window.get_pointer_location win in - let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in - let it = proof#get_iter_at_location ~x:b_x ~y:b_y in - let tags = it#tags in - List.iter - (fun t -> - ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter)) - tags; - false) in - script#misc#set_name "ScriptWindow"; - script#buffer#place_cursor ~where:(script#buffer#start_iter); - proof#misc#set_can_focus true; - message#misc#set_can_focus true; - script#misc#modify_font !current.text_font; - proof#misc#modify_font !current.text_font; - message#misc#modify_font !current.text_font; - { tab_label=basename; - filename=""; - script=script; - proof_view=proof; - message_view=message; - analyzed_view=legacy_av; - command_stack=stack; - encoding="" - } + let win = match proof#get_window `WIDGET with + | None -> assert false + | Some w -> w in + let x,y = Gdk.Window.get_pointer_location win in + let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in + let it = proof#get_iter_at_location ~x:b_x ~y:b_y in + let tags = it#tags in + List.iter + (fun t -> + ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter)) + tags; + false) in + script#misc#set_name "ScriptWindow"; + script#buffer#place_cursor ~where:(script#buffer#start_iter); + proof#misc#set_can_focus true; + message#misc#set_can_focus true; + script#misc#modify_font !current.text_font; + proof#misc#modify_font !current.text_font; + message#misc#modify_font !current.text_font; + { tab_label=basename; + filename=begin match file with None -> "" |Some f -> f end; + script=script; + proof_view=proof; + message_view=message; + analyzed_view=legacy_av; + encoding=""; + toplvl=ct; + command=command + } (* XXX - to be used later -let load_session session filename encs = - session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs; - session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename)); - session.filename <- filename; - session.script#buffer#set_modified false + let load_session session filename encs = + session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs; + session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename)); + session.filename <- filename; + session.script#buffer#set_modified false -let save_session session filename encs = - session.encoding <- List.find (IdeIO.save session.script#buffer filename) encs; - session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename)); - session.filename <- filename; - session.script#buffer#set_modified false + let save_session session filename encs = + session.encoding <- List.find (IdeIO.save session.script#buffer filename) encs; + session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename)); + session.filename <- filename; + session.script#buffer#set_modified false -let init_session session = - session.script#buffer#set_modified false; - session.script#clear_undo; - session.script#buffer#place_cursor session.script#buffer#start_iter - *) + let init_session session = + session.script#buffer#set_modified false; + session.script#clear_undo; + session.script#buffer#place_cursor session.script#buffer#start_iter +*) @@ -1593,93 +1565,93 @@ let init_session session = (* functions called by the user interface *) (*********************************************************************) (* XXX - to be used later -let do_open session filename = - try - load_session session filename ["UTF-8";"ISO-8859-1";"ISO-8859-15"]; - init_session session; - ignore (session_notebook#append_term session) - with _ -> () - - -let do_save session = - try - if session.script#buffer#modified then - save_session session session.filename [session.encoding] - with _ -> () - - -let choose_open = - let last_filename = ref "" in fun session -> - let open_dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Open file" ~modal:true () in - let enc_frame = GBin.frame ~label:"File encoding" ~packing:(open_dialog#vbox#pack ~fill:false) () in - let enc_entry = GEdit.entry ~text:(String.concat " " ["UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in - let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok - ~message:"Invalid encoding, please indicate the encoding to use." () in - let open_response = function - | `OPEN -> begin - match open_dialog#filename with - | Some fn -> begin - try - load_session session fn (Util.split_string_at ' ' enc_entry#text); - session.analyzed_view <- Some (new analyzed_view session); - init_session session; - session_notebook#goto_page (session_notebook#append_term session); - last_filename := fn - with - | Not_found -> open_dialog#misc#hide (); error_dialog#show () - | _ -> - error_dialog#set_markup "Unknown error while loading file, aborting."; - open_dialog#destroy (); error_dialog#destroy () - end - | None -> () - end - | `DELETE_EVENT -> open_dialog#destroy (); error_dialog#destroy () - in - let _ = open_dialog#connect#response open_response in - let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); open_dialog#show ()) in - let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in - let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in - open_dialog#add_select_button_stock `OPEN `OPEN; - open_dialog#add_button_stock `CANCEL `DELETE_EVENT; - open_dialog#add_filter filter_any; - open_dialog#add_filter filter_coq; - ignore(open_dialog#set_filename !last_filename); - open_dialog#show () - - -let choose_save session = - let save_dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save file" ~modal:true () in - let enc_frame = GBin.frame ~label:"File encoding" ~packing:(save_dialog#vbox#pack ~fill:false) () in - let enc_entry = GEdit.entry ~text:(String.concat " " [session.encoding;"UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in - let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok - ~message:"Invalid encoding, please indicate the encoding to use." () in - let save_response = function - | `SAVE -> begin - match save_dialog#filename with - | Some fn -> begin - try - save_session session fn (Util.split_string_at ' ' enc_entry#text) - with - | Not_found -> save_dialog#misc#hide (); error_dialog#show () - | _ -> - error_dialog#set_markup "Unknown error while saving file, aborting."; - save_dialog#destroy (); error_dialog#destroy () - end - | None -> () - end - | `DELETE_EVENT -> save_dialog#destroy (); error_dialog#destroy () - in - let _ = save_dialog#connect#response save_response in - let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); save_dialog#show ()) in - let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in - let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in - save_dialog#add_select_button_stock `SAVE `SAVE; - save_dialog#add_button_stock `CANCEL `DELETE_EVENT; - save_dialog#add_filter filter_any; - save_dialog#add_filter filter_coq; - ignore(save_dialog#set_filename session.filename); - save_dialog#show () - *) + let do_open session filename = + try + load_session session filename ["UTF-8";"ISO-8859-1";"ISO-8859-15"]; + init_session session; + ignore (session_notebook#append_term session) + with _ -> () + + + let do_save session = + try + if session.script#buffer#modified then + save_session session session.filename [session.encoding] + with _ -> () + + + let choose_open = + let last_filename = ref "" in fun session -> + let open_dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Open file" ~modal:true () in + let enc_frame = GBin.frame ~label:"File encoding" ~packing:(open_dialog#vbox#pack ~fill:false) () in + let enc_entry = GEdit.entry ~text:(String.concat " " ["UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in + let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok + ~message:"Invalid encoding, please indicate the encoding to use." () in + let open_response = function + | `OPEN -> begin + match open_dialog#filename with + | Some fn -> begin + try + load_session session fn (Util.split_string_at ' ' enc_entry#text); + session.analyzed_view <- Some (new analyzed_view session); + init_session session; + session_notebook#goto_page (session_notebook#append_term session); + last_filename := fn + with + | Not_found -> open_dialog#misc#hide (); error_dialog#show () + | _ -> + error_dialog#set_markup "Unknown error while loading file, aborting."; + open_dialog#destroy (); error_dialog#destroy () + end + | None -> () + end + | `DELETE_EVENT -> open_dialog#destroy (); error_dialog#destroy () + in + let _ = open_dialog#connect#response open_response in + let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); open_dialog#show ()) in + let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in + let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in + open_dialog#add_select_button_stock `OPEN `OPEN; + open_dialog#add_button_stock `CANCEL `DELETE_EVENT; + open_dialog#add_filter filter_any; + open_dialog#add_filter filter_coq; + ignore(open_dialog#set_filename !last_filename); + open_dialog#show () + + + let choose_save session = + let save_dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save file" ~modal:true () in + let enc_frame = GBin.frame ~label:"File encoding" ~packing:(save_dialog#vbox#pack ~fill:false) () in + let enc_entry = GEdit.entry ~text:(String.concat " " [session.encoding;"UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in + let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok + ~message:"Invalid encoding, please indicate the encoding to use." () in + let save_response = function + | `SAVE -> begin + match save_dialog#filename with + | Some fn -> begin + try + save_session session fn (Util.split_string_at ' ' enc_entry#text) + with + | Not_found -> save_dialog#misc#hide (); error_dialog#show () + | _ -> + error_dialog#set_markup "Unknown error while saving file, aborting."; + save_dialog#destroy (); error_dialog#destroy () + end + | None -> () + end + | `DELETE_EVENT -> save_dialog#destroy (); error_dialog#destroy () + in + let _ = save_dialog#connect#response save_response in + let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); save_dialog#show ()) in + let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in + let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in + save_dialog#add_select_button_stock `SAVE `SAVE; + save_dialog#add_button_stock `CANCEL `DELETE_EVENT; + save_dialog#add_filter filter_any; + save_dialog#add_filter filter_coq; + ignore(save_dialog#set_filename session.filename); + save_dialog#show () +*) (* Nota: using && here has the advantage of working both under win32 and unix. If someday we want the main command to be tried even if the "cd" has failed, @@ -1691,36 +1663,147 @@ let local_cd file = let do_print session = let av = session.analyzed_view in - match av#filename with - |None -> flash_info "Cannot print: this buffer has no name" - |Some f_name -> begin - let cmd = - local_cd session.filename ^ - !current.cmd_coqdoc ^ " --coqlib_path " ^ Envars.coqlib () ^ - " -ps " ^ Filename.quote (Filename.basename f_name) ^ - " | " ^ !current.cmd_print - in - let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () in - let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in - let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in - let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in - let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in - let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in - let print_button = GButton.button ~stock:`PRINT ~label:"Print" ~packing:hbox_print#add () in - let callback_print () = - let cmd = print_entry#text in - let s,_ = run_command av#insert_message cmd in - flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed"); - print_window#destroy () - in - ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ; - ignore (print_button#connect#clicked ~callback:callback_print); - print_window#misc#show () + match av#filename with + |None -> flash_info "Cannot print: this buffer has no name" + |Some f_name -> begin + let cmd = + local_cd f_name ^ + !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename f_name) ^ + " | " ^ !current.cmd_print + in + let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () in + let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in + let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in + let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in + let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in + let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in + let print_button = GButton.button ~stock:`PRINT ~label:"Print" ~packing:hbox_print#add () in + let callback_print () = + let cmd = print_entry#text in + let s,_ = run_command av#insert_message cmd in + flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed"); + print_window#destroy () + in + ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ; + ignore (print_button#connect#clicked ~callback:callback_print); + print_window#misc#show () + end + +let load_file handler f = + let f = absolute_filename f in + try + prerr_endline "Loading file starts"; + let is_f = Minilib.same_file f in + if not (Minilib.list_fold_left_i + (fun i found x -> if found then found else + let {analyzed_view=av} = x in + (match av#filename with + | None -> false + | Some fn -> + if is_f fn + then (session_notebook#goto_page i; true) + else false)) + 0 false session_notebook#pages) + then begin + prerr_endline "Loading: must open"; + let b = Buffer.create 1024 in + prerr_endline "Loading: get raw content"; + with_file handler f ~f:(input_channel b); + prerr_endline "Loading: convert content"; + let s = do_convert (Buffer.contents b) in + prerr_endline "Loading: create view"; + let session = create_session (Some f) in + prerr_endline "Loading: adding view"; + let index = session_notebook#append_term session in + let av = session.analyzed_view in + prerr_endline "Loading: stats"; + av#update_stats; + let input_buffer = session.script#buffer in + prerr_endline "Loading: fill buffer"; + input_buffer#set_text s; + input_buffer#place_cursor ~where:input_buffer#start_iter; + force_retag input_buffer; + prerr_endline ("Loading: switch to view "^ string_of_int index); + session_notebook#goto_page index; + prerr_endline "Loading: highlight"; + input_buffer#set_modified false; + prerr_endline "Loading: clear undo"; + session.script#clear_undo; + prerr_endline "Loading: success" + end + with + | e -> handler ("Load failed: "^(Printexc.to_string e)) + +let do_load = load_file flash_info + +let saveall_f () = + List.iter + (function + | {script = view ; analyzed_view = av} -> + begin match av#filename with + | None -> () + | Some f -> + ignore (av#save f) + end + ) session_notebook#pages + +let forbid_quit_to_save () = + begin try save_pref() with e -> flash_info "Cannot save preferences" end; + (if List.exists + (function + | {script=view} -> view#buffer#modified + ) + session_notebook#pages then + match (GToolbox.question_box ~title:"Quit" + ~buttons:["Save Named Buffers and Quit"; + "Quit without Saving"; + "Don't Quit"] + ~default:0 + ~icon: + (let img = GMisc.image () in + img#set_stock `DIALOG_WARNING; + img#set_icon_size `DIALOG; + img#coerce) + "There are unsaved buffers" + ) + with 1 -> saveall_f () ; false + | 2 -> false + | _ -> true + else false)|| + (let wait_window = + GWindow.window ~modal:true ~wm_class:"CoqIde" ~wm_name:"CoqIde" ~kind:`POPUP + ~title:"Terminating coqtops" () in + let _ = + GMisc.label ~text:"Terminating coqtops processes, please wait ..." + ~packing:wait_window#add () in + let warning_window = + GWindow.message_dialog ~message_type:`WARNING ~buttons:GWindow.Buttons.yes_no + ~message: + ("Some coqtops processes are still running.\n" ^ + "If you quit CoqIDE right now, you may have to kill them manually.\n" ^ + "Do you want to wait for those processes to terminate ?") () in + let () = List.iter (fun _ -> session_notebook#remove_page 0) session_notebook#pages in + let nb_try=ref (0) in + let () = wait_window#show () in + let () = while (Coq.coqtop_zombies () <> 0)&&(!nb_try <= 50) do + incr nb_try; + Thread.delay 0.1 ; + done in + if (!nb_try = 50) then begin + wait_window#misc#hide (); + match warning_window#run () with + | `YES -> warning_window#misc#hide (); true + | `NO | `DELETE_EVENT -> false end + else false) let main files = (* Statup preferences *) - load_pref (); + begin + try load_pref () + with e -> + flash_info ("Could not load preferences ("^Printexc.to_string e^")."); + end; (* Main window *) let w = GWindow.window @@ -1729,1626 +1812,1152 @@ let main files = ~width:!current.window_width ~height:!current.window_height ~title:"CoqIde" () in - (try - let icon_image = lib_ide_file "coq.png" in - let icon = GdkPixbuf.from_file icon_image in - w#set_icon (Some icon) - with _ -> ()); + (try + let icon_image = Filename.concat (List.find + (fun x -> Sys.file_exists (Filename.concat x "coq.png")) + Minilib.xdg_data_dirs) "coq.png" in + let icon = GdkPixbuf.from_file icon_image in + w#set_icon (Some icon) + with _ -> ()); - let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in + let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in + let new_f _ = + match select_file_for_save ~title:"Create file" () with + | None -> () + | Some f -> do_load f + in + let load_f _ = + match select_file_for_open ~title:"Load file" () with + | None -> () + | Some f -> do_load f + in + let save_f _ = + let current = session_notebook#current_term in + try + (match current.analyzed_view#filename with + | None -> + begin match select_file_for_save ~title:"Save file" () + with + | None -> () + | Some f -> + if current.analyzed_view#save_as f then begin + current.tab_label#set_text (Filename.basename f); + flash_info ("File " ^ f ^ " saved") + end + else warning ("Save Failed (check if " ^ f ^ " is writable)") + end + | Some f -> + if current.analyzed_view#save f then + flash_info ("File " ^ f ^ " saved") + else warning ("Save Failed (check if " ^ f ^ " is writable)") - (* Menu bar *) - let menubar = GMenu.menu_bar ~packing:vbox#pack () in + ) + with + | e -> warning "Save: unexpected error" + in + let saveas_f _ = + let current = session_notebook#current_term in + try (match current.analyzed_view#filename with + | None -> + begin match select_file_for_save ~title:"Save file as" () + with + | None -> () + | Some f -> + if current.analyzed_view#save_as f then begin + current.tab_label#set_text (Filename.basename f); + flash_info "Saved" + end + else flash_info "Save Failed" + end + | Some f -> + begin match select_file_for_save + ~dir:(ref (Filename.dirname f)) + ~filename:(Filename.basename f) + ~title:"Save file as" () + with + | None -> () + | Some f -> + if current.analyzed_view#save_as f then begin + current.tab_label#set_text (Filename.basename f); + flash_info "Saved" + end else flash_info "Save Failed" + end); + with e -> flash_info "Save Failed" + in + let revert_f {analyzed_view = av} = + (try + match av#filename,av#stats with + | Some f,Some stats -> + let new_stats = Unix.stat f in + if new_stats.Unix.st_mtime > stats.Unix.st_mtime + then av#revert + | Some _, None -> av#revert + | _ -> () + with _ -> av#revert) + in + let export_f kind _ = + let v = session_notebook#current_term in + let av = v.analyzed_view in + match av#filename with + | None -> + flash_info "Cannot print: this buffer has no name" + | Some f -> + let basef = Filename.basename f in + let output = + let basef_we = try Filename.chop_extension basef with _ -> basef in + match kind with + | "latex" -> basef_we ^ ".tex" + | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind + | _ -> assert false + in + let cmd = + local_cd f ^ !current.cmd_coqdoc ^ " --" ^ kind ^ + " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) + in + let s,_ = run_command av#insert_message cmd in + flash_info (cmd ^ + if s = Unix.WEXITED 0 + then " succeeded" + else " failed") + in + let quit_f _ = if not (forbid_quit_to_save ()) then exit 0 in + let get_active_view_for_cp () = + let has_sel (i0,i1) = i0#compare i1 <> 0 in + let current = session_notebook#current_term in + if has_sel current.script#buffer#selection_bounds + then current.script#as_view + else if has_sel current.proof_view#buffer#selection_bounds + then current.proof_view#as_view + else current.message_view#as_view + in + (* + let toggle_auto_complete_i = + edit_f#add_check_item "_Auto Completion" + ~active:!current.auto_complete + ~callback: + in + *) + (* + auto_complete := + (fun b -> match session_notebook#current_term.analyzed_view with + | Some av -> av#set_auto_complete b + | None -> ()); + *) + +(* begin of find/replace mechanism *) + let last_found = ref None in + let search_backward = ref false in + let find_w = GWindow.window + (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *) + (* ~allow_grow:true ~allow_shrink:true *) + (* ~width:!current.window_width ~height:!current.window_height *) + ~position:`CENTER + ~title:"CoqIde search/replace" () + in + let find_box = GPack.table + ~columns:3 ~rows:5 + ~col_spacings:10 ~row_spacings:10 ~border_width:10 + ~homogeneous:false ~packing:find_w#add () in - (* Toolbar *) - let toolbar = GButton.toolbar - ~orientation:`HORIZONTAL - ~style:`ICONS - ~tooltips:true - ~packing:(* handle#add *) - (vbox#pack ~expand:false ~fill:false) + let _ = + GMisc.label ~text:"Find:" + ~xalign:1.0 + ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () + in + let find_entry = GEdit.entry + ~editable: true + ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X) + () + in + let _ = + GMisc.label ~text:"Replace with:" + ~xalign:1.0 + ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () + in + let replace_entry = GEdit.entry + ~editable: true + ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X) + () + in + (* let _ = + GButton.check_button + ~label:"case sensitive" + ~active:true + ~packing: (find_box#attach ~left:1 ~top:2) + () + in + *) + let find_backwards_check = + GButton.check_button + ~label:"search backwards" + ~active:!search_backward + ~packing: (find_box#attach ~left:1 ~top:3) + () + in + let close_find_button = + GButton.button + ~label:"Close" + ~packing: (find_box#attach ~left:2 ~top:2) + () + in + let replace_find_button = + GButton.button + ~label:"Replace and find" + ~packing: (find_box#attach ~left:2 ~top:1) () + in + let find_again_button = + GButton.button + ~label:"_Find again" + ~packing: (find_box#attach ~left:2 ~top:0) + () + in + let last_find () = + let v = session_notebook#current_term.script in + let b = v#buffer in + let start,stop = + match !last_found with + | None -> let i = b#get_iter_at_mark `INSERT in (i,i) + | Some(start,stop) -> + let start = b#get_iter_at_mark start + and stop = b#get_iter_at_mark stop + in + b#remove_tag Tags.Script.found ~start ~stop; + last_found:=None; + start,stop in - show_toolbar := - (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); - - let factory = new GMenu.factory ~accel_path:"/" menubar in - let accel_group = factory#accel_group in - - (* File Menu *) - let file_menu = factory#add_submenu "_File" in - - let file_factory = new GMenu.factory ~accel_path:"/File/" file_menu ~accel_group in - - (* File/Load Menu *) - let load_file handler f = - let f = absolute_filename f in - try - prerr_endline "Loading file starts"; - if not (Util.list_fold_left_i - (fun i found x -> if found then found else - let {analyzed_view=av} = x in - (match av#filename with - | None -> false - | Some fn -> - if same_file f fn - then (session_notebook#goto_page i; true) - else false)) - 0 false session_notebook#pages) - then begin - prerr_endline "Loading: must open"; - let b = Buffer.create 1024 in - prerr_endline "Loading: get raw content"; - with_file handler f ~f:(input_channel b); - prerr_endline "Loading: convert content"; - let s = do_convert (Buffer.contents b) in - prerr_endline "Loading: create view"; - let session = create_session () in - session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename f)); - prerr_endline "Loading: adding view"; - let index = session_notebook#append_term session in - let av = session.analyzed_view in - prerr_endline "Loading: set filename"; - av#set_filename (Some f); - prerr_endline "Loading: stats"; - av#update_stats; - let input_buffer = session.script#buffer in - prerr_endline "Loading: fill buffer"; - input_buffer#set_text s; - input_buffer#place_cursor input_buffer#start_iter; - prerr_endline ("Loading: switch to view "^ string_of_int index); - session_notebook#goto_page index; - prerr_endline "Loading: highlight"; - input_buffer#set_modified false; - prerr_endline "Loading: clear undo"; - session.script#clear_undo; - prerr_endline "Loading: success" - end - with - | e -> handler ("Load failed: "^(Printexc.to_string e)) - in - let load f = load_file flash_info f in - let load_m = file_factory#add_item "_New" - ~key:GdkKeysyms._N in - let load_f () = - match select_file_for_save ~title:"Create file" () with - | None -> () - | Some f -> load f - in - ignore (load_m#connect#activate (load_f)); - - let load_m = file_factory#add_item "_Open" - ~key:GdkKeysyms._O in - let load_f () = - match select_file_for_open ~title:"Load file" () with - | None -> () - | Some f -> load f - in - ignore (load_m#connect#activate (load_f)); - - (* File/Save Menu *) - let save_m = file_factory#add_item "_Save" - ~key:GdkKeysyms._S in - let save_f () = - let current = session_notebook#current_term in - try - (match current.analyzed_view#filename with - | None -> - begin match select_file_for_save ~title:"Save file" () - with - | None -> () - | Some f -> - if current.analyzed_view#save_as f then begin - current.tab_label#set_text (Filename.basename f); - flash_info ("File " ^ f ^ " saved") - end - else warning ("Save Failed (check if " ^ f ^ " is writable)") - end - | Some f -> - if current.analyzed_view#save f then - flash_info ("File " ^ f ^ " saved") - else warning ("Save Failed (check if " ^ f ^ " is writable)") - - ) - with - | e -> warning "Save: unexpected error" + (v,b,start,stop) + in + let do_replace () = + let v = session_notebook#current_term.script in + let b = v#buffer in + match !last_found with + | None -> () + | Some(start,stop) -> + let start = b#get_iter_at_mark start + and stop = b#get_iter_at_mark stop + in + b#delete ~start ~stop; + b#insert ~iter:start replace_entry#text; + last_found:=None + in + let find_from (v : Undo.undoable_view) + (b : GText.buffer) (starti : GText.iter) text = + prerr_endline ("Searching for " ^ text); + match (if !search_backward then starti#backward_search text + else starti#forward_search text) + with + | None -> () + | Some(start,stop) -> + b#apply_tag Tags.Script.found ~start ~stop; + let start = `MARK (b#create_mark start) + and stop = `MARK (b#create_mark stop) in - ignore (save_m#connect#activate save_f); + v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25 + stop; + last_found := Some(start,stop) + in + let do_find () = + let (v,b,starti,_) = last_find () in + find_from v b starti find_entry#text + in + let do_replace_find () = + do_replace(); + do_find() + in + let close_find () = + let (v,b,_,stop) = last_find () in + b#place_cursor ~where:stop; + find_w#misc#hide(); + v#coerce#misc#grab_focus() + in + to_do_on_page_switch := + (fun i -> if find_w#misc#visible then close_find()):: + !to_do_on_page_switch; + let find_again () = + let (v,b,start,_) = last_find () in + let start = + if !search_backward + then start#backward_chars 1 + else start#forward_chars 1 + in + find_from v b start find_entry#text + in + let click_on_backward () = + search_backward := not !search_backward + in + let key_find ev = + let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in + if k = GdkKeysyms._Escape then + begin + let (v,b,_,stop) = last_find () in + find_w#misc#hide(); + v#coerce#misc#grab_focus(); + true + end + else if k = GdkKeysyms._Escape then + begin + close_find(); + true + end + else if k = GdkKeysyms._Return || + List.mem `CONTROL s && k = GdkKeysyms._f then + begin + find_again (); + true + end + else if List.mem `CONTROL s && k = GdkKeysyms._b then + begin + find_backwards_check#set_active (not !search_backward); + true + end + else false (* to let default callback execute *) + in + let find_f ~backward () = + let save_dir = !search_backward in + search_backward := backward; + find_w#show (); + find_w#present (); + find_entry#misc#grab_focus (); + search_backward := save_dir + in + let _ = find_again_button#connect#clicked find_again in + let _ = close_find_button#connect#clicked close_find in + let _ = replace_find_button#connect#clicked do_replace_find in + let _ = find_backwards_check#connect#clicked click_on_backward in + let _ = find_entry#connect#changed do_find in + let _ = find_entry#event#connect#key_press ~callback:key_find in + let _ = find_w#event#connect#delete ~callback:(fun _ -> find_w#misc#hide(); true) in + (* + let search_if = edit_f#add_item "Search _forward" + ~key:GdkKeysyms._greater + in + let search_ib = edit_f#add_item "Search _backward" + ~key:GdkKeysyms._less + in + *) + (* + let complete_i = edit_f#add_item "_Complete" + ~key:GdkKeysyms._comma + ~callback: + (do_if_not_computing + (fun b -> + let v = session_notebook#current_term.analyzed_view + + in v#complete_at_offset + ((v#view#buffer#get_iter `SEL_BOUND)#offset) + )) + in + complete_i#misc#set_state `INSENSITIVE; + *) +(* end of find/replace mechanism *) +(* begin Preferences *) + let reset_revert_timer () = + disconnect_revert_timer (); + if !current.global_auto_revert then + revert_timer := Some + (GMain.Timeout.add ~ms:!current.global_auto_revert_delay + ~callback: + (fun () -> + do_if_not_computing "revert" (sync revert_f) session_notebook#pages; + true)) + in reset_revert_timer (); (* to enable statup preferences timer *) + (* XXX *) + let auto_save_f {analyzed_view = av} = + (try + av#auto_save + with _ -> ()) + in - (* File/Save As Menu *) - let saveas_m = file_factory#add_item "S_ave as" - in - let saveas_f () = - let current = session_notebook#current_term in - try (match current.analyzed_view#filename with - | None -> - begin match select_file_for_save ~title:"Save file as" () - with - | None -> () - | Some f -> - if current.analyzed_view#save_as f then begin - current.tab_label#set_text (Filename.basename f); - flash_info "Saved" - end - else flash_info "Save Failed" - end - | Some f -> - begin match select_file_for_save - ~dir:(ref (Filename.dirname f)) - ~filename:(Filename.basename f) - ~title:"Save file as" () - with - | None -> () - | Some f -> - if current.analyzed_view#save_as f then begin - current.tab_label#set_text (Filename.basename f); - flash_info "Saved" - end else flash_info "Save Failed" - end); - with e -> flash_info "Save Failed" - in - ignore (saveas_m#connect#activate saveas_f); - (* XXX *) - (* File/Save All Menu *) - let saveall_m = file_factory#add_item "Sa_ve all" in - let saveall_f () = - List.iter - (function - | {script = view ; analyzed_view = av} -> - begin match av#filename with - | None -> () - | Some f -> - ignore (av#save f) - end - ) session_notebook#pages - in - (* XXX *) - let has_something_to_save () = - List.exists - (function - | {script=view} -> view#buffer#modified - ) - session_notebook#pages - in - ignore (saveall_m#connect#activate saveall_f); - (* XXX *) - (* File/Revert Menu *) - let revert_m = file_factory#add_item "_Revert all buffers" in - let revert_f () = - List.iter - (function - {analyzed_view = av} -> - (try - match av#filename,av#stats with - | Some f,Some stats -> - let new_stats = Unix.stat f in - if new_stats.Unix.st_mtime > stats.Unix.st_mtime - then av#revert - | Some _, None -> av#revert - | _ -> () - with _ -> av#revert) - ) session_notebook#pages - in - ignore (revert_m#connect#activate revert_f); - - (* File/Close Menu *) - let close_m = - file_factory#add_item "_Close buffer" ~key:GdkKeysyms._W in - let close_f () = - let v = !active_view in - let act = session_notebook#current_page in - if v = act then flash_info "Cannot close an active view" - else remove_current_view_page () - in - ignore (close_m#connect#activate close_f); - - (* File/Print Menu *) - let _ = file_factory#add_item "_Print..." - ~key:GdkKeysyms._P - ~callback:(fun () -> do_print session_notebook#current_term) in - - (* File/Export to Menu *) - let export_f kind () = - let v = session_notebook#current_term in - let av = v.analyzed_view in - match av#filename with - | None -> - flash_info "Cannot print: this buffer has no name" - | Some f -> - let basef = Filename.basename f in - let output = - let basef_we = try Filename.chop_extension basef with _ -> basef in - match kind with - | "latex" -> basef_we ^ ".tex" - | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind - | _ -> assert false - in - let cmd = - local_cd f ^ - !current.cmd_coqdoc ^ " --coqlib_path " ^ - Envars.coqlib () ^ " --" ^ kind ^ - " -o " ^ (Filename.quote output) ^ " " ^ - (Filename.quote basef) - in - let s,_ = run_command av#insert_message cmd in - flash_info (cmd ^ - if s = Unix.WEXITED 0 - then " succeeded" - else " failed") - in - let file_export_m = file_factory#add_submenu "E_xport to" in - - let file_export_factory = new GMenu.factory ~accel_path:"/Export/" file_export_m ~accel_group in - let _ = - file_export_factory#add_item "_Html" ~callback:(export_f "html") - in - let _ = - file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex") - in - let _ = - file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") - in - let _ = - file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf") - in - let _ = - file_export_factory#add_item "_Ps" ~callback:(export_f "ps") - in - - (* File/Rehighlight Menu *) - let rehighlight_m = file_factory#add_item "Reh_ighlight" ~key:GdkKeysyms._L in - ignore (rehighlight_m#connect#activate - (fun () -> - force_retag - session_notebook#current_term.script#buffer; - session_notebook#current_term.analyzed_view#recenter_insert)); - - (* File/Quit Menu *) - let quit_f () = - save_pref(); - if has_something_to_save () then - match (GToolbox.question_box ~title:"Quit" - ~buttons:["Save Named Buffers and Quit"; - "Quit without Saving"; - "Don't Quit"] - ~default:0 - ~icon: - (let img = GMisc.image () in - img#set_stock `DIALOG_WARNING; - img#set_icon_size `DIALOG; - img#coerce) - "There are unsaved buffers" - ) - with 1 -> saveall_f () ; exit 0 - | 2 -> exit 0 - | _ -> () - else exit 0 - in - let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q - ~callback:quit_f - in - ignore (w#event#connect#delete (fun _ -> quit_f (); true)); - - (* Edit Menu *) - let edit_menu = factory#add_submenu "_Edit" in - let edit_f = new GMenu.factory ~accel_path:"/Edit/" edit_menu ~accel_group in - ignore(edit_f#add_item "_Undo" ~key:GdkKeysyms._u ~callback: - (do_if_not_computing "undo" - (fun () -> - ignore (session_notebook#current_term.analyzed_view# - without_auto_complete - (fun () -> session_notebook#current_term.script#undo) ())))); - ignore(edit_f#add_item "_Clear Undo Stack" - (* ~key:GdkKeysyms._exclam *) - ~callback: - (fun () -> - ignore session_notebook#current_term.script#clear_undo)); - ignore(edit_f#add_separator ()); - let get_active_view_for_cp () = - let has_sel (i0,i1) = i0#compare i1 <> 0 in - let current = session_notebook#current_term in - if has_sel current.script#buffer#selection_bounds - then current.script#as_view - else if has_sel current.proof_view#buffer#selection_bounds - then current.proof_view#as_view - else current.message_view#as_view - in - ignore(edit_f#add_item "Cut" ~key:GdkKeysyms._X ~callback: - (fun () -> GtkSignal.emit_unit - (get_active_view_for_cp ()) - GtkText.View.S.cut_clipboard - )); - ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback: - (fun () -> GtkSignal.emit_unit - (get_active_view_for_cp ()) - GtkText.View.S.copy_clipboard)); - ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback: - (fun () -> - try GtkSignal.emit_unit - session_notebook#current_term.script#as_view - GtkText.View.S.paste_clipboard - with _ -> prerr_endline "EMIT PASTE FAILED")); - ignore (edit_f#add_separator ()); - - - (* - let toggle_auto_complete_i = - edit_f#add_check_item "_Auto Completion" - ~active:!current.auto_complete - ~callback: - in - *) - (* - auto_complete := - (fun b -> match session_notebook#current_term.analyzed_view with - | Some av -> av#set_auto_complete b - | None -> ()); - *) - - let last_found = ref None in - let search_backward = ref false in - let find_w = GWindow.window - (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *) - (* ~allow_grow:true ~allow_shrink:true *) - (* ~width:!current.window_width ~height:!current.window_height *) + let reset_auto_save_timer () = + disconnect_auto_save_timer (); + if !current.auto_save then + auto_save_timer := Some + (GMain.Timeout.add ~ms:!current.auto_save_delay + ~callback: + (fun () -> + do_if_not_computing "autosave" (sync auto_save_f) session_notebook#pages; + true)) + in reset_auto_save_timer (); (* to enable statup preferences timer *) +(* end Preferences *) + let do_or_activate f () = + do_if_not_computing "do_or_activate" + (fun current -> + let av = current.analyzed_view in + ignore (f av); + pop_info (); + let msg = match Coq.status !(current.toplvl) with + | Interface.Fail (l, str) -> + "Oops, problem while fetching coq status." + | Interface.Good status -> + let path = match status.Interface.status_path with + | None -> "" + | Some p -> " in " ^ p + in + let name = match status.Interface.status_proofname with + | None -> "" + | Some n -> ", proving " ^ n + in + "Ready" ^ path ^ name + in + push_info msg + ) + [session_notebook#current_term] + in + let do_if_active f _ = + do_if_not_computing "do_if_active" + (fun sess -> ignore (f sess.analyzed_view)) + [session_notebook#current_term] in + let match_callback _ = + let w = get_current_word () in + let cur_ct = !(session_notebook#current_term.toplvl) in + try + match Coq.mkcases cur_ct w with + | Interface.Fail _ -> raise Not_found + | Interface.Good cases -> + let print_branch c l = + Format.fprintf c " | @[%a@]=> _@\n" + (print_list (fun c s -> Format.fprintf c "%s@ " s)) l + in + let b = Buffer.create 1024 in + let fmt = Format.formatter_of_buffer b in + Format.fprintf fmt "@[match var with@\n%aend@]@." + (print_list print_branch) cases; + let s = Buffer.contents b in + prerr_endline s; + let {script = view } = session_notebook#current_term in + ignore (view#buffer#delete_selection ()); + let m = view#buffer#create_mark + (view#buffer#get_iter `INSERT) + in + if view#buffer#insert_interactive s then + let i = view#buffer#get_iter (`MARK m) in + let _ = i#nocopy#forward_chars 9 in + view#buffer#place_cursor ~where:i; + view#buffer#move_mark ~where:(i#backward_chars 3) + `SEL_BOUND + with Not_found -> flash_info "Not an inductive type" + in +(* External command callback *) + let compile_f _ = + let v = session_notebook#current_term in + let av = v.analyzed_view in + save_f (); + match av#filename with + | None -> + flash_info "Active buffer has no name" + | Some f -> + let cmd = !current.cmd_coqc ^ " -I " + ^ (Filename.quote (Filename.dirname f)) + ^ " " ^ (Filename.quote f) in + let s,res = run_command av#insert_message cmd in + if s = Unix.WEXITED 0 then + flash_info (f ^ " successfully compiled") + else begin + flash_info (f ^ " failed to compile"); + av#process_until_end_or_error; + av#insert_message "Compilation output:\n"; + av#insert_message res + end + in + let make_f _ = + let v = session_notebook#current_term in + let av = v.analyzed_view in + match av#filename with + | None -> + flash_info "Cannot make: this buffer has no name" + | Some f -> + let cmd = local_cd f ^ !current.cmd_make in + + (* + save_f (); + *) + av#insert_message "Command output:\n"; + let s,res = run_command av#insert_message cmd in + last_make := res; + last_make_index := 0; + flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") + in + let next_error _ = + try + let file,line,start,stop,error_msg = search_next_error () in + do_load file; + let v = session_notebook#current_term in + let av = v.analyzed_view in + let input_buffer = v.script#buffer in + (* + let init = input_buffer#start_iter in + let i = init#forward_lines (line-1) in + *) + (* + let convert_pos = byte_offset_to_char_offset phrase in + let start = convert_pos start in + let stop = convert_pos stop in + *) + (* + let starti = i#forward_chars start in + let stopi = i#forward_chars stop in + *) + let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in + let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in + input_buffer#apply_tag Tags.Script.error + ~start:starti + ~stop:stopi; + input_buffer#place_cursor ~where:starti; + av#set_message error_msg; + v.script#misc#grab_focus () + with Not_found -> + last_make_index := 0; + let v = session_notebook#current_term in + let av = v.analyzed_view in + av#set_message "No more errors.\n" + in + let coq_makefile_f _ = + let v = session_notebook#current_term in + let av = v.analyzed_view in + match av#filename with + | None -> + flash_info "Cannot make makefile: this buffer has no name" + | Some f -> + let cmd = local_cd f ^ !current.cmd_coqmakefile in + let s,res = run_command av#insert_message cmd in + flash_info + (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") + in + + let file_actions = GAction.action_group ~name:"File" () in + let export_actions = GAction.action_group ~name:"Export" () in + let edit_actions = GAction.action_group ~name:"Edit" () in + let navigation_actions = GAction.action_group ~name:"Navigation" () in + let tactics_actions = GAction.action_group ~name:"Tactics" () in + let templates_actions = GAction.action_group ~name:"Templates" () in + let queries_actions = GAction.action_group ~name:"Queries" () in + let display_actions = GAction.action_group ~name:"Display" () in + let compile_actions = GAction.action_group ~name:"Compile" () in + let windows_actions = GAction.action_group ~name:"Windows" () in + let help_actions = GAction.action_group ~name:"Help" () in + let add_gen_actions menu_name act_grp l = + let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) in + let add_simple_template menu_name act_grp text = + let text' = + let l = String.length text - 1 in + if String.get text l = '.' + then text ^"\n" + else text ^" " + in + GAction.add_action (menu_name^" "^(no_under text)) ~label:text + ~callback:(fun _ -> let {script = view } = session_notebook#current_term in + ignore (view#buffer#insert_interactive text')) act_grp + in + List.iter (function + | [] -> () + | [s] -> add_simple_template menu_name act_grp s + | s::_ as ll -> let label = "_@..." in label.[1] <- s.[0]; + GAction.add_action (menu_name^" "^(String.make 1 s.[0])) ~label act_grp; + List.iter (add_simple_template menu_name act_grp) ll + ) l + in + let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s) + ~accel:(!current.modifier_for_tactics^sc) + ~callback:(do_if_active (fun a -> a#insert_command + ("progress "^s^".\n") (s^".\n"))) in + let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel + ~callback:(fun _ -> let term = get_current_word () in + session_notebook#current_term.command#new_command ~command:s ~term ()) + in let add_complex_template (name, label, text, offset, len, key) = + (* Templates/Lemma *) + let callback _ = + let {script = view } = session_notebook#current_term in + if view#buffer#insert_interactive text then begin + let iter = view#buffer#get_iter_at_mark `INSERT in + ignore (iter#nocopy#backward_chars offset); + view#buffer#move_mark `INSERT ~where:iter; + ignore (iter#nocopy#backward_chars len); + view#buffer#move_mark `SEL_BOUND ~where:iter; + end in + match key with + |Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac) + |None -> GAction.add_action name ~label ~callback ?accel:None + in + GAction.add_actions file_actions [ + GAction.add_action "File" ~label:"_File"; + GAction.add_action "New" ~callback:new_f ~stock:`NEW; + GAction.add_action "Open" ~callback:load_f ~stock:`OPEN; + GAction.add_action "Save" ~callback:save_f ~stock:`SAVE ~tooltip:"Save current buffer"; + GAction.add_action "Save as" ~label:"S_ave as" ~callback:saveas_f ~stock:`SAVE_AS; + GAction.add_action "Save all" ~label:"Sa_ve all" ~callback:(fun _ -> saveall_f ()); + GAction.add_action "Revert all buffers" ~label:"_Revert all buffers" ~callback:(fun _ -> List.iter revert_f session_notebook#pages) ~stock:`REVERT_TO_SAVED; + GAction.add_action "Close buffer" ~label:"_Close buffer" ~callback:(fun _ -> remove_current_view_page ()) ~stock:`CLOSE ~tooltip:"Close current buffer"; + GAction.add_action "Print..." ~label:"_Print..." ~callback:(fun _ -> do_print session_notebook#current_term) ~stock:`PRINT ~accel:"p"; + GAction.add_action "Rehighlight" ~label:"Reh_ighlight" ~accel:"l" + ~callback:(fun _ -> force_retag + session_notebook#current_term.script#buffer; + session_notebook#current_term.analyzed_view#recenter_insert) + ~stock:`REFRESH; + GAction.add_action "Quit" ~callback:quit_f ~stock:`QUIT; + ]; + GAction.add_actions export_actions [ + GAction.add_action "Export to" ~label:"E_xport to"; + GAction.add_action "Html" ~label:"_Html" ~callback:(export_f "html"); + GAction.add_action "Latex" ~label:"_LaTeX" ~callback:(export_f "latex"); + GAction.add_action "Dvi" ~label:"_Dvi" ~callback:(export_f "dvi"); + GAction.add_action "Pdf" ~label:"_Pdf" ~callback:(export_f "pdf"); + GAction.add_action "Ps" ~label:"_Ps" ~callback:(export_f "ps"); + ]; + GAction.add_actions edit_actions [ + GAction.add_action "Edit" ~label:"_Edit"; + GAction.add_action "Undo" ~accel:"u" + ~callback:(fun _ -> do_if_not_computing "undo" + (fun sess -> + ignore (sess.analyzed_view#without_auto_complete + (fun () -> session_notebook#current_term.script#undo) ())) + [session_notebook#current_term]) ~stock:`UNDO; + GAction.add_action "Clear Undo Stack" ~label:"_Clear Undo Stack" + ~callback:(fun _ -> ignore session_notebook#current_term.script#clear_undo); + GAction.add_action "Cut" ~callback:(fun _ -> GtkSignal.emit_unit + (get_active_view_for_cp ()) + ~sgn:GtkText.View.S.cut_clipboard + ) ~stock:`CUT; + GAction.add_action "Copy" ~callback:(fun _ -> GtkSignal.emit_unit + (get_active_view_for_cp ()) + ~sgn:GtkText.View.S.copy_clipboard) ~stock:`COPY; + GAction.add_action "Paste" ~callback:(fun _ -> + try GtkSignal.emit_unit + session_notebook#current_term.script#as_view + ~sgn:GtkText.View.S.paste_clipboard + with _ -> prerr_endline "EMIT PASTE FAILED") ~stock:`PASTE; + GAction.add_action "Find in buffer" ~label:"_Find in buffer" ~callback:(fun _ -> find_f ~backward:false ()) ~stock:`FIND; + GAction.add_action "Find backwards" ~label:"Find _backwards" ~callback:(fun _ -> find_f ~backward:true ()) ~accel:"b"; + GAction.add_action "Complete Word" ~label:"Complete Word" ~callback:(fun _ -> + ignore ( + let av = session_notebook#current_term.analyzed_view in + av#complete_at_offset (av#get_insert)#offset + )) ~accel:"slash"; + GAction.add_action "External editor" ~label:"External editor" ~callback:(fun _ -> + let av = session_notebook#current_term.analyzed_view in + match av#filename with + | None -> warning "Call to external editor available only on named files" + | Some f -> + save_f (); + let com = Minilib.subst_command_placeholder !current.cmd_editor (Filename.quote f) in + let _ = run_command av#insert_message com in + av#revert) ~stock:`EDIT; + GAction.add_action "Preferences" ~callback:(fun _ -> + begin + try configure ~apply:update_notebook_pos () + with _ -> flash_info "Cannot save preferences" + end; + reset_revert_timer ()) ~stock:`PREFERENCES; + (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; + GAction.add_actions navigation_actions [ + GAction.add_action "Navigation" ~label:"_Navigation"; + GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN + ~callback:(fun _ -> do_or_activate (fun a -> a#process_next_phrase true) ()) + ~tooltip:"Forward one command" ~accel:(!current.modifier_for_navigation^"Down"); + GAction.add_action "Backward" ~label:"_Backward" ~stock:`GO_UP + ~callback:(fun _ -> do_or_activate (fun a -> a#undo_last_step) ()) + ~tooltip:"Backward one command" ~accel:(!current.modifier_for_navigation^"Up"); + GAction.add_action "Go to" ~label:"_Go to" ~stock:`JUMP_TO + ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_insert) ()) + ~tooltip:"Go to cursor" ~accel:(!current.modifier_for_navigation^"Right"); + GAction.add_action "Start" ~label:"_Start" ~stock:`GOTO_TOP + ~callback:(fun _ -> force_reset_initial ()) + ~tooltip:"Restart coq" ~accel:(!current.modifier_for_navigation^"Home"); + GAction.add_action "End" ~label:"_End" ~stock:`GOTO_BOTTOM + ~callback:(fun _ -> do_or_activate (fun a -> a#process_until_end_or_error) ()) + ~tooltip:"Go to end" ~accel:(!current.modifier_for_navigation^"End"); + GAction.add_action "Interrupt" ~label:"_Interrupt" ~stock:`STOP + ~callback:(fun _ -> break ()) ~tooltip:"Interrupt computations" + ~accel:(!current.modifier_for_navigation^"Break"); + GAction.add_action "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE + ~callback:(fun _ -> let sess = session_notebook#current_term in + toggle_proof_visibility sess.script#buffer + sess.analyzed_view#get_insert) ~tooltip:"Hide proof" + ~accel:(!current.modifier_for_navigation^"h"); + GAction.add_action "Previous" ~label:"_Previous" ~stock:`GO_BACK + ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_prev_occ_of_cur_word) ()) + ~tooltip:"Previous occurence" ~accel:(!current.modifier_for_navigation^"less"); + GAction.add_action "Next" ~label:"_Next" ~stock:`GO_FORWARD + ~callback:(fun _ -> do_or_activate (fun a -> a#go_to_next_occ_of_cur_word) ()) + ~tooltip:"Next occurence" ~accel:(!current.modifier_for_navigation^"greater"); + ]; + GAction.add_actions tactics_actions [ + GAction.add_action "Try Tactics" ~label:"_Try Tactics"; + GAction.add_action "Wizard" ~tooltip:"Proof Wizard" ~label:"" + ~stock:`DIALOG_INFO ~callback:(do_if_active (fun a -> a#tactic_wizard + !current.automatic_tactics)) + ~accel:(!current.modifier_for_tactics^"dollar"); + tactic_shortcut "auto" "a"; + tactic_shortcut "auto with *" "asterisk"; + tactic_shortcut "eauto" "e"; + tactic_shortcut "eauto with *" "ampersand"; + tactic_shortcut "intuition" "i"; + tactic_shortcut "omega" "o"; + tactic_shortcut "simpl" "s"; + tactic_shortcut "tauto" "p"; + tactic_shortcut "trivial" "v"; + ]; + add_gen_actions "Tactic" tactics_actions Coq_commands.tactics; + GAction.add_actions templates_actions [ + GAction.add_action "Templates" ~label:"Te_mplates"; + add_complex_template + ("Lemma", "_Lemma __", "Lemma new_lemma : .\nIdeproof.\n\nSave.\n", + 19, 9, Some "L"); + add_complex_template + ("Theorem", "_Theorem __", "Theorem new_theorem : .\nIdeproof.\n\nSave.\n", + 19, 11, Some "T"); + add_complex_template + ("Definition", "_Definition __", "Definition ident := .\n", + 6, 5, Some "D"); + add_complex_template + ("Inductive", "_Inductive __", "Inductive ident : :=\n | : .\n", + 14, 5, Some "I"); + add_complex_template + ("Fixpoint", "_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", + 29, 5, Some "F"); + add_complex_template ("Scheme", "_Scheme __", + "Scheme new_scheme := Induction for _ Sort _\ +\nwith _ := Induction for _ Sort _.\n",61,10, Some "S"); + GAction.add_action "match" ~label:"match ..." ~callback:match_callback + ~accel:(!current.modifier_for_templates^"C"); + ]; + add_gen_actions "Template" templates_actions Coq_commands.commands; + GAction.add_actions queries_actions [ + GAction.add_action "Queries" ~label:"_Queries"; + query_shortcut "SearchAbout" (Some "F2"); + query_shortcut "Check" (Some "F3"); + query_shortcut "Print" (Some "F4"); + query_shortcut "About" (Some "F5"); + query_shortcut "Locate" None; + query_shortcut "Whelp Locate" None; + ]; + GAction.add_action "Display" ~label:"_Display" display_actions; + List.iter + (fun (opts,name,label,key,dflt) -> + GAction.add_toggle_action name ~active:dflt ~label + ~accel:(!current.modifier_for_display^key) + ~callback:(fun v -> do_or_activate (fun a -> + let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in + a#show_goals) ()) display_actions) + print_items; + GAction.add_actions compile_actions [ + GAction.add_action "Compile" ~label:"_Compile"; + GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f; + GAction.add_action "Make" ~label:"_Make" ~callback:make_f ~accel:"F6"; + GAction.add_action "Next error" ~label:"_Next error" ~callback:next_error + ~accel:"F7"; + GAction.add_action "Make makefile" ~label:"Make makefile" ~callback:coq_makefile_f; + ]; + GAction.add_actions windows_actions [ + GAction.add_action "Windows" ~label:"_Windows"; + GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane" + ~callback:(fun _ -> let ccw = session_notebook#current_term.command in + if ccw#frame#misc#visible + then ccw#frame#misc#hide () + else ccw#frame#misc#show ()) + ~accel:"Escape"; + GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar" + ~active:(!current.show_toolbar) ~callback: + (fun _ -> !current.show_toolbar <- not !current.show_toolbar; + !show_toolbar !current.show_toolbar); + GAction.add_action "Detach View" ~label:"Detach _View" + ~callback:(fun _ -> do_if_not_computing "detach view" + (function {script=v;analyzed_view=av} -> + let w = GWindow.window ~show:true + ~width:(!current.window_width*2/3) + ~height:(!current.window_height*2/3) ~position:`CENTER - ~title:"CoqIde search/replace" () - in - let find_box = GPack.table - ~columns:3 ~rows:5 - ~col_spacings:10 ~row_spacings:10 ~border_width:10 - ~homogeneous:false ~packing:find_w#add () in - - let _ = - GMisc.label ~text:"Find:" - ~xalign:1.0 - ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () - in - let find_entry = GEdit.entry - ~editable: true - ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X) + ~title:(match av#filename with + | None -> "*Unnamed*" + | Some f -> f) () in - let _ = - GMisc.label ~text:"Replace with:" - ~xalign:1.0 - ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () + let sb = GBin.scrolled_window + ~packing:w#add () in - let replace_entry = GEdit.entry - ~editable: true - ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X) + let nv = GText.view + ~buffer:v#buffer + ~packing:sb#add () in - (* let _ = - GButton.check_button - ~label:"case sensitive" - ~active:true - ~packing: (find_box#attach ~left:1 ~top:2) - () - - in - *) - (* - let find_backwards_check = - GButton.check_button - ~label:"search backwards" - ~active:false - ~packing: (find_box#attach ~left:1 ~top:3) - () - in - *) - let close_find_button = - GButton.button - ~label:"Close" - ~packing: (find_box#attach ~left:2 ~top:0) - () - in - let replace_button = - GButton.button - ~label:"Replace" - ~packing: (find_box#attach ~left:2 ~top:1) - () - in - let replace_find_button = - GButton.button - ~label:"Replace and find" - ~packing: (find_box#attach ~left:2 ~top:2) - () - in - let find_again_button = - GButton.button - ~label:"_Find again" - ~packing: (find_box#attach ~left:2 ~top:3) - () - in - let find_again_backward_button = - GButton.button - ~label:"Find _backward" - ~packing: (find_box#attach ~left:2 ~top:4) - () - in - let last_find () = - let v = session_notebook#current_term.script in - let b = v#buffer in - let start,stop = - match !last_found with - | None -> let i = b#get_iter_at_mark `INSERT in (i,i) - | Some(start,stop) -> - let start = b#get_iter_at_mark start - and stop = b#get_iter_at_mark stop - in - b#remove_tag Tags.Script.found ~start ~stop; - last_found:=None; - start,stop - in - (v,b,start,stop) - in - let do_replace () = - let v = session_notebook#current_term.script in - let b = v#buffer in - match !last_found with - | None -> () - | Some(start,stop) -> - let start = b#get_iter_at_mark start - and stop = b#get_iter_at_mark stop - in - b#delete ~start ~stop; - b#insert ~iter:start replace_entry#text; - last_found:=None - in - let find_from (v : Undo.undoable_view) - (b : GText.buffer) (starti : GText.iter) text = - prerr_endline ("Searching for " ^ text); - match (if !search_backward then starti#backward_search text - else starti#forward_search text) - with - | None -> () - | Some(start,stop) -> - b#apply_tag Tags.Script.found ~start ~stop; - let start = `MARK (b#create_mark start) - and stop = `MARK (b#create_mark stop) - in - v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25 - stop; - last_found := Some(start,stop) - in - let do_find () = - let (v,b,starti,_) = last_find () in - find_from v b starti find_entry#text - in - let do_replace_find () = - do_replace(); - do_find() - in - let close_find () = - let (v,b,_,stop) = last_find () in - b#place_cursor stop; - find_w#misc#hide(); - v#coerce#misc#grab_focus() - in - to_do_on_page_switch := - (fun i -> if find_w#misc#visible then close_find()):: - !to_do_on_page_switch; - let find_again_forward () = - search_backward := false; - let (v,b,start,_) = last_find () in - let start = start#forward_chars 1 in - find_from v b start find_entry#text - in - let find_again_backward () = - search_backward := true; - let (v,b,start,_) = last_find () in - let start = start#backward_chars 1 in - find_from v b start find_entry#text - in - let key_find ev = - let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in - if k = GdkKeysyms._Escape then - begin - let (v,b,_,stop) = last_find () in - find_w#misc#hide(); - v#coerce#misc#grab_focus(); - true - end - else if k = GdkKeysyms._Return then - begin - close_find(); - true - end - else if List.mem `CONTROL s && k = GdkKeysyms._f then - begin - find_again_forward (); - true - end - else if List.mem `CONTROL s && k = GdkKeysyms._b then - begin - find_again_backward (); - true - end - else false (* to let default callback execute *) - in - let find_f ~backward () = - search_backward := backward; - find_w#show (); - find_w#present (); - find_entry#misc#grab_focus () - in - let _ = edit_f#add_item "_Find in buffer" - ~key:GdkKeysyms._F - ~callback:(find_f ~backward:false) - in - let _ = edit_f#add_item "Find _backwards" - ~key:GdkKeysyms._B - ~callback:(find_f ~backward:true) - in - let _ = close_find_button#connect#clicked close_find in - let _ = replace_button#connect#clicked do_replace in - let _ = replace_find_button#connect#clicked do_replace_find in - let _ = find_again_button#connect#clicked find_again_forward in - let _ = find_again_backward_button#connect#clicked find_again_backward in - let _ = find_entry#connect#changed do_find in - let _ = find_entry#event#connect#key_press ~callback:key_find in - let _ = find_w#event#connect#delete (fun _ -> find_w#misc#hide(); true) in - (* - let search_if = edit_f#add_item "Search _forward" - ~key:GdkKeysyms._greater - in - let search_ib = edit_f#add_item "Search _backward" - ~key:GdkKeysyms._less - in - *) - (* - let complete_i = edit_f#add_item "_Complete" - ~key:GdkKeysyms._comma - ~callback: - (do_if_not_computing - (fun b -> - let v = session_notebook#current_term.analyzed_view - - in v#complete_at_offset - ((v#view#buffer#get_iter `SEL_BOUND)#offset) - )) - in - complete_i#misc#set_state `INSENSITIVE; - *) - - ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback: - (fun () -> - ignore ( - let av = session_notebook#current_term.analyzed_view in - av#complete_at_offset (av#get_insert)#offset - ))); - - ignore(edit_f#add_separator ()); - (* external editor *) - let _ = - edit_f#add_item "External editor" ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in - match av#filename with - | None -> warning "Call to external editor available only on named files" - | Some f -> - save_f (); - let com = Flags.subst_command_placeholder !current.cmd_editor (Filename.quote f) in - let _ = run_command av#insert_message com in - av#revert) - in - let _ = edit_f#add_separator () in - (* Preferences *) - let reset_revert_timer () = - disconnect_revert_timer (); - if !current.global_auto_revert then - revert_timer := Some - (GMain.Timeout.add ~ms:!current.global_auto_revert_delay - ~callback: - (fun () -> - do_if_not_computing "revert" (sync revert_f) (); - true)) - in reset_revert_timer (); (* to enable statup preferences timer *) - (* XXX *) - let auto_save_f () = - List.iter - (function - {script = view ; analyzed_view = av} -> - (try - av#auto_save - with _ -> ()) - ) - session_notebook#pages - in - - let reset_auto_save_timer () = - disconnect_auto_save_timer (); - if !current.auto_save then - auto_save_timer := Some - (GMain.Timeout.add ~ms:!current.auto_save_delay - ~callback: - (fun () -> - do_if_not_computing "autosave" (sync auto_save_f) (); - true)) - in reset_auto_save_timer (); (* to enable statup preferences timer *) - - - let _ = - edit_f#add_item "_Preferences" - ~callback:(fun () -> configure ~apply:update_notebook_pos (); reset_revert_timer ()) - in - (* - let save_prefs_m = - configuration_factory#add_item "_Save preferences" - ~callback:(fun () -> save_pref ()) - in - *) - (* Navigation Menu *) - let navigation_menu = factory#add_submenu "_Navigation" in - let navigation_factory = - new GMenu.factory navigation_menu - ~accel_path:"/Navigation/" - ~accel_group - ~accel_modi:!current.modifier_for_navigation - in - let _do_or_activate f () = - let current = session_notebook#current_term in - let analyzed_view = current.analyzed_view in - if analyzed_view#is_active then begin - prerr_endline ("view "^current.tab_label#text^"already active"); - ignore (f analyzed_view) - end else - begin - flash_info "New proof started"; - prerr_endline ("activating view "^current.tab_label#text); - activate_input session_notebook#current_page; - ignore (f analyzed_view) - end - in - - let do_or_activate f = - do_if_not_computing "do_or_activate" - (_do_or_activate - (fun av -> f av; - pop_info (); - push_info (Coq.current_status()) - ) - ) - in - - let add_to_menu_toolbar text ~tooltip ?key ~callback icon = - begin - match key with None -> () - | Some key -> ignore (navigation_factory#add_item text ~key ~callback) - end; - ignore (toolbar#insert_button - ~tooltip -(* ~text:tooltip*) - ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR icon) - ~callback - ()) - in - add_to_menu_toolbar - "_Save" - ~tooltip:"Save current buffer" - ~callback:save_f - `SAVE; - add_to_menu_toolbar - "_Close" - ~tooltip:"Close current buffer" - ~callback:close_f - `CLOSE; - add_to_menu_toolbar - "_Forward" - ~tooltip:"Forward one command" - ~key:GdkKeysyms._Down - ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true )) - - `GO_DOWN; - add_to_menu_toolbar "_Backward" - ~tooltip:"Backward one command" - ~key:GdkKeysyms._Up - ~callback:(do_or_activate (fun a -> a#undo_last_step)) - `GO_UP; - add_to_menu_toolbar - "_Go to" - ~tooltip:"Go to cursor" - ~key:GdkKeysyms._Right - ~callback:(do_or_activate (fun a-> a#go_to_insert)) - `JUMP_TO; - add_to_menu_toolbar - "_Start" - ~tooltip:"Go to start" - ~key:GdkKeysyms._Home - ~callback:(do_or_activate (fun a -> a#reset_initial)) - `GOTO_TOP; - add_to_menu_toolbar - "_End" - ~tooltip:"Go to end" - ~key:GdkKeysyms._End - ~callback:(do_or_activate (fun a -> a#process_until_end_or_error)) - `GOTO_BOTTOM; - add_to_menu_toolbar "_Interrupt" - ~tooltip:"Interrupt computations" - ~key:GdkKeysyms._Break - ~callback:break - `STOP; - add_to_menu_toolbar "_Hide" - ~tooltip:"Hide proof" - ~key:GdkKeysyms._h - ~callback:(fun x -> - let sess = session_notebook#current_term in - toggle_proof_visibility sess.script#buffer - sess.analyzed_view#get_insert) - `MISSING_IMAGE; - - (* Tactics Menu *) - let tactics_menu = factory#add_submenu "_Try Tactics" in - let tactics_factory = - new GMenu.factory tactics_menu - ~accel_path:"/Tactics/" - ~accel_group - ~accel_modi:!current.modifier_for_tactics - in - let do_if_active_raw f () = - let current = session_notebook#current_term in - let analyzed_view = current.analyzed_view in - if analyzed_view#is_active then ignore (f analyzed_view) - in - let do_if_active f = - do_if_not_computing "do_if_active" (do_if_active_raw f) in - - ignore (tactics_factory#add_item "_auto" - ~key:GdkKeysyms._a - ~callback:(do_if_active (fun a -> a#insert_command "progress auto.\n" "auto.\n")) - ); - ignore (tactics_factory#add_item "_auto with *" - ~key:GdkKeysyms._asterisk - ~callback:(do_if_active (fun a -> a#insert_command - "progress auto with *.\n" - "auto with *.\n"))); - ignore (tactics_factory#add_item "_eauto" - ~key:GdkKeysyms._e - ~callback:(do_if_active (fun a -> a#insert_command - "progress eauto.\n" - "eauto.\n")) - ); - ignore (tactics_factory#add_item "_eauto with *" - ~key:GdkKeysyms._ampersand - ~callback:(do_if_active (fun a -> a#insert_command - "progress eauto with *.\n" - "eauto with *.\n")) - ); - ignore (tactics_factory#add_item "_intuition" - ~key:GdkKeysyms._i - ~callback:(do_if_active (fun a -> a#insert_command - "progress intuition.\n" - "intuition.\n")) - ); - ignore (tactics_factory#add_item "_omega" - ~key:GdkKeysyms._o - ~callback:(do_if_active (fun a -> a#insert_command - "omega.\n" "omega.\n")) - ); - ignore (tactics_factory#add_item "_simpl" - ~key:GdkKeysyms._s - ~callback:(do_if_active (fun a -> a#insert_command "progress simpl.\n" "simpl.\n" )) - ); - ignore (tactics_factory#add_item "_tauto" - ~key:GdkKeysyms._p - ~callback:(do_if_active (fun a -> a#insert_command "tauto.\n" "tauto.\n" )) - ); - ignore (tactics_factory#add_item "_trivial" - ~key:GdkKeysyms._v - ~callback:(do_if_active( fun a -> a#insert_command "progress trivial.\n" "trivial.\n" )) - ); - - - ignore (toolbar#insert_button - ~tooltip:"Proof Wizard" - ~text:"Wizard" - ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR `DIALOG_INFO) - ~callback:(do_if_active (fun a -> a#tactic_wizard - !current.automatic_tactics - )) - ()); - - - - ignore (tactics_factory#add_item "" - ~key:GdkKeysyms._dollar - ~callback:(do_if_active (fun a -> a#tactic_wizard - !current.automatic_tactics - )) - ); - - ignore (tactics_factory#add_separator ()); - let add_simple_template (factory: GMenu.menu GMenu.factory) - (menu_text, text) = - let text = - let l = String.length text - 1 in - if String.get text l = '.' - then text ^"\n" - else text ^" " - in - ignore (factory#add_item menu_text - ~callback: - (fun () -> let {script = view } = session_notebook#current_term in - ignore (view#buffer#insert_interactive text))) - in - List.iter - (fun l -> - match l with - | [] -> () - | [s] -> add_simple_template tactics_factory ("_"^s, s) - | s::_ -> - let a = "_@..." in - a.[1] <- s.[0]; - let f = tactics_factory#add_submenu a in - let ff = new GMenu.factory f ~accel_group in - List.iter - (fun x -> - add_simple_template - ff - ((String.sub x 0 1)^ - "_"^ - (String.sub x 1 (String.length x - 1)), - x)) - l - ) - Coq_commands.tactics; - - (* Templates Menu *) - let templates_menu = factory#add_submenu "Te_mplates" in - let templates_factory = new GMenu.factory templates_menu - ~accel_path:"/Templates/" - ~accel_group - ~accel_modi:!current.modifier_for_templates - in - let add_complex_template (menu_text, text, offset, len, key) = - (* Templates/Lemma *) - let callback () = - let {script = view } = session_notebook#current_term in - if view#buffer#insert_interactive text then begin - let iter = view#buffer#get_iter_at_mark `INSERT in - ignore (iter#nocopy#backward_chars offset); - view#buffer#move_mark `INSERT iter; - ignore (iter#nocopy#backward_chars len); - view#buffer#move_mark `SEL_BOUND iter; - end in - ignore (templates_factory#add_item menu_text ~callback ?key) - in - add_complex_template - ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", - 19, 9, Some GdkKeysyms._L); - add_complex_template - ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", - 19, 11, Some GdkKeysyms._T); - add_complex_template - ("_Definition __", "Definition ident := .\n", - 6, 5, Some GdkKeysyms._D); - add_complex_template - ("_Inductive __", "Inductive ident : :=\n | : .\n", - 14, 5, Some GdkKeysyms._I); - add_complex_template - ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", - 29, 5, Some GdkKeysyms._F); - add_complex_template("_Scheme __", - "Scheme new_scheme := Induction for _ Sort _ -with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); - - (* Template for match *) - let callback () = - let w = get_current_word () in - try - let cases = Coq.make_cases w - in - let print c = function - | [x] -> Format.fprintf c " | %s => _@\n" x - | x::l -> Format.fprintf c " | (%s%a) => _@\n" x - (print_list (fun c s -> Format.fprintf c " %s" s)) l - | [] -> assert false - in - let b = Buffer.create 1024 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "@[match var with@\n%aend@]@." - (print_list print) cases; - let s = Buffer.contents b in - prerr_endline s; - let {script = view } = session_notebook#current_term in - ignore (view#buffer#delete_selection ()); - let m = view#buffer#create_mark - (view#buffer#get_iter `INSERT) - in - if view#buffer#insert_interactive s then - let i = view#buffer#get_iter (`MARK m) in - let _ = i#nocopy#forward_chars 9 in - view#buffer#place_cursor i; - view#buffer#move_mark ~where:(i#backward_chars 3) - `SEL_BOUND - with Not_found -> flash_info "Not an inductive type" - in - ignore (templates_factory#add_item "match ..." - ~key:GdkKeysyms._C - ~callback - ); - - (* - let add_simple_template (factory: GMenu.menu GMenu.factory) - (menu_text, text) = - let text = - let l = String.length text - 1 in - if String.get text l = '.' - then text ^"\n" - else text ^" " - in - ignore (factory#add_item menu_text - ~callback: - (fun () -> let {view = view } = session_notebook#current_term in - ignore (view#buffer#insert_interactive text))) - in - *) - ignore (templates_factory#add_separator ()); - (* - List.iter (add_simple_template templates_factory) - [ "_auto", "auto "; - "_auto with *", "auto with * "; - "_eauto", "eauto "; - "_eauto with *", "eauto with * "; - "_intuition", "intuition "; - "_omega", "omega "; - "_simpl", "simpl "; - "_tauto", "tauto "; - "tri_vial", "trivial "; - ]; - ignore (templates_factory#add_separator ()); - *) - List.iter - (fun l -> - match l with - | [] -> () - | [s] -> add_simple_template templates_factory ("_"^s, s) - | s::_ -> - let a = "_@..." in - a.[1] <- s.[0]; - let f = templates_factory#add_submenu a in - let ff = new GMenu.factory f ~accel_group in - List.iter - (fun x -> - add_simple_template - ff - ((String.sub x 0 1)^ - "_"^ - (String.sub x 1 (String.length x - 1)), - x)) - l - ) - Coq_commands.commands; - - (* Queries Menu *) - let queries_menu = factory#add_submenu "_Queries" in - let queries_factory = new GMenu.factory queries_menu ~accel_group - ~accel_path:"/Queries" - ~accel_modi:[] - in - - (* Command/Show commands *) - let _ = - queries_factory#add_item "_SearchAbout " ~key:GdkKeysyms._F2 - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"SearchAbout" - ~term - ()) - in - let _ = - queries_factory#add_item "_Check " ~key:GdkKeysyms._F3 - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"Check" - ~term - ()) - in - let _ = - queries_factory#add_item "_Print " ~key:GdkKeysyms._F4 - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"Print" - ~term - ()) - in - let _ = - queries_factory#add_item "_About " ~key:GdkKeysyms._F5 - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"About" - ~term - ()) - in - let _ = - queries_factory#add_item "_Locate" - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"Locate" - ~term - ()) - in - let _ = - queries_factory#add_item "_Whelp Locate" - ~callback:(fun () -> let term = get_current_word () in - (Command_windows.command_window ())#new_command - ~command:"Whelp Locate" - ~term - ()) - in - - (* Display menu *) - - let display_menu = factory#add_submenu "_Display" in - let view_factory = new GMenu.factory display_menu - ~accel_path:"/Display/" - ~accel_group - ~accel_modi:!current.modifier_for_display - in - - let _ = ignore (view_factory#add_check_item - "Display _implicit arguments" - ~key:GdkKeysyms._i - ~callback:(fun _ -> printing_state.printing_implicit <- not printing_state.printing_implicit; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display _coercions" - ~key:GdkKeysyms._c - ~callback:(fun _ -> printing_state.printing_coercions <- not printing_state.printing_coercions; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display raw _matching expressions" - ~key:GdkKeysyms._m - ~callback:(fun _ -> printing_state.printing_raw_matching <- not printing_state.printing_raw_matching; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Deactivate _notations display" - ~key:GdkKeysyms._n - ~callback:(fun _ -> printing_state.printing_no_notation <- not printing_state.printing_no_notation; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display _all basic low-level contents" - ~key:GdkKeysyms._a - ~callback:(fun _ -> printing_state.printing_all <- not printing_state.printing_all; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display _existential variable instances" - ~key:GdkKeysyms._e - ~callback:(fun _ -> printing_state.printing_evar_instances <- not printing_state.printing_evar_instances; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display _universe levels" - ~key:GdkKeysyms._u - ~callback:(fun _ -> printing_state.printing_universes <- not printing_state.printing_universes; do_or_activate (fun a -> a#show_goals) ())) in - - let _ = ignore (view_factory#add_check_item - "Display all _low-level contents" - ~key:GdkKeysyms._l - ~callback:(fun _ -> printing_state.printing_full_all <- not printing_state.printing_full_all; do_or_activate (fun a -> a#show_goals) ())) in - - - - (* Externals *) - let externals_menu = factory#add_submenu "_Compile" in - let externals_factory = new GMenu.factory externals_menu - ~accel_path:"/Compile/" - ~accel_group - ~accel_modi:[] - in - - (* Command/Compile Menu *) - let compile_f () = - let v = session_notebook#current_term in - let av = v.analyzed_view in - save_f (); - match av#filename with - | None -> - flash_info "Active buffer has no name" - | Some f -> - let cmd = !current.cmd_coqc ^ " -I " - ^ (Filename.quote (Filename.dirname f)) - ^ " " ^ (Filename.quote f) in - let s,res = run_command av#insert_message cmd in - if s = Unix.WEXITED 0 then - flash_info (f ^ " successfully compiled") - else begin - flash_info (f ^ " failed to compile"); - activate_input session_notebook#current_page; - av#process_until_end_or_error; - av#insert_message "Compilation output:\n"; - av#insert_message res - end - in - let _ = - externals_factory#add_item "_Compile Buffer" ~callback:compile_f - in - - (* Command/Make Menu *) - let make_f () = - let v = session_notebook#current_term in - let av = v.analyzed_view in - match av#filename with - | None -> - flash_info "Cannot make: this buffer has no name" - | Some f -> - let cmd = - local_cd f ^ !current.cmd_make in - - (* - save_f (); - *) - av#insert_message "Command output:\n"; - let s,res = run_command av#insert_message cmd in - last_make := res; - last_make_index := 0; - flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") - in - let _ = externals_factory#add_item "_Make" - ~key:GdkKeysyms._F6 - ~callback:make_f - in - - - (* Compile/Next Error *) - let next_error () = - try - let file,line,start,stop,error_msg = search_next_error () in - load file; - let v = session_notebook#current_term in - let av = v.analyzed_view in - let input_buffer = v.script#buffer in - (* - let init = input_buffer#start_iter in - let i = init#forward_lines (line-1) in - *) - (* - let convert_pos = byte_offset_to_char_offset phrase in - let start = convert_pos start in - let stop = convert_pos stop in - *) - (* - let starti = i#forward_chars start in - let stopi = i#forward_chars stop in - *) - let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in - let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in - input_buffer#apply_tag Tags.Script.error - ~start:starti - ~stop:stopi; - input_buffer#place_cursor starti; - av#set_message error_msg; - v.script#misc#grab_focus () - with Not_found -> - last_make_index := 0; - let v = session_notebook#current_term in - let av = v.analyzed_view in - av#set_message "No more errors.\n" - in - let _ = - externals_factory#add_item "_Next error" - ~key:GdkKeysyms._F7 - ~callback:next_error in - - - (* Command/CoqMakefile Menu*) - let coq_makefile_f () = - let v = session_notebook#current_term in - let av = v.analyzed_view in - match av#filename with - | None -> - flash_info "Cannot make makefile: this buffer has no name" - | Some f -> - let cmd = - local_cd f ^ !current.cmd_coqmakefile in - let s,res = run_command av#insert_message cmd in - flash_info - (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") - in - let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f - in - (* Windows Menu *) - let configuration_menu = factory#add_submenu "_Windows" in - let configuration_factory = new GMenu.factory configuration_menu - ~accel_path:"/Windows" - ~accel_modi:[] - ~accel_group - in - let _ = - configuration_factory#add_item - "Show/Hide _Query Pane" - ~key:GdkKeysyms._Escape - ~callback:(fun () -> if (Command_windows.command_window ())#frame#misc#visible then - (Command_windows.command_window ())#frame#misc#hide () - else - (Command_windows.command_window ())#frame#misc#show ()) - in - let _ = - configuration_factory#add_check_item - "Show/Hide _Toolbar" - ~callback:(fun _ -> - !current.show_toolbar <- not !current.show_toolbar; - !show_toolbar !current.show_toolbar) - in - let _ = - configuration_factory#add_item - "Detach _View" - ~callback: - (do_if_not_computing "detach view" - (fun () -> - match session_notebook#current_term with - | {script=v;analyzed_view=av} -> - let w = GWindow.window ~show:true - ~width:(!current.window_width*2/3) - ~height:(!current.window_height*2/3) - ~position:`CENTER - ~title:(match av#filename with - | None -> "*Unnamed*" - | Some f -> f) - () - in - let sb = GBin.scrolled_window - ~packing:w#add () - in - let nv = GText.view - ~buffer:v#buffer - ~packing:sb#add - () - in - nv#misc#modify_font - !current.text_font; - ignore (w#connect#destroy - ~callback: - (fun () -> av#remove_detached_view w)); - av#add_detached_view w - - )) - in - (* Help Menu *) - - let help_menu = factory#add_submenu "_Help" in - let help_factory = new GMenu.factory help_menu - ~accel_path:"/Help/" - ~accel_modi:[] - ~accel_group in - let _ = help_factory#add_item "Browse Coq _Manual" - ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in - browse av#insert_message (doc_url ())) in - let _ = help_factory#add_item "Browse Coq _Library" - ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in - browse av#insert_message !current.library_url) in - let _ = - help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1 - ~callback:(fun () -> - let av = session_notebook#current_term.analyzed_view in - av#help_for_keyword ()) - in - let _ = help_factory#add_separator () in - let about_m = help_factory#add_item "_About" in - (* End of menu *) - - (* The vertical Separator between Scripts and Goals *) - let queries_pane = GPack.paned `VERTICAL ~packing:(vbox#pack ~expand:true ) () in - queries_pane#pack1 ~shrink:false ~resize:true session_notebook#coerce; - update_notebook_pos (); - let nb = session_notebook in - let command_object = Command_windows.command_window() in - let queries_frame = command_object#frame in - queries_pane#pack2 ~shrink:false ~resize:false (queries_frame#coerce); - let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in - lower_hbox#pack ~expand:true status#coerce; - let search_lbl = GMisc.label ~text:"Search:" - ~show:false - ~packing:(lower_hbox#pack ~expand:false) () - in - let search_history = ref [] in - let search_input = GEdit.combo ~popdown_strings:!search_history - ~enable_arrow_keys:true - ~show:false - ~packing:(lower_hbox#pack ~expand:false) () - in - search_input#disable_activate (); - let ready_to_wrap_search = ref false in - - let start_of_search = ref None in - let start_of_found = ref None in - let end_of_found = ref None in - let search_forward = ref true in - let matched_word = ref None in - - let memo_search () = - matched_word := Some search_input#entry#text - in - let end_search () = - prerr_endline "End Search"; - memo_search (); - let v = session_notebook#current_term.script in - v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT); - v#coerce#misc#grab_focus (); - search_input#entry#set_text ""; - search_lbl#misc#hide (); - search_input#misc#hide () - in - let end_search_focus_out () = - prerr_endline "End Search(focus out)"; - memo_search (); - let v = session_notebook#current_term.script in - v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT); - search_input#entry#set_text ""; - search_lbl#misc#hide (); - search_input#misc#hide () - in - ignore (search_input#entry#connect#activate ~callback:end_search); - ignore (search_input#entry#event#connect#key_press - ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in - if - kv = GdkKeysyms._Right - || kv = GdkKeysyms._Up - || kv = GdkKeysyms._Left - || (kv = GdkKeysyms._g - && (List.mem `CONTROL (GdkEvent.Key.state k))) - then end_search (); - false)); - ignore (search_input#entry#event#connect#focus_out - ~callback:(fun _ -> end_search_focus_out (); false)); - to_do_on_page_switch := - (fun i -> - start_of_search := None; - ready_to_wrap_search:=false)::!to_do_on_page_switch; - - (* TODO : make it work !!! *) - let rec search_f () = - search_lbl#misc#show (); - search_input#misc#show (); - - prerr_endline "search_f called"; - if !start_of_search = None then begin - (* A full new search is starting *) - start_of_search := - Some (session_notebook#current_term.script#buffer#create_mark - (session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT)); - start_of_found := !start_of_search; - end_of_found := !start_of_search; - matched_word := Some ""; - end; - let txt = search_input#entry#text in - let v = session_notebook#current_term.script in - let iit = v#buffer#get_iter_at_mark `SEL_BOUND - and insert_iter = v#buffer#get_iter_at_mark `INSERT - in - prerr_endline ("SELBOUND="^(string_of_int iit#offset)); - prerr_endline ("INSERT="^(string_of_int insert_iter#offset)); - - (match - if !search_forward then iit#forward_search txt - else let npi = iit#forward_chars (Glib.Utf8.length txt) in - match - (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset), - (let t = iit#get_text ~stop:npi in - flash_info (t^"\n"^txt); - t = txt) - with - | true,true -> - (flash_info "T,T";iit#backward_search txt) - | false,true -> flash_info "F,T";Some (iit,npi) - | _,false -> - (iit#backward_search txt) - - with - | None -> - if !ready_to_wrap_search then begin - ready_to_wrap_search := false; - flash_info "Search wrapped"; - v#buffer#place_cursor - (if !search_forward then v#buffer#start_iter else - v#buffer#end_iter); - search_f () - end else begin - if !search_forward then flash_info "Search at end" - else flash_info "Search at start"; - ready_to_wrap_search := true - end - | Some (start,stop) -> - prerr_endline "search: before moving marks"; - prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset)); - prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset)); - - v#buffer#move_mark `SEL_BOUND start; - v#buffer#move_mark `INSERT stop; - prerr_endline "search: after moving marks"; - prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset)); - prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset)); - v#scroll_to_mark `SEL_BOUND - ) - in - ignore (search_input#entry#event#connect#key_release - ~callback: - (fun ev -> - if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin - let v = session_notebook#current_term.script in - (match !start_of_search with - | None -> - prerr_endline "search_key_rel: Placing sel_bound"; - v#buffer#move_mark - `SEL_BOUND - (v#buffer#get_iter_at_mark `INSERT) - | Some mk -> let it = v#buffer#get_iter_at_mark - (`MARK mk) in - prerr_endline "search_key_rel: Placing cursor"; - v#buffer#place_cursor it; - start_of_search := None - ); - search_input#entry#set_text ""; - v#coerce#misc#grab_focus (); - end; - false - )); - ignore (search_input#entry#connect#changed search_f); - push_info "Ready"; - (* Location display *) - let l = GMisc.label - ~text:"Line: 1 Char: 1" - ~packing:lower_hbox#pack () in - l#coerce#misc#set_name "location"; - set_location := l#set_text; - (* Progress Bar *) - lower_hbox#pack pbar#coerce; - pbar#set_text "CoqIde started"; - (* XXX *) - change_font := - (fun fd -> - List.iter - (fun {script=view; proof_view=prf_v; message_view=msg_v} -> - view#misc#modify_font fd; - prf_v#misc#modify_font fd; - msg_v#misc#modify_font fd - ) - session_notebook#pages; - ); - let about_full_string = - "\nCoq is developed by the Coq Development Team\ - \n(INRIA - CNRS - University Paris 11 and partners)\ - \nWeb site: " ^ Coq_config.wwwcoq ^ - "\nFeature wish or bug report: http://coq.inria.fr/bugs\ - \n\ - \nCredits for CoqIDE, the Integrated Development Environment for Coq:\ - \n\ - \nMain author : Benjamin Monate\ - \nContributors : Jean-Christophe Filliâtre\ - \n Pierre Letouzey, Claude Marché\ - \n Bruno Barras, Pierre Corbineau\ - \n Julien Narboux, Hugo Herbelin, ... \ - \n\ - \nVersion information\ - \n-------------------\ - \n" - in - let initial_about (b:GText.buffer) = - let initial_string = "Welcome to CoqIDE, an Integrated Development Environment for Coq\n" in - let coq_version = Coq.short_version () in - b#insert ~iter:b#start_iter "\n\n"; - if Glib.Utf8.validate ("You are running " ^ coq_version) then b#insert ~iter:b#start_iter ("You are running " ^ coq_version); - if Glib.Utf8.validate initial_string then b#insert ~iter:b#start_iter initial_string; - (try - let image = lib_ide_file "coq.png" in - let startup_image = GdkPixbuf.from_file image in - b#insert ~iter:b#start_iter "\n\n"; - b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image; - b#insert ~iter:b#start_iter "\n\n\t\t " - with _ -> ()) - in - - let about (b:GText.buffer) = - (try - let image = lib_ide_file "coq.png" in - let startup_image = GdkPixbuf.from_file image in - b#insert ~iter:b#start_iter "\n\n"; - b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image; - b#insert ~iter:b#start_iter "\n\n\t\t " - with _ -> ()); - if Glib.Utf8.validate about_full_string - then b#insert about_full_string; - let coq_version = Coq.version () in - if Glib.Utf8.validate coq_version - then b#insert coq_version - - in - w#add_accel_group accel_group; - (* Remove default pango menu for textviews *) - w#show (); - ignore (about_m#connect#activate - ~callback:(fun () -> let prf_v = session_notebook#current_term.proof_view in - prf_v#buffer#set_text ""; about prf_v#buffer)); - (* - - *) - resize_window := (fun () -> - w#resize - ~width:!current.window_width - ~height:!current.window_height); - ignore(nb#connect#switch_page - ~callback: - (fun i -> - prerr_endline ("switch_page: starts " ^ string_of_int i); - List.iter (function f -> f i) !to_do_on_page_switch; - prerr_endline "switch_page: success") - ); - if List.length files >=1 then - begin - List.iter (fun f -> - if Sys.file_exists f then load f else - let f = if Filename.check_suffix f ".v" then f else f^".v" in - load_file (fun s -> print_endline s; exit 1) f) - files; - activate_input 0 - end - else - begin - let session = create_session () in - let index = session_notebook#append_term session in - activate_input index; - end; - initial_about session_notebook#current_term.proof_view#buffer; - !show_toolbar !current.show_toolbar; - session_notebook#current_term.script#misc#grab_focus () - -;; + nv#misc#modify_font + !current.text_font; + ignore (w#connect#destroy + ~callback: + (fun () -> av#remove_detached_view w)); + av#add_detached_view w) + [session_notebook#current_term]); + ]; + GAction.add_actions help_actions [ + GAction.add_action "Help" ~label:"_Help"; + GAction.add_action "Browse Coq Manual" ~label:"Browse Coq _Manual" + ~callback:(fun _ -> + let av = session_notebook#current_term.analyzed_view in + browse av#insert_message (doc_url ())); + GAction.add_action "Browse Coq Library" ~label:"Browse Coq _Library" + ~callback:(fun _ -> + let av = session_notebook#current_term.analyzed_view in + browse av#insert_message !current.library_url); + GAction.add_action "Help for keyword" ~label:"Help for _keyword" + ~callback:(fun _ -> let av = session_notebook#current_term.analyzed_view in + av#help_for_keyword ()) ~stock:`HELP; + GAction.add_action "About Coq" ~label:"_About" ~stock:`ABOUT; + ]; + Coqide_ui.init (); + Coqide_ui.ui_m#insert_action_group file_actions 0; + Coqide_ui.ui_m#insert_action_group export_actions 0; + Coqide_ui.ui_m#insert_action_group edit_actions 0; + Coqide_ui.ui_m#insert_action_group navigation_actions 0; + Coqide_ui.ui_m#insert_action_group tactics_actions 0; + Coqide_ui.ui_m#insert_action_group templates_actions 0; + Coqide_ui.ui_m#insert_action_group queries_actions 0; + Coqide_ui.ui_m#insert_action_group display_actions 0; + Coqide_ui.ui_m#insert_action_group compile_actions 0; + Coqide_ui.ui_m#insert_action_group windows_actions 0; + Coqide_ui.ui_m#insert_action_group help_actions 0; + w#add_accel_group Coqide_ui.ui_m#get_accel_group ; + if Coq_config.gtk_platform <> `QUARTZ + then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar"); + let tbar = GtkButton.Toolbar.cast ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget) + in let () = GtkButton.Toolbar.set ~orientation:`HORIZONTAL ~style:`ICONS + ~tooltips:true tbar in + let toolbar = new GObj.widget tbar in + vbox#pack toolbar; + + show_toolbar := + (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); + + ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true)); + + (* The vertical Separator between Scripts and Goals *) + vbox#pack ~expand:true session_notebook#coerce; + update_notebook_pos (); + let nb = session_notebook in + let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in + lower_hbox#pack ~expand:true status#coerce; + let search_lbl = GMisc.label ~text:"Search:" + ~show:false + ~packing:(lower_hbox#pack ~expand:false) () + in + let search_history = ref [] in + let (search_input,_) = GEdit.combo_box_entry_text ~strings:!search_history ~show:false + ~packing:(lower_hbox#pack ~expand:false) () + in + let ready_to_wrap_search = ref false in + + let start_of_search = ref None in + let start_of_found = ref None in + let end_of_found = ref None in + let search_forward = ref true in + let matched_word = ref None in + + let memo_search () = + matched_word := Some search_input#entry#text + in + let end_search () = + prerr_endline "End Search"; + memo_search (); + let v = session_notebook#current_term.script in + v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT); + v#coerce#misc#grab_focus (); + search_input#entry#set_text ""; + search_lbl#misc#hide (); + search_input#misc#hide () + in + let end_search_focus_out () = + prerr_endline "End Search(focus out)"; + memo_search (); + let v = session_notebook#current_term.script in + v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT); + search_input#entry#set_text ""; + search_lbl#misc#hide (); + search_input#misc#hide () + in + ignore (search_input#entry#connect#activate ~callback:end_search); + ignore (search_input#entry#event#connect#key_press + ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in + if + kv = GdkKeysyms._Right + || kv = GdkKeysyms._Up + || kv = GdkKeysyms._Left + || (kv = GdkKeysyms._g + && (List.mem `CONTROL (GdkEvent.Key.state k))) + then end_search (); + false)); + ignore (search_input#entry#event#connect#focus_out + ~callback:(fun _ -> end_search_focus_out (); false)); + to_do_on_page_switch := + (fun i -> + start_of_search := None; + ready_to_wrap_search:=false)::!to_do_on_page_switch; + + (* TODO : make it work !!! *) + let rec search_f () = + search_lbl#misc#show (); + search_input#misc#show (); + + prerr_endline "search_f called"; + if !start_of_search = None then begin + (* A full new search is starting *) + start_of_search := + Some (session_notebook#current_term.script#buffer#create_mark + (session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT)); + start_of_found := !start_of_search; + end_of_found := !start_of_search; + matched_word := Some ""; + end; + let txt = search_input#entry#text in + let v = session_notebook#current_term.script in + let iit = v#buffer#get_iter_at_mark `SEL_BOUND + and insert_iter = v#buffer#get_iter_at_mark `INSERT + in + prerr_endline ("SELBOUND="^(string_of_int iit#offset)); + prerr_endline ("INSERT="^(string_of_int insert_iter#offset)); + + (match + if !search_forward then iit#forward_search txt + else let npi = iit#forward_chars (Glib.Utf8.length txt) in + match + (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset), + (let t = iit#get_text ~stop:npi in + flash_info (t^"\n"^txt); + t = txt) + with + | true,true -> + (flash_info "T,T";iit#backward_search txt) + | false,true -> flash_info "F,T";Some (iit,npi) + | _,false -> + (iit#backward_search txt) + + with + | None -> + if !ready_to_wrap_search then begin + ready_to_wrap_search := false; + flash_info "Search wrapped"; + v#buffer#place_cursor + ~where:(if !search_forward then v#buffer#start_iter else + v#buffer#end_iter); + search_f () + end else begin + if !search_forward then flash_info "Search at end" + else flash_info "Search at start"; + ready_to_wrap_search := true + end + | Some (start,stop) -> + prerr_endline "search: before moving marks"; + prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset)); + prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset)); + + v#buffer#move_mark `SEL_BOUND ~where:start; + v#buffer#move_mark `INSERT ~where:stop; + prerr_endline "search: after moving marks"; + prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset)); + prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset)); + v#scroll_to_mark `SEL_BOUND + ) + in + ignore (search_input#entry#event#connect#key_release + ~callback: + (fun ev -> + if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin + let v = session_notebook#current_term.script in + (match !start_of_search with + | None -> + prerr_endline "search_key_rel: Placing sel_bound"; + v#buffer#move_mark + `SEL_BOUND + ~where:(v#buffer#get_iter_at_mark `INSERT) + | Some mk -> let it = v#buffer#get_iter_at_mark + (`MARK mk) in + prerr_endline "search_key_rel: Placing cursor"; + v#buffer#place_cursor ~where:it; + start_of_search := None + ); + search_input#entry#set_text ""; + v#coerce#misc#grab_focus (); + end; + false + )); + ignore (search_input#entry#connect#changed ~callback:search_f); + push_info "Ready"; + (* Location display *) + let l = GMisc.label + ~text:"Line: 1 Char: 1" + ~packing:lower_hbox#pack () in + l#coerce#misc#set_name "location"; + set_location := l#set_text; + (* Progress Bar *) + lower_hbox#pack pbar#coerce; + pbar#set_text "CoqIde started"; + (* XXX *) + change_font := + (fun fd -> + List.iter + (fun {script=view; proof_view=prf_v; message_view=msg_v} -> + view#misc#modify_font fd; + prf_v#misc#modify_font fd; + msg_v#misc#modify_font fd + ) + session_notebook#pages; + ); + let about_full_string = + "\nCoq is developed by the Coq Development Team\ + \n(INRIA - CNRS - LIX - LRI - PPS)\ + \nWeb site: " ^ Coq_config.wwwcoq ^ + "\nFeature wish or bug report: http://coq.inria.fr/bugs/\ + \n\ + \nCredits for CoqIDE, the Integrated Development Environment for Coq:\ + \n\ + \nMain author : Benjamin Monate\ + \nContributors : Jean-Christophe Filliâtre\ + \n Pierre Letouzey, Claude Marché\ + \n Bruno Barras, Pierre Corbineau\ + \n Julien Narboux, Hugo Herbelin, ... \ + \n\ + \nVersion information\ + \n-------------------\ + \n" + in + let initial_about (b:GText.buffer) = + let initial_string = + "Welcome to CoqIDE, an Integrated Development Environment for Coq\n" + in + let coq_version = Coq.short_version () in + b#insert ~iter:b#start_iter "\n\n"; + if Glib.Utf8.validate ("You are running " ^ coq_version) then + b#insert ~iter:b#start_iter ("You are running " ^ coq_version); + if Glib.Utf8.validate initial_string then + b#insert ~iter:b#start_iter initial_string; + (try + let image = Filename.concat (List.find + (fun x -> Sys.file_exists (Filename.concat x "coq.png")) + Minilib.xdg_data_dirs) "coq.png" in + let startup_image = GdkPixbuf.from_file image in + b#insert ~iter:b#start_iter "\n\n"; + b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image; + b#insert ~iter:b#start_iter "\n\n\t\t " + with _ -> ()) + in + + let about (b:GText.buffer) = + (try + let image = Filename.concat (List.find + (fun x -> Sys.file_exists (Filename.concat x "coq.png")) + Minilib.xdg_data_dirs) "coq.png" in + let startup_image = GdkPixbuf.from_file image in + b#insert ~iter:b#start_iter "\n\n"; + b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image; + b#insert ~iter:b#start_iter "\n\n\t\t " + with _ -> ()); + if Glib.Utf8.validate about_full_string + then b#insert about_full_string; + let coq_version = Coq.version () in + if Glib.Utf8.validate coq_version + then b#insert coq_version + + in + (* Remove default pango menu for textviews *) + w#show (); + ignore ((help_actions#get_action "About Coq")#connect#activate + ~callback:(fun _ -> let prf_v = session_notebook#current_term.proof_view in + prf_v#buffer#set_text ""; about prf_v#buffer)); + (* + + *) + resize_window := (fun () -> + w#resize + ~width:!current.window_width + ~height:!current.window_height); + ignore(nb#connect#switch_page + ~callback: + (fun i -> + prerr_endline ("switch_page: starts " ^ string_of_int i); + List.iter (function f -> f i) !to_do_on_page_switch; + prerr_endline "switch_page: success") + ); + if List.length files >=1 then + begin + List.iter (fun f -> + if Sys.file_exists f then do_load f else + let f = if Filename.check_suffix f ".v" then f else f^".v" in + load_file (fun s -> print_endline s; exit 1) f) + files; + session_notebook#goto_page 0; + end + else + begin + let session = create_session None in + let index = session_notebook#append_term session in + session_notebook#goto_page index; + end; + initial_about session_notebook#current_term.proof_view#buffer; + !show_toolbar !current.show_toolbar; + session_notebook#current_term.script#misc#grab_focus ();; (* This function check every half of second if GeoProof has send something on his private clipboard *) let rec check_for_geoproof_input () = let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in - while true do - Thread.delay 0.1; - let s = cb_Dr#text in - (match s with - Some s -> - if s <> "Ack" then - session_notebook#current_term.script#buffer#insert (s^"\n"); - cb_Dr#set_text "Ack" - | None -> () - ); - (* cb_Dr#clear does not work so i use : *) - (* cb_Dr#set_text "Ack" *) - done - - -let start () = - let files = Coq.init () in - ignore_break (); - GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc"); - (try - GtkMain.Rc.add_default_file (Filename.concat System.home ".coqide-gtk2rc"); - with Not_found -> ()); - ignore (GtkMain.Main.init ()); - GtkData.AccelGroup.set_default_mod_mask - (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]); - ignore ( - Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL; - `WARNING;`CRITICAL] - (fun ~level msg -> - if level land Glib.Message.log_level `WARNING <> 0 - then Pp.warning msg - else failwith ("Coqide internal error: " ^ msg))); - Command_windows.main (); - init_stdout (); - main files; - if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ()); - while true do - try - GtkThread.main () - with - | Sys.Break -> prerr_endline "Interrupted." - | e -> - safe_prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e)); - flush_all (); - crash_save 127 - done - + while true do + Thread.delay 0.1; + let s = cb_Dr#text in + (match s with + Some s -> + if s <> "Ack" then + session_notebook#current_term.script#buffer#insert (s^"\n"); + cb_Dr#set_text "Ack" + | None -> () + ); + (* cb_Dr#clear does not work so i use : *) + (* cb_Dr#set_text "Ack" *) + done + +(** By default, the coqtop we try to launch is exactly the current coqide + full name, with the last occurrence of "coqide" replaced by "coqtop". + This should correctly handle the ".opt", ".byte", ".exe" situations. + If the replacement fails, we default to "coqtop", hoping it's somewhere + in the path. Note that the -coqtop option to coqide allows to override + this default coqtop path *) + +let default_coqtop_path () = + let prog = Sys.executable_name in + try + let pos = String.length prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") prog pos in + String.blit "coqtop" 0 prog i 6; + prog + with _ -> "coqtop" + +let read_coqide_args argv = + let rec filter_coqtop coqtop project_files out = function + | "-coqtop" :: prog :: args -> + if coqtop = "" then filter_coqtop prog project_files out args + else + (output_string stderr "Error: multiple -coqtop options"; exit 1) + | "-f" :: file :: args -> + filter_coqtop coqtop + ((Minilib.canonical_path_name (Filename.dirname file), + Project_file.read_project_file file) :: project_files) out args + | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 + | arg::args -> filter_coqtop coqtop project_files (arg::out) args + | [] -> ((if coqtop = "" then default_coqtop_path () else coqtop), + List.rev project_files,List.rev out) + in + let coqtop,project_files,argv = filter_coqtop "" [] [] argv in + Minilib.coqtop_path := coqtop; + custom_project_files := project_files; + argv +let process_argv argv = + try + let continue,filtered = Coq.filter_coq_opts (List.tl argv) in + if not continue then + (List.iter Minilib.safe_prerr_endline filtered; exit 0); + let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in + if opts <> [] then + (Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1); + filtered + with _ -> + (Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1) diff --git a/ide/coqide.mli b/ide/coqide.mli index ea995c71..38b0fab0 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -1,16 +1,40 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit +(** Filter the argv from coqide specific options, and set + Minilib.coqtop_path accordingly *) +val read_coqide_args : string list -> string list + +(** Ask coqtop the remaining options it doesn't recognize *) +val process_argv : string list -> string list + +(** Prepare the widgets, load the given files in tabs *) +val main : string list -> unit + +(** Function to save anything and kill all coqtops + @return [false] if you're allowed to quit. *) +val forbid_quit_to_save : unit -> bool + +(** Function to load of a file. *) +val do_load : string -> unit + +(** Set coqide to ignore Ctrl-C, while launching [crash_save] and + exiting for others received signals *) +val ignore_break : unit -> unit + +(** Emergency saving of opened files as "foo.v.crashcoqide", + and exit (if the integer isn't 127). *) +val crash_save : int -> unit + +val check_for_geoproof_input : unit -> unit diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 new file mode 100644 index 00000000..3fec0631 --- /dev/null +++ b/ide/coqide_main.ml4 @@ -0,0 +1,105 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit) -> (unit -> bool) -> unit + = "caml_gtk_mac_init" + +external gtk_mac_ready : ([> Gtk.widget ] as 'a) Gtk.obj -> ([> Gtk.widget ] as 'a) Gtk.obj -> + ([> Gtk.widget ] as 'a) Gtk.obj -> unit + = "caml_gtk_mac_ready" +END + +let initmac () = IFDEF QUARTZ THEN gtk_mac_init Coqide.do_load Coqide.forbid_quit_to_save ELSE () END + +let macready x y z = IFDEF QUARTZ THEN gtk_mac_ready x#as_widget y#as_widget z#as_widget ELSE () END + +(* On win32, we add the directory of coqide to the PATH at launch-time + (this used to be done in a .bat script). *) + +let set_win32_path () = + Unix.putenv "PATH" + (Filename.dirname Sys.executable_name ^ ";" ^ + (try Sys.getenv "PATH" with _ -> "")) + +(* On win32, since coqide is now console-free, we re-route stdout/stderr + to avoid Sys_error if someone writes to them. We write to a pipe which + is never read (by default) or to a temp log file (when in debug mode). +*) + +let reroute_stdout_stderr () = + let out_descr = + if !Ideutils.debug then + Unix.descr_of_out_channel (snd (Filename.open_temp_file "coqide_" ".log")) + else + snd (Unix.pipe ()) + in + Unix.dup2 out_descr Unix.stdout; + Unix.dup2 out_descr Unix.stderr + +(* We also provide specific kill and interrupt functions. *) + +(* Since [win32_interrupt] involves some hack about the process console, + only one should run at the same time, we simply skip execution of + [win32_interrupt] if another instance is already running *) + +let ctrl_c_mtx = Mutex.create () + +let ctrl_c_protect f i = + if not (Mutex.try_lock ctrl_c_mtx) then () + else try f i; Mutex.unlock ctrl_c_mtx with _ -> Mutex.unlock ctrl_c_mtx + +IFDEF WIN32 THEN +external win32_kill : int -> unit = "win32_kill" +external win32_interrupt : int -> unit = "win32_interrupt" +let () = + Coq.killer := win32_kill; + Coq.interrupter := ctrl_c_protect win32_interrupt; + set_win32_path (); + reroute_stdout_stderr () +END + +let () = + let argl = Array.to_list Sys.argv in + let argl = Coqide.read_coqide_args argl in + let files = Coqide.process_argv argl in + let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in + Coq.check_connection args; + Coqide.sup_args := args; + Coqide.ignore_break (); + (try + let gtkrcdir = List.find + (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) + Minilib.xdg_config_dirs in + GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc"); + with Not_found -> ()); + ignore (GtkMain.Main.init ()); + initmac () ; +(* GtkData.AccelGroup.set_default_mod_mask + (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) + ignore ( + Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL; + `WARNING;`CRITICAL] + (fun ~level msg -> + if level land Glib.Message.log_level `WARNING <> 0 + then Printf.eprintf "Warning: %s\n" msg + else failwith ("Coqide internal error: " ^ msg))); + Coqide.main files; + if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); + macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") + (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); + while true do + try + GtkThread.main () + with + | Sys.Break -> Ideutils.prerr_endline "Interrupted." + | e -> + Minilib.safe_prerr_endline + ("CoqIde unexpected error:" ^ (Printexc.to_string e)); + Coqide.crash_save 127 + done diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml new file mode 100644 index 00000000..0d7c67ac --- /dev/null +++ b/ide/coqide_ui.ml @@ -0,0 +1,151 @@ +let ui_m = GAction.ui_manager ();; + +let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) + +let list_items menu li = + let res_buf = Buffer.create 500 in + let tactic_item = function + |[] -> Buffer.create 1 + |[s] -> let b = Buffer.create 16 in + let () = Buffer.add_string b ("\n") in + b + |s::_ as l -> let b = Buffer.create 50 in + let () = (Buffer.add_string b ("\n")) in + let () = (List.iter + (fun x -> Buffer.add_string b ("\n")) l) in + let () = Buffer.add_string b"\n" in + b in + let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in + res_buf + +let init () = + let theui = Printf.sprintf " + + + + + + + + + + + + + + + + + + + %s + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + %s + + + + + + + + + + + %s + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +" + (if Coq_config.gtk_platform <> `QUARTZ then "" else "") + (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) + (Buffer.contents (list_items "Template" Coq_commands.commands)) + in + ignore (ui_m#add_ui_from_string theui); diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 1b52dba3..c69f92e2 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -1,22 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Hashtbl.add h s ()) - [ "Add" ; "Check"; "Eval"; "Extraction" ; - "Load" ; "Undo"; "Goal"; - "Proof" ; "Print"; "Qed" ; "Defined" ; "Save" ; - "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" - ]; - Hashtbl.mem h - - let is_constr_kw = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; - "end"; "as"; "let"; "in"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type" ]; - Hashtbl.mem h - - (* Without this table, the automaton would be too big and - ocamllex would fail *) - let is_one_word_declaration = - let h = Hashtbl.create 97 in - List.iter (fun s -> Hashtbl.add h s ()) - [ (* Theorems *) - "Theorem" ; "Lemma" ; "Fact" ; "Remark" ; "Corollary" ; - "Proposition" ; "Property" ; - (* Definitions *) - "Definition" ; "Let" ; "Example" ; "SubClass" ; - "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ; - (* Assumptions *) - "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ; - "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters"; - (* Inductive *) - "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; - (* Other *) - "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" - ]; - Hashtbl.mem h - - let starting = ref true -} - -let space = - [' ' '\010' '\013' '\009' '\012'] -let firstchar = - ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] -let identchar = - ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let ident = firstchar identchar* - -let multiword_declaration = - "Module" (space+ "Type")? -| "Program" space+ ident -| "Existing" space+ "Instance" -| "Canonical" space+ "Structure" - -let locality = ("Local" space+)? - -let multiword_command = - "Set" (space+ ident)* -| "Unset" (space+ ident)* -| "Open" space+ locality "Scope" -| "Close" space+ locality "Scope" -| "Bind" space+ "Scope" -| "Arguments" space+ "Scope" -| "Reserved" space+ "Notation" space+ locality -| "Delimit" space+ "Scope" -| "Next" space+ "Obligation" -| "Solve" space+ "Obligations" -| "Require" space+ ("Import"|"Export")? -| "Infix" space+ locality -| "Notation" space+ locality -| "Hint" space+ locality ident -| "Reset" (space+ "Initial")? -| "Tactic" space+ "Notation" -| "Implicit" space+ "Arguments" -| "Implicit" space+ ("Type"|"Types") -| "Combined" space+ "Scheme" -| "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"))| - ("Library"|"Inline"|"NoInline"|"Blacklist")) -| "Recursive" space+ "Extraction" (space+ "Library")? -| ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist") -| "Extract" space+ (("Inlined" space+) "Constant"| "Inductive") - -(* At least still missing: "Inline" + decl, variants of "Identity - Coercion", variants of Print, Add, ... *) - -rule next_starting_order = parse - | "(*" { comment_start := lexeme_start lexbuf; comment lexbuf } - | space+ { next_starting_order lexbuf } - | multiword_declaration - { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl } - | multiword_command - { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd } - | ident as id - { if id = "Time" then next_starting_order lexbuf else - begin - starting:=false; - if is_one_word_command id then - lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd - else if is_one_word_declaration id then - lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl - else - next_interior_order lexbuf - end - } - | _ { starting := false; next_interior_order lexbuf} - | eof { raise End_of_file } - -and next_interior_order = parse - | "(*" - { comment_start := lexeme_start lexbuf; comment lexbuf } - | ident as id - { if is_constr_kw id then - lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd - else - next_interior_order lexbuf } - | "." (" "|"\n"|"\t") { starting := true; next_starting_order lexbuf } - | _ { next_interior_order lexbuf} - | eof { raise End_of_file } - -and comment = parse - | "*)" { !comment_start,lexeme_end lexbuf,Tags.Script.comment } - | "(*" { ignore (comment lexbuf); comment lexbuf } - | "\"" { string_in_comment lexbuf } - | _ { comment lexbuf } - | eof { raise End_of_file } - -and string_in_comment = parse - | "\"\"" { string_in_comment lexbuf } - | "\"" { comment lexbuf } - | _ { string_in_comment lexbuf } - | eof { raise End_of_file } - -{ - open Ideutils - - let highlighting = ref false - - let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop = - starting := true; (* approximation: assume the beginning of a sentence *) - if !highlighting then prerr_endline "Rejected highlight" - else begin - highlighting := true; - prerr_endline "Highlighting slice now"; - input_buffer#remove_tag ~start ~stop Tags.Script.error; - input_buffer#remove_tag ~start ~stop Tags.Script.kwd; - input_buffer#remove_tag ~start ~stop Tags.Script.decl; - input_buffer#remove_tag ~start ~stop Tags.Script.comment; - - (try begin - let offset = start#offset in - let s = start#get_slice ~stop in - let convert_pos = byte_offset_to_char_offset s in - let lb = Lexing.from_string s in - try - while true do - let b,e,o = - if !starting then next_starting_order lb - else next_interior_order lb in - - let b,e = convert_pos b,convert_pos e in - let start = input_buffer#get_iter_at_char (offset + b) in - let stop = input_buffer#get_iter_at_char (offset + e) in - input_buffer#apply_tag ~start ~stop o - done - with End_of_file -> () - end - with _ -> ()); - highlighting := false - end - - let highlight_current_line input_buffer = - try - let i = get_insert input_buffer in - highlight_slice input_buffer (i#set_line_offset 0) i - with _ -> () - - let highlight_around_current_line input_buffer = - try - let i = get_insert input_buffer in - highlight_slice input_buffer - (i#backward_lines 10) - (ignore (i#nocopy#forward_lines 10);i) - - with _ -> () - - let highlight_all input_buffer = - try - highlight_slice input_buffer input_buffer#start_iter input_buffer#end_iter - with _ -> () - -} diff --git a/ide/ide.mllib b/ide/ide.mllib index 63935db3..9bbf9b0d 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -1,3 +1,4 @@ +Minilib Okey Config_file Configwin_keys @@ -12,12 +13,14 @@ Typed_notebook Config_lexer Utf8_convert Preferences +Project_file Ideutils +Ideproof Coq_lex Gtk_parsing Undo Coq Coq_commands -Coq_tactics Command_windows +Coqide_ui Coqide diff --git a/ide/ide_mac_stubs.c b/ide/ide_mac_stubs.c new file mode 100644 index 00000000..64deb71d --- /dev/null +++ b/ide/ide_mac_stubs.c @@ -0,0 +1,85 @@ +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include + +GtkOSXApplication *theApp; +value open_file_fun, forbid_quit_fun, themenubar, pref_item, about_item; + +static void osx_accel_map_foreach_lcb(gpointer data,const gchar *accel_path, + guint accel_key, GdkModifierType accel_mods, + gboolean changed) { + if (accel_mods & GDK_CONTROL_MASK) { + accel_mods |= GDK_META_MASK; + accel_mods &= (accel_mods & GDK_MOD1_MASK) ? ~GDK_MOD1_MASK : ~GDK_CONTROL_MASK; + if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { + g_print("could not change accelerator %s\n",accel_path); + } + } + if (accel_mods & GDK_MOD1_MASK) { + accel_mods &= ~ GDK_MOD1_MASK; + accel_mods |= GDK_CONTROL_MASK; + if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { + g_print("could not change accelerator %s\n",accel_path); + } + } +} + +static gboolean deal_with_open(GtkOSXApplication *app, gchar *path, gpointer user_data) +{ + CAMLparam0(); + CAMLlocal2(string_path, res); + string_path = caml_copy_string(path); + res = caml_callback_exn(open_file_fun,string_path); + gboolean truc = !(Is_exception_result(res)); + CAMLreturnT(gboolean, truc); +} + +static gboolean deal_with_quit(GtkOSXApplication *app, gpointer user_data) +{ + CAMLparam0(); + CAMLlocal1(res); + res = caml_callback_exn(forbid_quit_fun,Val_unit); + gboolean truc = (Bool_val(res))||((Is_exception_result(res))); + CAMLreturnT(gboolean, truc); +} + +CAMLprim value caml_gtk_mac_init(value open_file_the_fun, value forbid_quit_the_fun) +{ + CAMLparam2(open_file_the_fun,forbid_quit_the_fun); + open_file_fun = open_file_the_fun; + caml_register_generational_global_root(&open_file_fun); + forbid_quit_fun = forbid_quit_the_fun; + caml_register_generational_global_root(&forbid_quit_fun); + theApp = g_object_new(GTK_TYPE_OSX_APPLICATION, NULL); + g_signal_connect(theApp, "NSApplicationOpenFile", G_CALLBACK(deal_with_open), NULL); + g_signal_connect(theApp, "NSApplicationBlockTermination", G_CALLBACK(deal_with_quit), NULL); + CAMLreturn (Val_unit); +} + +CAMLprim value caml_gtk_mac_ready(value menubar, value prefs, value about) +{ + GtkOSXApplicationMenuGroup * pref_grp, * about_grp; + CAMLparam3(menubar,prefs,about); + themenubar = menubar; + pref_item = prefs; + about_item = about; + caml_register_generational_global_root(&themenubar); + caml_register_generational_global_root(&pref_item); + caml_register_generational_global_root(&about_item); + /* gtk_accel_map_foreach(NULL, osx_accel_map_foreach_lcb);*/ + gtk_osxapplication_set_menu_bar(theApp,check_cast(GTK_MENU_SHELL,themenubar)); + about_grp = gtk_osxapplication_add_app_menu_group(theApp); + pref_grp = gtk_osxapplication_add_app_menu_group(theApp); + gtk_osxapplication_add_app_menu_item(theApp,about_grp,check_cast(GTK_MENU_ITEM,about_item)); + gtk_osxapplication_add_app_menu_item(theApp,pref_grp,check_cast(GTK_MENU_ITEM,pref_item)); + gtk_osxapplication_ready(theApp); + CAMLreturn(Val_unit); +} diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c new file mode 100644 index 00000000..c09bf37d --- /dev/null +++ b/ide/ide_win32_stubs.c @@ -0,0 +1,49 @@ +#define _WIN32_WINNT 0x0501 /* Cf below, we restrict to */ + +#include +#include +#include + +/* Win32 emulation of kill -9 */ + +/* The pid returned by Unix.create_process is actually a pseudo-pid, + made via a cast of the obtained HANDLE, (cf. win32unix/createprocess.c + in the sources of ocaml). Since we're still in the caller process, + we simply cast back to get an handle... + The 0 is the exit code we want for the terminated process. +*/ + +CAMLprim value win32_kill(value pseudopid) { + CAMLparam1(pseudopid); + TerminateProcess((HANDLE)(Long_val(pseudopid)), 0); + CAMLreturn(Val_unit); +} + + +/* Win32 emulation of a kill -2 (SIGINT) */ + +/* This code rely of the fact that coqide is now without initial console. + Otherwise, no console creation in win32unix/createprocess.c, hence + the same console for coqide and all coqtop, and everybody will be + signaled at the same time by the code below. */ + +/* Moreover, AttachConsole exists only since WinXP, and GetProcessId + since WinXP SP1. For avoiding the GetProcessId, we could adapt code + from win32unix/createprocess.c to make it return both the pid and the + handle. For avoiding the AttachConsole, I don't know, maybe having + an intermediate process between coqide and coqtop ? */ + +CAMLprim value win32_interrupt(value pseudopid) { + CAMLparam1(pseudopid); + HANDLE h; + DWORD pid; + FreeConsole(); /* Normally unnecessary, just to be sure... */ + h = (HANDLE)(Long_val(pseudopid)); + pid = GetProcessId(h); + AttachConsole(pid); + /* We want to survive the Ctrl-C that will also concerns us */ + SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */ + GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */ + FreeConsole(); + CAMLreturn(Val_unit); +} diff --git a/ide/ideproof.ml b/ide/ideproof.ml new file mode 100644 index 00000000..3c3324cb --- /dev/null +++ b/ide/ideproof.ml @@ -0,0 +1,137 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let iter = new GText.iter it in + let start = iter#backward_to_tag_toggle (Some tag) in + let stop = iter#forward_to_tag_toggle (Some tag) in + match GdkEvent.get_type evt with + | `BUTTON_PRESS -> + let ev = GdkEvent.Button.cast evt in + if (GdkEvent.Button.button ev) <> 3 then false else begin + let ctxt_menu = GMenu.menu () in + let factory = new GMenu.factory ctxt_menu in + List.iter + (fun (text,cmd) -> ignore (factory#add_item text ~callback:(sel_cb cmd))) + menu_content; + ctxt_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev); + true + end + | `MOTION_NOTIFY -> + hover_cb start stop; false + | _ -> false)) + +let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with + | [] -> assert false + | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals -> + let on_hover sel_start sel_stop = + proof#buffer#remove_tag + ~start:proof#buffer#start_iter + ~stop:sel_start + Tags.Proof.highlight; + proof#buffer#remove_tag + ~start:sel_stop + ~stop:proof#buffer#end_iter + Tags.Proof.highlight; + proof#buffer#apply_tag ~start:sel_start ~stop:sel_stop Tags.Proof.highlight + in + let goals_cnt = List.length rem_goals + 1 in + let head_str = Printf.sprintf + "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s") + in + let goal_str index total = Printf.sprintf + "\n______________________________________(%d/%d)\n" index total + in + (* Insert current goal and its hypotheses *) + let hyps_hints, goal_hints = match hints with + | None -> [], [] + | Some (hl, h) -> (hl, h) + in + let rec insert_hyp hints hs = match hs with + | [] -> () + | hyp :: hs -> + let tags, rem_hints = match hints with + | [] -> [], [] + | hint :: hints -> + let tag = proof#buffer#create_tag [] in + let () = hook_tag_cb tag hint sel_cb on_hover in + [tag], hints + in + let () = proof#buffer#insert ~tags (hyp ^ "\n") in + insert_hyp rem_hints hs + in + let () = proof#buffer#insert head_str in + let () = insert_hyp hyps_hints hyps in + let () = + let tags = if goal_hints <> [] then + let tag = proof#buffer#create_tag [] in + let () = hook_tag_cb tag goal_hints sel_cb on_hover in + [tag] + else [] + in + proof#buffer#insert (goal_str 1 goals_cnt); + proof#buffer#insert ~tags (cur_goal ^ "\n") + in + (* Insert remaining goals (no hypotheses) *) + let fold_goal i _ { Interface.goal_ccl = g } = + proof#buffer#insert (goal_str i goals_cnt); + proof#buffer#insert (g ^ "\n") + in + let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in + ignore(proof#buffer#place_cursor + ~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2))); + ignore(proof#scroll_to_mark `INSERT) + + +let mode_cesar (proof:GText.view) = function + | [] -> assert false + | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> + proof#buffer#insert " *** Declarative Mode ***\n"; + List.iter + (fun hyp -> proof#buffer#insert (hyp^"\n")) + hyps; + proof#buffer#insert "______________________________________\n"; + proof#buffer#insert ("thesis := \n "^cur_goal^"\n"); + ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) + +let display mode (view:GText.view) goals hints evars = + let () = view#buffer#set_text "" in + match goals with + | None -> () + (* No proof in progress *) + | Some { Interface.fg_goals = []; Interface.bg_goals = [] } -> + (* A proof has been finished, but not concluded *) + begin match evars with + | Some evs when evs <> [] -> + view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n"; + let iter evar = + let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in + view#buffer#insert msg + in + List.iter iter evs + | _ -> + view#buffer#insert "Proof Completed." + end + | Some { Interface.fg_goals = []; Interface.bg_goals = bg } -> + (* No foreground proofs, but still unfocused ones *) + view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n"; + let iter goal = + let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in + view#buffer#insert msg + in + List.iter iter bg + | Some { Interface.fg_goals = fg } -> + mode view fg hints diff --git a/ide/ideutils.ml b/ide/ideutils.ml index a6be77f2..fd460c4e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ignore (status_context#push s)),status_context#pop let flash_info = - let flash_context = status#new_context "Flash" in + let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) @@ -31,20 +29,10 @@ let set_location = ref (function s -> failwith "not ready") let pbar = GRange.progress_bar ~pulse_step:0.2 () -(* On a Win32 application with no console, writing to stderr raise - a Sys_error "bad file descriptor" *) -let safe_prerr_endline msg = try prerr_endline msg with _ -> () - -let debug = Flags.debug +let debug = ref (false) let prerr_endline s = - if !debug then try (prerr_endline s;flush stderr) with _ -> () -let prerr_string s = - if !debug then try (prerr_string s;flush stderr) with _ -> () - -let lib_ide_file f = - let coqlib = Envars.coqlib () in - Filename.concat (Filename.concat coqlib "ide") f + if !debug then try prerr_endline s;flush stderr with _ -> () let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT @@ -102,7 +90,7 @@ let try_convert s = try do_convert s with _ -> - "(* Fatal error: wrong encoding in input. + "(* Fatal error: wrong encoding in input. \ Please choose a correct encoding in the preference panel.*)";; @@ -153,26 +141,6 @@ let set_highlight_timer f = Some (GMain.Timeout.add ~ms:2000 ~callback:(fun () -> f (); highlight_timer := None; true)) - -(* Get back the standard coq out channels *) -let init_stdout,read_stdout,clear_stdout = - let out_buff = Buffer.create 100 in - let out_ft = Format.formatter_of_buffer out_buff in - let deep_out_ft = Format.formatter_of_buffer out_buff in - let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in - (fun () -> - Pp_control.std_ft := out_ft; - Pp_control.err_ft := out_ft; - Pp_control.deep_ft := deep_out_ft; -), - (fun () -> Format.pp_print_flush out_ft (); - let r = Buffer.contents out_buff in - prerr_endline "Output from Coq is: "; prerr_endline r; - Buffer.clear out_buff; r), - (fun () -> - Format.pp_print_flush out_ft (); Buffer.clear out_buff) - - let last_dir = ref "" let filter_all_files () = GFile.filter @@ -310,7 +278,7 @@ let run_command f c = (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) let browse f url = - let com = Flags.subst_command_placeholder !current.cmd_browse url in + let com = Minilib.subst_command_placeholder !current.cmd_browse url in let s = Sys.command com in if s = 127 then f ("Could not execute\n\""^com^ @@ -318,78 +286,45 @@ let browse f url = let doc_url () = if !current.doc_url = use_default_doc_url || !current.doc_url = "" then - if Sys.file_exists - (String.sub Coq_config.localwwwrefman 7 - (String.length Coq_config.localwwwrefman - 7)) - then - Coq_config.localwwwrefman - else - Coq_config.wwwrefman + let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in + if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman else !current.doc_url let url_for_keyword = let ht = Hashtbl.create 97 in - lazy ( - begin try - let cin = - try open_in (lib_ide_file "index_urls.txt") + lazy ( + begin try + let cin = + try let index_urls = Filename.concat (List.find + (fun x -> Sys.file_exists (Filename.concat x "index_urls.txt")) + Minilib.xdg_config_dirs) "index_urls.txt" in + open_in index_urls + with Not_found -> + let doc_url = doc_url () in + let n = String.length doc_url in + if n > 8 && String.sub doc_url 0 7 = "file://" then + open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt") + else + raise Exit + in + try while true do + let s = input_line cin in + try + let i = String.index s ',' in + let k = String.sub s 0 i in + let u = String.sub s (i + 1) (String.length s - i - 1) in + Hashtbl.add ht k u + with _ -> + Minilib.safe_prerr_endline "Warning: Cannot parse documentation index file." + done with End_of_file -> + close_in cin with _ -> - let doc_url = doc_url () in - let n = String.length doc_url in - if n > 8 && String.sub doc_url 0 7 = "file://" then - open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt") - else - raise Exit - in - try while true do - let s = input_line cin in - try - let i = String.index s ',' in - let k = String.sub s 0 i in - let u = String.sub s (i + 1) (String.length s - i - 1) in - Hashtbl.add ht k u - with _ -> - Printf.eprintf "Warning: Cannot parse documentation index file.\n"; - flush stderr - done with End_of_file -> - close_in cin - with _ -> - Printf.eprintf "Warning: Cannot find documentation index file.\n"; - flush stderr - end; - Hashtbl.find ht : string -> string) - + Minilib.safe_prerr_endline "Warning: Cannot find documentation index file." + end; + Hashtbl.find ht : string -> string) let browse_keyword f text = try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u) with Not_found -> f ("No documentation found for \""^text^"\".\n") - -(* - checks if two file names refer to the same (existing) file by - comparing their device and inode. - It seems that under Windows, inode is always 0, so we cannot - accurately check if - -*) -(* Optimised for partial application (in case many candidates must be - compared to f1). *) -let same_file f1 = - try - let s1 = Unix.stat f1 in - (fun f2 -> - try - let s2 = Unix.stat f2 in - s1.Unix.st_dev = s2.Unix.st_dev && - if Sys.os_type = "Win32" then f1 = f2 - else s1.Unix.st_ino = s2.Unix.st_ino - with - Unix.Unix_error _ -> false) - with - Unix.Unix_error _ -> (fun _ -> false) - -let absolute_filename f = - if Filename.is_relative f then - Filename.concat (Sys.getcwd ()) f - else f - +let absolute_filename f = Minilib.correct_path f (Sys.getcwd ()) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index d6311c78..1e29d323 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit) -> 'a -> unit val sync : ('a -> 'b) -> 'a -> 'b @@ -18,8 +16,6 @@ val doc_url : unit -> string val browse : (string -> unit) -> string -> unit val browse_keyword : (string -> unit) -> string -> unit val byte_offset_to_char_offset : string -> int -> int -val init_stdout : unit -> unit -val clear_stdout : unit -> unit val debug : bool ref val disconnect_revert_timer : unit -> unit val disconnect_auto_save_timer : unit -> unit @@ -31,15 +27,13 @@ val get_insert : < get_iter_at_mark : [> `INSERT] -> 'a; .. > -> 'a val is_char_start : char -> bool -val lib_ide_file : string -> string val my_stat : string -> Unix.stats option -val safe_prerr_endline : string -> unit +(** debug printing *) val prerr_endline : string -> unit -val prerr_string : string -> unit + val print_id : 'a -> unit -val read_stdout : unit -> string val revert_timer : GMain.Timeout.id option ref val auto_save_timer : GMain.Timeout.id option ref val select_file_for_open : @@ -69,13 +63,6 @@ val set_location : (string -> unit) ref val pbar : GRange.progress_bar - -(* - checks if two file names refer to the same (existing) file -*) - -val same_file : string -> string -> bool - (* returns an absolute filename equivalent to given filename *) diff --git a/ide/mac_default_accel_map b/ide/mac_default_accel_map new file mode 100644 index 00000000..4d34636f --- /dev/null +++ b/ide/mac_default_accel_map @@ -0,0 +1,372 @@ +; coqide.opt GtkAccelMap rc-file -*- scheme -*- +; this file is an automated accelerator map dump +; +; (gtk_accel_path "/C_anonical Structure/" "") +; (gtk_accel_path "/M_odule Type/" "") +; (gtk_accel_path "/c_ompute/" "") +; (gtk_accel_path "/Templates/_E.../" "") +(gtk_accel_path "/Templates/match" "c") +; (gtk_accel_path "/D_erive Inversion/" "") +; (gtk_accel_path "/Queries/Check" "F3") +; (gtk_accel_path "/i_dtac/" "") +; (gtk_accel_path "/L_oad/" "") +; (gtk_accel_path "/a_ssert/" "") +; (gtk_accel_path "/f_irstorder using/" "") +; (gtk_accel_path "/s_olve/" "") +; (gtk_accel_path "/Tactics/_l.../" "") +(gtk_accel_path "/Templates/Inductive" "i") +; (gtk_accel_path "/a_ssert (__:__)/" "") +; (gtk_accel_path "/T_est Printing Synth/" "") +; (gtk_accel_path "/Templates/_R.../" "") +; (gtk_accel_path "/Help/Browse Coq Library" "") +; (gtk_accel_path "/U_nset Extraction Optimize/" "") +; (gtk_accel_path "/s_imple inversion/" "") +(gtk_accel_path "/Edit/Copy" "c") +; (gtk_accel_path "/E_xtract Inductive/" "") +(gtk_accel_path "/Edit/Cut" "x") +; (gtk_accel_path "/i_nfo/" "") +; (gtk_accel_path "/R_emove Printing If/" "") +; (gtk_accel_path "/e_apply/" "") +; (gtk_accel_path "/F_ixpoint/" "") +; (gtk_accel_path "/c_hange __ in/" "") +; (gtk_accel_path "/l_apply/" "") +; (gtk_accel_path "/s_imple induction/" "") +; (gtk_accel_path "/f_ail/" "") +; (gtk_accel_path "/e_lim/" "") +; (gtk_accel_path "/r_ewrite <- __ in/" "") +; (gtk_accel_path "/A_dd Printing Let/" "") +; (gtk_accel_path "/T_ransparent/" "") +; (gtk_accel_path "/Tactics/_d.../" "") +(gtk_accel_path "/Tactics/Wizard" "dollar") +; (gtk_accel_path "/Windows/Detach View" "") +; (gtk_accel_path "/T_heorem/" "") +(gtk_accel_path "/Templates/Scheme" "s") +; (gtk_accel_path "/R_emark/" "") +; (gtk_accel_path "/Compile/Compile" "") +; (gtk_accel_path "/A_dd Relation/" "") +; (gtk_accel_path "/r_ename __ into/" "") +; (gtk_accel_path "/File/Save as" "") +; (gtk_accel_path "/f_irstorder/" "") +; (gtk_accel_path "/G_rammar/" "") +; (gtk_accel_path "/f_irstorder with/" "") +; (gtk_accel_path "/r_ed/" "") +; (gtk_accel_path "/D_efinition/" "") +; (gtk_accel_path "/R_equire Import/" "") +; (gtk_accel_path "/d_iscriminate/" "") +; (gtk_accel_path "/i_ntro after/" "") +; (gtk_accel_path "/Export/Latex" "") +; (gtk_accel_path "/j_p/" "") +; (gtk_accel_path "/a_uto with/" "") +; (gtk_accel_path "/S_ection/" "") +; (gtk_accel_path "/r_ewrite/" "") +; (gtk_accel_path "/Export/Html" "") +; (gtk_accel_path "/Tactics/_i.../" "") +; (gtk_accel_path "/a_utorewrite/" "") +; (gtk_accel_path "/F_ocus/" "") +; (gtk_accel_path "/Templates/_O.../" "") +; (gtk_accel_path "/l_azy in/" "") +; (gtk_accel_path "/d_ependent inversion__clear __ with/" "") +; (gtk_accel_path "/c_utrewrite/" "") +(gtk_accel_path "/Edit/Undo" "u") +; (gtk_accel_path "/c_onstructor __ with/" "") +; (gtk_accel_path "/r_ing/" "") +; (gtk_accel_path "/d_ependent rewrite <-/" "") +; (gtk_accel_path "/e_limtype/" "") +(gtk_accel_path "/Tactics/simpl" "s") +; (gtk_accel_path "/H_int/" "") +; (gtk_accel_path "/H_int Rewrite/" "") +; (gtk_accel_path "/V_ariable/" "") +; (gtk_accel_path "/U_nset Implicit Arguments/" "") +; (gtk_accel_path "/s_implify__eq/" "") +; (gtk_accel_path "/Compile/Next error" "F7") +; (gtk_accel_path "/Edit/Edit" "") +; (gtk_accel_path "/S_et Extraction Optimize/" "") +; (gtk_accel_path "/H_ypothesis/" "") +; (gtk_accel_path "/E_nd Silent./" "") +; (gtk_accel_path "/S_yntax/" "") +; (gtk_accel_path "/d_ecide equality/" "") +; (gtk_accel_path "/O_paque/" "") +; (gtk_accel_path "/Templates/_T.../" "") +; (gtk_accel_path "/Tactics/_a.../" "") +; (gtk_accel_path "/Templates/_G.../" "") +; (gtk_accel_path "/c_ase/" "") +(gtk_accel_path "/Navigation/Backward" "Up") +; (gtk_accel_path "/C_oFixpoint/" "") +; (gtk_accel_path "/P_rogram Fixpoint/" "") +; (gtk_accel_path "/d_ependent inversion__clear/" "") +; (gtk_accel_path "/c_ase __ with/" "") +; (gtk_accel_path "/a_ssumption/" "") +; (gtk_accel_path "/t_ransitivity/" "") +; (gtk_accel_path "/i_ntros until/" "") +; (gtk_accel_path "/s_plit/" "") +; (gtk_accel_path "/e_xists/" "") +(gtk_accel_path "/Templates/Theorem" "t") +; (gtk_accel_path "/Navigation/Navigation" "") +; (gtk_accel_path "/H_int Unfold/" "") +; (gtk_accel_path "/I_mplicit Arguments/" "") +; (gtk_accel_path "/Help/Help" "") +; (gtk_accel_path "/d_ecompose sum/" "") +; (gtk_accel_path "/A_dd Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T./" "") +; (gtk_accel_path "/Te_mplates/" "") +(gtk_accel_path "/Edit/Find in buffer" "f") +; (gtk_accel_path "/r_eplace __ with/" "") +(gtk_accel_path "/Tactics/omega" "o") +; (gtk_accel_path "/S_cheme/" "") +; (gtk_accel_path "/L_emma/" "") +; (gtk_accel_path "/i_nversion__clear __ in/" "") +; (gtk_accel_path "/E_xtraction Inline/" "") +; (gtk_accel_path "/S_yntactic Definition/" "") +; (gtk_accel_path "/i_nstantiate (__:=__)/" "") +; (gtk_accel_path "/C_hapter/" "") +; (gtk_accel_path "/Templates/_L.../" "") +; (gtk_accel_path "/Tactics/_f.../" "") +; (gtk_accel_path "/Queries/Queries" "") +; (gtk_accel_path "/T_est Printing Wildcard/" "") +(gtk_accel_path "/File/Open" "o") +; (gtk_accel_path "/f_old __ in/" "") +(gtk_accel_path "/Navigation/Go to" "Right") +; (gtk_accel_path "/Export/Export to" "") +; (gtk_accel_path "/c_ongruence/" "") +; (gtk_accel_path "/c_learbody/" "") +(gtk_accel_path "/File/Close buffer" "w") +; (gtk_accel_path "/a_pply/" "") +; (gtk_accel_path "/Queries/SearchAbout" "F2") +; (gtk_accel_path "/i_ntro/" "") +; (gtk_accel_path "/H_int Immediate/" "") +; (gtk_accel_path "/p_ose __:=__)/" "") +; (gtk_accel_path "/U_nset Undo/" "") +; (gtk_accel_path "/Tactics/_s.../" "") +; (gtk_accel_path "/P_rogram Definition/" "") +; (gtk_accel_path "/R_equire/" "") +; (gtk_accel_path "/c_ompare/" "") +; (gtk_accel_path "/s_ymmetry in/" "") +(gtk_accel_path "/Display/Display coercions" "c") +(gtk_accel_path "/Navigation/Previous" "less") +(gtk_accel_path "/Display/Display all low-level contents" "l") +; (gtk_accel_path "/C_oercion Local/" "") +; (gtk_accel_path "/f_ix __ with/" "") +; (gtk_accel_path "/A_dd ML Path/" "") +; (gtk_accel_path "/A_xiom/" "") +; (gtk_accel_path "/Templates/Templates" "") +; (gtk_accel_path "/a_bstract/" "") +; (gtk_accel_path "/Edit/Clear Undo Stack" "") +(gtk_accel_path "/File/New" "n") +; (gtk_accel_path "/Tactics/_hnf/" "") +; (gtk_accel_path "/d_o/" "") +; (gtk_accel_path "/E_xtract Constant/" "") +; (gtk_accel_path "/E_nd/" "") +; (gtk_accel_path "/Templates/_Qed./" "") +; (gtk_accel_path "/A_dd Rec ML Path/" "") +; (gtk_accel_path "/Templates/_D.../" "") +(gtk_accel_path "/Navigation/Hide" "h") +; (gtk_accel_path "/c_ofix/" "") +; (gtk_accel_path "/_Try Tactics/" "") +; (gtk_accel_path "/S_et Printing Wildcard/" "") +; (gtk_accel_path "/i_nversion__clear/" "") +; (gtk_accel_path "/Templates/_V.../" "") +; (gtk_accel_path "/Export/Ps" "") +; (gtk_accel_path "/U_nset Hyps__limit/" "") +; (gtk_accel_path "/H_int Extern/" "") +; (gtk_accel_path "/f_unctional induction/" "") +; (gtk_accel_path "/U_nset Extraction AutoInline/" "") +; (gtk_accel_path "/U_nfocus/" "") +; (gtk_accel_path "/Edit/External editor" "") +; (gtk_accel_path "/I_dentity Coercion/" "") +; (gtk_accel_path "/a_bsurd/" "") +; (gtk_accel_path "/c_hange/" "") +(gtk_accel_path "/Tactics/eauto" "e") +; (gtk_accel_path "/O_bligations Tactic/" "") +(gtk_accel_path "/Tactics/trivial" "v") +; (gtk_accel_path "/d_ependent inversion/" "") +; (gtk_accel_path "/c_bv/" "") +; (gtk_accel_path "/A_dd Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. /" "") +; (gtk_accel_path "/p_ose/" "") +; (gtk_accel_path "/s_et (__:=__)/" "") +; (gtk_accel_path "/R_equire Export/" "") +; (gtk_accel_path "/L_tac/" "") +; (gtk_accel_path "/A_dd Rec LoadPath/" "") +; (gtk_accel_path "/Tactics/_c.../" "") +(gtk_accel_path "/Navigation/End" "End") +(gtk_accel_path "/Templates/Lemma" "l") +(gtk_accel_path "/Navigation/Start" "Home") +; (gtk_accel_path "/Templates/_I.../" "") +(gtk_accel_path "/File/Print..." "p") +; (gtk_accel_path "/d_ependent rewrite ->/" "") +; (gtk_accel_path "/S_tructure/" "") +; (gtk_accel_path "/T_est Printing Let/" "") +; (gtk_accel_path "/T_ime/" "") +; (gtk_accel_path "/g_eneralize/" "") +(gtk_accel_path "/Display/Display all basic low-level contents" "a") +; (gtk_accel_path "/Tactics/_p.../" "") +; (gtk_accel_path "/f_old/" "") +; (gtk_accel_path "/H_int Resolve/" "") +; (gtk_accel_path "/M_utual Inductive/" "") +; (gtk_accel_path "/i_nversion __ in/" "") +; (gtk_accel_path "/Windows/Show/Hide Toolbar" "") +(gtk_accel_path "/File/Save" "s") +; (gtk_accel_path "/File/Save all" "") +; (gtk_accel_path "/Queries/Print" "F4") +; (gtk_accel_path "/c_onstructor/" "") +; (gtk_accel_path "/Export/Dvi" "") +; (gtk_accel_path "/s_etoid__replace/" "") +; (gtk_accel_path "/D_efined./" "") +; (gtk_accel_path "/I_nfix/" "") +(gtk_accel_path "/Navigation/Next" "greater") +; (gtk_accel_path "/A_dd Morphism/" "") +; (gtk_accel_path "/Windows/Windows" "") +; (gtk_accel_path "/e_xact/" "") +; (gtk_accel_path "/c_bv in/" "") +; (gtk_accel_path "/t_ry/" "") +; (gtk_accel_path "/Templates/_A.../" "") +(gtk_accel_path "/Display/Display notations" "n") +; (gtk_accel_path "/c_lear/" "") +; (gtk_accel_path "/Compile/Make" "F6") +(gtk_accel_path "/Tactics/eauto with *" "ampersand") +; (gtk_accel_path "/Help/Browse Coq Manual" "") +; (gtk_accel_path "/Templates/_N.../" "") +(gtk_accel_path "/File/Quit" "q") +; (gtk_accel_path "/u_nfold/" "") +; (gtk_accel_path "/Tactics/_u.../" "") +; (gtk_accel_path "/d_ouble induction/" "") +; (gtk_accel_path "/S_et Silent./" "") +; (gtk_accel_path "/V_ariables/" "") +; (gtk_accel_path "/U_nset Printing Wildcard/" "") +; (gtk_accel_path "/r_ewrite <-/" "") +; (gtk_accel_path "/I_nductive/" "") +; (gtk_accel_path "/e_auto with/" "") +; (gtk_accel_path "/r_epeat/" "") +; (gtk_accel_path "/Queries/Locate" "") +; (gtk_accel_path "/S_et Hyps__limit/" "") +; (gtk_accel_path "/A_dd Abstract Semi Ring A Aplus Amult Aone Azero Aeq T./" "") +; (gtk_accel_path "/c_ompute in/" "") +; (gtk_accel_path "/Templates/_F.../" "") +; (gtk_accel_path "/G_lobal Variable/" "") +; (gtk_accel_path "/t_auto/" "") +; (gtk_accel_path "/E_xtraction NoInline/" "") +; (gtk_accel_path "/u_nfold __ in/" "") +; (gtk_accel_path "/s_imple destruct/" "") +(gtk_accel_path "/Navigation/Interrupt" "Break") +; (gtk_accel_path "/Templates/_S.../" "") +; (gtk_accel_path "/i_njection/" "") +; (gtk_accel_path "/R_ead Module/" "") +; (gtk_accel_path "/P_rogram Lemma/" "") +; (gtk_accel_path "/U_nset Silent./" "") +(gtk_accel_path "/Display/Display universe levels" "u") +; (gtk_accel_path "/f_ourier/" "") +; (gtk_accel_path "/D_erive Inversion__clear/" "") +; (gtk_accel_path "/Tactics/_omega/" "") +; (gtk_accel_path "/S_et Undo/" "") +; (gtk_accel_path "/A_dd Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]./" "") +; (gtk_accel_path "/s_impl __ in/" "") +; (gtk_accel_path "/Windows/Show/Hide Query Pane" "Escape") +; (gtk_accel_path "/R_estore State/" "") +; (gtk_accel_path "/R_emove Printing Let/" "") +; (gtk_accel_path "/A_dd Printing If/" "") +(gtk_accel_path "/Tactics/tauto" "p") +; (gtk_accel_path "/s_impl/" "") +; (gtk_accel_path "/i_ntros/" "") +; (gtk_accel_path "/s_ymmetry/" "") +; (gtk_accel_path "/c_ut/" "") +; (gtk_accel_path "/r_efine/" "") +; (gtk_accel_path "/Tactics/_e.../" "") +; (gtk_accel_path "/e_exact/" "") +(gtk_accel_path "/Navigation/Forward" "Down") +(gtk_accel_path "/Edit/Paste" "v") +; (gtk_accel_path "/C_oercion/" "") +; (gtk_accel_path "/Tactics/_r.../" "") +; (gtk_accel_path "/d_estruct/" "") +; (gtk_accel_path "/A_dd Setoid/" "") +; (gtk_accel_path "/Queries/Whelp Locate" "") +; (gtk_accel_path "/T_est Printing If/" "") +; (gtk_accel_path "/Display/Display" "") +; (gtk_accel_path "/Tactics/_move __ after/" "") +(gtk_accel_path "/Edit/Complete Word" "slash") +; (gtk_accel_path "/s_ubst/" "") +; (gtk_accel_path "/Help/About Coq" "") +; (gtk_accel_path "/s_etoid__rewrite/" "") +; (gtk_accel_path "/Tactics/Try Tactics" "") +; (gtk_accel_path "/Templates/_C.../" "") +; (gtk_accel_path "/L_ocal/" "") +; (gtk_accel_path "/s_et/" "") +; (gtk_accel_path "/Tactics/_quote/" "") +(gtk_accel_path "/Templates/Definition" "d") +; (gtk_accel_path "/S_et Implicit Arguments/" "") +; (gtk_accel_path "/File/Revert all buffers" "") +; (gtk_accel_path "/Templates/_P.../" "") +; (gtk_accel_path "/t_rivial/" "") +(gtk_accel_path "/Display/Display existential variable instances" "e") +; (gtk_accel_path "/Tactics/_j.../" "") +; (gtk_accel_path "/A_dd LoadPath/" "") +; (gtk_accel_path "/N_otation/" "") +; (gtk_accel_path "/Edit/Preferences" "") +; (gtk_accel_path "/L_oad Verbose/" "") +; (gtk_accel_path "/i_ntro __ after/" "") +; (gtk_accel_path "/D_erive Dependent Inversion/" "") +; (gtk_accel_path "/d_ependent inversion __ with/" "") +; (gtk_accel_path "/P_rogram Theorem/" "") +; (gtk_accel_path "/E_xtraction Language/" "") +; (gtk_accel_path "/Templates/_U.../" "") +(gtk_accel_path "/Display/Display raw matching expressions" "m") +; (gtk_accel_path "/c_asetype/" "") +(gtk_accel_path "/Edit/Find backwards" "b") +; (gtk_accel_path "/S_ave./" "") +; (gtk_accel_path "/p_attern/" "") +; (gtk_accel_path "/M_odule/" "") +; (gtk_accel_path "/D_eclare ML Module/" "") +; (gtk_accel_path "/Templates/_H.../" "") +; (gtk_accel_path "/F_act/" "") +; (gtk_accel_path "/A_dd Field/" "") +; (gtk_accel_path "/R_emove LoadPath/" "") +; (gtk_accel_path "/Templates/_Write State/" "") +; (gtk_accel_path "/Compile/Make makefile" "") +; (gtk_accel_path "/C_oInductive/" "") +; (gtk_accel_path "/Compile/Compile buffer" "") +; (gtk_accel_path "/l_eft/" "") +; (gtk_accel_path "/a_pply __ with/" "") +(gtk_accel_path "/File/Rehighlight" "l") +; (gtk_accel_path "/File/File" "") +; (gtk_accel_path "/D_erive Dependent Inversion__clear/" "") +; (gtk_accel_path "/d_ecompose/" "") +; (gtk_accel_path "/r_ewrite __ in/" "") +(gtk_accel_path "/Display/Display implicit arguments" "i") +; (gtk_accel_path "/e_lim __ using/" "") +; (gtk_accel_path "/a_ssert (__:=__)/" "") +; (gtk_accel_path "/i_nversion __ using/" "") +; (gtk_accel_path "/P_arameter/" "") +; (gtk_accel_path "/H_int Constructors/" "") +; (gtk_accel_path "/j_p /" "") +; (gtk_accel_path "/p_rogress/" "") +; (gtk_accel_path "/Templates/_M.../" "") +; (gtk_accel_path "/e_lim __ with/" "") +; (gtk_accel_path "/f_irst/" "") +; (gtk_accel_path "/l_azy/" "") +; (gtk_accel_path "/i_nversion/" "") +(gtk_accel_path "/Help/Help for keyword" "h") +; (gtk_accel_path "/a_uto/" "") +; (gtk_accel_path "/G_oal/" "") +; (gtk_accel_path "/i_nversion __ using __ in/" "") +(gtk_accel_path "/Tactics/intuition" "i") +; (gtk_accel_path "/r_ed in/" "") +; (gtk_accel_path "/Tactics/_g.../" "") +; (gtk_accel_path "/g_eneralize dependent/" "") +; (gtk_accel_path "/Queries/About" "F5") +; (gtk_accel_path "/r_ight/" "") +(gtk_accel_path "/Tactics/auto" "a") +(gtk_accel_path "/Templates/Fixpoint" "f") +; (gtk_accel_path "/r_eflexivity/" "") +; (gtk_accel_path "/i_nduction/" "") +; (gtk_accel_path "/i_ntuition/" "") +; (gtk_accel_path "/Tactics/_t.../" "") +; (gtk_accel_path "/f_ix/" "") +; (gtk_accel_path "/Export/Pdf" "") +; (gtk_accel_path "/N_ext Obligation/" "") +(gtk_accel_path "/Tactics/auto with *" "asterisk") +; (gtk_accel_path "/R_ecord/" "") +; (gtk_accel_path "/P_roof./" "") +; (gtk_accel_path "/c_ontradiction/" "") +; (gtk_accel_path "/S_et Extraction AutoInline/" "") +; (gtk_accel_path "/e_auto/" "") +; (gtk_accel_path "/d_ecompose record/" "") +; (gtk_accel_path "/f_ield/" "") +; (gtk_accel_path "/E_val/" "") +; (gtk_accel_path "/R_eset Extraction Inline/" "") diff --git a/ide/minilib.ml b/ide/minilib.ml new file mode 100644 index 00000000..cec77f3b --- /dev/null +++ b/ide/minilib.ml @@ -0,0 +1,174 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a + | b::l -> it_list_f (i+1) (f i a b) l + in + it_list_f + +(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that + [l1++l2=l] and [l1] has length [i]. + It raises [Failure] when [i] is negative or greater than the length of [l] *) + +let list_chop n l = + let rec chop_aux i acc = function + | tl when i=0 -> (List.rev acc, tl) + | h::t -> chop_aux (pred i) (h::acc) t + | [] -> failwith "list_chop" + in + chop_aux n [] l + + +let list_map_i f = + let rec map_i_rec i = function + | [] -> [] + | x::l -> let v = f i x in v :: map_i_rec (i+1) l + in + map_i_rec + + +let list_index x = + let rec index_x n = function + | y::l -> if x = y then n else index_x (succ n) l + | [] -> raise Not_found + in + index_x 1 + +let list_index0 x l = list_index x l - 1 + +let list_filter_i p = + let rec filter_i_rec i = function + | [] -> [] + | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' + in + filter_i_rec 0 + +let string_map f s = + let l = String.length s in + let r = String.create l in + for i= 0 to (l - 1) do r.[i] <- f (s.[i]) done; + r + +let subst_command_placeholder s t = + Str.global_replace (Str.regexp_string "%s") t s + +let path_to_list p = + let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in + Str.split sep p + +(* On win32, the home directory is probably not in $HOME, but in + some other environment variable *) + +let home = + try Sys.getenv "HOME" with Not_found -> + try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> + try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name + +let xdg_config_home = + try + Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq" + with Not_found -> + Filename.concat home "/.config/coq" + +let xdg_config_dirs = + xdg_config_home :: (try + List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) + with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with |None -> [] |Some d -> [d])) + +let xdg_data_home = + try + Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq" + with Not_found -> + Filename.concat home "/.local/share/coq" + +let xdg_data_dirs = + xdg_data_home :: (try + List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) + with Not_found -> + "/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with |None -> [] |Some d -> [d])) + +let coqtop_path = ref "" + +(* On a Win32 application with no console, writing to stderr raise + a Sys_error "bad file descriptor", hence the "try" below. + Ideally, we should re-route message to a log file somewhere, or + print in the response buffer. +*) + +let safe_prerr_endline s = + try prerr_endline s;flush stderr with _ -> () + +(* Hints to partially detects if two paths refer to the same repertory *) +let rec remove_path_dot p = + let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) + let n = String.length curdir in + let l = String.length p in + if l > n && String.sub p 0 n = curdir then + let n' = + let sl = String.length Filename.dir_sep in + let i = ref n in + while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in + remove_path_dot (String.sub p n' (l - n')) + else + p + +let strip_path p = + let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) + let n = String.length cwd in + let l = String.length p in + if l > n && String.sub p 0 n = cwd then + let n' = + let sl = String.length Filename.dir_sep in + let i = ref n in + while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in + remove_path_dot (String.sub p n' (l - n')) + else + remove_path_dot p + +let canonical_path_name p = + let current = Sys.getcwd () in + try + Sys.chdir p; + let p' = Sys.getcwd () in + Sys.chdir current; + p' + with Sys_error _ -> + (* We give up to find a canonical name and just simplify it... *) + strip_path p + +let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f + +(* + checks if two file names refer to the same (existing) file by + comparing their device and inode. + It seems that under Windows, inode is always 0, so we cannot + accurately check if + +*) +(* Optimised for partial application (in case many candidates must be + compared to f1). *) +let same_file f1 = + try + let s1 = Unix.stat f1 in + (fun f2 -> + try + let s2 = Unix.stat f2 in + s1.Unix.st_dev = s2.Unix.st_dev && + if Sys.os_type = "Win32" then f1 = f2 + else s1.Unix.st_ino = s2.Unix.st_ino + with + Unix.Unix_error _ -> false) + with + Unix.Unix_error _ -> (fun _ -> false) diff --git a/ide/minilib.mli b/ide/minilib.mli new file mode 100644 index 00000000..53d6c87c --- /dev/null +++ b/ide/minilib.mli @@ -0,0 +1,44 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a +val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list +val list_filter_i : (int -> 'a -> bool) -> 'a list -> 'a list +val list_chop : int -> 'a list -> 'a list * 'a list +val list_index0 : 'a -> 'a list -> int + +val string_map : (char -> char) -> string -> string + +val subst_command_placeholder : string -> string -> string + +val home : string +val xdg_config_home : string +val xdg_config_dirs : string list +val xdg_data_home : string +val xdg_data_dirs : string list + +val coqtop_path : string ref + +(** safe version of Pervasives.prerr_endline + (avoid exception in win32 without console) *) +val safe_prerr_endline : string -> unit + +val remove_path_dot : string -> string +val strip_path : string -> string +val canonical_path_name : string -> string +(** correct_path f dir = dir/f if f is relative *) +val correct_path : string -> string -> string + +(** checks if two file names refer to the same (existing) file *) +val same_file : string -> string -> bool + diff --git a/ide/preferences.ml b/ide/preferences.ml index 790bf560..02673098 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -1,53 +1,44 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "MOD1" - | `MOD2 -> "MOD2" - | `MOD3 -> "MOD3" - | `MOD4 -> "MOD4" - | `MOD5 -> "MOD5" - | `BUTTON1 -> "BUTTON1" - | `BUTTON2 -> "BUTTON2" - | `BUTTON3 -> "BUTTON3" - | `BUTTON4 -> "BUTTON4" - | `BUTTON5 -> "BUTTON5" - | `CONTROL -> "CONTROL" - | `LOCK -> "LOCK" - | `SHIFT -> "SHIFT" - -let (str_to_mod:string -> Gdk.Tags.modifier) = - function - | "MOD1" -> `MOD1 - | "MOD2" -> `MOD2 - | "MOD3" -> `MOD3 - | "MOD4" -> `MOD4 - | "MOD5" -> `MOD5 - | "BUTTON1" -> `BUTTON1 - | "BUTTON2" -> `BUTTON2 - | "BUTTON3" -> `BUTTON3 - | "BUTTON4" -> `BUTTON4 - | "BUTTON5" -> `BUTTON5 - | "CONTROL" -> `CONTROL - | "LOCK" -> `LOCK - | "SHIFT" -> `SHIFT - | s -> `MOD1 + | `MOD1 -> "" + | `MOD2 -> "" + | `MOD3 -> "" + | `MOD4 -> "" + | `MOD5 -> "" + | `CONTROL -> "" + | `SHIFT -> "" + | `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> "" + +let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l + +let str_to_mod_list s = snd (GtkData.AccelGroup.parse s) + +type project_behavior = Ignore_args | Append_args | Subst_args + +let string_of_project_behavior = function + |Ignore_args -> "ignored" + |Append_args -> "appended to arguments" + |Subst_args -> "taken instead of arguments" + +let project_behavior_of_string s = + if s = "taken instead of arguments" then Subst_args + else if s = "appended to arguments" then Append_args + else Ignore_args type pref = { @@ -63,6 +54,9 @@ type pref = mutable auto_save_delay : int; mutable auto_save_name : string * string; + mutable read_project : project_behavior; + mutable project_file_name : string; + mutable encoding_use_locale : bool; mutable encoding_use_utf8 : bool; mutable encoding_manual : string; @@ -70,11 +64,11 @@ type pref = mutable automatic_tactics : string list; mutable cmd_print : string; - mutable modifier_for_navigation : Gdk.Tags.modifier list; - mutable modifier_for_templates : Gdk.Tags.modifier list; - mutable modifier_for_tactics : Gdk.Tags.modifier list; - mutable modifier_for_display : Gdk.Tags.modifier list; - mutable modifiers_valid : Gdk.Tags.modifier list; + mutable modifier_for_navigation : string; + mutable modifier_for_templates : string; + mutable modifier_for_tactics : string; + mutable modifier_for_display : string; + mutable modifiers_valid : string; mutable cmd_browse : string; mutable cmd_editor : string; @@ -117,6 +111,9 @@ let (current:pref ref) = auto_save_delay = 10000; auto_save_name = "#","#"; + read_project = Ignore_args; + project_file_name = "_CoqProject"; + encoding_use_locale = true; encoding_use_utf8 = false; encoding_manual = "ISO_8859-1"; @@ -124,18 +121,20 @@ let (current:pref ref) = automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; - modifier_for_navigation = [`CONTROL; `MOD1]; - modifier_for_templates = [`CONTROL; `SHIFT]; - modifier_for_tactics = [`CONTROL; `MOD1]; - modifier_for_display = [`MOD1;`SHIFT]; - modifiers_valid = [`SHIFT; `CONTROL; `MOD1]; + modifier_for_navigation = ""; + modifier_for_templates = ""; + modifier_for_tactics = ""; + modifier_for_display = ""; + modifiers_valid = ""; cmd_browse = Flags.browser_cmd_fmt; cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s"; (* text_font = Pango.Font.from_string "sans 12";*) - text_font = Pango.Font.from_string "Monospace 10"; + text_font = Pango.Font.from_string (match Coq_config.gtk_platform with + |`QUARTZ -> "Arial Unicode MS 11" + |_ -> "Monospace 10"); doc_url = Coq_config.wwwrefman; library_url = Coq_config.wwwstdlib; @@ -168,13 +167,15 @@ let contextual_menus_on_goal = ref (fun x -> ()) let resize_window = ref (fun () -> ()) let save_pref () = + if not (Sys.file_exists Minilib.xdg_config_home) + then Unix.mkdir Minilib.xdg_config_home 0o700; (try GtkData.AccelMap.save accel_file with _ -> ()); let p = !current in - try - let add = Stringmap.add in + + let add = Minilib.Stringmap.add in let (++) x f = f x in - Stringmap.empty ++ + Minilib.Stringmap.empty ++ add "cmd_coqc" [p.cmd_coqc] ++ add "cmd_make" [p.cmd_make] ++ add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ @@ -186,22 +187,20 @@ let save_pref () = add "auto_save_delay" [string_of_int p.auto_save_delay] ++ add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++ + add "project_options" [string_of_project_behavior p.read_project] ++ + add "project_file_name" [p.project_file_name] ++ + add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++ add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++ add "encoding_manual" [p.encoding_manual] ++ add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ - add "modifier_for_navigation" - (List.map mod_to_str p.modifier_for_navigation) ++ - add "modifier_for_templates" - (List.map mod_to_str p.modifier_for_templates) ++ - add "modifier_for_tactics" - (List.map mod_to_str p.modifier_for_tactics) ++ - add "modifier_for_display" - (List.map mod_to_str p.modifier_for_display) ++ - add "modifiers_valid" - (List.map mod_to_str p.modifiers_valid) ++ + add "modifier_for_navigation" [p.modifier_for_navigation] ++ + add "modifier_for_templates" [p.modifier_for_templates] ++ + add "modifier_for_tactics" [p.modifier_for_tactics] ++ + add "modifier_for_display" [p.modifier_for_display] ++ + add "modifiers_valid" [p.modifiers_valid] ++ add "cmd_browse" [p.cmd_browse] ++ add "cmd_editor" [p.cmd_editor] ++ @@ -222,15 +221,17 @@ let save_pref () = add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ Config_lexer.print_file pref_file - with _ -> prerr_endline "Could not save preferences." let load_pref () = - (try GtkData.AccelMap.load accel_file with _ -> ()); + let accel_dir = List.find + (fun x -> Sys.file_exists (Filename.concat x "coqide.keys")) + Minilib.xdg_config_dirs in + GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys"); let p = !current in - try + let m = Config_lexer.load_file pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in - let set k f = try let v = Stringmap.find k m in f v with _ -> () in + let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in let set_hd k f = set k (fun v -> f (List.hd v)) in let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in let set_int k f = set_hd k (fun v -> f (int_of_string v)) in @@ -251,19 +252,22 @@ let load_pref () = set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v); set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v); set_hd "encoding_manual" (fun v -> np.encoding_manual <- v); + set_hd "project_options" + (fun v -> np.read_project <- (project_behavior_of_string v)); + set_hd "project_file_name" (fun v -> np.project_file_name <- v); set "automatic_tactics" (fun v -> np.automatic_tactics <- v); set_hd "cmd_print" (fun v -> np.cmd_print <- v); - set "modifier_for_navigation" - (fun v -> np.modifier_for_navigation <- List.map str_to_mod v); - set "modifier_for_templates" - (fun v -> np.modifier_for_templates <- List.map str_to_mod v); - set "modifier_for_tactics" - (fun v -> np.modifier_for_tactics <- List.map str_to_mod v); - set "modifier_for_display" - (fun v -> np.modifier_for_display <- List.map str_to_mod v); - set "modifiers_valid" - (fun v -> np.modifiers_valid <- List.map str_to_mod v); + set_hd "modifier_for_navigation" + (fun v -> np.modifier_for_navigation <- v); + set_hd "modifier_for_templates" + (fun v -> np.modifier_for_templates <- v); + set_hd "modifier_for_tactics" + (fun v -> np.modifier_for_tactics <- v); + set_hd "modifier_for_display" + (fun v -> np.modifier_for_display <- v); + set_hd "modifiers_valid" + (fun v -> np.modifiers_valid <- v); set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v); set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v); set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v); @@ -274,7 +278,7 @@ let load_pref () = v <> Coq_config.wwwcoq ^ "doc" && v <> Coq_config.wwwcoq ^ "doc/" then - prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v); + (*prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*) np.doc_url <- v); set_hd "library_url" (fun v -> np.library_url <- v); set_bool "show_toolbar" (fun v -> np.show_toolbar <- v); @@ -289,21 +293,10 @@ let load_pref () = set_bool "lax_syntax" (fun v -> np.lax_syntax <- v); set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); - current := np; + current := np (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - with e -> - prerr_endline ("Could not load preferences ("^ - (Printexc.to_string e)^").") - -let split_string_format s = - try - let i = Util.string_index_from s 0 "%s" in - let pre = (String.sub s 0 i) in - let post = String.sub s (i+2) (String.length s - i - 2) in - pre,post - with Not_found -> s,"" let configure ?(apply=(fun () -> ())) () = let cmd_coqc = @@ -462,46 +455,62 @@ let configure ?(apply=(fun () -> ())) () = (if !current.encoding_use_utf8 then "UTF-8" else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual) in + let read_project = + combo + "Project file options are" + ~f:(fun s -> !current.read_project <- project_behavior_of_string s) + ~editable:false + [string_of_project_behavior Subst_args; + string_of_project_behavior Append_args; + string_of_project_behavior Ignore_args] + (string_of_project_behavior !current.read_project) + in + let project_file_name = + string "Default name for project file" + ~f:(fun s -> !current.project_file_name <- s) + !current.project_file_name + in let help_string = "restart to apply" in + let the_valid_mod = str_to_mod_list !current.modifiers_valid in let modifier_for_tactics = modifiers - ~allow:!current.modifiers_valid - ~f:(fun l -> !current.modifier_for_tactics <- l) + ~allow:the_valid_mod + ~f:(fun l -> !current.modifier_for_tactics <- mod_list_to_str l) ~help:help_string "Modifiers for Tactics Menu" - !current.modifier_for_tactics + (str_to_mod_list !current.modifier_for_tactics) in let modifier_for_templates = modifiers - ~allow:!current.modifiers_valid - ~f:(fun l -> !current.modifier_for_templates <- l) + ~allow:the_valid_mod + ~f:(fun l -> !current.modifier_for_templates <- mod_list_to_str l) ~help:help_string "Modifiers for Templates Menu" - !current.modifier_for_templates + (str_to_mod_list !current.modifier_for_templates) in let modifier_for_navigation = modifiers - ~allow:!current.modifiers_valid - ~f:(fun l -> !current.modifier_for_navigation <- l) + ~allow:the_valid_mod + ~f:(fun l -> !current.modifier_for_navigation <- mod_list_to_str l) ~help:help_string "Modifiers for Navigation Menu" - !current.modifier_for_navigation + (str_to_mod_list !current.modifier_for_navigation) in let modifier_for_display = modifiers - ~allow:!current.modifiers_valid - ~f:(fun l -> !current.modifier_for_display <- l) + ~allow:the_valid_mod + ~f:(fun l -> !current.modifier_for_display <- mod_list_to_str l) ~help:help_string "Modifiers for Display Menu" - !current.modifier_for_display + (str_to_mod_list !current.modifier_for_display) in let modifiers_valid = modifiers - ~f:(fun l -> !current.modifiers_valid <- l) + ~f:(fun l -> !current.modifiers_valid <- mod_list_to_str l) "Allowed modifiers" - !current.modifiers_valid + the_valid_mod in let cmd_editor = let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in @@ -520,8 +529,7 @@ let configure ?(apply=(fun () -> ())) () = "netscape -remote \"openURL(%s)\""; "mozilla -remote \"openURL(%s)\""; "firefox -remote \"openURL(%s,new-windows)\" || firefox %s &"; - "seamonkey -remote \"openURL(%s)\" || seamonkey %s &"; - "open -a Safari %s &" + "seamonkey -remote \"openURL(%s)\" || seamonkey %s &" ] in combo ~help:"(%s for url)" @@ -534,6 +542,8 @@ let configure ?(apply=(fun () -> ())) () = in let doc_url = let predefined = [ + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]); + Coq_config.wwwrefman; use_default_doc_url ] in combo @@ -545,11 +555,13 @@ let configure ?(apply=(fun () -> ())) () = !current.doc_url in let library_url = let predefined = [ + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]); Coq_config.wwwstdlib ] in combo "Library URL" ~f:(fun s -> !current.library_url <- s) + ~new_allowed: true (predefined@[if List.mem !current.library_url predefined then "" else !current.library_url]) !current.library_url @@ -577,27 +589,30 @@ let configure ?(apply=(fun () -> ())) () = (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) let cmds = - [Section("Fonts", + [Section("Fonts", Some `SELECT_FONT, [config_font]); - Section("Files", + Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) encodings; ]); + Section("Project", Some (`STOCK "gtk-page-setup"), + [project_file_name;read_project; + ]); (* Section("Appearance", config_appearance); *) - Section("Externals", + Section("Externals", None, [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print; cmd_editor; cmd_browse;doc_url;library_url]); - Section("Tactics Wizard", + Section("Tactics Wizard", None, [automatic_tactics]); - Section("Shortcuts", + Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation]); - Section("Misc", + Section("Misc", Some `ADD, misc)] in (* diff --git a/ide/preferences.mli b/ide/preferences.mli index 472ae30f..f55088f1 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (ML "foo.ml") *) + | MLI of string (* MLI file : foo.mli -> (MLI "foo.mli") *) + | ML4 of string (* ML4 file : foo.ml4 -> (ML4 "foo.ml4") *) + | MLLIB of string (* MLLIB file : foo.mllib -> (MLLIB "foo.mllib") *) + | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *) + | V of string (* V file : foo.v -> (V "foo") *) + | Arg of string + | Special of string * string * string (* file, dependencies, command *) + | Subdir of string + | Def of string * string (* X=foo -> Def ("X","foo") *) + | Include of string + | RInclude of string * string (* -R physicalpath logicalpath *) + +type install = + | NoInstall + | TraditionalInstall + | UserInstall + | UnspecInstall + +exception Parsing_error +let rec parse_string = parser + | [< '' ' | '\n' | '\t' >] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string s) + | [< >] -> "" +and parse_string2 = parser + | [< ''"' >] -> "" + | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) +and parse_skip_comment = parser + | [< ''\n'; s >] -> s + | [< 'c; s >] -> parse_skip_comment s + | [< >] -> [< >] +and parse_args = parser + | [< '' ' | '\n' | '\t'; s >] -> parse_args s + | [< ''#'; s >] -> parse_args (parse_skip_comment s) + | [< ''"'; str = parse_string2; s >] -> ("" ^ str) :: parse_args s + | [< 'c; str = parse_string; s >] -> ((String.make 1 c) ^ str) :: (parse_args s) + | [< >] -> [] + + +let parse f = + let c = open_in f in + let res = parse_args (Stream.of_channel c) in + close_in c; + res + +let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function + | [] -> opts,List.rev l + | ("-h"|"--help") :: _ -> + raise Parsing_error + | ("-no-opt"|"-byte") :: r -> + process_cmd_line orig_dir (project_file,makefile,install,false) l r + | ("-full"|"-opt") :: r -> + process_cmd_line orig_dir (project_file,makefile,install,true) l r + | "-impredicative-set" :: r -> + Minilib.safe_prerr_endline "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."; + process_cmd_line orig_dir opts (Arg "-impredicative_set" :: l) r + | "-no-install" :: r -> + Minilib.safe_prerr_endline "Option -no-install is deprecated. Use \"-install none\" instead"; + process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r + | "-install" :: d :: r -> + if install <> UnspecInstall then Minilib.safe_prerr_endline "Warning: -install sets more than once."; + let install = + match d with + | "user" -> UserInstall + | "none" -> NoInstall + | "global" -> TraditionalInstall + | _ -> Minilib.safe_prerr_endline (String.concat "" ["Warning: invalid option '"; d; "' passed to -install."]); + install + in + process_cmd_line orig_dir (project_file,makefile,install,opt) l r + | "-custom" :: com :: dependencies :: file :: r -> + process_cmd_line orig_dir opts (Special (file,dependencies,com) :: l) r + | "-I" :: d :: r -> + process_cmd_line orig_dir opts ((Include (Minilib.correct_path d orig_dir)) :: l) r + | "-R" :: p :: lp :: r -> + process_cmd_line orig_dir opts (RInclude (Minilib.correct_path p orig_dir,lp) :: l) r + | ("-I"|"-custom") :: _ -> + raise Parsing_error + | "-f" :: file :: r -> + let file = Minilib.remove_path_dot (Minilib.correct_path file orig_dir) in + let () = match project_file with + | None -> () + | Some _ -> Minilib.safe_prerr_endline + "Warning: Several features will not work with multiple project files." + in + let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in + process_cmd_line orig_dir opts' l' r + | ["-f"] -> + raise Parsing_error + | "-o" :: file :: r -> + begin try + let _ = String.index file '/' in + raise Parsing_error + with Not_found -> + let () = match makefile with + |None -> () + |Some f -> + Minilib.safe_prerr_endline ("Warning: Only one output file is genererated. "^f^" will not be.") + in process_cmd_line orig_dir (project_file,Some file,install,opt) l r + end + | v :: "=" :: def :: r -> + process_cmd_line orig_dir opts (Def (v,def) :: l) r + | "-arg" :: a :: r -> + process_cmd_line orig_dir opts (Arg a :: l) r + | f :: r -> + let f = Minilib.correct_path f orig_dir in + process_cmd_line orig_dir opts (( + if Filename.check_suffix f ".v" then V f + else if (Filename.check_suffix f ".ml") then ML f + else if (Filename.check_suffix f ".ml4") then ML4 f + else if (Filename.check_suffix f ".mli") then MLI f + else if (Filename.check_suffix f ".mllib") then MLLIB f + else if (Filename.check_suffix f ".mlpack") then MLPACK f + else Subdir f) :: l) r + +let rec post_canonize f = + if Filename.basename f = Filename.current_dir_name + then let dir = Filename.dirname f in + if dir = Filename.current_dir_name then f else post_canonize dir + else f + +(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(i_inc,r_inc),(args,defs)) *) +let split_arguments = + let rec aux = function + | V n :: r -> + let (v,m,o,s),i,d = aux r in ((Minilib.remove_path_dot n::v,m,o,s),i,d) + | ML n :: r -> + let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in + ((v,(mli,ml4,Minilib.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) + | MLI n :: r -> + let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in + ((v,(Minilib.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) + | ML4 n :: r -> + let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in + ((v,(mli,Minilib.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) + | MLLIB n :: r -> + let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in + ((v,(mli,ml4,ml,Minilib.remove_path_dot n::mllib,mlpack),o,s),i,d) + | MLPACK n :: r -> + let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in + ((v,(mli,ml4,ml,mllib,Minilib.remove_path_dot n::mlpack),o,s),i,d) + | Special (n,dep,c) :: r -> + let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,c)::o,s),i,d) + | Subdir n :: r -> + let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) + | Include p :: r -> + let t,(i,r),d = aux r in (t,((Minilib.remove_path_dot (post_canonize p), + Minilib.canonical_path_name p)::i,r),d) + | RInclude (p,l) :: r -> + let t,(i,r),d = aux r in (t,(i,(Minilib.remove_path_dot (post_canonize p),l, + Minilib.canonical_path_name p)::r),d) + | Def (v,def) :: r -> + let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) + | Arg a :: r -> + let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) + | [] -> ([],([],[],[],[],[]),[],[]),([],[]),([],[]) + in aux + +let read_project_file f = + split_arguments + (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) + +let args_from_project file project_files default_name = + let is_f = Minilib.same_file file in + let contains_file dir = + List.exists (fun x -> is_f (Minilib.correct_path x dir)) + in + let build_cmd_line i_inc r_inc args = + List.fold_right (fun (_,i) o -> "-I" :: i :: o) i_inc + (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc + (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args [])) + in try + let (_,(_,(i_inc,r_inc),(args,_))) = + List.find (fun (dir,((v_files,_,_,_),_,_)) -> + contains_file dir v_files) project_files in + build_cmd_line i_inc r_inc args + with Not_found -> + let rec find_project_file dir = try + let ((v_files,_,_,_),(i_inc,r_inc),(args,_)) = + read_project_file (Filename.concat dir default_name) in + if contains_file dir v_files + then build_cmd_line i_inc r_inc args + else let newdir = Filename.dirname dir in + Minilib.safe_prerr_endline newdir; + if dir = newdir then [] else find_project_file newdir + with Sys_error s -> + let newdir = Filename.dirname dir in + if dir = newdir then [] else find_project_file newdir + in find_project_file (Filename.dirname file) diff --git a/ide/tags.ml b/ide/tags.ml index aacac46e..52ba54dc 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*