summaryrefslogtreecommitdiff
path: root/ide
diff options
context:
space:
mode:
Diffstat (limited to 'ide')
-rw-r--r--ide/.merlin2
-rw-r--r--ide/FAQ2
-rw-r--r--ide/coq.lang59
-rw-r--r--ide/coq.ml75
-rw-r--r--ide/coq.mli6
-rw-r--r--ide/coq.pngbin71924 -> 12907 bytes
-rw-r--r--ide/coqOps.ml196
-rw-r--r--ide/coqOps.mli2
-rw-r--r--ide/coqide.ml310
-rw-r--r--ide/coqide_ui.ml12
-rw-r--r--ide/coqidetop.mllib7
-rw-r--r--ide/document.ml35
-rw-r--r--ide/document.mli4
-rw-r--r--ide/fileOps.ml8
-rw-r--r--ide/ide.mllib9
-rw-r--r--ide/ide_slave.ml124
-rw-r--r--ide/ideutils.ml103
-rw-r--r--ide/ideutils.mli9
-rw-r--r--ide/interface.mli9
-rw-r--r--ide/nanoPG.ml2
-rw-r--r--ide/preferences.ml1274
-rw-r--r--ide/preferences.mli175
-rw-r--r--ide/project_file.ml495
-rw-r--r--ide/richprinter.ml24
-rw-r--r--ide/richprinter.mli36
-rw-r--r--ide/sentence.ml5
-rw-r--r--ide/serialize.ml121
-rw-r--r--ide/serialize.mli39
-rw-r--r--ide/session.ml39
-rw-r--r--ide/session.mli2
-rw-r--r--ide/tags.ml61
-rw-r--r--ide/tags.mli21
-rw-r--r--ide/texmacspp.ml768
-rw-r--r--ide/texmacspp.mli12
-rw-r--r--ide/utils/configwin_keys.ml2
-rw-r--r--ide/utils/okey.ml27
-rw-r--r--ide/wg_Command.ml25
-rw-r--r--ide/wg_Command.mli2
-rw-r--r--ide/wg_Completion.ml4
-rw-r--r--ide/wg_Find.ml2
-rw-r--r--ide/wg_MessageView.ml50
-rw-r--r--ide/wg_MessageView.mli11
-rw-r--r--ide/wg_ProofView.ml41
-rw-r--r--ide/wg_ScriptView.ml31
-rw-r--r--ide/wg_Segment.ml118
-rw-r--r--ide/wg_Segment.mli14
-rw-r--r--ide/xml_lexer.mli44
-rw-r--r--ide/xml_lexer.mll317
-rw-r--r--ide/xml_parser.ml232
-rw-r--r--ide/xml_parser.mli106
-rw-r--r--ide/xml_printer.ml145
-rw-r--r--ide/xml_printer.mli29
-rw-r--r--ide/xmlprotocol.ml583
-rw-r--r--ide/xmlprotocol.mli18
54 files changed, 3864 insertions, 1583 deletions
diff --git a/ide/.merlin b/ide/.merlin
index 3f3d9d27..953b5dce 100644
--- a/ide/.merlin
+++ b/ide/.merlin
@@ -1,4 +1,4 @@
-PKG lablgtk2.sourceview2
+PKG unix laglgtk2 lablgtk2.sourceview2
S utils
B utils
diff --git a/ide/FAQ b/ide/FAQ
index 07b81824..c8b0a5d3 100644
--- a/ide/FAQ
+++ b/ide/FAQ
@@ -1,7 +1,7 @@
CoqIde FAQ
Q0) What is CoqIde?
-R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations.
+R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations.
Q1) How to enable Emacs keybindings?
R1: Insert
diff --git a/ide/coq.lang b/ide/coq.lang
index e25eedbc..484264ec 100644
--- a/ide/coq.lang
+++ b/ide/coq.lang
@@ -95,11 +95,24 @@
<keyword>Type</keyword>
</context>
- <context id="coq" class="no-spell-check">
+ <!-- Terms -->
+ <context id="constr">
<include>
<context ref="string"/>
<context ref="coqdoc"/>
<context ref="comment"/>
+ <context ref="constr-sort"/>
+ <context ref="constr-keyword"/>
+ <context id="dot-nosep">
+ <match>\.\.</match>
+ </context>
+ </include>
+ </context>
+
+ <context id="coq" class="no-spell-check">
+ <include>
+ <context ref="coqdoc"/>
+ <context ref="comment"/>
<context id="declaration">
<start>\%{decl_head}</start>
@@ -110,14 +123,7 @@
<context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/>
<context sub-pattern="id_list" where="start" style-ref="identifier"/>
<context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/>
- <context ref="constr-keyword"/>
- <context ref="constr-sort"/>
- <context id="dot-nosep">
- <match>\.\.</match>
- </context>
- <context ref="string"/>
- <context ref="coqdoc"/>
- <context ref="comment"/>
+ <context ref="constr"/>
</include>
</context>
@@ -127,21 +133,19 @@
<include>
<context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
<context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
- <context ref="command-in-proof"/>
- <context ref="string"/>
<context ref="coqdoc"/>
<context ref="comment"/>
- <context ref="constr-keyword"/>
- <context ref="constr-sort"/>
- <context id="bullet" extend-parent="false">
- <match>\%{dot_sep}\s*(?'bul'\%{bullet})</match>
+ <context id="bullet" style-ref="vernac-keyword" extend-parent="false">
+ <match>\%{bullet}</match>
+ </context>
+ <context extend-parent="false">
+ <start>\%[</start>
+ <end>\%{dot_sep}</end>
<include>
- <context sub-pattern="bul" style-ref="vernac-keyword"/>
+ <context ref="command-in-proof"/>
+ <context ref="constr"/>
</include>
</context>
- <context id="bullet-sol" style-ref="vernac-keyword">
- <match>^\s*\%{bullet}</match>
- </context>
</include>
</context>
@@ -150,11 +154,19 @@
<end>\%{dot_sep}</end>
<include>
<context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
- <context ref="constr-keyword"/>
- <context ref="constr-sort"/>
+ <context ref="constr"/>
</include>
</context>
+ <context ref="command"/>
+ </include>
+ </context>
+
+ <!-- Toplevel commands -->
+ <context id="command" extend-parent="false">
+ <start>\%[</start>
+ <end>\%{dot_sep}</end>
+ <include>
<context id="command-in-proof" style-ref="vernac-keyword">
<keyword>About</keyword>
<keyword>Check</keyword>
@@ -166,7 +178,7 @@
<keyword>Transparent</keyword>
</context>
- <context id="command" style-ref="vernac-keyword">
+ <context id="toplevel-command" style-ref="vernac-keyword">
<keyword>Add</keyword>
<keyword>Load</keyword>
<keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</keyword>
@@ -228,7 +240,10 @@
<context sub-pattern="qua_list" style-ref="identifier"/>
</include>
</context>
+
+ <context ref="constr"/>
</include>
</context>
+
</definitions>
</language>
diff --git a/ide/coq.ml b/ide/coq.ml
index 98576a98..6d44ca59 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines =
"Command was: "^cmd^"\n"^
"Answer was: "^(String.concat "\n " lines))
-let check_remaining_opt arg =
- if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg)
-
let rec filter_coq_opts args =
let argstr = String.concat " " (List.map Filename.quote args) in
let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in
@@ -125,7 +122,7 @@ and asks_for_coqtop args =
~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
match pb_mes#run () with
| `YES ->
- let () = current.cmd_coqtop <- None in
+ let () = cmd_coqtop#set None in
let () = custom_coqtop := None in
let () = pb_mes#destroy () in
filter_coq_opts args
@@ -200,8 +197,6 @@ module GlibMainLoop = struct
let read_all = Ideutils.io_read_all
let async_chan_of_file fd = Glib.Io.channel_of_descr fd
let async_chan_of_socket s = !gio_channel_of_descr_socket s
- let add_timeout ~sec callback =
- ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback)
end
module CoqTop = Spawn.Async(GlibMainLoop)
@@ -232,7 +227,7 @@ type coqtop = {
(* non quoted command-line arguments of coqtop *)
mutable sup_args : string list;
(* called whenever coqtop dies *)
- mutable reset_handler : reset_kind -> unit task;
+ mutable reset_handler : unit task;
(* called whenever coqtop sends a feedback message *)
mutable feedback_handler : Feedback.feedback -> unit;
(* actual coqtop process and its status *)
@@ -295,23 +290,20 @@ let rec check_errors = function
| `NVAL :: _ -> raise (TubeError "NVAL")
| `OUT :: _ -> raise (TubeError "OUT")
-let handle_intermediate_message handle xml =
- let message = Pp.to_message xml in
- let level = message.Pp.message_level in
- let content = message.Pp.message_content in
- let logger = match handle.waiting_for with
- | Some (_, l) -> l
+let handle_intermediate_message handle level content =
+ let logger = match handle.waiting_for with
+ | Some (_, l) -> l
| None -> function
- | Pp.Error -> Minilib.log ~level:`ERROR
- | Pp.Info -> Minilib.log ~level:`INFO
- | Pp.Notice -> Minilib.log ~level:`NOTICE
- | Pp.Warning -> Minilib.log ~level:`WARNING
- | Pp.Debug _ -> Minilib.log ~level:`DEBUG
+ | Feedback.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s)
+ | Feedback.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s)
+ | Feedback.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s)
+ | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s)
+ | Feedback.Debug -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s)
in
logger level content
let handle_feedback feedback_processor xml =
- let feedback = Feedback.to_feedback xml in
+ let feedback = Xmlprotocol.to_feedback xml in
feedback_processor feedback
let handle_final_answer handle xml =
@@ -336,19 +328,22 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
let lex = Lexing.from_string s in
let p = Xml_parser.make (Xml_parser.SLexbuf lex) in
let rec loop () =
- let xml = Xml_parser.parse p in
+ let xml = Xml_parser.parse ~do_not_canonicalize:true p in
let l_end = Lexing.lexeme_end lex in
state.fragment <- String.sub s l_end (String.length s - l_end);
state.lexerror <- None;
- if Pp.is_message xml then begin
- handle_intermediate_message handle xml;
- loop ()
- end else if Feedback.is_feedback xml then begin
- handle_feedback feedback_processor xml;
+ match Xmlprotocol.is_message xml with
+ | Some (lvl, _loc, msg) ->
+ handle_intermediate_message handle lvl msg;
loop ()
- end else begin
- ignore (handle_final_answer handle xml)
- end
+ | None ->
+ if Xmlprotocol.is_feedback xml then begin
+ handle_feedback feedback_processor xml;
+ loop ()
+ end else
+ begin
+ ignore (handle_final_answer handle xml)
+ end
in
try loop ()
with Xml_parser.Error _ as e ->
@@ -362,7 +357,9 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
let print_exception = function
| Xml_parser.Error e -> Xml_parser.error e
- | Serialize.Marshal_error -> "Protocol violation"
+ | Serialize.Marshal_error(expected,actual) ->
+ "Protocol violation. Expected: " ^ expected ^ " Actual: "
+ ^ Xml_printer.to_string actual
| e -> Printexc.to_string e
let input_watch handle respawner feedback_processor =
@@ -424,6 +421,7 @@ let mkready coqtop =
fun () -> coqtop.status <- Ready; Void
let rec respawn_coqtop ?(why=Unexpected) coqtop =
+ if why = Unexpected then warning "Coqtop died badly. Resetting.";
clear_handle coqtop.handle;
ignore_error (fun () ->
coqtop.handle <-
@@ -435,7 +433,7 @@ let rec respawn_coqtop ?(why=Unexpected) coqtop =
If not, there isn't much we can do ... *)
assert (coqtop.handle.alive = true);
coqtop.status <- New;
- ignore (coqtop.reset_handler why coqtop.handle (mkready coqtop))
+ ignore (coqtop.reset_handler coqtop.handle (mkready coqtop))
let spawn_coqtop sup_args =
bind_self_as (fun this -> {
@@ -443,7 +441,7 @@ let spawn_coqtop sup_args =
(fun () -> respawn_coqtop (this ()))
(fun msg -> (this ()).feedback_handler msg);
sup_args = sup_args;
- reset_handler = (fun _ _ k -> k ());
+ reset_handler = (fun _ k -> k ());
feedback_handler = (fun _ -> ());
status = New;
})
@@ -465,10 +463,6 @@ let close_coqtop coqtop =
let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop
-let break_coqtop coqtop =
- try !interrupter (CoqTop.unixpid coqtop.handle.proc)
- with _ -> Minilib.log "Error while sending Ctrl-C"
-
let get_arguments coqtop = coqtop.sup_args
let set_arguments coqtop args =
@@ -518,6 +512,17 @@ let search flags = eval_call (Xmlprotocol.search flags)
let init x = eval_call (Xmlprotocol.init x)
let stop_worker x = eval_call (Xmlprotocol.stop_worker x)
+let break_coqtop coqtop workers =
+ if coqtop.status = Busy then
+ try !interrupter (CoqTop.unixpid coqtop.handle.proc)
+ with _ -> Minilib.log "Error while sending Ctrl-C"
+ else
+ let rec aux = function
+ | [] -> Void
+ | w :: ws -> stop_worker w coqtop.handle (fun _ -> aux ws)
+ in
+ let Void = aux workers in ()
+
module PrintOpt =
struct
type t = string list
diff --git a/ide/coq.mli b/ide/coq.mli
index d9eda0f3..8a1fa3ed 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -60,7 +60,7 @@ val is_computing : coqtop -> bool
val spawn_coqtop : string list -> coqtop
(** Create a coqtop process with some command-line arguments. *)
-val set_reset_handler : coqtop -> (reset_kind -> unit task) -> unit
+val set_reset_handler : coqtop -> unit task -> unit
(** Register a handler called when a coqtop dies (badly or on purpose) *)
val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit
@@ -70,8 +70,8 @@ val init_coqtop : coqtop -> unit task -> unit
(** Finish initializing a freshly spawned coqtop, by running a first task on it.
The task should run its inner continuation at the end. *)
-val break_coqtop : coqtop -> unit
-(** Interrupt the current computation of coqtop. *)
+val break_coqtop : coqtop -> string list -> unit
+(** Interrupt the current computation of coqtop or the worker if coqtop it not running. *)
val close_coqtop : coqtop -> unit
(** Close coqtop. Subsequent requests will be discarded. Hook ignored. *)
diff --git a/ide/coq.png b/ide/coq.png
index cccd5a9a..136bfdd5 100644
--- a/ide/coq.png
+++ b/ide/coq.png
Binary files differ
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index 89f4e513..1563c7ff 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -12,15 +12,19 @@ open Ideutils
open Interface
open Feedback
-type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ]
-type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
+let b2c = byte_offset_to_char_offset
+
+type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of Loc.t * string | `WARNING of Loc.t * string ]
+type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR | `WARNING ]
let mem_flag_of_flag : flag -> mem_flag = function
| `ERROR _ -> `ERROR
+ | `WARNING _ -> `WARNING
| (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag
let str_of_flag = function
| `UNSAFE -> "U"
| `PROCESSING -> "P"
| `ERROR _ -> "E"
+ | `WARNING _ -> "W"
| `INCOMPLETE -> "I"
class type signals =
@@ -44,12 +48,9 @@ module SentenceId : sig
val mk_sentence :
start:GText.mark -> stop:GText.mark -> flag list -> sentence
- val set_flags : sentence -> flag list -> unit
val add_flag : sentence -> flag -> unit
val has_flag : sentence -> mem_flag -> bool
val remove_flag : sentence -> mem_flag -> unit
- val same_sentence : sentence -> sentence -> bool
- val hidden_edit_id : unit -> int
val find_all_tooltips : sentence -> int -> string list
val add_tooltip : sentence -> int -> int -> string -> unit
val set_index : sentence -> int -> unit
@@ -87,18 +88,15 @@ end = struct
index = -1;
changed_sig = new GUtil.signal ();
}
- let hidden_edit_id () = decr id; !id
let changed s =
s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags)
- let set_flags s f = s.flags <- f; changed s
let add_flag s f = s.flags <- CList.add_set (=) f s.flags; changed s
let has_flag s mf =
List.exists (fun f -> mem_flag_of_flag f = mf) s.flags
let remove_flag s mf =
s.flags <- List.filter (fun f -> mem_flag_of_flag f <> mf) s.flags; changed s
- let same_sentence s1 s2 = s1.edit_id = s2.edit_id
let find_all_tooltips s off =
CList.map_filter (fun (start,stop,t) ->
if start <= off && off <= stop then Some t else None)
@@ -130,8 +128,6 @@ end = struct
end
open SentenceId
-let prefs = Preferences.current
-
let log msg : unit task =
Coq.lift (fun () -> Minilib.log msg)
@@ -142,7 +138,7 @@ object
method tactic_wizard : string list -> unit task
method process_next_phrase : unit task
method process_until_end_or_error : unit task
- method handle_reset_initial : Coq.reset_kind -> unit task
+ method handle_reset_initial : unit task
method raw_coq_query : string -> unit task
method show_goals : unit task
method backtrack_last_phrase : unit task
@@ -160,15 +156,71 @@ object
end
let flags_to_color f =
- let of_col c = `NAME (Tags.string_of_color c) in
if List.mem `PROCESSING f then `NAME "blue"
else if List.mem `ERROR f then `NAME "red"
else if List.mem `UNSAFE f then `NAME "orange"
else if List.mem `INCOMPLETE f then `NAME "gray"
- else of_col (Tags.get_processed_color ())
+ else `NAME Preferences.processed_color#get
+
+let validate s =
+ let open Xml_datatype in
+ let rec validate = function
+ | PCData s -> Glib.Utf8.validate s
+ | Element (_, _, children) -> List.for_all validate children
+ in
+ validate (Richpp.repr s)
module Doc = Document
+let segment_model (doc : sentence Doc.document) : Wg_Segment.model =
+object (self)
+
+ val mutable cbs = []
+
+ val mutable document_length = 0
+
+ method length = document_length
+
+ method changed ~callback = cbs <- callback :: cbs
+
+ method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu ->
+ let fold accu _ _ s =
+ let flags = List.map mem_flag_of_flag s.flags in
+ f accu (flags_to_color flags)
+ in
+ Doc.fold_all doc accu fold
+
+ method private on_changed (i, f) =
+ let data = (i, flags_to_color f) in
+ List.iter (fun f -> f (`SET data)) cbs
+
+ method private on_push s ctx =
+ let after = match ctx with
+ | None -> []
+ | Some (l, _) -> l
+ in
+ List.iter (fun s -> set_index s (s.index + 1)) after;
+ set_index s (document_length - List.length after);
+ ignore ((SentenceId.connect s)#changed self#on_changed);
+ document_length <- document_length + 1;
+ List.iter (fun f -> f `INSERT) cbs
+
+ method private on_pop s ctx =
+ let () = match ctx with
+ | None -> ()
+ | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l
+ in
+ set_index s (-1);
+ document_length <- document_length - 1;
+ List.iter (fun f -> f `REMOVE) cbs
+
+ initializer
+ let _ = (Doc.connect doc)#pushed self#on_push in
+ let _ = (Doc.connect doc)#popped self#on_pop in
+ ()
+
+end
+
class coqops
(_script:Wg_ScriptView.script_view)
(_pv:Wg_ProofView.proof_view)
@@ -201,20 +253,8 @@ object(self)
script#misc#set_has_tooltip true;
ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback);
feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback;
- let on_changed (i, f) = segment#add i (flags_to_color f) in
- let on_push s =
- set_index s document_length;
- ignore ((SentenceId.connect s)#changed on_changed);
- document_length <- succ document_length;
- segment#set_length document_length;
- let flags = List.map mem_flag_of_flag s.flags in
- segment#add s.index (flags_to_color flags);
- in
- let on_pop s =
- set_index s (-1);
- document_length <- pred document_length;
- segment#set_length document_length;
- in
+ let md = segment_model document in
+ segment#set_model md;
let on_click id =
let find _ _ s = Int.equal s.index id in
let sentence = Doc.find document find in
@@ -230,8 +270,6 @@ object(self)
script#buffer#place_cursor iter;
ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter)
in
- let _ = (Doc.connect document)#pushed on_push in
- let _ = (Doc.connect document)#popped on_pop in
let _ = segment#connect#clicked on_click in
()
@@ -301,8 +339,11 @@ object(self)
method private show_goals_aux ?(move_insert=false) () =
Coq.PrintOpt.set_printing_width proof#width;
if move_insert then begin
- buffer#place_cursor ~where:self#get_start_of_input;
- script#recenter_insert;
+ let dest = self#get_start_of_input in
+ if (buffer#get_iter_at_mark `INSERT)#compare dest <= 0 then begin
+ buffer#place_cursor ~where:dest;
+ script#recenter_insert
+ end
end;
Coq.bind (Coq.goals ~logger:messages#push ()) (function
| Fail x -> self#handle_failure_aux ~move_insert x
@@ -322,7 +363,7 @@ object(self)
method raw_coq_query phrase =
let action = log "raw_coq_query starting now" in
let display_error s =
- if not (Glib.Utf8.validate s) then
+ if not (validate s) then
flash_info "This error is so nasty that I can't even display it."
else messages#add s;
in
@@ -331,7 +372,7 @@ object(self)
let next = function
| Fail (_, _, err) -> display_error err; Coq.return ()
| Good msg ->
- messages#add msg; Coq.return ()
+ messages#add_string msg; Coq.return ()
in
Coq.bind (Coq.seq action query) next
@@ -362,8 +403,8 @@ object(self)
let start_sentence, stop_sentence, phrase = self#get_sentence sentence in
let pre_chars, post_chars =
if Loc.is_ghost loc then 0, String.length phrase else Loc.unloc loc in
- let pre = Ideutils.glib_utf8_pos_to_offset phrase ~off:pre_chars in
- let post = Ideutils.glib_utf8_pos_to_offset phrase ~off:post_chars in
+ let pre = b2c phrase pre_chars in
+ let post = b2c phrase post_chars in
let start = start_sentence#forward_chars pre in
let stop = start_sentence#forward_chars post in
let markup = Glib.Markup.escape_text text in
@@ -406,7 +447,6 @@ object(self)
| Processed, Some (id,sentence) ->
log "Processed" id;
remove_flag sentence `PROCESSING;
- remove_flag sentence `ERROR;
self#mark_as_needed sentence
| ProcessingIn _, Some (id,sentence) ->
log "ProcessingIn" id;
@@ -424,14 +464,25 @@ object(self)
log "GlobRef" id;
self#attach_tooltip sentence loc
(Printf.sprintf "%s %s %s" filepath ident ty)
- | ErrorMsg(loc, msg), Some (id,sentence) ->
+ | Message(Error, loc, msg), Some (id,sentence) ->
+ let loc = Option.default Loc.ghost loc in
+ let msg = Richpp.raw_print msg in
log "ErrorMsg" id;
remove_flag sentence `PROCESSING;
- add_flag sentence (`ERROR msg);
+ add_flag sentence (`ERROR (loc, msg));
self#mark_as_needed sentence;
self#attach_tooltip sentence loc msg;
if not (Loc.is_ghost loc) then
self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc))
+ | Message(Warning, loc, msg), Some (id,sentence) ->
+ let loc = Option.default Loc.ghost loc in
+ let msg = Richpp.raw_print msg in
+ log "WarningMsg" id;
+ add_flag sentence (`WARNING (loc, msg));
+ self#attach_tooltip sentence loc msg;
+ self#position_warning_tag_at_sentence sentence loc
+ | Message((Info|Notice|Debug as lvl), _, msg), _ ->
+ messages#push lvl msg
| InProgress n, _ ->
if n < 0 then processed <- processed + abs n
else to_process <- to_process + n
@@ -466,13 +517,25 @@ object(self)
| None -> ()
| Some (start, stop) ->
buffer#apply_tag Tags.Script.error
- ~start:(iter#forward_chars (byte_offset_to_char_offset phrase start))
- ~stop:(iter#forward_chars (byte_offset_to_char_offset phrase stop))
+ ~start:(iter#forward_chars (b2c phrase start))
+ ~stop:(iter#forward_chars (b2c phrase stop))
method private position_error_tag_at_sentence sentence loc =
let start, _, phrase = self#get_sentence sentence in
self#position_error_tag_at_iter start phrase loc
+ method private position_warning_tag_at_iter iter_start iter_stop phrase loc =
+ if Loc.is_ghost loc then
+ buffer#apply_tag Tags.Script.warning ~start:iter_start ~stop:iter_stop
+ else
+ buffer#apply_tag Tags.Script.warning
+ ~start:(iter_start#forward_chars (b2c phrase loc.Loc.bp))
+ ~stop:(iter_stop#forward_chars (b2c phrase loc.Loc.ep))
+
+ method private position_warning_tag_at_sentence sentence loc =
+ let start, stop, phrase = self#get_sentence sentence in
+ self#position_warning_tag_at_iter start stop phrase loc
+
method private process_interp_error queue sentence loc msg tip id =
Coq.bind (Coq.return ()) (function () ->
let start, stop, phrase = self#get_sentence sentence in
@@ -483,7 +546,7 @@ object(self)
self#position_error_tag_at_iter start phrase loc;
buffer#place_cursor ~where:stop;
messages#clear;
- messages#push Pp.Error msg;
+ messages#push Feedback.Error msg;
self#show_goals
end else
self#show_goals_aux ~move_insert:true ()
@@ -499,13 +562,19 @@ object(self)
condition returns true; it is fed with the number of phrases read and the
iters enclosing the current sentence. *)
method private fill_command_queue until queue =
+ let topstack =
+ if Doc.focused document then fst (Doc.context document) else [] in
let rec loop n iter =
match Sentence.find buffer iter with
| None -> ()
| Some (start, stop) ->
if until n start stop then begin
()
- end else if stop#backward_char#has_tag Tags.Script.processed then begin
+ end else if
+ List.exists (fun (_, s) ->
+ start#equal (buffer#get_iter_at_mark s.start) &&
+ stop#equal (buffer#get_iter_at_mark s.stop)) topstack
+ then begin
Queue.push (`Skip (start, stop)) queue;
loop n stop
end else begin
@@ -559,7 +628,8 @@ object(self)
if Queue.is_empty queue then conclude topstack else
match Queue.pop queue, topstack with
| `Skip(start,stop), [] ->
- logger Pp.Error "You must close the proof with Qed or Admitted";
+
+ logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted");
self#discard_command_queue queue;
conclude []
| `Skip(start,stop), (_,s) :: topstack ->
@@ -575,7 +645,7 @@ object(self)
let handle_answer = function
| Good (id, (Util.Inl (* NewTip *) (), msg)) ->
Doc.assign_tip_id document id;
- logger Pp.Notice msg;
+ logger Feedback.Notice (Richpp.richpp_of_string msg);
self#commit_queue_transaction sentence;
loop id []
| Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
@@ -583,7 +653,7 @@ object(self)
let topstack, _ = Doc.context document in
self#exit_focus;
self#cleanup (Doc.cut_at document tip);
- logger Pp.Notice msg;
+ logger Feedback.Notice (Richpp.richpp_of_string msg);
self#mark_as_needed sentence;
if Queue.is_empty queue then loop tip []
else loop tip (List.rev topstack)
@@ -602,7 +672,7 @@ object(self)
let next = function
| Good _ ->
messages#clear;
- messages#push Pp.Info "All proof terms checked by the kernel";
+ messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel");
Coq.return ()
| Fail x -> self#handle_failure x in
Coq.bind (Coq.status ~logger:messages#push true) next
@@ -618,7 +688,15 @@ object(self)
method get_errors =
let extract_error s =
match List.find (function `ERROR _ -> true | _ -> false) s.flags with
- | `ERROR msg -> (buffer#get_iter_at_mark s.start)#line + 1, msg
+ | `ERROR (loc, msg) ->
+ let iter =
+ if Loc.is_ghost loc then
+ buffer#get_iter_at_mark s.start
+ else
+ let (iter, _, phrase) = self#get_sentence s in
+ let (start, _) = Loc.unloc loc in
+ iter#forward_chars (b2c phrase start) in
+ iter#line + 1, msg
| _ -> assert false in
List.rev
(Doc.fold_all document [] (fun acc _ _ s ->
@@ -630,7 +708,7 @@ object(self)
method private process_until_iter iter =
let until _ start stop =
- if prefs.Preferences.stop_before then stop#compare iter > 0
+ if Preferences.stop_before#get then stop#compare iter > 0
else start#compare iter >= 0
in
self#process_until until false
@@ -696,8 +774,8 @@ object(self)
self#cleanup (Doc.cut_at document to_id);
conclusion ()
| Fail (safe_id, loc, msg) ->
- if loc <> None then messages#push Pp.Error "Fixme LOC";
- messages#push Pp.Error msg;
+(* if loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *)
+ messages#push Feedback.Error msg;
if Stateid.equal safe_id Stateid.dummy then self#show_goals
else undo safe_id
(Doc.focused document && Doc.is_in_focus document safe_id))
@@ -714,8 +792,7 @@ object(self)
method private handle_failure_aux
?(move_insert=false) (safe_id, (loc : (int * int) option), msg)
=
- messages#clear;
- messages#push Pp.Error msg;
+ messages#push Feedback.Error msg;
ignore(self#process_feedback ());
if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ())
else
@@ -772,7 +849,7 @@ object(self)
self#show_goals
in
let display_error (loc, s) =
- if not (Glib.Utf8.validate s) then
+ if not (validate s) then
flash_info "This error is so nasty that I can't even display it."
else messages#add s
in
@@ -782,10 +859,10 @@ object(self)
let next = function
| Fail (_, l, str) -> (* FIXME: check *)
display_error (l, str);
- messages#add ("Unsuccessfully tried: "^phrase);
+ messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase));
more
| Good msg ->
- messages#add msg;
+ messages#add_string msg;
stop Tags.Script.processed
in
Coq.bind (Coq.seq action query) next
@@ -797,10 +874,8 @@ object(self)
in
loop l
- method handle_reset_initial why =
+ method handle_reset_initial =
let action () =
- if why = Coq.Unexpected then warning "Coqtop died badly. Resetting."
- else
(* clear the stack *)
if Doc.focused document then Doc.unfocus document;
while not (Doc.is_empty document) do
@@ -829,7 +904,10 @@ object(self)
method initialize =
let get_initial_state =
let next = function
- | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return ()
+ | Fail (_, _, message) ->
+ let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in
+ let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in
+ ignore (popup#run ()); exit 1
| Good id -> initial_state <- id; Coq.return () in
Coq.bind (Coq.init (get_filename ())) next in
Coq.seq get_initial_state Coq.PrintOpt.enforce
diff --git a/ide/coqOps.mli b/ide/coqOps.mli
index 4a37a1fa..332c18f2 100644
--- a/ide/coqOps.mli
+++ b/ide/coqOps.mli
@@ -15,7 +15,7 @@ object
method tactic_wizard : string list -> unit task
method process_next_phrase : unit task
method process_until_end_or_error : unit task
- method handle_reset_initial : Coq.reset_kind -> unit task
+ method handle_reset_initial : unit task
method raw_coq_query : string -> unit task
method show_goals : unit task
method backtrack_last_phrase : unit task
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 608cf82f..450bfcdf 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -44,8 +44,6 @@ open Session
(** {2 Some static elements } *)
-let prefs = Preferences.current
-
(** 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 []
@@ -87,9 +85,9 @@ let make_coqtop_args = function
|None -> "", !sup_args
|Some the_file ->
let get_args f = Project_file.args_from_project f
- !custom_project_files prefs.project_file_name
+ !custom_project_files project_file_name#get
in
- match prefs.read_project with
+ match read_project#get with
|Ignore_args -> "", !sup_args
|Append_args ->
let fname, args = get_args the_file in fname, args @ !sup_args
@@ -164,7 +162,6 @@ let load_file ?(maycreate=false) f =
input_buffer#place_cursor ~where:input_buffer#start_iter;
Sentence.tag_all input_buffer;
session.script#clear_undo ();
- !refresh_editor_hook ();
Minilib.log "Loading: success";
end
with e -> flash_info ("Load failed: "^(Printexc.to_string e))
@@ -250,7 +247,6 @@ module File = struct
let newfile _ =
let session = create_session None in
let index = notebook#append_term session in
- !refresh_editor_hook ();
notebook#goto_page index
let load _ =
@@ -319,13 +315,13 @@ let export kind sn =
| _ -> assert false
in
let cmd =
- local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^
+ local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^
(Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
in
- sn.messages#set ("Running: "^cmd);
+ sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
let finally st = flash_info (cmd ^ pr_exit_status st)
in
- run_command sn.messages#add finally cmd
+ run_command (fun msg -> sn.messages#add_string msg) finally cmd
let export kind = cb_on_current_term (export kind)
@@ -334,8 +330,8 @@ let print sn =
|None -> flash_info "Cannot print: this buffer has no name"
|Some f_name ->
let cmd =
- local_cd f_name ^ prefs.cmd_coqdoc ^ " -ps " ^
- Filename.quote (Filename.basename f_name) ^ " | " ^ prefs.cmd_print
+ local_cd f_name ^ cmd_coqdoc#get ^ " -ps " ^
+ Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get
in
let w = GWindow.window ~title:"Print" ~modal:true
~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" ()
@@ -378,17 +374,17 @@ end
let reset_revert_timer () =
FileOps.revert_timer.kill ();
- if prefs.global_auto_revert then
+ if global_auto_revert#get then
FileOps.revert_timer.run
- ~ms:prefs.global_auto_revert_delay
+ ~ms:global_auto_revert_delay#get
~callback:(fun () -> File.revert_all (); true)
let reset_autosave_timer () =
let autosave sn = try sn.fileops#auto_save with _ -> () in
let autosave_all () = List.iter autosave notebook#pages; true in
FileOps.autosave_timer.kill ();
- if prefs.auto_save then
- FileOps.autosave_timer.run ~ms:prefs.auto_save_delay ~callback:autosave_all
+ if auto_save#get then
+ FileOps.autosave_timer.run ~ms:auto_save_delay#get ~callback:autosave_all
(** Export of functions used in [coqide_main] : *)
@@ -408,8 +404,8 @@ let coq_makefile sn =
match sn.fileops#filename with
|None -> flash_info "Cannot make makefile: this buffer has no name"
|Some f ->
- let cmd = local_cd f ^ prefs.cmd_coqmakefile in
- let finally st = flash_info (current.cmd_coqmakefile ^ pr_exit_status st)
+ let cmd = local_cd f ^ cmd_coqmakefile#get in
+ let finally st = flash_info (cmd_coqmakefile#get ^ pr_exit_status st)
in
run_command ignore finally cmd
@@ -421,7 +417,7 @@ let editor sn =
|Some f ->
File.save ();
let f = Filename.quote f in
- let cmd = Util.subst_command_placeholder prefs.cmd_editor f in
+ let cmd = Util.subst_command_placeholder cmd_editor#get f in
run_command ignore (fun _ -> sn.fileops#revert) cmd
let editor = cb_on_current_term editor
@@ -431,13 +427,13 @@ let compile sn =
match sn.fileops#filename with
|None -> flash_info "Active buffer has no name"
|Some f ->
- let cmd = prefs.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f))
+ let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f))
^ " " ^ (Filename.quote f) ^ " 2>&1"
in
let buf = Buffer.create 1024 in
- sn.messages#set ("Running: "^cmd);
+ sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd));
let display s =
- sn.messages#add s;
+ sn.messages#add_string s;
Buffer.add_string buf s
in
let finally st =
@@ -445,8 +441,8 @@ let compile sn =
flash_info (f ^ " successfully compiled")
else begin
flash_info (f ^ " failed to compile");
- sn.messages#set "Compilation output:\n";
- sn.messages#add (Buffer.contents buf);
+ sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
+ sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf));
end
in
run_command display finally cmd
@@ -467,17 +463,17 @@ let make sn =
|None -> flash_info "Cannot make: this buffer has no name"
|Some f ->
File.saveall ();
- let cmd = local_cd f ^ prefs.cmd_make ^ " 2>&1" in
- sn.messages#set "Compilation output:\n";
+ let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in
+ sn.messages#set (Richpp.richpp_of_string "Compilation output:\n");
Buffer.reset last_make_buf;
last_make := "";
last_make_index := 0;
last_make_dir := Filename.dirname f;
let display s =
- sn.messages#add s;
+ sn.messages#add_string s;
Buffer.add_string last_make_buf s
in
- let finally st = flash_info (current.cmd_make ^ pr_exit_status st)
+ let finally st = flash_info (cmd_make#get ^ pr_exit_status st)
in
run_command display finally cmd
@@ -512,11 +508,11 @@ let next_error sn =
let stopi = b#get_iter_at_byte ~line:(line-1) stop in
b#apply_tag Tags.Script.error ~start:starti ~stop:stopi;
b#place_cursor ~where:starti;
- sn.messages#set error_msg;
+ sn.messages#set (Richpp.richpp_of_string error_msg);
sn.script#misc#grab_focus ()
with Not_found ->
last_make_index := 0;
- sn.messages#set "No more errors.\n"
+ sn.messages#set (Richpp.richpp_of_string "No more errors.\n")
let next_error = cb_on_current_term next_error
@@ -537,7 +533,7 @@ let update_status sn =
| None -> ""
| Some n -> ", proving " ^ n
in
- display ("Ready"^ (if current.nanoPG then ", [μPG]" else "") ^ path ^ name);
+ display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name);
Coq.return ()
in
Coq.bind (Coq.status ~logger:sn.messages#push false) next
@@ -574,7 +570,7 @@ module Nav = struct
let restart _ = on_current_term restart
let interrupt sn =
Minilib.log "User break received";
- Coq.break_coqtop sn.coqtop
+ Coq.break_coqtop sn.coqtop CString.(Set.elements (Map.domain sn.jobpage#data))
let interrupt = cb_on_current_term interrupt
let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document)
end
@@ -681,12 +677,18 @@ let searchabout sn =
let searchabout () = on_current_term searchabout
+let doquery query sn =
+ sn.messages#clear;
+ Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore
+
let otherquery command sn =
- let word = get_current_word sn in
- if word <> "" then
- let query = command ^ " " ^ word ^ "." in
- sn.messages#clear;
- Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore
+ Option.iter (fun query -> doquery (query ^ ".") sn)
+ begin try
+ let i = CString.string_index_from command 0 "..." in
+ let word = get_current_word sn in
+ if word = "" then None
+ else Some (CString.sub command 0 i ^ " " ^ word)
+ with Not_found -> Some command end
let otherquery command = cb_on_current_term (otherquery command)
@@ -722,7 +724,7 @@ let initial_about () =
else ""
in
let msg = initial_string ^ version_info ^ log_file_message () in
- on_current_term (fun term -> term.messages#add msg)
+ on_current_term (fun term -> term.messages#add_string msg)
let coq_icon () =
(* May raise Nof_found *)
@@ -787,7 +789,7 @@ let coqtop_arguments sn =
let args = String.concat " " args in
let msg = Printf.sprintf "Invalid arguments: %s" args in
let () = sn.messages#clear in
- sn.messages#push Pp.Error msg
+ sn.messages#push Feedback.Error (Richpp.richpp_of_string msg)
else dialog#destroy ()
in
let _ = entry#connect#activate ok_cb in
@@ -809,69 +811,19 @@ let zoom_fit sn =
let cols = script#right_margin_position in
let pango_ctx = script#misc#pango_context in
let layout = pango_ctx#create_layout in
- let fsize = Pango.Font.get_size current.text_font in
+ let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in
Pango.Layout.set_text layout (String.make cols 'X');
let tlen = fst (Pango.Layout.get_pixel_size layout) in
- Pango.Font.set_size current.text_font
+ Pango.Font.set_size (Pango.Font.from_string text_font#get)
(fsize * space / tlen / Pango.scale * Pango.scale);
- save_pref ();
- !refresh_editor_hook ()
+ save_pref ()
end
(** Refresh functions *)
-let refresh_editor_prefs () =
- let wrap_mode = if prefs.dynamic_word_wrap then `WORD else `NONE in
- let show_spaces =
- if prefs.show_spaces then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *)
- else 0
- in
- let fd = prefs.text_font in
- let clr = Tags.color_of_string prefs.background_color
- in
- let iter_session sn =
- (* Editor settings *)
- sn.script#set_wrap_mode wrap_mode;
- sn.script#set_show_line_numbers prefs.show_line_number;
- sn.script#set_auto_indent prefs.auto_indent;
- sn.script#set_highlight_current_line prefs.highlight_current_line;
-
- (* Hack to handle missing binding in lablgtk *)
- let conv = { Gobject.name = "draw-spaces"; Gobject.conv = Gobject.Data.int }
- in
- Gobject.set conv sn.script#as_widget show_spaces;
-
- sn.script#set_show_right_margin prefs.show_right_margin;
- if prefs.show_progress_bar then sn.segment#misc#show () else sn.segment#misc#hide ();
- sn.script#set_insert_spaces_instead_of_tabs
- prefs.spaces_instead_of_tabs;
- sn.script#set_tab_width prefs.tab_length;
- sn.script#set_auto_complete prefs.auto_complete;
-
- (* Fonts *)
- sn.script#misc#modify_font fd;
- sn.proof#misc#modify_font fd;
- sn.messages#modify_font fd;
- sn.command#refresh_font ();
-
- (* Colors *)
- Tags.set_processing_color (Tags.color_of_string current.processing_color);
- Tags.set_processed_color (Tags.color_of_string current.processed_color);
- Tags.set_error_color (Tags.color_of_string current.error_color);
- Tags.set_error_fg_color (Tags.color_of_string current.error_fg_color);
- sn.script#misc#modify_base [`NORMAL, `COLOR clr];
- sn.proof#misc#modify_base [`NORMAL, `COLOR clr];
- sn.messages#refresh_color ();
- sn.command#refresh_color ();
- sn.errpage#refresh_color ();
- sn.jobpage#refresh_color ();
-
- in
- List.iter iter_session notebook#pages
-
let refresh_notebook_pos () =
- let pos = match prefs.vertical_tabs, prefs.opposite_tabs with
+ let pos = match vertical_tabs#get, opposite_tabs#get with
| false, false -> `TOP
| false, true -> `BOTTOM
| true , false -> `LEFT
@@ -906,19 +858,19 @@ let toggle_items menu_name l =
let f d =
let label = d.Opt.label in
let k, name = get_shortcut label in
- let accel = Option.map ((^) prefs.modifier_for_display) k in
+ let accel = Option.map ((^) modifier_for_display#get) k in
toggle_item name ~label ?accel ~active:d.Opt.init
~callback:(printopts_callback d.Opt.opts)
menu_name
in
List.iter f l
+let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
+
(** Create alphabetical menu items with elements in sub-items.
[l] is a list of lists, one per initial letter *)
let alpha_items menu_name item_name l =
- let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
- in
let mk_item text =
let text' =
let last = String.length text - 1 in
@@ -948,7 +900,7 @@ let alpha_items menu_name item_name l =
Caveat: the offset is now from the start of the text. *)
let template_item (text, offset, len, key) =
- let modifier = prefs.modifier_for_templates in
+ let modifier = modifier_for_templates#get in
let idx = String.index text ' ' in
let name = String.sub text 0 idx in
let label = "_"^name^" __" in
@@ -965,6 +917,16 @@ let template_item (text, offset, len, key) =
in
item name ~label ~callback:(cb_on_current_term callback) ~accel:(modifier^key)
+(** Create menu items for pairs (query, shortcut key). *)
+let user_queries_items menu_name item_name l =
+ let mk_item (query, key) =
+ let callback = Query.query query in
+ let accel = if not (CString.is_empty key) then
+ Some (modifier_for_queries#get^key) else None in
+ item (item_name^" "^(no_under query)) ~label:query ?accel ~callback menu_name
+ in
+ List.iter mk_item l
+
let emit_to_focus window sgn =
let focussed_widget = GtkWindow.Window.get_focus window#as_window in
let obj = Gobject.unsafe_cast focussed_widget in
@@ -975,8 +937,7 @@ let emit_to_focus window sgn =
let build_ui () =
let w = GWindow.window
~wm_class:"CoqIde" ~wm_name:"CoqIde"
- ~allow_grow:true ~allow_shrink:true
- ~width:prefs.window_width ~height:prefs.window_height
+ ~width:window_width#get ~height:window_height#get
~title:"CoqIde" ()
in
let () =
@@ -1074,77 +1035,60 @@ let build_ui () =
~callback:(fun _ -> notebook#next_page ());
item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus")
~stock:`ZOOM_IN ~callback:(fun _ ->
- Pango.Font.set_size current.text_font
- (Pango.Font.get_size current.text_font + Pango.scale);
- save_pref ();
- !refresh_editor_hook ());
+ let ft = Pango.Font.from_string text_font#get in
+ Pango.Font.set_size ft (Pango.Font.get_size ft + Pango.scale);
+ text_font#set (Pango.Font.to_string ft);
+ save_pref ());
item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus")
~stock:`ZOOM_OUT ~callback:(fun _ ->
- Pango.Font.set_size current.text_font
- (Pango.Font.get_size current.text_font - Pango.scale);
- save_pref ();
- !refresh_editor_hook ());
+ let ft = Pango.Font.from_string text_font#get in
+ Pango.Font.set_size ft (Pango.Font.get_size ft - Pango.scale);
+ text_font#set (Pango.Font.to_string ft);
+ save_pref ());
item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Control>0")
~stock:`ZOOM_FIT ~callback:(cb_on_current_term MiscMenu.zoom_fit);
toggle_item "Show Toolbar" ~label:"Show _Toolbar"
- ~active:(prefs.show_toolbar)
- ~callback:(fun _ ->
- prefs.show_toolbar <- not prefs.show_toolbar;
- !refresh_toolbar_hook ());
+ ~active:(show_toolbar#get)
+ ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get));
item "Query Pane" ~label:"_Query Pane"
~accel:"F1"
~callback:(cb_on_current_term MiscMenu.show_hide_query_pane)
];
toggle_items view_menu Coq.PrintOpt.bool_items;
- menu navigation_menu [
- item "Navigation" ~label:"_Navigation";
- item "Forward" ~label:"_Forward" ~stock:`GO_DOWN ~callback:Nav.forward_one
- ~tooltip:"Forward one command"
- ~accel:(prefs.modifier_for_navigation^"Down");
- item "Backward" ~label:"_Backward" ~stock:`GO_UP ~callback:Nav.backward_one
- ~tooltip:"Backward one command"
- ~accel:(prefs.modifier_for_navigation^"Up");
- item "Go to" ~label:"_Go to" ~stock:`JUMP_TO ~callback:Nav.goto
- ~tooltip:"Go to cursor"
- ~accel:(prefs.modifier_for_navigation^"Right");
- item "Start" ~label:"_Start" ~stock:`GOTO_TOP ~callback:Nav.restart
- ~tooltip:"Restart coq"
- ~accel:(prefs.modifier_for_navigation^"Home");
- item "End" ~label:"_End" ~stock:`GOTO_BOTTOM ~callback:Nav.goto_end
- ~tooltip:"Go to end"
- ~accel:(prefs.modifier_for_navigation^"End");
- item "Interrupt" ~label:"_Interrupt" ~stock:`STOP ~callback:Nav.interrupt
- ~tooltip:"Interrupt computations"
- ~accel:(prefs.modifier_for_navigation^"Break");
-(* wait for this available in GtkSourceView !
- item "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
- ~callback:(fun _ -> let sess = notebook#current_term in
- toggle_proof_visibility sess.buffer
- sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
- ~accel:(prefs.modifier_for_navigation^"h");*)
- item "Previous" ~label:"_Previous" ~stock:`GO_BACK
- ~callback:Nav.previous_occ
- ~tooltip:"Previous occurrence"
- ~accel:(prefs.modifier_for_navigation^"less");
- item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ
- ~tooltip:"Next occurrence"
- ~accel:(prefs.modifier_for_navigation^"greater");
- item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document
- ~tooltip:"Fully check the document"
- ~accel:(current.modifier_for_navigation^"f");
- ];
+ let navitem (text, label, stock, callback, tooltip, accel) =
+ let accel = modifier_for_navigation#get ^ accel in
+ item text ~label ~stock ~callback ~tooltip ~accel
+ in
+ menu navigation_menu begin
+ [
+ (fun e -> item "Navigation" ~label:"_Navigation" e);
+ ] @ List.map navitem [
+ ("Forward", "_Forward", `GO_DOWN, Nav.forward_one, "Forward one command", "Down");
+ ("Backward", "_Backward", `GO_UP, Nav.backward_one, "Backward one command", "Up");
+ ("Go to", "_Go to", `JUMP_TO, Nav.goto, "Go to cursor", "Right");
+ ("Start", "_Start", `GOTO_TOP, Nav.restart, "Restart coq", "Home");
+ ("End", "_End", `GOTO_BOTTOM, Nav.goto_end, "Go to end", "End");
+ ("Interrupt", "_Interrupt", `STOP, Nav.interrupt, "Interrupt computations", "Break");
+ (* wait for this available in GtkSourceView !
+ ("Hide", "_Hide", `MISSING_IMAGE,
+ ~callback:(fun _ -> let sess = notebook#current_term in
+ toggle_proof_visibility sess.buffer sess.analyzed_view#get_insert), "Hide proof", "h"); *)
+ ("Previous", "_Previous", `GO_BACK, Nav.previous_occ, "Previous occurrence", "less");
+ ("Next", "_Next", `GO_FORWARD, Nav.next_occ, "Next occurrence", "greater");
+ ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f");
+ ] end;
let tacitem s sc =
item s ~label:("_"^s)
- ~accel:(prefs.modifier_for_tactics^sc)
+ ~accel:(modifier_for_tactics#get^sc)
~callback:(tactic_wizard_callback [s])
in
menu tactics_menu [
item "Try Tactics" ~label:"_Try Tactics";
item "Wizard" ~label:"<Proof Wizard>" ~stock:`DIALOG_INFO
- ~tooltip:"Proof Wizard" ~accel:(prefs.modifier_for_tactics^"dollar")
- ~callback:(tactic_wizard_callback prefs.automatic_tactics);
+ ~tooltip:"Proof Wizard" ~accel:(modifier_for_tactics#get^"dollar")
+ ~callback:(tactic_wizard_callback automatic_tactics#get);
tacitem "auto" "a";
tacitem "auto with *" "asterisk";
tacitem "eauto" "e";
@@ -1166,21 +1110,27 @@ let build_ui () =
template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F");
template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^
"with _ := Induction for _ Sort _.\n", 7,10, "S");
- item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"M")
+ item "match" ~label:"match ..." ~accel:(modifier_for_templates#get^"M")
~callback:match_callback
];
alpha_items templates_menu "Template" Coq_commands.commands;
- let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in
+ let qitem s sc ?(dots = true) =
+ let query = if dots then s ^ "..." else s in
+ item s ~label:("_"^s)
+ ~accel:(modifier_for_queries#get^sc)
+ ~callback:(Query.query query)
+ in
menu queries_menu [
item "Queries" ~label:"_Queries";
- qitem "Search" (Some "<Ctrl><Shift>K");
- qitem "Check" (Some "<Ctrl><Shift>C");
- qitem "Print" (Some "<Ctrl><Shift>P");
- qitem "About" (Some "<Ctrl><Shift>A");
- qitem "Locate" (Some "<Ctrl><Shift>L");
- qitem "Print Assumptions" (Some "<Ctrl><Shift>N");
+ qitem "Search" "K" ~dots:false;
+ qitem "Check" "C";
+ qitem "Print" "P";
+ qitem "About" "A";
+ qitem "Locate" "L";
+ qitem "Print Assumptions" "N";
];
+ user_queries_items queries_menu "User-Query" user_queries#get;
menu tools_menu [
item "Tools" ~label:"_Tools";
@@ -1211,17 +1161,17 @@ let build_ui () =
item "Help" ~label:"_Help";
item "Browse Coq Manual" ~label:"Browse Coq _Manual"
~callback:(fun _ ->
- browse notebook#current_term.messages#add (doc_url ()));
+ browse notebook#current_term.messages#add_string (doc_url ()));
item "Browse Coq Library" ~label:"Browse Coq _Library"
~callback:(fun _ ->
- browse notebook#current_term.messages#add prefs.library_url);
+ browse notebook#current_term.messages#add_string library_url#get);
item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP
~callback:(fun _ -> on_current_term (fun sn ->
- browse_keyword sn.messages#add (get_current_word sn)));
+ browse_keyword sn.messages#add_string (get_current_word sn)));
item "Help for μPG mode" ~label:"Help for μPG mode"
~callback:(fun _ -> on_current_term (fun sn ->
sn.messages#clear;
- sn.messages#add (NanoPG.get_documentation ())));
+ sn.messages#add_string (NanoPG.get_documentation ())));
item "About Coq" ~label:"_About" ~stock:`ABOUT
~callback:MiscMenu.about
];
@@ -1259,7 +1209,7 @@ let build_ui () =
(* Reset on tab switch *)
let _ = notebook#connect#switch_page ~callback:(fun _ ->
- if prefs.reset_on_tab_switch then Nav.restart ())
+ if reset_on_tab_switch#get then Nav.restart ())
in
(* Vertical Separator between Scripts and Goals *)
@@ -1267,7 +1217,7 @@ let build_ui () =
let () = refresh_notebook_pos () in
let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
let () = lower_hbox#pack ~expand:true status#coerce in
- let () = push_info ("Ready"^ if current.nanoPG then ", [μPG]" else "") in
+ let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "") in
(* Location display *)
let l = GMisc.label
@@ -1310,43 +1260,33 @@ let build_ui () =
let _ = Glib.Timeout.add ~ms:300 ~callback in
(* Initializing hooks *)
- let refresh_toolbar () =
- if prefs.show_toolbar
- then toolbar#misc#show ()
- else toolbar#misc#hide ()
- in
- let refresh_style () =
- let style = style_manager#style_scheme prefs.source_style in
+ let refresh_style style =
+ let style = style_manager#style_scheme style in
let iter_session v = v.script#source_buffer#set_style_scheme style in
List.iter iter_session notebook#pages
in
- let refresh_language () =
- let lang = lang_manager#language prefs.source_language in
+ let refresh_language lang =
+ let lang = lang_manager#language lang in
let iter_session v = v.script#source_buffer#set_language lang in
List.iter iter_session notebook#pages
in
- let resize_window () =
- w#resize ~width:prefs.window_width ~height:prefs.window_height
+ let refresh_toolbar b =
+ if b then toolbar#misc#show () else toolbar#misc#hide ()
in
- refresh_toolbar ();
- refresh_toolbar_hook := refresh_toolbar;
- refresh_style_hook := refresh_style;
- refresh_language_hook := refresh_language;
- refresh_editor_hook := refresh_editor_prefs;
- resize_window_hook := resize_window;
- refresh_tabs_hook := refresh_notebook_pos;
+ stick show_toolbar toolbar refresh_toolbar;
+ let _ = source_style#connect#changed refresh_style in
+ let _ = source_language#connect#changed refresh_language in
(* Color configuration *)
Tags.Script.incomplete#set_property
(`BACKGROUND_STIPPLE
(Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02"));
- Tags.Script.incomplete#set_property
- (`BACKGROUND_GDK (Tags.get_processed_color ()));
(* Showtime ! *)
w#show ()
+
(** {2 Coqide main function } *)
let make_file_buffer f =
@@ -1356,7 +1296,7 @@ let make_file_buffer f =
let make_scratch_buffer () =
let session = create_session None in
let _ = notebook#append_term session in
- !refresh_editor_hook ()
+ ()
let main files =
build_ui ();
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
index edfe28b2..2ae18593 100644
--- a/ide/coqide_ui.ml
+++ b/ide/coqide_ui.ml
@@ -18,6 +18,15 @@ let list_items menu li =
let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in
res_buf
+let list_queries menu li =
+ let res_buf = Buffer.create 500 in
+ let query_item (q, _) =
+ let s = "<menuitem action='"^menu^" "^(no_under q)^"' />\n" in
+ Buffer.add_string res_buf s
+ in
+ let () = List.iter query_item li in
+ res_buf
+
let init () =
let theui = Printf.sprintf "<ui>
<menubar name='CoqIde MenuBar'>
@@ -119,6 +128,8 @@ let init () =
<menuitem action='About' />
<menuitem action='Locate' />
<menuitem action='Print Assumptions' />
+ <separator />
+ %s
</menu>
<menu name='Tools' action='Tools'>
<menuitem action='Comment' />
@@ -162,5 +173,6 @@ let init () =
(if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "")
(Buffer.contents (list_items "Tactic" Coq_commands.tactics))
(Buffer.contents (list_items "Template" Coq_commands.commands))
+ (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get))
in
ignore (ui_m#add_ui_from_string theui);
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
index 92301dc3..ed1fa465 100644
--- a/ide/coqidetop.mllib
+++ b/ide/coqidetop.mllib
@@ -1,2 +1,9 @@
+Xml_lexer
+Xml_parser
+Xml_printer
+Serialize
+Richprinter
Xmlprotocol
+Texmacspp
+Document
Ide_slave
diff --git a/ide/document.ml b/ide/document.ml
index 9823e757..62457fe5 100644
--- a/ide/document.ml
+++ b/ide/document.ml
@@ -16,8 +16,8 @@ type id = Stateid.t
class type ['a] signals =
object
- method popped : callback:('a -> unit) -> unit
- method pushed : callback:('a -> unit) -> unit
+ method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit
+ method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit
end
class ['a] signal () =
@@ -32,14 +32,14 @@ end
type 'a document = {
mutable stack : 'a sentence list;
mutable context : ('a sentence list * 'a sentence list) option;
- pushed_sig : 'a signal;
- popped_sig : 'a signal;
+ pushed_sig : ('a * ('a list * 'a list) option) signal;
+ popped_sig : ('a * ('a list * 'a list) option) signal;
}
-let connect d =
+let connect d : 'a signals =
object
- method pushed ~callback = d.pushed_sig#connect callback
- method popped ~callback = d.popped_sig#connect callback
+ method pushed ~callback = d.pushed_sig#connect (fun (x, ctx) -> callback x ctx)
+ method popped ~callback = d.popped_sig#connect (fun (x, ctx) -> callback x ctx)
end
let create () = {
@@ -49,6 +49,12 @@ let create () = {
popped_sig = new signal ();
}
+let repr_context s = match s.context with
+| None -> None
+| Some (cl, cr) ->
+ let map s = s.data in
+ Some (List.map map cl, List.map map cr)
+
(* Invariant, only the tip is a allowed to have state_id = None *)
let invariant l = l = [] || (List.hd l).state_id <> None
@@ -64,12 +70,13 @@ let tip_data = function
let push d x =
assert(invariant d.stack);
d.stack <- { data = x; state_id = None } :: d.stack;
- d.pushed_sig#call x
+ d.pushed_sig#call (x, repr_context d)
let pop = function
| { stack = [] } -> raise Empty
- | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data
-
+ | { stack = { data }::xs } as s ->
+ s.stack <- xs; s.popped_sig#call (data, repr_context s); data
+
let focus d ~cond_top:c_start ~cond_bot:c_stop =
assert(invariant d.stack);
if d.context <> None then invalid_arg "focus";
@@ -124,12 +131,6 @@ let context d =
let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in
List.map (flat pair true) top, List.map (flat pair true) bot
-let iter d f =
- let a, s, b = to_lists d in
- List.iter (flat f false) a;
- List.iter (flat f true) s;
- List.iter (flat f false) b
-
let stateid_opt_equal = Option.equal Stateid.equal
let is_in_focus d id =
@@ -154,7 +155,7 @@ let cut_at d id =
if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone)
else CSig.Cont (n + 1, data :: zone) in
let n, zone = CList.fold_left_until aux (0, []) d.stack in
- for i = 1 to n do ignore(pop d) done;
+ for _i = 1 to n do ignore(pop d) done;
List.rev zone
let find_id d f =
diff --git a/ide/document.mli b/ide/document.mli
index 0d803ff0..fb96cb6d 100644
--- a/ide/document.mli
+++ b/ide/document.mli
@@ -108,8 +108,8 @@ val print :
class type ['a] signals =
object
- method popped : callback:('a -> unit) -> unit
- method pushed : callback:('a -> unit) -> unit
+ method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit
+ method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit
end
val connect : 'a document -> 'a signals
diff --git a/ide/fileOps.ml b/ide/fileOps.ml
index 835ea014..7be1bdb9 100644
--- a/ide/fileOps.ml
+++ b/ide/fileOps.ml
@@ -8,8 +8,6 @@
open Ideutils
-let prefs = Preferences.current
-
let revert_timer = mktimer ()
let autosave_timer = mktimer ()
@@ -87,7 +85,7 @@ object(self)
flash_info "Could not overwrite file"
| _ ->
Minilib.log "Auto revert set to false";
- prefs.Preferences.global_auto_revert <- false;
+ Preferences.global_auto_revert#set false;
revert_timer.kill ()
method save f =
@@ -120,9 +118,9 @@ object(self)
| None -> None
| Some f ->
let dir = Filename.dirname f in
- let base = (fst prefs.Preferences.auto_save_name) ^
+ let base = (fst Preferences.auto_save_name#get) ^
(Filename.basename f) ^
- (snd prefs.Preferences.auto_save_name)
+ (snd Preferences.auto_save_name#get)
in Some (Filename.concat dir base)
method private need_auto_save =
diff --git a/ide/ide.mllib b/ide/ide.mllib
index e082bd18..b2f32fcf 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,18 +9,23 @@ Configwin
Editable_cells
Config_parser
Tags
-Wg_Segment
Wg_Notebook
Config_lexer
Utf8_convert
Preferences
Project_file
-Ideutils
+Serialize
+Richprinter
+Xml_lexer
+Xml_parser
+Xml_printer
Xmlprotocol
+Ideutils
Coq
Coq_lex
Sentence
Gtk_parsing
+Wg_Segment
Wg_ProofView
Wg_MessageView
Wg_Detachable
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
index bd98fe16..5b07d3ec 100644
--- a/ide/ide_slave.ml
+++ b/ide/ide_slave.ml
@@ -1,4 +1,5 @@
(************************************************************************)
+
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
@@ -7,7 +8,7 @@
(************************************************************************)
open Vernacexpr
-open Errors
+open CErrors
open Util
open Pp
open Printer
@@ -47,6 +48,7 @@ let init_stdout, read_stdout =
let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+let pr_error s = pr_with_pid s
let pr_debug s =
if !Flags.debug then pr_with_pid s
let pr_debug_call q =
@@ -94,15 +96,15 @@ let is_undo cmd = match cmd with
(** Check whether a command is forbidden by CoqIDE *)
let coqide_cmd_checks (loc,ast) =
- let user_error s = Errors.user_err_loc (loc, "CoqIde", str s) in
+ let user_error s = CErrors.user_err_loc (loc, "CoqIde", str s) in
if is_debug ast then
user_error "Debug mode not available within CoqIDE";
if is_known_option ast then
- msg_warning (strbrk"This will not work. Use CoqIDE display menu instead");
+ Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead");
if Vernac.is_navigation_vernac ast || is_undo ast then
- msg_warning (strbrk "Rather use CoqIDE navigation instead");
+ Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead");
if is_query ast then
- msg_warning (strbrk "Query commands should not be inserted in scripts")
+ Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts")
(** Interpretation (cf. [Ide_intf.interp]) *)
@@ -130,7 +132,8 @@ let annotate phrase =
(** Goal display *)
-let hyp_next_tac sigma env (id,_,ast) =
+let hyp_next_tac sigma env decl =
+ let (id,_,ast) = Context.Named.Declaration.to_tuple decl in
let id_s = Names.Id.to_string id in
let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in
[
@@ -184,14 +187,19 @@ let process_goal sigma g =
let id = Goal.uid g in
let ccl =
let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
- string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in
+ Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr)
+ in
let process_hyp d (env,l) =
- let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in
- let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in
+ let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in
+ let d' = List.map (fun name -> let open Context.Named.Declaration in
+ match pi2 d with
+ | None -> LocalAssum (name, pi3 d)
+ | Some value -> LocalDef (name, value, pi3 d))
+ (pi1 d) in
(List.fold_right Environ.push_named d' env,
- (string_of_ppcmds (pr_var_list_decl env sigma d)) :: l) in
+ (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in
let (_env, hyps) =
- Context.fold_named_list_context process_hyp
+ Context.NamedList.fold process_hyp
(Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in
{ Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
@@ -206,7 +214,7 @@ let export_pre_goals pgs =
let goals () =
Stm.finish ();
let s = read_stdout () in
- if not (String.is_empty s) then msg_info (str s);
+ if not (String.is_empty s) then Feedback.msg_info (str s);
try
let pfts = Proof_global.give_me_the_proof () in
Some (export_pre_goals (Proof.map_structured_proof pfts process_goal))
@@ -216,7 +224,7 @@ let evars () =
try
Stm.finish ();
let s = read_stdout () in
- if not (String.is_empty s) then msg_info (str s);
+ if not (String.is_empty s) then Feedback.msg_info (str s);
let pfts = Proof_global.give_me_the_proof () in
let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in
@@ -249,7 +257,7 @@ let status force =
Stm.finish ();
if force then Stm.join ();
let s = read_stdout () in
- if not (String.is_empty s) then msg_info (str s);
+ if not (String.is_empty s) then Feedback.msg_info (str s);
let path =
let l = Names.DirPath.repr (Lib.cwd ()) in
List.rev_map Names.Id.to_string l
@@ -275,11 +283,33 @@ let export_coq_object t = {
Interface.coq_object_object = t.Search.coq_object_object
}
+let pattern_of_string ?env s =
+ let env =
+ match env with
+ | None -> Global.env ()
+ | Some e -> e
+ in
+ let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+ let (_, pat) = Constrintern.intern_constr_pattern env constr in
+ pat
+
+let dirpath_of_string_list s =
+ let path = String.concat "." s in
+ let m = Pcoq.parse_string Pcoq.Constr.global path in
+ let (_, qid) = Libnames.qualid_of_reference m in
+ let id =
+ try Nametab.full_name_module qid
+ with Not_found ->
+ CErrors.errorlabstrm "Search.interface_search"
+ (str "Module " ++ str path ++ str " not found.")
+ in
+ id
+
let import_search_constraint = function
- | Interface.Name_Pattern s -> Search.Name_Pattern s
- | Interface.Type_Pattern s -> Search.Type_Pattern s
- | Interface.SubType_Pattern s -> Search.SubType_Pattern s
- | Interface.In_Module ms -> Search.In_Module ms
+ | Interface.Name_Pattern s -> Search.Name_Pattern (Str.regexp s)
+ | Interface.Type_Pattern s -> Search.Type_Pattern (pattern_of_string s)
+ | Interface.SubType_Pattern s -> Search.SubType_Pattern (pattern_of_string s)
+ | Interface.In_Module ms -> Search.In_Module (dirpath_of_string_list ms)
| Interface.Include_Blacklist -> Search.Include_Blacklist
let search flags =
@@ -333,10 +363,14 @@ let handle_exn (e, info) =
let loc_of e = match Loc.get_loc e with
| Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
| _ -> None in
- let mk_msg () = read_stdout ()^"\n"^string_of_ppcmds (Errors.print ~info e) in
+ let mk_msg () =
+ let msg = read_stdout () in
+ let msg = str msg ++ fnl () ++ CErrors.print ~info e in
+ Richpp.richpp_of_pp msg
+ in
match e with
- | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
- | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+ | CErrors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!"
+ | CErrors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!"
| e ->
match Stateid.get info with
| Some (valid, _) -> valid, loc_of info, mk_msg ()
@@ -351,8 +385,6 @@ let init =
match file with
| None -> Stm.get_current_state ()
| Some file ->
- if not (Filename.check_suffix file ".v") then
- error "A file with suffix .v is expected.";
let dir = Filename.dirname file in
let open Loadpath in let open CUnix in
let initial_id, _ =
@@ -361,6 +393,7 @@ let init =
0 (Printf.sprintf "Add LoadPath \"%s\". " dir)
else Stm.get_current_state (), `NewTip in
Stm.set_compilation_hints file;
+ Stm.finish ();
initial_id
end
@@ -382,6 +415,15 @@ let interp ((_raw, verbose), s) =
let quit = ref false
+(** Serializes the output of Stm.get_ast *)
+let print_ast id =
+ match Stm.get_ast id with
+ | Some (expr, loc) -> begin
+ try Texmacspp.tmpp expr loc
+ with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e)
+ end
+ | None -> Xml_datatype.PCData "ERROR"
+
(** Grouping all call handlers together + error handling *)
let eval_call xml_oc log c =
@@ -412,7 +454,7 @@ let eval_call xml_oc log c =
Interface.interp = interruptible interp;
Interface.handle_exn = handle_exn;
Interface.stop_worker = Stm.stop_worker;
- Interface.print_ast = Stm.print_ast;
+ Interface.print_ast = print_ast;
Interface.annotate = interruptible annotate;
} in
Xmlprotocol.abstract_eval_call handler c
@@ -427,22 +469,18 @@ let print_xml =
fun oc xml ->
Mutex.lock m;
try Xml_printer.print oc xml; Mutex.unlock m
- with e -> let e = Errors.push e in Mutex.unlock m; iraise e
+ with e -> let e = CErrors.push e in Mutex.unlock m; iraise e
-let slave_logger xml_oc level message =
+let slave_logger xml_oc ?loc level message =
(* convert the message into XML *)
- let msg = string_of_ppcmds (hov 0 message) in
- let message = {
- Pp.message_level = level;
- Pp.message_content = msg;
- } in
- let () = pr_debug (Printf.sprintf "-> %S" msg) in
- let xml = Pp.of_message message in
+ let msg = hov 0 message in
+ let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in
+ let xml = Xmlprotocol.of_message level loc (Richpp.richpp_of_pp message) in
print_xml xml_oc xml
let slave_feeder xml_oc msg =
- let xml = Feedback.of_feedback msg in
+ let xml = Xmlprotocol.of_feedback msg in
print_xml xml_oc xml
(** The main loop *)
@@ -460,8 +498,8 @@ let loop () =
CThread.thread_friendly_read in_ch s ~off:0 ~len) in
let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
let () = Xml_parser.check_eof xml_ic false in
- set_logger (slave_logger xml_oc);
- set_feeder (slave_feeder xml_oc);
+ Feedback.set_logger (slave_logger xml_oc);
+ Feedback.add_feeder (slave_feeder xml_oc);
(* We'll handle goal fetching and display in our own way *)
Vernacentries.enable_goal_printing := false;
Vernacentries.qed_display_script := false;
@@ -469,9 +507,9 @@ let loop () =
try
let xml_query = Xml_parser.parse xml_ic in
(* pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
- let q = Xmlprotocol.to_call xml_query in
+ let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in
let () = pr_debug_call q in
- let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in
+ let r = eval_call xml_oc (slave_logger xml_oc Feedback.Notice) q in
let () = pr_debug_answer q r in
(* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *)
print_xml xml_oc (Xmlprotocol.of_answer q r);
@@ -481,11 +519,11 @@ let loop () =
pr_debug "End of input, exiting gracefully.";
exit 0
| Xml_parser.Error (err, loc) ->
- pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err);
- exit 1
- | Serialize.Marshal_error ->
- pr_debug "Incorrect query.";
- exit 1
+ pr_error ("XML syntax error: " ^ Xml_parser.error_msg err)
+ | Serialize.Marshal_error (msg,node) ->
+ pr_error "Unexpected XML message";
+ pr_error ("Expected XML node: " ^ msg);
+ pr_error ("XML tree received: " ^ Xml_printer.to_string_fmt node)
| any ->
pr_debug ("Fatal exception in coqtop:\n" ^ Printexc.to_string any);
exit 1
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 44a86556..06a13273 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -9,8 +9,6 @@
open Preferences
-exception Forbidden
-
let warn_image () =
let img = GMisc.image () in
img#set_stock `DIALOG_WARNING;
@@ -31,13 +29,54 @@ let push_info,pop_info,clear_info =
let size = ref 0 in
(fun s -> incr size; ignore (status_context#push s)),
(fun () -> decr size; status_context#pop ()),
- (fun () -> for i = 1 to !size do status_context#pop () done; size := 0)
+ (fun () -> for _i = 1 to !size do status_context#pop () done; size := 0)
let flash_info =
let flash_context = status#new_context ~name:"Flash" in
(fun ?(delay=5000) s -> flash_context#flash ~delay s)
-
+let xml_to_string xml =
+ let open Xml_datatype in
+ let buf = Buffer.create 1024 in
+ let rec iter = function
+ | PCData s -> Buffer.add_string buf s
+ | Element (_, _, children) ->
+ List.iter iter children
+ in
+ let () = iter (Richpp.repr xml) in
+ Buffer.contents buf
+
+let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text =
+ (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that
+ it has to reimplement its own helper function. Unluckily, it relies on
+ a slow algorithm, so that we have to have our own quicker version here.
+ Alas, it is still much slower than the native version... *)
+ if CList.is_empty tags then buf#insert ~iter:(buf#get_iter_at_mark mark) text
+ else
+ let it = buf#get_iter_at_mark mark in
+ let () = buf#move_mark rmark ~where:it in
+ let () = buf#insert ~iter:(buf#get_iter_at_mark mark) text in
+ let start = buf#get_iter_at_mark mark in
+ let stop = buf#get_iter_at_mark rmark in
+ let iter tag = buf#apply_tag tag start stop in
+ List.iter iter tags
+
+let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg =
+ let open Xml_datatype in
+ let tag name =
+ match GtkText.TagTable.lookup buf#tag_table name with
+ | None -> raise Not_found
+ | Some tag -> new GText.tag tag
+ in
+ let rmark = `MARK (buf#create_mark buf#start_iter) in
+ let rec insert tags = function
+ | PCData s -> insert_with_tags buf mark rmark tags s
+ | Element (t, _, children) ->
+ let tags = try tag t :: tags with Not_found -> tags in
+ List.iter (fun xml -> insert tags xml) children
+ in
+ let () = try insert tags (Richpp.repr msg) with _ -> () in
+ buf#delete_mark rmark
let set_location = ref (function s -> failwith "not ready")
@@ -74,7 +113,7 @@ let do_convert s =
in
let s =
if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s)
- else match current.encoding with
+ else match encoding#get with
|Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
|Emanual enc -> try from_manual enc with _ -> from_loc ()
in
@@ -87,10 +126,28 @@ let try_convert s =
"(* Fatal error: wrong encoding in input. \
Please choose a correct encoding in the preference panel.*)";;
+let export file_name s =
+ let oc = open_out_bin file_name in
+ let ending = line_ending#get in
+ let is_windows = ref false in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ | '\r' -> is_windows := true
+ | '\n' ->
+ begin match ending with
+ | `DEFAULT ->
+ if !is_windows then (output_char oc '\r'; output_char oc '\n')
+ else output_char oc '\n'
+ | `WINDOWS -> output_char oc '\r'; output_char oc '\n'
+ | `UNIX -> output_char oc '\n'
+ end
+ | c -> output_char oc c
+ done;
+ close_out oc
let try_export file_name s =
let s =
- try match current.encoding with
+ try match encoding#get with
|Eutf8 -> Minilib.log "UTF-8 is enforced" ; s
|Elocale ->
let is_unicode,char_set = Glib.Convert.get_charset () in
@@ -109,11 +166,7 @@ let try_export file_name s =
Minilib.log ("Error ("^str^") in transcoding: falling back to UTF-8");
s
in
- try
- let oc = open_out file_name in
- output_string oc s;
- close_out oc;
- true
+ try export file_name s; true
with e -> Minilib.log (Printexc.to_string e);false
type timer = { run : ms:int -> callback:(unit->bool) -> unit;
@@ -140,7 +193,7 @@ let filter_coq_files () = GFile.filter
~name:"Coq source code"
~patterns:[ "*.v"] ()
-let current_dir () = match current.project_path with
+let current_dir () = match project_path#get with
| None -> ""
| Some dir -> dir
@@ -164,7 +217,7 @@ let select_file_for_open ~title ?filename () =
match file_chooser#filename with
| None -> None
| Some _ as f ->
- current.project_path <- file_chooser#current_folder; f
+ project_path#set file_chooser#current_folder; f
end
| `DELETE_EVENT | `CANCEL -> None in
file_chooser#destroy ();
@@ -193,7 +246,7 @@ let select_file_for_save ~title ?filename () =
file := file_chooser#filename;
match !file with
None -> ()
- | Some s -> current.project_path <- file_chooser#current_folder
+ | Some s -> project_path#set file_chooser#current_folder
end
| `DELETE_EVENT | `CANCEL -> ()
end ;
@@ -238,7 +291,7 @@ let coqtop_path () =
let file = match !custom_coqtop with
| Some s -> s
| None ->
- match current.cmd_coqtop with
+ match cmd_coqtop#get with
| Some s -> s
| None ->
let prog = String.copy Sys.executable_name in
@@ -272,17 +325,17 @@ let textview_width (view : #GText.view_skel) =
let char_width = GPango.to_pixels metrics#approx_char_width in
pixel_width / char_width
-type logger = Pp.message_level -> string -> unit
+type logger = Feedback.level -> Richpp.richpp -> unit
let default_logger level message =
let level = match level with
- | Pp.Debug _ -> `DEBUG
- | Pp.Info -> `INFO
- | Pp.Notice -> `NOTICE
- | Pp.Warning -> `WARNING
- | Pp.Error -> `ERROR
+ | Feedback.Debug -> `DEBUG
+ | Feedback.Info -> `INFO
+ | Feedback.Notice -> `NOTICE
+ | Feedback.Warning -> `WARNING
+ | Feedback.Error -> `ERROR
in
- Minilib.log ~level message
+ Minilib.log ~level (xml_to_string message)
(** {6 File operations} *)
@@ -364,7 +417,7 @@ let run_command display finally cmd =
(** Web browsing *)
let browse prerr url =
- let com = Util.subst_command_placeholder current.cmd_browse url in
+ let com = Util.subst_command_placeholder cmd_browse#get url in
let finally = function
| Unix.WEXITED 127 ->
prerr
@@ -375,13 +428,13 @@ let browse prerr url =
run_command (fun _ -> ()) finally com
let doc_url () =
- if current.doc_url = use_default_doc_url || current.doc_url = ""
+ if doc_url#get = use_default_doc_url || doc_url#get = ""
then
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
+ else doc_url#get
let url_for_keyword =
let ht = Hashtbl.create 97 in
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index e5307218..e32a4d9e 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -52,6 +52,11 @@ val pop_info : unit -> unit
val clear_info : unit -> unit
val flash_info : ?delay:int -> string -> unit
+val xml_to_string : Richpp.richpp -> string
+
+val insert_xml : ?mark:GText.mark -> ?tags:GText.tag list ->
+ #GText.buffer_skel -> Richpp.richpp -> unit
+
val set_location : (string -> unit) ref
(* In win32, when a command-line is to be executed via cmd.exe
@@ -64,9 +69,9 @@ val requote : string -> string
val textview_width : #GText.view_skel -> int
(** Returns an approximate value of the character width of a textview *)
-type logger = Pp.message_level -> string -> unit
+type logger = Feedback.level -> Richpp.richpp -> unit
-val default_logger : Pp.message_level -> string -> unit
+val default_logger : logger
(** Default logger. It logs messages that the casual user should not see. *)
(** {6 I/O operations} *)
diff --git a/ide/interface.mli b/ide/interface.mli
index 6f7f1bcd..2a9b8b24 100644
--- a/ide/interface.mli
+++ b/ide/interface.mli
@@ -12,14 +12,15 @@
type raw = bool
type verbose = bool
+type richpp = Richpp.richpp
(** The type of coqtop goals *)
type goal = {
goal_id : string;
(** Unique goal identifier *)
- goal_hyp : string list;
+ goal_hyp : richpp list;
(** List of hypotheses *)
- goal_ccl : string;
+ goal_ccl : richpp;
(** Goal conclusion *)
}
@@ -118,7 +119,7 @@ type edit_id = Feedback.edit_id
should probably retract to that point *)
type 'a value =
| Good of 'a
- | Fail of (state_id * location * string)
+ | Fail of (state_id * location * richpp)
type ('a, 'b) union = ('a, 'b) Util.union
@@ -202,7 +203,7 @@ type about_sty = unit
type about_rty = coq_info
type handle_exn_sty = Exninfo.iexn
-type handle_exn_rty = state_id * location * string
+type handle_exn_rty = state_id * location * richpp
(* Retrocompatibility stuff *)
type interp_sty = (raw * verbose) * string
diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml
index 42d65cec..93bdeb32 100644
--- a/ide/nanoPG.ml
+++ b/ide/nanoPG.ml
@@ -303,7 +303,7 @@ let init w nb ags =
then false
else begin
eprintf "got key %s\n%!" (pr_key t);
- if current.nanoPG then begin
+ if nanoPG#get then begin
match find gui !cur t with
| `Do e ->
eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status);
diff --git a/ide/preferences.ml b/ide/preferences.ml
index f7cc27a5..f0fd45d7 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -17,19 +17,67 @@ let style_manager = GSourceView2.source_style_scheme_manager ~default:true
let () = style_manager#set_search_path
((Minilib.coqide_data_dirs ())@style_manager#search_path)
-let get_config_file name =
- let find_config dir = Sys.file_exists (Filename.concat dir name) in
- let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
- Filename.concat config_dir name
+type tag = {
+ tag_fg_color : string option;
+ tag_bg_color : string option;
+ tag_bold : bool;
+ tag_italic : bool;
+ tag_underline : bool;
+}
-(* Small hack to handle v8.3 to v8.4 change in configuration file *)
-let loaded_pref_file =
- try get_config_file "coqiderc"
- with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+(** Generic preferences *)
-let loaded_accel_file =
- try get_config_file "coqide.keys"
- with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
+type obj = {
+ set : string list -> unit;
+ get : unit -> string list;
+}
+
+let preferences : obj Util.String.Map.t ref = ref Util.String.Map.empty
+let unknown_preferences : string list Util.String.Map.t ref = ref Util.String.Map.empty
+
+class type ['a] repr =
+object
+ method into : string list -> 'a option
+ method from : 'a -> string list
+end
+
+class ['a] preference_signals ~(changed : 'a GUtil.signal) =
+object
+ inherit GUtil.ml_signals [changed#disconnect]
+ method changed = changed#connect ~after
+end
+
+class ['a] preference ~(name : string list) ~(init : 'a) ~(repr : 'a repr) =
+object (self)
+ initializer
+ let set v = match repr#into v with None -> () | Some s -> self#set s in
+ let get () = repr#from self#get in
+ let obj = { set = set; get = get; } in
+ let name = String.concat "." name in
+ if Util.String.Map.mem name !preferences then
+ invalid_arg ("Preference " ^ name ^ " already exists")
+ else
+ preferences := Util.String.Map.add name obj !preferences
+
+ val default = init
+ val mutable data = init
+ val changed : 'a GUtil.signal = new GUtil.signal ()
+ val name : string list = name
+ method connect = new preference_signals ~changed
+ method get = data
+ method set (n : 'a) = data <- n; changed#call n
+ method reset () = self#set default
+ method default = default
+end
+
+let stick (pref : 'a preference) (obj : #GObj.widget as 'obj)
+ (cb : 'a -> unit) =
+ let _ = cb pref#get in
+ let p_id = pref#connect#changed (fun v -> cb v) in
+ let _ = obj#misc#connect#destroy (fun () -> pref#connect#disconnect p_id) in
+ ()
+
+(** Useful marshallers *)
let mod_to_str m =
match m with
@@ -74,359 +122,537 @@ let inputenc_of_string s =
else if s = "LOCALE" then Elocale
else Emanual s)
+type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ]
+
+let line_end_of_string = function
+| "unix" -> `UNIX
+| "windows" -> `WINDOWS
+| _ -> `DEFAULT
+
+let line_end_to_string = function
+| `UNIX -> "unix"
+| `WINDOWS -> "windows"
+| `DEFAULT -> "default"
+
+let use_default_doc_url = "(automatic)"
+
+module Repr =
+struct
+
+let string : string repr =
+object
+ method from s = [s]
+ method into = function [s] -> Some s | _ -> None
+end
+
+let string_pair : (string * string) repr =
+object
+ method from (s1, s2) = [s1; s2]
+ method into = function [s1; s2] -> Some (s1, s2) | _ -> None
+end
+
+let string_list : string list repr =
+object
+ method from s = s
+ method into s = Some s
+end
+
+let string_pair_list (sep : char) : (string * string) list repr =
+object
+ val sep' = String.make 1 sep
+ method from = CList.map (fun (s1, s2) -> CString.concat sep' [s1; s2])
+ method into l =
+ try
+ Some (CList.map (fun s ->
+ let split = CString.split sep s in
+ CList.nth split 0, CList.nth split 1) l)
+ with Failure _ -> None
+end
+
+let bool : bool repr =
+object
+ method from s = [string_of_bool s]
+ method into = function
+ | ["true"] -> Some true
+ | ["false"] -> Some false
+ | _ -> None
+end
+
+let int : int repr =
+object
+ method from s = [string_of_int s]
+ method into = function
+ | [i] -> (try Some (int_of_string i) with _ -> None)
+ | _ -> None
+end
+
+let option (r : 'a repr) : 'a option repr =
+object
+ method from = function None -> [] | Some v -> "" :: r#from v
+ method into = function
+ | [] -> Some None
+ | "" :: s -> Some (r#into s)
+ | _ -> None
+end
+
+let custom (from : 'a -> string) (into : string -> 'a) : 'a repr =
+object
+ method from x = try [from x] with _ -> []
+ method into = function
+ | [s] -> (try Some (into s) with _ -> None)
+ | _ -> None
+end
+
+let tag : tag repr =
+let _to s = if s = "" then None else Some s in
+let _of = function None -> "" | Some s -> s in
+object
+ method from tag = [
+ _of tag.tag_fg_color;
+ _of tag.tag_bg_color;
+ string_of_bool tag.tag_bold;
+ string_of_bool tag.tag_italic;
+ string_of_bool tag.tag_underline;
+ ]
+ method into = function
+ | [fg; bg; bd; it; ul] ->
+ (try Some {
+ tag_fg_color = _to fg;
+ tag_bg_color = _to bg;
+ tag_bold = bool_of_string bd;
+ tag_italic = bool_of_string it;
+ tag_underline = bool_of_string ul;
+ }
+ with _ -> None)
+ | _ -> None
+end
+
+end
+
+let get_config_file name =
+ let find_config dir = Sys.file_exists (Filename.concat dir name) in
+ let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
+ Filename.concat config_dir name
+
+(* Small hack to handle v8.3 to v8.4 change in configuration file *)
+let loaded_pref_file =
+ try get_config_file "coqiderc"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
+
+let loaded_accel_file =
+ try get_config_file "coqide.keys"
+ with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
(** Hooks *)
-let refresh_style_hook = ref (fun () -> ())
-let refresh_language_hook = ref (fun () -> ())
-let refresh_editor_hook = ref (fun () -> ())
-let refresh_toolbar_hook = ref (fun () -> ())
-let contextual_menus_on_goal_hook = ref (fun x -> ())
-let resize_window_hook = ref (fun () -> ())
-let refresh_tabs_hook = ref (fun () -> ())
+(** New style preferences *)
-type pref =
- {
- mutable cmd_coqtop : string option;
- mutable cmd_coqc : string;
- mutable cmd_make : string;
- mutable cmd_coqmakefile : string;
- mutable cmd_coqdoc : string;
+let cmd_coqtop =
+ new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string)
- mutable source_language : string;
- mutable source_style : string;
+let cmd_coqc =
+ new preference ~name:["cmd_coqc"] ~init:"coqc" ~repr:Repr.(string)
- mutable global_auto_revert : bool;
- mutable global_auto_revert_delay : int;
+let cmd_make =
+ new preference ~name:["cmd_make"] ~init:"make" ~repr:Repr.(string)
- mutable auto_save : bool;
- mutable auto_save_delay : int;
- mutable auto_save_name : string * string;
+let cmd_coqmakefile =
+ new preference ~name:["cmd_coqmakefile"] ~init:"coq_makefile -o makefile *.v" ~repr:Repr.(string)
- mutable read_project : project_behavior;
- mutable project_file_name : string;
- mutable project_path : string option;
+let cmd_coqdoc =
+ new preference ~name:["cmd_coqdoc"] ~init:"coqdoc -q -g" ~repr:Repr.(string)
- mutable encoding : inputenc;
+let source_language =
+ new preference ~name:["source_language"] ~init:"coq" ~repr:Repr.(string)
- mutable automatic_tactics : string list;
- mutable cmd_print : string;
+let source_style =
+ new preference ~name:["source_style"] ~init:"coq_style" ~repr:Repr.(string)
- mutable modifier_for_navigation : string;
- mutable modifier_for_templates : string;
- mutable modifier_for_tactics : string;
- mutable modifier_for_display : string;
- mutable modifiers_valid : string;
+let global_auto_revert =
+ new preference ~name:["global_auto_revert"] ~init:false ~repr:Repr.(bool)
- mutable cmd_browse : string;
- mutable cmd_editor : string;
+let global_auto_revert_delay =
+ new preference ~name:["global_auto_revert_delay"] ~init:10000 ~repr:Repr.(int)
- mutable text_font : Pango.font_description;
+let auto_save =
+ new preference ~name:["auto_save"] ~init:true ~repr:Repr.(bool)
- mutable doc_url : string;
- mutable library_url : string;
+let auto_save_delay =
+ new preference ~name:["auto_save_delay"] ~init:10000 ~repr:Repr.(int)
- mutable show_toolbar : bool;
- mutable contextual_menus_on_goal : bool;
- mutable window_width : int;
- mutable window_height :int;
- mutable query_window_width : int;
- mutable query_window_height : int;
-(*
- mutable use_utf8_notation : bool;
-*)
- mutable auto_complete : bool;
- mutable stop_before : bool;
- mutable reset_on_tab_switch : bool;
- mutable vertical_tabs : bool;
- mutable opposite_tabs : bool;
-
- mutable background_color : string;
- mutable processing_color : string;
- mutable processed_color : string;
- mutable error_color : string;
- mutable error_fg_color : string;
-
- mutable dynamic_word_wrap : bool;
- mutable show_line_number : bool;
- mutable auto_indent : bool;
- mutable show_spaces : bool;
- mutable show_right_margin : bool;
- mutable show_progress_bar : bool;
- mutable spaces_instead_of_tabs : bool;
- mutable tab_length : int;
- mutable highlight_current_line : bool;
-
- mutable nanoPG : bool;
+let auto_save_name =
+ new preference ~name:["auto_save_name"] ~init:("#","#") ~repr:Repr.(string_pair)
+
+let read_project =
+ let repr = Repr.custom string_of_project_behavior project_behavior_of_string in
+ new preference ~name:["read_project"] ~init:Append_args ~repr
+
+let project_file_name =
+ new preference ~name:["project_file_name"] ~init:"_CoqProject" ~repr:Repr.(string)
+
+let project_path =
+ new preference ~name:["project_path"] ~init:None ~repr:Repr.(option string)
+
+let encoding =
+ let repr = Repr.custom string_of_inputenc inputenc_of_string in
+ let init = if Sys.os_type = "Win32" then Eutf8 else Elocale in
+ new preference ~name:["encoding"] ~init ~repr
+
+let automatic_tactics =
+ let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in
+ new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list)
+let cmd_print =
+ new preference ~name:["cmd_print"] ~init:"lpr" ~repr:Repr.(string)
+
+let attach_modifiers (pref : string preference) prefix =
+ let cb mds =
+ let mds = str_to_mod_list mds in
+ let change ~path ~key ~modi ~changed =
+ if CString.is_sub prefix path 0 then
+ ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path)
+ in
+ GtkData.AccelMap.foreach change
+ in
+ pref#connect#changed cb
+
+let modifier_for_navigation =
+ new preference ~name:["modifier_for_navigation"] ~init:"<Control>" ~repr:Repr.(string)
+
+let modifier_for_templates =
+ new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string)
+
+let modifier_for_tactics =
+ new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string)
+
+let modifier_for_display =
+ new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string)
+
+let modifier_for_queries =
+ new preference ~name:["modifier_for_queries"] ~init:"<Control><Shift>" ~repr:Repr.(string)
+
+let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/"
+let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/"
+let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/"
+let _ = attach_modifiers modifier_for_display "<Actions>/View/"
+let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/"
+
+let modifiers_valid =
+ new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string)
+
+let cmd_browse =
+ new preference ~name:["cmd_browse"] ~init:Flags.browser_cmd_fmt ~repr:Repr.(string)
+
+let cmd_editor =
+ let init = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s" in
+ new preference ~name:["cmd_editor"] ~init ~repr:Repr.(string)
+
+let text_font =
+ let init = match Coq_config.gtk_platform with
+ | `QUARTZ -> "Arial Unicode MS 11"
+ | _ -> "Monospace 10"
+ in
+ new preference ~name:["text_font"] ~init ~repr:Repr.(string)
+
+let doc_url =
+object
+ inherit [string] preference
+ ~name:["doc_url"] ~init:Coq_config.wwwrefman ~repr:Repr.(string)
+ as super
+
+ method set v =
+ if not (Flags.is_standard_doc_url v) &&
+ v <> use_default_doc_url &&
+ (* Extra hack to support links to last released doc version *)
+ v <> Coq_config.wwwcoq ^ "doc" &&
+ v <> Coq_config.wwwcoq ^ "doc/"
+ then super#set v
+
+end
+
+let library_url =
+ new preference ~name:["library_url"] ~init:Coq_config.wwwstdlib ~repr:Repr.(string)
+
+let show_toolbar =
+ new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool)
+
+let contextual_menus_on_goal =
+ new preference ~name:["contextual_menus_on_goal"] ~init:true ~repr:Repr.(bool)
+
+let window_width =
+ new preference ~name:["window_width"] ~init:800 ~repr:Repr.(int)
+
+let window_height =
+ new preference ~name:["window_height"] ~init:600 ~repr:Repr.(int)
+
+let auto_complete =
+ new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool)
+
+let stop_before =
+ new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool)
+
+let reset_on_tab_switch =
+ new preference ~name:["reset_on_tab_switch"] ~init:false ~repr:Repr.(bool)
+
+let line_ending =
+ let repr = Repr.custom line_end_to_string line_end_of_string in
+ new preference ~name:["line_ending"] ~init:`DEFAULT ~repr
+
+let vertical_tabs =
+ new preference ~name:["vertical_tabs"] ~init:false ~repr:Repr.(bool)
+
+let opposite_tabs =
+ new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool)
+
+let background_color =
+ new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string)
+
+let attach_bg (pref : string preference) (tag : GText.tag) =
+ pref#connect#changed (fun c -> tag#set_property (`BACKGROUND c))
+
+let attach_fg (pref : string preference) (tag : GText.tag) =
+ pref#connect#changed (fun c -> tag#set_property (`FOREGROUND c))
+
+let processing_color =
+ new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string)
+
+let _ = attach_bg processing_color Tags.Script.to_process
+let _ = attach_bg processing_color Tags.Script.incomplete
+
+let tags = ref Util.String.Map.empty
+
+let list_tags () = !tags
+
+let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = {
+ tag_fg_color = fg;
+ tag_bg_color = bg;
+ tag_bold = bold;
+ tag_italic = italic;
+ tag_underline = underline;
}
-let use_default_doc_url = "(automatic)"
+let create_tag name default =
+ let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in
+ let set_tag tag =
+ begin match pref#get.tag_bg_color with
+ | None -> tag#set_property (`BACKGROUND_SET false)
+ | Some c ->
+ tag#set_property (`BACKGROUND_SET true);
+ tag#set_property (`BACKGROUND c)
+ end;
+ begin match pref#get.tag_fg_color with
+ | None -> tag#set_property (`FOREGROUND_SET false)
+ | Some c ->
+ tag#set_property (`FOREGROUND_SET true);
+ tag#set_property (`FOREGROUND c)
+ end;
+ begin match pref#get.tag_bold with
+ | false -> tag#set_property (`WEIGHT_SET false)
+ | true ->
+ tag#set_property (`WEIGHT_SET true);
+ tag#set_property (`WEIGHT `BOLD)
+ end;
+ begin match pref#get.tag_italic with
+ | false -> tag#set_property (`STYLE_SET false)
+ | true ->
+ tag#set_property (`STYLE_SET true);
+ tag#set_property (`STYLE `ITALIC)
+ end;
+ begin match pref#get.tag_underline with
+ | false -> tag#set_property (`UNDERLINE_SET false)
+ | true ->
+ tag#set_property (`UNDERLINE_SET true);
+ tag#set_property (`UNDERLINE `SINGLE)
+ end;
+ in
+ let iter table =
+ let tag = GText.tag ~name () in
+ table#add tag#as_tag;
+ ignore (pref#connect#changed (fun _ -> set_tag tag));
+ set_tag tag;
+ in
+ List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table];
+ tags := Util.String.Map.add name pref !tags
-let current = {
- cmd_coqtop = None;
- cmd_coqc = "coqc";
- cmd_make = "make";
- cmd_coqmakefile = "coq_makefile -o makefile *.v";
- cmd_coqdoc = "coqdoc -q -g";
- cmd_print = "lpr";
+let () =
+ let iter (name, tag) = create_tag name tag in
+ List.iter iter [
+ ("constr.evar", make_tag ());
+ ("constr.keyword", make_tag ~fg:"dark green" ());
+ ("constr.notation", make_tag ());
+ ("constr.path", make_tag ());
+ ("constr.reference", make_tag ~fg:"navy"());
+ ("constr.type", make_tag ~fg:"#008080" ());
+ ("constr.variable", make_tag ());
+ ("message.debug", make_tag ());
+ ("message.error", make_tag ());
+ ("message.warning", make_tag ());
+ ("module.definition", make_tag ~fg:"orange red" ~bold:true ());
+ ("module.keyword", make_tag ());
+ ("tactic.keyword", make_tag ());
+ ("tactic.primitive", make_tag ());
+ ("tactic.string", make_tag ());
+ ]
- global_auto_revert = false;
- global_auto_revert_delay = 10000;
+let processed_color =
+ new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string)
- auto_save = true;
- auto_save_delay = 10000;
- auto_save_name = "#","#";
+let _ = attach_bg processed_color Tags.Script.processed
+let _ = attach_bg processed_color Tags.Proof.highlight
- source_language = "coq";
- source_style = "coq_style";
+let error_color =
+ new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string)
- read_project = Append_args;
- project_file_name = "_CoqProject";
- project_path = None;
+let _ = attach_bg error_color Tags.Script.error_bg
- encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale;
+let error_fg_color =
+ new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string)
- automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
- "auto with *"; "intuition" ];
+let _ = attach_fg error_fg_color Tags.Script.error
- modifier_for_navigation = "<Control>";
- modifier_for_templates = "<Control><Shift>";
- modifier_for_tactics = "<Control><Alt>";
- modifier_for_display = "<Alt><Shift>";
- modifiers_valid = "<Alt><Control><Shift>";
+let dynamic_word_wrap =
+ new preference ~name:["dynamic_word_wrap"] ~init:false ~repr:Repr.(bool)
+let show_line_number =
+ new preference ~name:["show_line_number"] ~init:false ~repr:Repr.(bool)
- cmd_browse = Flags.browser_cmd_fmt;
- cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s";
+let auto_indent =
+ new preference ~name:["auto_indent"] ~init:false ~repr:Repr.(bool)
-(* text_font = Pango.Font.from_string "sans 12";*)
- text_font = Pango.Font.from_string (match Coq_config.gtk_platform with
- |`QUARTZ -> "Arial Unicode MS 11"
- |_ -> "Monospace 10");
+let show_spaces =
+ new preference ~name:["show_spaces"] ~init:true ~repr:Repr.(bool)
- doc_url = Coq_config.wwwrefman;
- library_url = Coq_config.wwwstdlib;
+let show_right_margin =
+ new preference ~name:["show_right_margin"] ~init:false ~repr:Repr.(bool)
- show_toolbar = true;
- contextual_menus_on_goal = true;
- window_width = 800;
- window_height = 600;
- query_window_width = 600;
- query_window_height = 400;
-(*
- use_utf8_notation = false;
-*)
- auto_complete = false;
- stop_before = true;
- reset_on_tab_switch = false;
- vertical_tabs = false;
- opposite_tabs = false;
-
- background_color = Tags.default_color;
- processed_color = Tags.default_processed_color;
- processing_color = Tags.default_processing_color;
- error_color = Tags.default_error_color;
- error_fg_color = Tags.default_error_fg_color;
-
- dynamic_word_wrap = false;
- show_line_number = false;
- auto_indent = false;
- show_spaces = true;
- show_right_margin = false;
- show_progress_bar = true;
- spaces_instead_of_tabs = true;
- tab_length = 2;
- highlight_current_line = false;
-
- nanoPG = false;
- }
+let show_progress_bar =
+ new preference ~name:["show_progress_bar"] ~init:true ~repr:Repr.(bool)
+
+let spaces_instead_of_tabs =
+ new preference ~name:["spaces_instead_of_tabs"] ~init:true ~repr:Repr.(bool)
+
+let tab_length =
+ new preference ~name:["tab_length"] ~init:2 ~repr:Repr.(int)
+
+let highlight_current_line =
+ new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool)
+
+let nanoPG =
+ new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool)
+
+let user_queries =
+ new preference ~name:["user_queries"] ~init:[] ~repr:Repr.(string_pair_list '$')
+
+class tag_button (box : Gtk.box Gtk.obj) =
+object (self)
+
+ inherit GObj.widget box
+
+ val fg_color = GButton.color_button ()
+ val fg_unset = GButton.toggle_button ()
+ val bg_color = GButton.color_button ()
+ val bg_unset = GButton.toggle_button ()
+ val bold = GButton.toggle_button ()
+ val italic = GButton.toggle_button ()
+ val underline = GButton.toggle_button ()
+
+ method set_tag tag =
+ let track c but set = match c with
+ | None -> set#set_active true
+ | Some c ->
+ set#set_active false;
+ but#set_color (Tags.color_of_string c)
+ in
+ track tag.tag_bg_color bg_color bg_unset;
+ track tag.tag_fg_color fg_color fg_unset;
+ bold#set_active tag.tag_bold;
+ italic#set_active tag.tag_italic;
+ underline#set_active tag.tag_underline;
+
+ method tag =
+ let get but set =
+ if set#active then None
+ else Some (Tags.string_of_color but#color)
+ in
+ {
+ tag_bg_color = get bg_color bg_unset;
+ tag_fg_color = get fg_color fg_unset;
+ tag_bold = bold#active;
+ tag_italic = italic#active;
+ tag_underline = underline#active;
+ }
+
+ initializer
+ let box = new GPack.box box in
+ let set_stock button stock =
+ let stock = GMisc.image ~stock ~icon_size:`BUTTON () in
+ button#set_image stock#coerce
+ in
+ set_stock fg_unset `CANCEL;
+ set_stock bg_unset `CANCEL;
+ set_stock bold `BOLD;
+ set_stock italic `ITALIC;
+ set_stock underline `UNDERLINE;
+ box#pack fg_color#coerce;
+ box#pack fg_unset#coerce;
+ box#pack bg_color#coerce;
+ box#pack bg_unset#coerce;
+ box#pack bold#coerce;
+ box#pack italic#coerce;
+ box#pack underline#coerce;
+ let cb but obj = obj#set_sensitive (not but#active) in
+ let _ = fg_unset#connect#toggled (fun () -> cb fg_unset fg_color#misc) in
+ let _ = bg_unset#connect#toggled (fun () -> cb bg_unset bg_color#misc) in
+ ()
+
+end
+
+let tag_button () =
+ let box = GPack.hbox () in
+ new tag_button (Gobject.unsafe_cast box#as_widget)
+
+(** Old style preferences *)
let save_pref () =
if not (Sys.file_exists (Minilib.coqide_config_home ()))
then Unix.mkdir (Minilib.coqide_config_home ()) 0o700;
let () = try GtkData.AccelMap.save accel_file with _ -> () in
- let p = current in
-
- let add = Util.String.Map.add in
- let (++) x f = f x in
- Util.String.Map.empty ++
- add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++
- add "cmd_coqc" [p.cmd_coqc] ++
- add "cmd_make" [p.cmd_make] ++
- add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
- add "cmd_coqdoc" [p.cmd_coqdoc] ++
- add "source_language" [p.source_language] ++
- add "source_style" [p.source_style] ++
- add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
- add "global_auto_revert_delay"
- [string_of_int p.global_auto_revert_delay] ++
- add "auto_save" [string_of_bool p.auto_save] ++
- 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 "project_path" (match p.project_path with None -> [] | Some s -> [s]) ++
-
- add "encoding" [string_of_inputenc p.encoding] ++
-
- add "automatic_tactics" p.automatic_tactics ++
- add "cmd_print" [p.cmd_print] ++
- 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] ++
-
- add "text_font" [Pango.Font.to_string p.text_font] ++
-
- add "doc_url" [p.doc_url] ++
- add "library_url" [p.library_url] ++
- add "show_toolbar" [string_of_bool p.show_toolbar] ++
- add "contextual_menus_on_goal"
- [string_of_bool p.contextual_menus_on_goal] ++
- add "window_height" [string_of_int p.window_height] ++
- add "window_width" [string_of_int p.window_width] ++
- add "query_window_height" [string_of_int p.query_window_height] ++
- add "query_window_width" [string_of_int p.query_window_width] ++
- add "auto_complete" [string_of_bool p.auto_complete] ++
- add "stop_before" [string_of_bool p.stop_before] ++
- add "reset_on_tab_switch" [string_of_bool p.reset_on_tab_switch] ++
- add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
- add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
- add "background_color" [p.background_color] ++
- add "processing_color" [p.processing_color] ++
- add "processed_color" [p.processed_color] ++
- add "error_color" [p.error_color] ++
- add "error_fg_color" [p.error_fg_color] ++
- add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++
- add "show_line_number" [string_of_bool p.show_line_number] ++
- add "auto_indent" [string_of_bool p.auto_indent] ++
- add "show_spaces" [string_of_bool p.show_spaces] ++
- add "show_right_margin" [string_of_bool p.show_right_margin] ++
- add "show_progress_bar" [string_of_bool p.show_progress_bar] ++
- add "spaces_instead_of_tabs" [string_of_bool p.spaces_instead_of_tabs] ++
- add "tab_length" [string_of_int p.tab_length] ++
- add "highlight_current_line" [string_of_bool p.highlight_current_line] ++
- add "nanoPG" [string_of_bool p.nanoPG] ++
- Config_lexer.print_file pref_file
+ let add = Util.String.Map.add in
+ let fold key obj accu = add key (obj.get ()) accu in
+ let prefs = Util.String.Map.fold fold !preferences Util.String.Map.empty in
+ let prefs = Util.String.Map.fold Util.String.Map.add !unknown_preferences prefs in
+ Config_lexer.print_file pref_file prefs
let load_pref () =
let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
let m = Config_lexer.load_file loaded_pref_file in
- let np = current in
- let set k f = try let v = Util.String.Map.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
- let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in
- let set_command_with_pair_compat k f =
- set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit)
+ let iter name v =
+ if Util.String.Map.mem name !preferences then
+ try (Util.String.Map.find name !preferences).set v with _ -> ()
+ else unknown_preferences := Util.String.Map.add name v !unknown_preferences
in
- let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in
- set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v);
- set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
- set_hd "cmd_make" (fun v -> np.cmd_make <- v);
- set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
- set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
- set_hd "source_language" (fun v -> np.source_language <- v);
- set_hd "source_style" (fun v -> np.source_style <- v);
- set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
- set_int "global_auto_revert_delay"
- (fun v -> np.global_auto_revert_delay <- v);
- set_bool "auto_save" (fun v -> np.auto_save <- v);
- set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
- set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
- set_hd "encoding" (fun v -> np.encoding <- (inputenc_of_string 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_option "project_path" (fun v -> np.project_path <- v);
- set "automatic_tactics"
- (fun v -> np.automatic_tactics <- v);
- set_hd "cmd_print" (fun v -> np.cmd_print <- 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);
- set_hd "doc_url" (fun v ->
- if not (Flags.is_standard_doc_url v) &&
- v <> use_default_doc_url &&
- (* Extra hack to support links to last released doc version *)
- v <> Coq_config.wwwcoq ^ "doc" &&
- v <> Coq_config.wwwcoq ^ "doc/"
- then
- (* ("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);
- set_bool "contextual_menus_on_goal"
- (fun v -> np.contextual_menus_on_goal <- v);
- set_int "window_width" (fun v -> np.window_width <- v);
- set_int "window_height" (fun v -> np.window_height <- v);
- set_int "query_window_width" (fun v -> np.query_window_width <- v);
- set_int "query_window_height" (fun v -> np.query_window_height <- v);
- set_bool "auto_complete" (fun v -> np.auto_complete <- v);
- set_bool "stop_before" (fun v -> np.stop_before <- v);
- set_bool "reset_on_tab_switch" (fun v -> np.reset_on_tab_switch <- v);
- set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
- set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
- set_hd "background_color" (fun v -> np.background_color <- v);
- set_hd "processing_color" (fun v -> np.processing_color <- v);
- set_hd "processed_color" (fun v -> np.processed_color <- v);
- set_hd "error_color" (fun v -> np.error_color <- v);
- set_hd "error_fg_color" (fun v -> np.error_fg_color <- v);
- set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v);
- set_bool "show_line_number" (fun v -> np.show_line_number <- v);
- set_bool "auto_indent" (fun v -> np.auto_indent <- v);
- set_bool "show_spaces" (fun v -> np.show_spaces <- v);
- set_bool "show_right_margin" (fun v -> np.show_right_margin <- v);
- set_bool "show_progress_bar" (fun v -> np.show_progress_bar <- v);
- set_bool "spaces_instead_of_tabs" (fun v -> np.spaces_instead_of_tabs <- v);
- set_int "tab_length" (fun v -> np.tab_length <- v);
- set_bool "highlight_current_line" (fun v -> np.highlight_current_line <- v);
- set_bool "nanoPG" (fun v -> np.nanoPG <- v);
- ()
+ Util.String.Map.iter iter m
+
+let pstring name p = string ~f:p#set name p#get
+let pbool name p = bool ~f:p#set name p#get
+let pmodifiers ?(all = false) name p = modifiers
+ ?allow:(if all then None else Some (str_to_mod_list modifiers_valid#get))
+ ~f:(fun l -> p#set (mod_list_to_str l))
+ ~help:"restart to apply"
+ name
+ (str_to_mod_list p#get)
let configure ?(apply=(fun () -> ())) () =
let cmd_coqtop =
string
- ~f:(fun s -> current.cmd_coqtop <- if s = "AUTO" then None else Some s)
- " coqtop" (match current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
- let cmd_coqc =
- string
- ~f:(fun s -> current.cmd_coqc <- s)
- " coqc" current.cmd_coqc in
- let cmd_make =
- string
- ~f:(fun s -> current.cmd_make <- s)
- " make" current.cmd_make in
- let cmd_coqmakefile =
- string
- ~f:(fun s -> current.cmd_coqmakefile <- s)
- "coqmakefile" current.cmd_coqmakefile in
- let cmd_coqdoc =
- string
- ~f:(fun s -> current.cmd_coqdoc <- s)
- " coqdoc" current.cmd_coqdoc in
- let cmd_print =
- string
- ~f:(fun s -> current.cmd_print <- s)
- " Print ps" current.cmd_print in
+ ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s))
+ " coqtop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in
+ let cmd_coqc = pstring " coqc" cmd_coqc in
+ let cmd_make = pstring " make" cmd_make in
+ let cmd_coqmakefile = pstring "coqmakefile" cmd_coqmakefile in
+ let cmd_coqdoc = pstring " coqdoc" cmd_coqdoc in
+ let cmd_print = pstring " Print ps" cmd_print in
let config_font =
let box = GPack.hbox () in
@@ -435,18 +661,13 @@ let configure ?(apply=(fun () -> ())) () =
"Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
box#pack ~expand:true w#coerce;
ignore (w#misc#connect#realize
- ~callback:(fun () -> w#set_font_name
- (Pango.Font.to_string current.text_font)));
+ ~callback:(fun () -> w#set_font_name text_font#get));
custom
~label:"Fonts for text"
box
(fun () ->
let fd = w#font_name in
- current.text_font <- (Pango.Font.from_string fd) ;
-(*
- Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font);
-*)
- !refresh_editor_hook ())
+ text_font#set fd)
true
in
@@ -458,121 +679,94 @@ let configure ?(apply=(fun () -> ())) () =
~border_width:2
~packing:(box#pack ~expand:true) ()
in
- let background_label = GMisc.label
- ~text:"Background color"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:0) ()
- in
- let processed_label = GMisc.label
- ~text:"Background color of processed text"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:1) ()
- in
- let processing_label = GMisc.label
- ~text:"Background color of text being processed"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
- in
- let error_label = GMisc.label
- ~text:"Background color of errors"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:3) ()
- in
- let error_fg_label = GMisc.label
- ~text:"Foreground color of errors"
- ~packing:(table#attach ~expand:`X ~left:0 ~top:4) ()
- in
- let () = background_label#set_xalign 0. in
- let () = processed_label#set_xalign 0. in
- let () = processing_label#set_xalign 0. in
- let () = error_label#set_xalign 0. in
- let () = error_fg_label#set_xalign 0. in
- let background_button = GButton.color_button
- ~color:(Tags.color_of_string (current.background_color))
- ~packing:(table#attach ~left:1 ~top:0) ()
- in
- let processed_button = GButton.color_button
- ~color:(Tags.get_processed_color ())
- ~packing:(table#attach ~left:1 ~top:1) ()
- in
- let processing_button = GButton.color_button
- ~color:(Tags.get_processing_color ())
- ~packing:(table#attach ~left:1 ~top:2) ()
- in
- let error_button = GButton.color_button
- ~color:(Tags.get_error_color ())
- ~packing:(table#attach ~left:1 ~top:3) ()
- in
- let error_fg_button = GButton.color_button
- ~color:(Tags.get_error_fg_color ())
- ~packing:(table#attach ~left:1 ~top:4) ()
- in
let reset_button = GButton.button
~label:"Reset"
~packing:box#pack ()
in
- let reset_cb () =
- background_button#set_color Tags.(color_of_string default_color);
- processing_button#set_color Tags.(color_of_string default_processing_color);
- processed_button#set_color Tags.(color_of_string default_processed_color);
- error_button#set_color Tags.(color_of_string default_error_color);
+ let iter i (text, pref) =
+ let label = GMisc.label
+ ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) ()
+ in
+ let () = label#set_xalign 0. in
+ let button = GButton.color_button
+ ~color:(Tags.color_of_string pref#get)
+ ~packing:(table#attach ~left:1 ~top:i) ()
+ in
+ let _ = button#connect#color_set begin fun () ->
+ pref#set (Tags.string_of_color button#color)
+ end in
+ let reset _ =
+ pref#reset ();
+ button#set_color Tags.(color_of_string pref#get)
+ in
+ let _ = reset_button#connect#clicked ~callback:reset in
+ ()
in
- let _ = reset_button#connect#clicked ~callback:reset_cb in
+ let () = Util.List.iteri iter [
+ ("Background color", background_color);
+ ("Background color of processed text", processed_color);
+ ("Background color of text being processed", processing_color);
+ ("Background color of errors", error_color);
+ ("Foreground color of errors", error_fg_color);
+ ] in
let label = "Color configuration" in
- let callback () =
- current.background_color <- Tags.string_of_color background_button#color;
- current.processing_color <- Tags.string_of_color processing_button#color;
- current.processed_color <- Tags.string_of_color processed_button#color;
- current.error_color <- Tags.string_of_color error_button#color;
- current.error_fg_color <- Tags.string_of_color error_fg_button#color;
- !refresh_editor_hook ();
- Tags.set_processing_color processing_button#color;
- Tags.set_processed_color processed_button#color;
- Tags.set_error_color error_button#color;
- Tags.set_error_fg_color error_fg_button#color
+ let callback () = () in
+ custom ~label box callback true
+ in
+
+ let config_tags =
+ let box = GPack.vbox () in
+ let scroll = GBin.scrolled_window
+ ~hpolicy:`NEVER
+ ~vpolicy:`AUTOMATIC
+ ~packing:(box#pack ~expand:true)
+ ()
in
+ let table = GPack.table
+ ~row_spacings:5
+ ~col_spacings:5
+ ~border_width:2
+ ~packing:scroll#add_with_viewport ()
+ in
+ let i = ref 0 in
+ let cb = ref [] in
+ let iter text tag =
+ let label = GMisc.label
+ ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) ()
+ in
+ let () = label#set_xalign 0. in
+ let button = tag_button () in
+ let callback () = tag#set button#tag in
+ button#set_tag tag#get;
+ table#attach ~left:1 ~top:!i button#coerce;
+ incr i;
+ cb := callback :: !cb;
+ in
+ let () = Util.String.Map.iter iter !tags in
+ let label = "Tag configuration" in
+ let callback () = List.iter (fun f -> f ()) !cb in
custom ~label box callback true
in
let config_editor =
let label = "Editor configuration" in
let box = GPack.vbox () in
- let gen_button text active =
- GButton.check_button ~label:text ~active ~packing:box#pack () in
- let wrap = gen_button "Dynamic word wrap" current.dynamic_word_wrap in
- let line = gen_button "Show line number" current.show_line_number in
- let auto_indent = gen_button "Auto indentation" current.auto_indent in
- let auto_complete = gen_button "Auto completion" current.auto_complete in
- let show_spaces = gen_button "Show spaces" current.show_spaces in
- let show_right_margin = gen_button "Show right margin" current.show_right_margin in
- let show_progress_bar = gen_button "Show progress bar" current.show_progress_bar in
- let spaces_instead_of_tabs =
- gen_button "Insert spaces instead of tabs"
- current.spaces_instead_of_tabs
- in
- let highlight_current_line =
- gen_button "Highlight current line"
- current.highlight_current_line
- in
- let nanoPG = gen_button "Emacs/PG keybindings (μPG mode)" current.nanoPG in
-(* let lbox = GPack.hbox ~packing:box#pack () in *)
-(* let _ = GMisc.label ~text:"Tab width" *)
-(* ~xalign:0. *)
-(* ~packing:(lbox#pack ~expand:true) () *)
-(* in *)
-(* let tab_width = GEdit.spin_button *)
-(* ~digits:0 ~packing:lbox#pack () *)
-(* in *)
- let callback () =
- current.dynamic_word_wrap <- wrap#active;
- current.show_line_number <- line#active;
- current.auto_indent <- auto_indent#active;
- current.show_spaces <- show_spaces#active;
- current.show_right_margin <- show_right_margin#active;
- current.show_progress_bar <- show_progress_bar#active;
- current.spaces_instead_of_tabs <- spaces_instead_of_tabs#active;
- current.highlight_current_line <- highlight_current_line#active;
- current.nanoPG <- nanoPG#active;
- current.auto_complete <- auto_complete#active;
-(* current.tab_length <- tab_width#value_as_int; *)
- !refresh_editor_hook ()
+ let button text (pref : bool preference) =
+ let active = pref#get in
+ let but = GButton.check_button ~label:text ~active ~packing:box#pack () in
+ ignore (but#connect#toggled (fun () -> pref#set but#active))
in
+ let () = button "Dynamic word wrap" dynamic_word_wrap in
+ let () = button "Show line number" show_line_number in
+ let () = button "Auto indentation" auto_indent in
+ let () = button "Auto completion" auto_complete in
+ let () = button "Show spaces" show_spaces in
+ let () = button "Show right margin" show_right_margin in
+ let () = button "Show progress bar" show_progress_bar in
+ let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in
+ let () = button "Highlight current line" highlight_current_line in
+ let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in
+ let callback () = () in
custom ~label box callback true
in
@@ -600,177 +794,110 @@ let configure ?(apply=(fun () -> ())) () =
(string_of_int current.window_width)
in
*)
-(* let use_utf8_notation =
- bool
- ~f:(fun b ->
- current.use_utf8_notation <- b;
- )
- "Use Unicode Notation: " current.use_utf8_notation
- in
-*)
(*
let config_appearance = [show_toolbar; window_width; window_height] in
*)
- let global_auto_revert =
- bool
- ~f:(fun s -> current.global_auto_revert <- s)
- "Enable global auto revert" current.global_auto_revert
- in
+ let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in
let global_auto_revert_delay =
string
- ~f:(fun s -> current.global_auto_revert_delay <-
+ ~f:(fun s -> global_auto_revert_delay#set
(try int_of_string s with _ -> 10000))
"Global auto revert delay (ms)"
- (string_of_int current.global_auto_revert_delay)
+ (string_of_int global_auto_revert_delay#get)
in
- let auto_save =
- bool
- ~f:(fun s -> current.auto_save <- s)
- "Enable auto save" current.auto_save
- in
+ let auto_save = pbool "Enable auto save" auto_save in
let auto_save_delay =
string
- ~f:(fun s -> current.auto_save_delay <-
+ ~f:(fun s -> auto_save_delay#set
(try int_of_string s with _ -> 10000))
"Auto save delay (ms)"
- (string_of_int current.auto_save_delay)
+ (string_of_int auto_save_delay#get)
in
- let stop_before =
- bool
- ~f:(fun s -> current.stop_before <- s)
- "Stop interpreting before the current point" current.stop_before
- in
+ let stop_before = pbool "Stop interpreting before the current point" stop_before in
- let reset_on_tab_switch =
- bool
- ~f:(fun s -> current.reset_on_tab_switch <- s)
- "Reset coqtop on tab switch" current.reset_on_tab_switch
- in
+ let reset_on_tab_switch = pbool "Reset coqtop on tab switch" reset_on_tab_switch in
- let vertical_tabs =
- bool
- ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ())
- "Vertical tabs" current.vertical_tabs
- in
+ let vertical_tabs = pbool "Vertical tabs" vertical_tabs in
- let opposite_tabs =
- bool
- ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ())
- "Tabs on opposite side" current.opposite_tabs
- in
+ let opposite_tabs = pbool "Tabs on opposite side" opposite_tabs in
let encodings =
combo
"File charset encoding "
- ~f:(fun s -> current.encoding <- (inputenc_of_string s))
+ ~f:(fun s -> encoding#set (inputenc_of_string s))
~new_allowed: true
- ("UTF-8"::"LOCALE":: match current.encoding with
+ ("UTF-8"::"LOCALE":: match encoding#get with
|Emanual s -> [s]
|_ -> []
)
- (string_of_inputenc current.encoding)
+ (string_of_inputenc encoding#get)
+ in
+
+ let line_ending =
+ combo
+ "EOL character"
+ ~f:(fun s -> line_ending#set (line_end_of_string s))
+ ~new_allowed:false
+ ["unix"; "windows"; "default"]
+ (line_end_to_string line_ending#get)
in
let source_style =
- let f s =
- current.source_style <- s;
- !refresh_style_hook ()
- in
combo "Highlighting style:"
- ~f ~new_allowed:false
- style_manager#style_scheme_ids current.source_style
+ ~f:source_style#set ~new_allowed:false
+ style_manager#style_scheme_ids source_style#get
in
let source_language =
- let f s =
- current.source_language <- s;
- !refresh_language_hook ()
- in
combo "Language:"
- ~f ~new_allowed:false
+ ~f:source_language#set ~new_allowed:false
(List.filter
(fun x -> Str.string_match (Str.regexp "^coq") x 0)
lang_manager#language_ids)
- current.source_language
+ source_language#get
in
let read_project =
combo
"Project file options are"
- ~f:(fun s -> current.read_project <- project_behavior_of_string s)
+ ~f:(fun s -> read_project#set (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
+ (string_of_project_behavior read_project#get)
in
- let help_string =
- "restart to apply"
- in
- let the_valid_mod = str_to_mod_list current.modifiers_valid in
+ let project_file_name = pstring "Default name for project file" project_file_name in
let modifier_for_tactics =
- modifiers
- ~allow:the_valid_mod
- ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l)
- ~help:help_string
- "Modifiers for Tactics Menu"
- (str_to_mod_list current.modifier_for_tactics)
+ pmodifiers "Modifiers for Tactics Menu" modifier_for_tactics
in
let modifier_for_templates =
- modifiers
- ~allow:the_valid_mod
- ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l)
- ~help:help_string
- "Modifiers for Templates Menu"
- (str_to_mod_list current.modifier_for_templates)
+ pmodifiers "Modifiers for Templates Menu" modifier_for_templates
in
let modifier_for_navigation =
- modifiers
- ~allow:the_valid_mod
- ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l)
- ~help:help_string
- "Modifiers for Navigation Menu"
- (str_to_mod_list current.modifier_for_navigation)
+ pmodifiers "Modifiers for Navigation Menu" modifier_for_navigation
in
let modifier_for_display =
- modifiers
- ~allow:the_valid_mod
- ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l)
- ~help:help_string
- "Modifiers for View Menu"
- (str_to_mod_list current.modifier_for_display)
+ pmodifiers "Modifiers for View Menu" modifier_for_display
in
- let modifiers_valid =
- modifiers
- ~f:(fun l ->
- current.modifiers_valid <- mod_list_to_str l)
- "Allowed modifiers"
- the_valid_mod
+ let modifier_for_queries =
+ pmodifiers "Modifiers for Queries Menu" modifier_for_queries
in
- let modifier_notice =
- let b = GPack.hbox () in
- let _lbl =
- GMisc.label ~markup:"You need to <b>restart CoqIDE</b> after changing these settings"
- ~packing:b#add () in
- custom b (fun () -> ()) true
+ let modifiers_valid =
+ pmodifiers ~all:true "Allowed modifiers" modifiers_valid
in
let cmd_editor =
let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in
combo
~help:"(%s for file name)"
"External editor"
- ~f:(fun s -> current.cmd_editor <- s)
+ ~f:cmd_editor#set
~new_allowed: true
- (predefined@[if List.mem current.cmd_editor predefined then ""
- else current.cmd_editor])
- current.cmd_editor
+ (predefined@[if List.mem cmd_editor#get predefined then ""
+ else cmd_editor#get])
+ cmd_editor#get
in
let cmd_browse =
let predefined = [
@@ -783,58 +910,82 @@ let configure ?(apply=(fun () -> ())) () =
combo
~help:"(%s for url)"
"Browser"
- ~f:(fun s -> current.cmd_browse <- s)
+ ~f:cmd_browse#set
~new_allowed: true
- (predefined@[if List.mem current.cmd_browse predefined then ""
- else current.cmd_browse])
- current.cmd_browse
+ (predefined@[if List.mem cmd_browse#get predefined then ""
+ else cmd_browse#get])
+ cmd_browse#get
in
let doc_url =
let predefined = [
- "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]);
+ "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]);
Coq_config.wwwrefman;
use_default_doc_url
] in
combo
"Manual URL"
- ~f:(fun s -> current.doc_url <- s)
+ ~f:doc_url#set
~new_allowed: true
- (predefined@[if List.mem current.doc_url predefined then ""
- else current.doc_url])
- current.doc_url in
+ (predefined@[if List.mem doc_url#get predefined then ""
+ else doc_url#get])
+ doc_url#get in
let library_url =
let predefined = [
- "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
+ "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]);
Coq_config.wwwstdlib
] in
combo
"Library URL"
- ~f:(fun s -> current.library_url <- s)
+ ~f:(fun s -> library_url#set s)
~new_allowed: true
- (predefined@[if List.mem current.library_url predefined then ""
- else current.library_url])
- current.library_url
+ (predefined@[if List.mem library_url#get predefined then ""
+ else library_url#get])
+ library_url#get
in
let automatic_tactics =
strings
- ~f:(fun l -> current.automatic_tactics <- l)
+ ~f:automatic_tactics#set
~add:(fun () -> ["<edit me>"])
"Wizard tactics to try in order"
- current.automatic_tactics
+ automatic_tactics#get
in
- let contextual_menus_on_goal =
- bool
- ~f:(fun s ->
- current.contextual_menus_on_goal <- s;
- !contextual_menus_on_goal_hook s)
- "Contextual menus on goal" current.contextual_menus_on_goal
- in
+ let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in
let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch;
vertical_tabs;opposite_tabs] in
+ let add_user_query () =
+ let input_string l v =
+ match GToolbox.input_string ~title:l v with
+ | None -> ""
+ | Some s -> s
+ in
+ let q = input_string "User query" "Your query" in
+ let k = input_string "Shortcut key" "Shortcut (a single letter)" in
+ let q = CString.map (fun c -> if c = '$' then ' ' else c) q in
+ (* Anything that is not a simple letter will be ignored. *)
+ let k =
+ if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k
+ else "" in
+ let k = CString.uppercase k in
+ [q, k]
+ in
+
+ let user_queries =
+ list
+ ~f:user_queries#set
+ (* Disallow same query, key or empty query. *)
+ ~eq:(fun (q1, k1) (q2, k2) -> k1 = k2 || q1 = "" || q2 = "" || q1 = q2)
+ ~add:add_user_query
+ ~titles:["User query"; "Shortcut key"]
+ "User queries"
+ (fun (q, s) -> [q; s])
+ user_queries#get
+
+ in
+
(* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
(shame on Benjamin) *)
let cmds =
@@ -842,11 +993,13 @@ let configure ?(apply=(fun () -> ())) () =
[config_font]);
Section("Colors", Some `SELECT_COLOR,
[config_color; source_language; source_style]);
+ Section("Tags", Some `SELECT_COLOR,
+ [config_tags]);
Section("Editor", Some `EDIT, [config_editor]);
Section("Files", Some `DIRECTORY,
[global_auto_revert;global_auto_revert_delay;
auto_save; auto_save_delay; (* auto_save_name*)
- encodings;
+ encodings; line_ending;
]);
Section("Project", Some (`STOCK "gtk-page-setup"),
[project_file_name;read_project;
@@ -862,9 +1015,10 @@ let configure ?(apply=(fun () -> ())) () =
[automatic_tactics]);
Section("Shortcuts", Some `PREFERENCES,
[modifiers_valid; modifier_for_tactics;
- modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_notice]);
+ modifier_for_templates; modifier_for_display; modifier_for_navigation;
+ modifier_for_queries; user_queries]);
Section("Misc", Some `ADD,
- misc)]
+ misc)]
in
(*
Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 4095eb66..801869d1 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -11,96 +11,101 @@ val style_manager : GSourceView2.source_style_scheme_manager
type project_behavior = Ignore_args | Append_args | Subst_args
type inputenc = Elocale | Eutf8 | Emanual of string
-
-type pref =
- {
- mutable cmd_coqtop : string option;
- mutable cmd_coqc : string;
- mutable cmd_make : string;
- mutable cmd_coqmakefile : string;
- mutable cmd_coqdoc : string;
-
- mutable source_language : string;
- mutable source_style : string;
-
- mutable global_auto_revert : bool;
- mutable global_auto_revert_delay : int;
-
- mutable auto_save : bool;
- mutable auto_save_delay : int;
- mutable auto_save_name : string * string;
-
- mutable read_project : project_behavior;
- mutable project_file_name : string;
- mutable project_path : string option;
-
- mutable encoding : inputenc;
-
- mutable automatic_tactics : string list;
- mutable cmd_print : string;
-
- 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;
-
- mutable text_font : Pango.font_description;
-
- mutable doc_url : string;
- mutable library_url : string;
-
- mutable show_toolbar : bool;
- mutable contextual_menus_on_goal : bool;
- mutable window_width : int;
- mutable window_height : int;
- mutable query_window_width : int;
- mutable query_window_height : int;
-(*
- mutable use_utf8_notation : bool;
-*)
- mutable auto_complete : bool;
- mutable stop_before : bool;
- mutable reset_on_tab_switch : bool;
- mutable vertical_tabs : bool;
- mutable opposite_tabs : bool;
-
- mutable background_color : string;
- mutable processing_color : string;
- mutable processed_color : string;
- mutable error_color : string;
- mutable error_fg_color : string;
-
- mutable dynamic_word_wrap : bool;
- mutable show_line_number : bool;
- mutable auto_indent : bool;
- mutable show_spaces : bool;
- mutable show_right_margin : bool;
- mutable show_progress_bar : bool;
- mutable spaces_instead_of_tabs : bool;
- mutable tab_length : int;
- mutable highlight_current_line : bool;
-
- mutable nanoPG : bool;
-
- }
+type line_ending = [ `DEFAULT | `WINDOWS | `UNIX ]
+
+type tag = {
+ tag_fg_color : string option;
+ tag_bg_color : string option;
+ tag_bold : bool;
+ tag_italic : bool;
+ tag_underline : bool;
+}
+
+class type ['a] repr =
+object
+ method into : string list -> 'a option
+ method from : 'a -> string list
+end
+
+class ['a] preference_signals : changed:'a GUtil.signal ->
+object
+ inherit GUtil.ml_signals
+ method changed : callback:('a -> unit) -> GtkSignal.id
+end
+
+class ['a] preference : name:string list -> init:'a -> repr:'a repr ->
+object
+ method connect : 'a preference_signals
+ method get : 'a
+ method set : 'a -> unit
+ method reset : unit -> unit
+ method default : 'a
+end
+
+val list_tags : unit -> tag preference Util.String.Map.t
+
+val cmd_coqtop : string option preference
+val cmd_coqc : string preference
+val cmd_make : string preference
+val cmd_coqmakefile : string preference
+val cmd_coqdoc : string preference
+val source_language : string preference
+val source_style : string preference
+val global_auto_revert : bool preference
+val global_auto_revert_delay : int preference
+val auto_save : bool preference
+val auto_save_delay : int preference
+val auto_save_name : (string * string) preference
+val read_project : project_behavior preference
+val project_file_name : string preference
+val project_path : string option preference
+val encoding : inputenc preference
+val automatic_tactics : string list preference
+val cmd_print : string preference
+val modifier_for_navigation : string preference
+val modifier_for_templates : string preference
+val modifier_for_tactics : string preference
+val modifier_for_display : string preference
+val modifier_for_queries : string preference
+val modifiers_valid : string preference
+val cmd_browse : string preference
+val cmd_editor : string preference
+val text_font : string preference
+val doc_url : string preference
+val library_url : string preference
+val show_toolbar : bool preference
+val contextual_menus_on_goal : bool preference
+val window_width : int preference
+val window_height : int preference
+val auto_complete : bool preference
+val stop_before : bool preference
+val reset_on_tab_switch : bool preference
+val line_ending : line_ending preference
+val vertical_tabs : bool preference
+val opposite_tabs : bool preference
+val background_color : string preference
+val processing_color : string preference
+val processed_color : string preference
+val error_color : string preference
+val error_fg_color : string preference
+val dynamic_word_wrap : bool preference
+val show_line_number : bool preference
+val auto_indent : bool preference
+val show_spaces : bool preference
+val show_right_margin : bool preference
+val show_progress_bar : bool preference
+val spaces_instead_of_tabs : bool preference
+val tab_length : int preference
+val highlight_current_line : bool preference
+val nanoPG : bool preference
+val user_queries : (string * string) list preference
val save_pref : unit -> unit
val load_pref : unit -> unit
-val current : pref
-
val configure : ?apply:(unit -> unit) -> unit -> unit
-(* Hooks *)
-val refresh_editor_hook : (unit -> unit) ref
-val refresh_style_hook : (unit -> unit) ref
-val refresh_language_hook : (unit -> unit) ref
-val refresh_toolbar_hook : (unit -> unit) ref
-val resize_window_hook : (unit -> unit) ref
-val refresh_tabs_hook : (unit -> unit) ref
+val stick : 'a preference ->
+ (#GObj.widget as 'obj) -> ('a -> unit) -> unit
val use_default_doc_url : string
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
index 07ab5344..de0720e0 100644
--- a/ide/project_file.ml4
+++ b/ide/project_file.ml4
@@ -56,24 +56,24 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
| ("-full"|"-opt") :: r ->
process_cmd_line orig_dir (project_file,makefile,install,true) l r
| "-impredicative-set" :: r ->
- Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.");
+ Feedback.msg_warning (Pp.str "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 ->
- Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead")));
+ Feedback.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead")));
process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r
| "-install" :: d :: r ->
- if install <> UnspecInstall then Pp.msg_warning (Pp.str "-install sets more than once.");
+ if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once.");
let install =
match d with
| "user" -> UserInstall
| "none" -> NoInstall
| "global" -> TraditionalInstall
- | _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install.")));
+ | _ -> Feedback.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install.")));
install
in
process_cmd_line orig_dir (project_file,makefile,install,opt) l r
| "-custom" :: com :: dependencies :: file :: r ->
- Pp.msg_warning (Pp.app
+ Feedback.msg_warning (Pp.app
(Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".")
(Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.")
);
@@ -86,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r
| "-I" :: d :: r ->
process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r
- | "-R" :: p :: "-as" :: lp :: r
| "-R" :: p :: lp :: r ->
process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r
| ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ ->
@@ -95,7 +94,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in
let () = match project_file with
| None -> ()
- | Some _ -> Pp.msg_warning (Pp.str
+ | Some _ -> Feedback.msg_warning (Pp.str
"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
@@ -110,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
let () = match makefile with
|None -> ()
|Some f ->
- Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be.")))
+ Feedback.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be.")))
in process_cmd_line orig_dir (project_file,Some file,install,opt) l r
end
| v :: "=" :: def :: r ->
@@ -139,48 +138,44 @@ let rec post_canonize f =
else f
(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_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 ((CUnix.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,CUnix.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,(CUnix.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,CUnix.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,CUnix.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,CUnix.remove_path_dot n::mlpack),o,s),i,d)
- | Special (n,dep,is_phony,c) :: r ->
- let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,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)
- | MLInclude p :: r ->
- let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p),
- CUnix.canonical_path_name p)::ml,q,r),d)
- | Include (p,l) :: r ->
- let t,(ml,i,r),d = aux r in
- let i_new = (CUnix.remove_path_dot (post_canonize p),l,
- CUnix.canonical_path_name p) in
- (t,(ml,i_new::i,r),d)
- | RInclude (p,l) :: r ->
- let t,(ml,i,r),d = aux r in
- let r_new = (CUnix.remove_path_dot (post_canonize p),l,
- CUnix.canonical_path_name p) in
- (t,(ml,i,r_new::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 split_arguments args =
+ List.fold_right
+ (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t),
+ (ml_inc,q_inc,r_inc as i),(args,defs as d)) ->
+ match a with
+ | V n ->
+ ((CUnix.remove_path_dot n::v,m,o,s),i,d)
+ | ML n ->
+ ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
+ | MLI n ->
+ ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
+ | ML4 n ->
+ ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
+ | MLLIB n ->
+ ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d)
+ | MLPACK n ->
+ ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d)
+ | Special (n,dep,is_phony,c) ->
+ ((v,m,(n,dep,is_phony,c)::o,s),i,d)
+ | Subdir n ->
+ ((v,m,o,n::s),i,d)
+ | MLInclude p ->
+ let ml_new = (CUnix.remove_path_dot (post_canonize p),
+ CUnix.canonical_path_name p) in
+ (t,(ml_new::ml_inc,q_inc,r_inc),d)
+ | Include (p,l) ->
+ let q_new = (CUnix.remove_path_dot (post_canonize p),l,
+ CUnix.canonical_path_name p) in
+ (t,(ml_inc,q_new::q_inc,r_inc),d)
+ | RInclude (p,l) ->
+ let r_new = (CUnix.remove_path_dot (post_canonize p),l,
+ CUnix.canonical_path_name p) in
+ (t,(ml_inc,q_inc,r_new::r_inc),d)
+ | Def (v,def) ->
+ (t,i,(args,(v,def)::defs))
+ | Arg a ->
+ (t,i,(a::args,defs)))
+ args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[]))
let read_project_file f =
split_arguments
diff --git a/ide/richprinter.ml b/ide/richprinter.ml
new file mode 100644
index 00000000..5f39f36e
--- /dev/null
+++ b/ide/richprinter.ml
@@ -0,0 +1,24 @@
+open Richpp
+
+module RichppConstr = Ppconstr.Richpp
+module RichppVernac = Ppvernac.Richpp
+module RichppTactic = Pptactic.Richpp
+
+type rich_pp =
+ Ppannotation.t Richpp.located Xml_datatype.gxml
+ * Xml_datatype.xml
+
+let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag
+
+let make_richpp pr ast =
+ let rich_pp =
+ rich_pp get_annotations (pr ast)
+ in
+ let xml = Ppannotation.(
+ xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp
+ )
+ in
+ (rich_pp, xml)
+
+let richpp_vernac = make_richpp RichppVernac.pr_vernac
+let richpp_constr = make_richpp RichppConstr.pr_constr_expr
diff --git a/ide/richprinter.mli b/ide/richprinter.mli
new file mode 100644
index 00000000..c9e84e3e
--- /dev/null
+++ b/ide/richprinter.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** This module provides an entry point to "rich" pretty-printers that
+ produce pretty-printing as done by {!Printer} but with additional
+ annotations represented as a semi-structured document.
+
+ To understand what are these annotations and how they are represented
+ as standard XML attributes, please refer to {!Ppannotation}.
+
+ In addition to these annotations, each node of the semi-structured
+ document contains a [startpos] and an [endpos] attribute that
+ relate this node to the raw pretty-printing.
+ Please refer to {!Richpp} for more details. *)
+
+(** A rich pretty-print is composed of: *)
+type rich_pp =
+
+ (** - a generalized semi-structured document whose attributes are
+ annotations ; *)
+ Ppannotation.t Richpp.located Xml_datatype.gxml
+
+ (** - an XML document, representing annotations as usual textual
+ XML attributes. *)
+ * Xml_datatype.xml
+
+(** [richpp_vernac phrase] produces a rich pretty-printing of [phrase]. *)
+val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp
+
+(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *)
+val richpp_constr : Constrexpr.constr_expr -> rich_pp
diff --git a/ide/sentence.ml b/ide/sentence.ml
index 0f6c1168..e332682d 100644
--- a/ide/sentence.ml
+++ b/ide/sentence.ml
@@ -16,6 +16,7 @@
let split_slice_lax (buffer:GText.buffer) start stop =
buffer#remove_tag ~start ~stop Tags.Script.sentence;
buffer#remove_tag ~start ~stop Tags.Script.error;
+ buffer#remove_tag ~start ~stop Tags.Script.warning;
buffer#remove_tag ~start ~stop Tags.Script.error_bg;
let slice = buffer#get_text ~start ~stop () in
let apply_tag off tag =
@@ -63,13 +64,13 @@ let grab_sentence_start (iter:GText.iter) soi =
(** Search forward the first character immediately after a sentence end *)
-let rec grab_sentence_stop (start:GText.iter) =
+let 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 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
diff --git a/ide/serialize.ml b/ide/serialize.ml
new file mode 100644
index 00000000..7b568501
--- /dev/null
+++ b/ide/serialize.ml
@@ -0,0 +1,121 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error of string * xml
+
+(** Utility functions *)
+
+let rec get_attr attr = function
+ | [] -> raise Not_found
+ | (k, v) :: l when CString.equal k attr -> v
+ | _ :: l -> get_attr attr l
+
+let massoc x l =
+ try get_attr x l
+ with Not_found -> raise (Marshal_error("attribute " ^ x,PCData "not there"))
+
+let constructor t c args = Element (t, ["val", c], args)
+let do_match t mf = function
+ | Element (s, attrs, args) when CString.equal s t ->
+ let c = massoc "val" attrs in
+ mf c args
+ | x -> raise (Marshal_error (t,x))
+
+let singleton = function
+ | [x] -> x
+ | l -> raise (Marshal_error
+ ("singleton",PCData ("list of length " ^ string_of_int (List.length l))))
+
+let raw_string = function
+ | [] -> ""
+ | [PCData s] -> s
+ | x::_ -> raise (Marshal_error("raw string",x))
+
+(** Base types *)
+
+let of_unit () = Element ("unit", [], [])
+let to_unit : xml -> unit = function
+ | Element ("unit", [], []) -> ()
+ | x -> raise (Marshal_error ("unit",x))
+
+let of_bool (b : bool) : xml =
+ if b then constructor "bool" "true" []
+ else constructor "bool" "false" []
+let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
+ | "true" -> true
+ | "false" -> false
+ | x -> raise (Marshal_error("bool",PCData x)))
+
+let of_list (f : 'a -> xml) (l : 'a list) =
+ Element ("list", [], List.map f l)
+let to_list (f : xml -> 'a) : xml -> 'a list = function
+ | Element ("list", [], l) -> List.map f l
+ | x -> raise (Marshal_error("list",x))
+
+let of_option (f : 'a -> xml) : 'a option -> xml = function
+ | None -> Element ("option", ["val", "none"], [])
+ | Some x -> Element ("option", ["val", "some"], [f x])
+let to_option (f : xml -> 'a) : xml -> 'a option = function
+ | Element ("option", ["val", "none"], []) -> None
+ | Element ("option", ["val", "some"], [x]) -> Some (f x)
+ | x -> raise (Marshal_error("option",x))
+
+let of_string (s : string) : xml = Element ("string", [], [PCData s])
+let to_string : xml -> string = function
+ | Element ("string", [], l) -> raw_string l
+ | x -> raise (Marshal_error("string",x))
+
+let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
+let to_int : xml -> int = function
+ | Element ("int", [], [PCData s]) ->
+ (try int_of_string s with Failure _ -> raise(Marshal_error("int",PCData s)))
+ | x -> raise (Marshal_error("int",x))
+
+let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml =
+ Element ("pair", [], [f (fst x); g (snd x)])
+let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
+ | Element ("pair", [], [x; y]) -> (f x, g y)
+ | x -> raise (Marshal_error("pair",x))
+
+let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function
+ | CSig.Inl x -> Element ("union", ["val","in_l"], [f x])
+ | CSig.Inr x -> Element ("union", ["val","in_r"], [g x])
+let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function
+ | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x)
+ | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x)
+ | x -> raise (Marshal_error("union",x))
+
+(** More elaborate types *)
+
+let of_edit_id i = Element ("edit_id",["val",string_of_int i],[])
+let to_edit_id = function
+ | Element ("edit_id",["val",i],[]) ->
+ let id = int_of_string i in
+ assert (id <= 0 );
+ id
+ | x -> raise (Marshal_error("edit_id",x))
+
+let of_loc loc =
+ let start, stop = Loc.unloc loc in
+ Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[])
+let to_loc xml =
+ match xml with
+ | Element ("loc", l,[]) ->
+ let start = massoc "start" l in
+ let stop = massoc "stop" l in
+ (try
+ Loc.make_loc (int_of_string start, int_of_string stop)
+ with Not_found | Invalid_argument _ -> raise (Marshal_error("loc",PCData(start^":"^stop))))
+ | x -> raise (Marshal_error("loc",x))
+
+let of_xml x = Element ("xml", [], [x])
+let to_xml xml = match xml with
+| Element ("xml", [], [x]) -> x
+| x -> raise (Marshal_error("xml",x))
diff --git a/ide/serialize.mli b/ide/serialize.mli
new file mode 100644
index 00000000..bf9e184e
--- /dev/null
+++ b/ide/serialize.mli
@@ -0,0 +1,39 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+exception Marshal_error of string * xml
+
+val massoc: string -> (string * string) list -> string
+val constructor: string -> string -> xml list -> xml
+val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b
+val singleton: 'a list -> 'a
+val raw_string: xml list -> string
+val of_unit: unit -> xml
+val to_unit: xml -> unit
+val of_bool: bool -> xml
+val to_bool: xml -> bool
+val of_list: ('a -> xml) -> 'a list -> xml
+val to_list: (xml -> 'a) -> xml -> 'a list
+val of_option: ('a -> xml) -> 'a option -> xml
+val to_option: (xml -> 'a) -> xml -> 'a option
+val of_string: string -> xml
+val to_string: xml -> string
+val of_int: int -> xml
+val to_int: xml -> int
+val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml
+val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b
+val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml
+val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union
+val of_edit_id: int -> xml
+val to_edit_id: xml -> int
+val of_loc : Loc.t -> xml
+val to_loc : xml -> Loc.t
+val of_xml : xml -> xml
+val to_xml : xml -> xml
diff --git a/ide/session.ml b/ide/session.ml
index 34c533b8..fc6340d2 100644
--- a/ide/session.ml
+++ b/ide/session.ml
@@ -8,8 +8,6 @@
open Preferences
-let prefs = Preferences.current
-
(** A session is a script buffer + proof + messages,
interacting with a coqtop, and a few other elements around *)
@@ -18,7 +16,7 @@ class type ['a] page =
inherit GObj.widget
method update : 'a -> unit
method on_update : callback:('a -> unit) -> unit
- method refresh_color : unit -> unit
+ method data : 'a
end
class type control =
@@ -50,8 +48,8 @@ let create_buffer () =
let buffer = GSourceView2.source_buffer
~tag_table:Tags.Script.table
~highlight_matching_brackets:true
- ?language:(lang_manager#language prefs.source_language)
- ?style_scheme:(style_manager#style_scheme prefs.source_style)
+ ?language:(lang_manager#language source_language#get)
+ ?style_scheme:(style_manager#style_scheme source_style#get)
()
in
let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in
@@ -110,10 +108,10 @@ let set_buffer_handlers
let id = ref 0 in
fun () -> incr id; !id in
let running_action = ref None in
- let cancel_signal reason =
+ let cancel_signal ?(stop_emit=true) reason =
Minilib.log ("user_action cancelled: "^reason);
action_was_cancelled := true;
- GtkSignal.stop_emit () in
+ if stop_emit then GtkSignal.stop_emit () in
let del_mark () =
try buffer#delete_mark (`NAME "target")
with GText.No_such_mark _ -> () in
@@ -126,7 +124,7 @@ let set_buffer_handlers
fun () -> (* If Coq is busy due to the current action, we don't cancel *)
match !running_action with
| Some aid when aid = action -> ()
- | _ -> cancel_signal "Coq busy" in
+ | _ -> cancel_signal ~stop_emit:false "Coq busy" in
Coq.try_grab coqtop action fallback in
let get_start () = buffer#get_iter_at_mark (`NAME "start_of_input") in
let get_stop () = buffer#get_iter_at_mark (`NAME "stop_of_input") in
@@ -197,12 +195,8 @@ let set_buffer_handlers
to a point indicated by coq. *)
if !no_coq_action_required then begin
let start, stop = get_start (), get_stop () in
- buffer#remove_tag Tags.Script.error ~start ~stop;
- buffer#remove_tag Tags.Script.error_bg ~start ~stop;
- buffer#remove_tag Tags.Script.tooltip ~start ~stop;
- buffer#remove_tag Tags.Script.processed ~start ~stop;
- buffer#remove_tag Tags.Script.to_process ~start ~stop;
- buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+ List.iter (fun tag -> buffer#remove_tag tag ~start ~stop)
+ Tags.Script.ephemere;
Sentence.tag_on_insert buffer
end;
end in
@@ -254,10 +248,9 @@ let make_table_widget ?sort cd cb =
~model:store ~packing:frame#add () in
let () = data#set_headers_visible true in
let () = data#set_headers_clickable true in
- let refresh () =
- let clr = Tags.color_of_string current.background_color in
- data#misc#modify_base [`NORMAL, `COLOR clr]
- in
+ let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed refresh in
+ let _ = data#misc#connect#realize (fun () -> refresh background_color#get) in
let mk_rend c = GTree.cell_renderer_text [], ["text",c] in
let cols =
List.map2 (fun (_,c) (_,n,v) ->
@@ -285,10 +278,10 @@ let make_table_widget ?sort cd cb =
data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc)
);
let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in
- frame, (fun f -> f columns store), refresh
+ frame, (fun f -> f columns store)
let create_errpage (script : Wg_ScriptView.script_view) : errpage =
- let table, access, refresh =
+ let table, access =
make_table_widget ~sort:(0, `ASCENDING)
[`Int,"Line",true; `String,"Error message",true]
(fun columns store tp vc ->
@@ -320,11 +313,11 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage =
errs
end
method on_update ~callback:cb = callback := cb
- method refresh_color () = refresh ()
+ method data = !last_update
end
let create_jobpage coqtop coqops : jobpage =
- let table, access, refresh =
+ let table, access =
make_table_widget ~sort:(0, `ASCENDING)
[`String,"Worker",true; `String,"Job name",true]
(fun columns store tp vc ->
@@ -360,7 +353,7 @@ let create_jobpage coqtop coqops : jobpage =
jobs
end
method on_update ~callback:cb = callback := cb
- method refresh_color () = refresh ()
+ method data = !last_update
end
let create_proof () =
diff --git a/ide/session.mli b/ide/session.mli
index 0881e403..028a1f9d 100644
--- a/ide/session.mli
+++ b/ide/session.mli
@@ -14,7 +14,7 @@ class type ['a] page =
inherit GObj.widget
method update : 'a -> unit
method on_update : callback:('a -> unit) -> unit
- method refresh_color : unit -> unit
+ method data : 'a
end
class type control =
diff --git a/ide/tags.ml b/ide/tags.ml
index 0e4ab96d..e4510e7a 100644
--- a/ide/tags.ml
+++ b/ide/tags.ml
@@ -13,28 +13,16 @@ let make_tag (tt:GText.tag_table) ~name prop =
tt#add new_tag#as_tag;
new_tag
-(* These work fine for colorblind people too *)
-let default_processed_color = "light green"
-let default_processing_color = "light blue"
-let default_error_color = "#FFCCCC"
-let default_error_fg_color = "red"
-let default_color = "cornsilk"
-
-let processed_color = ref default_processed_color
-let processing_color = ref default_processing_color
-let error_color = ref default_error_color
-let error_fg_color = ref default_error_fg_color
-
module Script =
struct
let table = GText.tag_table ()
let comment = make_tag table ~name:"comment" []
- let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND !error_fg_color]
- let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color]
- let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color]
- let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color]
+ let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE]
+ let warning = make_tag table ~name:"warning" [`UNDERLINE `SINGLE; `FOREGROUND "blue"]
+ let error_bg = make_tag table ~name:"error_bg" []
+ let to_process = make_tag table ~name:"to_process" []
+ let processed = make_tag table ~name:"processed" []
let incomplete = make_tag table ~name:"incomplete" [
- `BACKGROUND !processing_color;
`BACKGROUND_STIPPLE_SET true;
]
let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"]
@@ -42,9 +30,11 @@ struct
let sentence = make_tag table ~name:"sentence" []
let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *)
+ let ephemere =
+ [error; warning; error_bg; tooltip; processed; to_process; incomplete; unjustified]
+
let all =
- [comment; error; error_bg; to_process; processed; incomplete; unjustified;
- found; sentence; tooltip]
+ comment :: found :: sentence :: ephemere
let edit_zone =
let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in
@@ -56,7 +46,7 @@ end
module Proof =
struct
let table = GText.tag_table ()
- let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color]
+ let highlight = make_tag table ~name:"highlight" []
let hypothesis = make_tag table ~name:"hypothesis" []
let goal = make_tag table ~name:"goal" []
end
@@ -77,34 +67,3 @@ let string_of_color clr =
let color_of_string s =
let colormap = Gdk.Color.get_system_colormap () in
Gdk.Color.alloc ~colormap (`NAME s)
-
-let get_processed_color () = color_of_string !processed_color
-
-let set_processed_color clr =
- let s = string_of_color clr in
- processed_color := s;
- Script.processed#set_property (`BACKGROUND s);
- Proof.highlight#set_property (`BACKGROUND s)
-
-let get_processing_color () = color_of_string !processing_color
-
-let set_processing_color clr =
- let s = string_of_color clr in
- processing_color := s;
- Script.incomplete#set_property (`BACKGROUND s);
- Script.to_process#set_property (`BACKGROUND s)
-
-let get_error_color () = color_of_string !error_color
-
-let set_error_color clr =
- let s = string_of_color clr in
- error_color := s;
- Script.error_bg#set_property (`BACKGROUND s)
-
-let get_error_fg_color () = color_of_string !error_fg_color
-
-let set_error_fg_color clr =
- let s = string_of_color clr in
- error_fg_color := s;
- Script.error#set_property (`FOREGROUND s)
-
diff --git a/ide/tags.mli b/ide/tags.mli
index 00583f1b..02e15a5a 100644
--- a/ide/tags.mli
+++ b/ide/tags.mli
@@ -11,6 +11,7 @@ sig
val table : GText.tag_table
val comment : GText.tag
val error : GText.tag
+ val warning : GText.tag
val error_bg : GText.tag
val to_process : GText.tag
val processed : GText.tag
@@ -20,6 +21,7 @@ sig
val sentence : GText.tag
val tooltip : GText.tag
val edit_zone : GText.tag (* for debugging *)
+ val ephemere : GText.tag list
val all : GText.tag list
end
@@ -41,22 +43,3 @@ end
val string_of_color : Gdk.color -> string
val color_of_string : string -> Gdk.color
-
-val get_processed_color : unit -> Gdk.color
-val set_processed_color : Gdk.color -> unit
-
-val get_processing_color : unit -> Gdk.color
-val set_processing_color : Gdk.color -> unit
-
-val get_error_color : unit -> Gdk.color
-val set_error_color : Gdk.color -> unit
-
-val get_error_fg_color : unit -> Gdk.color
-val set_error_fg_color : Gdk.color -> unit
-
-val default_processed_color : string
-val default_processing_color : string
-val default_error_color : string
-val default_error_fg_color : string
-val default_color : string
-
diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml
new file mode 100644
index 00000000..680da7f5
--- /dev/null
+++ b/ide/texmacspp.ml
@@ -0,0 +1,768 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+open Vernacexpr
+open Constrexpr
+open Names
+open Misctypes
+open Bigint
+open Decl_kinds
+open Extend
+open Libnames
+
+let unlock loc =
+ let start, stop = Loc.unloc loc in
+ (string_of_int start, string_of_int stop)
+
+let xmlWithLoc loc ename attr xml =
+ let start, stop = unlock loc in
+ Element(ename, [ "begin", start; "end", stop ] @ attr, xml)
+
+let get_fst_attr_in_xml_list attr xml_list =
+ let attrs_list =
+ List.map (function
+ | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs)
+ | _ -> [])
+ xml_list in
+ match List.flatten attrs_list with
+ | [] -> (attr, "")
+ | l -> (List.hd l)
+
+let backstep_loc xmllist =
+ let start_att = get_fst_attr_in_xml_list "begin" xmllist in
+ let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in
+ [start_att ; stop_att]
+
+let compare_begin_att xml1 xml2 =
+ let att1 = get_fst_attr_in_xml_list "begin" [xml1] in
+ let att2 = get_fst_attr_in_xml_list "begin" [xml2] in
+ match att1, att2 with
+ | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0
+ | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1
+ | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1
+ | _ -> 0
+
+let xmlBeginSection loc name = xmlWithLoc loc "beginsection" ["name", name] []
+
+let xmlEndSegment loc name = xmlWithLoc loc "endsegment" ["name", name] []
+
+let xmlThm typ name loc xml =
+ xmlWithLoc loc "theorem" ["type", typ; "name", name] xml
+
+let xmlDef typ name loc xml =
+ xmlWithLoc loc "definition" ["type", typ; "name", name] xml
+
+let xmlNotation attr name loc xml =
+ xmlWithLoc loc "notation" (("name", name) :: attr) xml
+
+let xmlReservedNotation attr name loc =
+ xmlWithLoc loc "reservednotation" (("name", name) :: attr) []
+
+let xmlCst name ?(attr=[]) loc =
+ xmlWithLoc loc "constant" (("name", name) :: attr) []
+
+let xmlOperator name ?(attr=[]) ?(pprules=[]) loc =
+ xmlWithLoc loc "operator"
+ (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) []
+
+let xmlApply loc ?(attr=[]) xml = xmlWithLoc loc "apply" attr xml
+
+let xmlToken loc ?(attr=[]) xml = xmlWithLoc loc "token" attr xml
+
+let xmlTyped xml = Element("typed", (backstep_loc xml), xml)
+
+let xmlReturn ?(attr=[]) xml = Element("return", attr, xml)
+
+let xmlCase xml = Element("case", [], xml)
+
+let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml)
+
+let xmlWith xml = Element("with", [], xml)
+
+let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml])
+
+let xmlInductive kind loc xml = xmlWithLoc loc "inductive" ["kind",kind] xml
+
+let xmlCoFixpoint xml = Element("cofixpoint", [], xml)
+
+let xmlFixpoint xml = Element("fixpoint", [], xml)
+
+let xmlCheck loc xml = xmlWithLoc loc "check" [] xml
+
+let xmlAssumption kind loc xml = xmlWithLoc loc "assumption" ["kind",kind] xml
+
+let xmlComment loc xml = xmlWithLoc loc "comment" [] xml
+
+let xmlCanonicalStructure attr loc = xmlWithLoc loc "canonicalstructure" attr []
+
+let xmlQed ?(attr=[]) loc = xmlWithLoc loc "qed" attr []
+
+let xmlPatvar id loc = xmlWithLoc loc "patvar" ["id", id] []
+
+let xmlReference ref =
+ let name = Libnames.string_of_reference ref in
+ let i, j = Loc.unloc (Libnames.loc_of_reference ref) in
+ let b, e = string_of_int i, string_of_int j in
+ Element("reference",["name", name; "begin", b; "end", e] ,[])
+
+let xmlRequire loc ?(attr=[]) xml = xmlWithLoc loc "require" attr xml
+let xmlImport loc ?(attr=[]) xml = xmlWithLoc loc "import" attr xml
+
+let xmlAddLoadPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml
+let xmlRemoveLoadPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr
+let xmlAddMLPath loc ?(attr=[]) = xmlWithLoc loc "addmlpath" attr
+
+let xmlExtend loc xml = xmlWithLoc loc "extend" [] xml
+
+let xmlScope loc action ?(attr=[]) name xml =
+ xmlWithLoc loc "scope" (["name",name;"action",action] @ attr) xml
+
+let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] []
+
+let xmlProof loc xml = xmlWithLoc loc "proof" [] xml
+
+let xmlRawTactic name rtac =
+ Element("rawtactic", ["name",name],
+ [PCData (Pp.string_of_ppcmds (Pptactic.pr_raw_tactic rtac))])
+
+let xmlSectionSubsetDescr name ssd =
+ Element("sectionsubsetdescr",["name",name],
+ [PCData (Proof_using.to_string ssd)])
+
+let xmlDeclareMLModule loc s =
+ xmlWithLoc loc "declarexmlmodule" []
+ (List.map (fun x -> Element("path",["value",x],[])) s)
+
+(* tactics *)
+let xmlLtac loc xml = xmlWithLoc loc "ltac" [] xml
+
+(* toplevel commands *)
+let xmlGallina loc xml = xmlWithLoc loc "gallina" [] xml
+
+let xmlTODO loc x =
+ xmlWithLoc loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+let string_of_name n =
+ match n with
+ | Anonymous -> "_"
+ | Name id -> Id.to_string id
+
+let string_of_glob_sort s =
+ match s with
+ | GProp -> "Prop"
+ | GSet -> "Set"
+ | GType _ -> "Type"
+
+let string_of_cast_sort c =
+ match c with
+ | CastConv _ -> "CastConv"
+ | CastVM _ -> "CastVM"
+ | CastNative _ -> "CastNative"
+ | CastCoerce -> "CastCoerce"
+
+let string_of_case_style s =
+ match s with
+ | LetStyle -> "Let"
+ | IfStyle -> "If"
+ | LetPatternStyle -> "LetPattern"
+ | MatchStyle -> "Match"
+ | RegularStyle -> "Regular"
+
+let attribute_of_syntax_modifier sm =
+match sm with
+ | SetItemLevel (sl, NumLevel n) ->
+ List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n]
+ | SetItemLevel (sl, NextLevel) ->
+ List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"]
+ | SetLevel i -> ["level", string_of_int i]
+ | SetAssoc a ->
+ begin match a with
+ | NonA -> ["",""]
+ | RightA -> ["associativity", "right"]
+ | LeftA -> ["associativity", "left"]
+ end
+ | SetEntryType (s, _) -> ["entrytype", s]
+ | SetOnlyPrinting -> ["onlyprinting", ""]
+ | SetOnlyParsing -> ["onlyparsing", ""]
+ | SetCompatVersion v -> ["compat", Flags.pr_version v]
+ | SetFormat (system, (loc, s)) ->
+ let start, stop = unlock loc in
+ ["format-"^system, s; "begin", start; "end", stop]
+
+let string_of_assumption_kind l a many =
+ match l, a, many with
+ | (Discharge, Logical, true) -> "Hypotheses"
+ | (Discharge, Logical, false) -> "Hypothesis"
+ | (Discharge, Definitional, true) -> "Variables"
+ | (Discharge, Definitional, false) -> "Variable"
+ | (Global, Logical, true) -> "Axioms"
+ | (Global, Logical, false) -> "Axiom"
+ | (Global, Definitional, true) -> "Parameters"
+ | (Global, Definitional, false) -> "Parameter"
+ | (Local, Logical, true) -> "Local Axioms"
+ | (Local, Logical, false) -> "Local Axiom"
+ | (Local, Definitional, true) -> "Local Parameters"
+ | (Local, Definitional, false) -> "Local Parameter"
+ | (Global, Conjectural, _) -> "Conjecture"
+ | ((Discharge | Local), Conjectural, _) -> assert false
+
+let rec pp_bindlist bl =
+ let tlist =
+ List.flatten
+ (List.map
+ (fun (loc_names, _, e) ->
+ let names =
+ (List.map
+ (fun (loc, name) ->
+ xmlCst (string_of_name name) loc) loc_names) in
+ match e with
+ | CHole _ -> names
+ | _ -> names @ [pp_expr e])
+ bl) in
+ match tlist with
+ | [e] -> e
+ | l -> xmlTyped l
+and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *)
+ Element ("decl_notation", ["name", s], [pp_expr ce])
+and pp_local_binder lb = (* don't know what it is for now *)
+ match lb with
+ | LocalRawDef ((_, nam), ce) ->
+ let attrs = ["name", string_of_name nam] in
+ pp_expr ~attr:attrs ce
+ | LocalRawAssum (namll, _, ce) ->
+ let ppl =
+ List.map (fun (loc, nam) -> (xmlCst (string_of_name nam) loc)) namll in
+ xmlTyped (ppl @ [pp_expr ce])
+ | LocalPattern _ ->
+ assert false
+and pp_local_decl_expr lde = (* don't know what it is for now *)
+ match lde with
+ | AssumExpr (_, ce) -> pp_expr ce
+ | DefExpr (_, ce, _) -> pp_expr ce
+and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) =
+ (* inductive_expr *)
+ let b,e = Loc.unloc l in
+ let location = ["begin", string_of_int b; "end", string_of_int e] in
+ [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *)
+ begin match cl_or_rdexpr with
+ | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel
+ | RecordDecl (_, ldewwwl) ->
+ List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl
+ end @
+ begin match ceo with (* don't know what it is for now *)
+ | Some ce -> [pp_expr ce]
+ | None -> []
+ end @
+ (List.map pp_local_binder lbl)
+and pp_recursion_order_expr optid roe = (* don't know what it is for now *)
+ let attrs =
+ match optid with
+ | None -> []
+ | Some (loc, id) ->
+ let start, stop = unlock loc in
+ ["begin", start; "end", stop ; "name", Id.to_string id] in
+ let kind, expr =
+ match roe with
+ | CStructRec -> "struct", []
+ | CWfRec e -> "rec", [pp_expr e]
+ | CMeasureRec (e, None) -> "mesrec", [pp_expr e]
+ | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in
+ Element ("recursion_order", ["kind", kind] @ attrs, expr)
+and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) =
+ (* fixpoint_expr *)
+ let start, stop = unlock loc in
+ let id = Id.to_string id in
+ [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
+ (* fixpoint name *)
+ [pp_recursion_order_expr optid roe] @
+ (List.map pp_local_binder lbl) @
+ [pp_expr ce] @
+ begin match ceo with (* don't know what it is for now *)
+ | Some ce -> [pp_expr ce]
+ | None -> []
+ end
+and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *)
+ (* Nota: it is like fixpoint_expr without (optid, roe)
+ * so could be merged if there is no more differences *)
+ let start, stop = unlock loc in
+ let id = Id.to_string id in
+ [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
+ (* cofixpoint name *)
+ (List.map pp_local_binder lbl) @
+ [pp_expr ce] @
+ begin match ceo with (* don't know what it is for now *)
+ | Some ce -> [pp_expr ce]
+ | None -> []
+ end
+and pp_lident (loc, id) = xmlCst (Id.to_string id) loc
+and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce]
+and pp_cases_pattern_expr cpe =
+ match cpe with
+ | CPatAlias (loc, cpe, id) ->
+ xmlApply loc
+ (xmlOperator "alias" ~attr:["name", string_of_id id] loc ::
+ [pp_cases_pattern_expr cpe])
+ | CPatCstr (loc, ref, None, cpel2) ->
+ xmlApply loc
+ (xmlOperator "reference"
+ ~attr:["name", Libnames.string_of_reference ref] loc ::
+ [Element ("impargs", [], []);
+ Element ("args", [], (List.map pp_cases_pattern_expr cpel2))])
+ | CPatCstr (loc, ref, Some cpel1, cpel2) ->
+ xmlApply loc
+ (xmlOperator "reference"
+ ~attr:["name", Libnames.string_of_reference ref] loc ::
+ [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1));
+ Element ("args", [], (List.map pp_cases_pattern_expr cpel2))])
+ | CPatAtom (loc, optr) ->
+ let attrs = match optr with
+ | None -> []
+ | Some r -> ["name", Libnames.string_of_reference r] in
+ xmlApply loc (xmlOperator "atom" ~attr:attrs loc :: [])
+ | CPatOr (loc, cpel) ->
+ xmlApply loc (xmlOperator "or" loc :: List.map pp_cases_pattern_expr cpel)
+ | CPatNotation (loc, n, (subst_constr, subst_rec), cpel) ->
+ xmlApply loc
+ (xmlOperator "notation" loc ::
+ [xmlOperator n loc;
+ Element ("subst", [],
+ [Element ("subterms", [],
+ List.map pp_cases_pattern_expr subst_constr);
+ Element ("recsubterms", [],
+ List.map
+ (fun (cpel) ->
+ Element ("recsubterm", [],
+ List.map pp_cases_pattern_expr cpel))
+ subst_rec)]);
+ Element ("args", [], (List.map pp_cases_pattern_expr cpel))])
+ | CPatPrim (loc, tok) -> pp_token loc tok
+ | CPatRecord (loc, rcl) ->
+ xmlApply loc
+ (xmlOperator "record" loc ::
+ List.map (fun (r, cpe) ->
+ Element ("field",
+ ["reference", Libnames.string_of_reference r],
+ [pp_cases_pattern_expr cpe]))
+ rcl)
+ | CPatDelimiters (loc, delim, cpe) ->
+ xmlApply loc
+ (xmlOperator "delimiter" ~attr:["name", delim] loc ::
+ [pp_cases_pattern_expr cpe])
+ | CPatCast _ -> assert false
+and pp_case_expr (e, name, pat) =
+ match name, pat with
+ | None, None -> xmlScrutinee [pp_expr e]
+ | Some (loc, name), None ->
+ let start, stop= unlock loc in
+ xmlScrutinee ~attr:["name", string_of_name name;
+ "begin", start; "end", stop] [pp_expr e]
+ | Some (loc, name), Some p ->
+ let start, stop= unlock loc in
+ xmlScrutinee ~attr:["name", string_of_name name;
+ "begin", start; "end", stop]
+ [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
+ | None, Some p ->
+ xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
+and pp_branch_expr_list bel =
+ xmlWith
+ (List.map
+ (fun (_, cpel, e) ->
+ let ppcepl =
+ List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in
+ let ppe = [pp_expr e] in
+ xmlCase (ppcepl @ ppe))
+ bel)
+and pp_token loc tok =
+ let tokstr =
+ match tok with
+ | String s -> PCData s
+ | Numeral n -> PCData (to_string n) in
+ xmlToken loc [tokstr]
+and pp_local_binder_list lbl =
+ let l = (List.map pp_local_binder lbl) in
+ Element ("recurse", (backstep_loc l), l)
+and pp_const_expr_list cel =
+ let l = List.map pp_expr cel in
+ Element ("recurse", (backstep_loc l), l)
+and pp_expr ?(attr=[]) e =
+ match e with
+ | CRef (r, _) ->
+ xmlCst ~attr
+ (Libnames.string_of_reference r) (Libnames.loc_of_reference r)
+ | CProdN (loc, bl, e) ->
+ xmlApply loc
+ (xmlOperator "forall" loc :: [pp_bindlist bl] @ [pp_expr e])
+ | CApp (loc, (_, hd), args) ->
+ xmlApply ~attr loc (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args)
+ | CAppExpl (loc, (_, r, _), args) ->
+ xmlApply ~attr loc
+ (xmlCst (Libnames.string_of_reference r)
+ (Libnames.loc_of_reference r) :: List.map pp_expr args)
+ | CNotation (loc, notation, ([],[],[])) ->
+ xmlOperator notation loc
+ | CNotation (loc, notation, (args, cell, lbll)) ->
+ let fmts = Notation.find_notation_extra_printing_rules notation in
+ let oper = xmlOperator notation loc ~pprules:fmts in
+ let cels = List.map pp_const_expr_list cell in
+ let lbls = List.map pp_local_binder_list lbll in
+ let args = List.map pp_expr args in
+ xmlApply loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls)))
+ | CSort(loc, s) ->
+ xmlOperator (string_of_glob_sort s) loc
+ | CDelimiters (loc, scope, ce) ->
+ xmlApply loc (xmlOperator "delimiter" ~attr:["name", scope] loc ::
+ [pp_expr ce])
+ | CPrim (loc, tok) -> pp_token loc tok
+ | CGeneralization (loc, kind, _, e) ->
+ let kind= match kind with
+ | Explicit -> "explicit"
+ | Implicit -> "implicit" in
+ xmlApply loc
+ (xmlOperator "generalization" ~attr:["kind", kind] loc :: [pp_expr e])
+ | CCast (loc, e, tc) ->
+ begin match tc with
+ | CastConv t | CastVM t |CastNative t ->
+ xmlApply loc
+ (xmlOperator ":" loc ~attr:["kind", (string_of_cast_sort tc)] ::
+ [pp_expr e; pp_expr t])
+ | CastCoerce ->
+ xmlApply loc
+ (xmlOperator ":" loc ~attr:["kind", "CastCoerce"] ::
+ [pp_expr e])
+ end
+ | CEvar (loc, ek, cel) ->
+ let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in
+ xmlApply loc
+ (xmlOperator "evar" loc ~attr:["id", string_of_id ek] ::
+ ppcel)
+ | CPatVar (loc, id) -> xmlPatvar (string_of_id id) loc
+ | CHole (loc, _, _, _) -> xmlCst ~attr "_" loc
+ | CIf (loc, test, (_, ret), th, el) ->
+ let return = match ret with
+ | None -> []
+ | Some r -> [xmlReturn [pp_expr r]] in
+ xmlApply loc
+ (xmlOperator "if" loc ::
+ return @ [pp_expr th] @ [pp_expr el])
+ | CLetTuple (loc, names, (_, ret), value, body) ->
+ let return = match ret with
+ | None -> []
+ | Some r -> [xmlReturn [pp_expr r]] in
+ xmlApply loc
+ (xmlOperator "lettuple" loc ::
+ return @
+ (List.map (fun (loc, var) -> xmlCst (string_of_name var) loc) names) @
+ [pp_expr value; pp_expr body])
+ | CCases (loc, sty, ret, cel, bel) ->
+ let return = match ret with
+ | None -> []
+ | Some r -> [xmlReturn [pp_expr r]] in
+ xmlApply loc
+ (xmlOperator "match" loc ~attr:["style", (string_of_case_style sty)] ::
+ (return @
+ [Element ("scrutinees", [], List.map pp_case_expr cel)] @
+ [pp_branch_expr_list bel]))
+ | CRecord (_, _) -> assert false
+ | CLetIn (loc, (varloc, var), value, body) ->
+ xmlApply loc
+ (xmlOperator "let" loc ::
+ [xmlCst (string_of_name var) varloc; pp_expr value; pp_expr body])
+ | CLambdaN (loc, bl, e) ->
+ xmlApply loc
+ (xmlOperator "lambda" loc :: [pp_bindlist bl] @ [pp_expr e])
+ | CCoFix (_, _, _) -> assert false
+ | CFix (loc, lid, fel) ->
+ xmlApply loc
+ (xmlOperator "fix" loc ::
+ List.flatten (List.map
+ (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d))
+ fel))
+
+let pp_comment (c) =
+ match c with
+ | CommentConstr e -> [pp_expr e]
+ | CommentString s -> [Element ("string", [], [PCData s])]
+ | CommentInt i -> [PCData (string_of_int i)]
+
+let rec tmpp v loc =
+ match v with
+ (* Control *)
+ | VernacLoad (verbose,f) ->
+ xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] []
+ | VernacTime (loc,e) ->
+ xmlApply loc (Element("time",[],[]) ::
+ [tmpp e loc])
+ | VernacRedirect (s, (loc,e)) ->
+ xmlApply loc (Element("redirect",["path", s],[]) ::
+ [tmpp e loc])
+ | VernacTimeout (s,e) ->
+ xmlApply loc (Element("timeout",["val",string_of_int s],[]) ::
+ [tmpp e loc])
+ | VernacFail e -> xmlApply loc (Element("fail",[],[]) :: [tmpp e loc])
+ | VernacError _ -> xmlWithLoc loc "error" [] []
+
+ (* Syntax *)
+ | VernacSyntaxExtension (_, ((_, name), sml)) ->
+ let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+ xmlReservedNotation attrs name loc
+
+ | VernacOpenCloseScope (_,(true,name)) -> xmlScope loc "open" name []
+ | VernacOpenCloseScope (_,(false,name)) -> xmlScope loc "close" name []
+ | VernacDelimiters (name,Some tag) ->
+ xmlScope loc "delimit" name ~attr:["delimiter",tag] []
+ | VernacDelimiters (name,None) ->
+ xmlScope loc "undelimit" name ~attr:[] []
+ | VernacInfix (_,((_,name),sml),ce,sn) ->
+ let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+ let sc_attr =
+ match sn with
+ | Some scope -> ["scope", scope]
+ | None -> [] in
+ xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
+ | VernacNotation (_, ce, (lstr, sml), sn) ->
+ let name = snd lstr in
+ let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+ let sc_attr =
+ match sn with
+ | Some scope -> ["scope", scope]
+ | None -> [] in
+ xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
+ | VernacBindScope _ as x -> xmlTODO loc x
+ | VernacNotationAddFormat _ as x -> xmlTODO loc x
+ | VernacUniverse _
+ | VernacConstraint _
+ | VernacPolymorphic (_, _) as x -> xmlTODO loc x
+ (* Gallina *)
+ | VernacDefinition (ldk, ((_,id),_), de) ->
+ let l, dk =
+ match ldk with
+ | Some l, dk -> (l, dk)
+ | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *)
+ let e =
+ match de with
+ | ProveBody (_, ce) -> ce
+ | DefineBody (_, Some _, ce, None) -> ce
+ | DefineBody (_, None , ce, None) -> ce
+ | DefineBody (_, Some _, ce, Some _) -> ce
+ | DefineBody (_, None , ce, Some _) -> ce in
+ let str_dk = Kindops.string_of_definition_kind (l, false, dk) in
+ let str_id = Id.to_string id in
+ (xmlDef str_dk str_id loc [pp_expr e])
+ | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) ->
+ let str_tk = Kindops.string_of_theorem_kind tk in
+ let str_id = Id.to_string id in
+ (xmlThm str_tk str_id loc [pp_expr statement])
+ | VernacStartTheoremProof _ as x -> xmlTODO loc x
+ | VernacEndProof pe ->
+ begin
+ match pe with
+ | Admitted -> xmlQed loc
+ | Proved (_, Some ((_, id), Some tk)) ->
+ let nam = Id.to_string id in
+ let typ = Kindops.string_of_theorem_kind tk in
+ xmlQed ~attr:["name", nam; "type", typ] loc
+ | Proved (_, Some ((_, id), None)) ->
+ let nam = Id.to_string id in
+ xmlQed ~attr:["name", nam] loc
+ | Proved _ -> xmlQed loc
+ end
+ | VernacExactProof _ as x -> xmlTODO loc x
+ | VernacAssumption ((l, a), _, sbwcl) ->
+ let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in
+ let many =
+ List.length (List.flatten (List.map fst binders)) > 1 in
+ let exprs =
+ List.flatten (List.map pp_simple_binder binders) in
+ let l = match l with Some x -> x | None -> Decl_kinds.Global in
+ let kind = string_of_assumption_kind l a many in
+ xmlAssumption kind loc exprs
+ | VernacInductive (_, _, iednll) ->
+ let kind =
+ let (_, _, _, k, _),_ = List.hd iednll in
+ begin
+ match k with
+ | Record -> "Record"
+ | Structure -> "Structure"
+ | Inductive_kw -> "Inductive"
+ | CoInductive -> "CoInductive"
+ | Class _ -> "Class"
+ | Variant -> "Variant"
+ end in
+ let exprs =
+ List.flatten (* should probably not be flattened *)
+ (List.map
+ (fun (ie, dnl) -> (pp_inductive_expr ie) @
+ (List.map pp_decl_notation dnl)) iednll) in
+ xmlInductive kind loc exprs
+ | VernacFixpoint (_, fednll) ->
+ let exprs =
+ List.flatten (* should probably not be flattened *)
+ (List.map
+ (fun (fe, dnl) -> (pp_fixpoint_expr fe) @
+ (List.map pp_decl_notation dnl)) fednll) in
+ xmlFixpoint exprs
+ | VernacCoFixpoint (_, cfednll) ->
+ (* Nota: it is like VernacFixpoint without so could be merged *)
+ let exprs =
+ List.flatten (* should probably not be flattened *)
+ (List.map
+ (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @
+ (List.map pp_decl_notation dnl)) cfednll) in
+ xmlCoFixpoint exprs
+ | VernacScheme _ as x -> xmlTODO loc x
+ | VernacCombinedScheme _ as x -> xmlTODO loc x
+
+ (* Gallina extensions *)
+ | VernacBeginSection (_, id) -> xmlBeginSection loc (Id.to_string id)
+ | VernacEndSegment (_, id) -> xmlEndSegment loc (Id.to_string id)
+ | VernacNameSectionHypSet _ as x -> xmlTODO loc x
+ | VernacRequire (from, import, l) ->
+ let import = match import with
+ | None -> []
+ | Some true -> ["export","true"]
+ | Some false -> ["import","true"]
+ in
+ let from = match from with
+ | None -> []
+ | Some r -> ["from", Libnames.string_of_reference r]
+ in
+ xmlRequire loc ~attr:(from @ import) (List.map (fun ref ->
+ xmlReference ref) l)
+ | VernacImport (true,l) ->
+ xmlImport loc ~attr:["export","true"] (List.map (fun ref ->
+ xmlReference ref) l)
+ | VernacImport (false,l) ->
+ xmlImport loc (List.map (fun ref ->
+ xmlReference ref) l)
+ | VernacCanonical r ->
+ let attr =
+ match r with
+ | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q]
+ | AN (Ident (_, id)) -> ["id", Id.to_string id]
+ | ByNotation (_, s, _) -> ["notation", s] in
+ xmlCanonicalStructure attr loc
+ | VernacCoercion _ as x -> xmlTODO loc x
+ | VernacIdentityCoercion _ as x -> xmlTODO loc x
+
+ (* Type classes *)
+ | VernacInstance _ as x -> xmlTODO loc x
+
+ | VernacContext _ as x -> xmlTODO loc x
+
+ | VernacDeclareInstances _ as x -> xmlTODO loc x
+
+ | VernacDeclareClass _ as x -> xmlTODO loc x
+
+ (* Modules and Module Types *)
+ | VernacDeclareModule _ as x -> xmlTODO loc x
+ | VernacDefineModule _ as x -> xmlTODO loc x
+ | VernacDeclareModuleType _ as x -> xmlTODO loc x
+ | VernacInclude _ as x -> xmlTODO loc x
+
+ (* Solving *)
+
+ | (VernacSolveExistential _) as x ->
+ xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+ (* Auxiliary file and library management *)
+ | VernacAddLoadPath (recf,name,None) ->
+ xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] []
+ | VernacAddLoadPath (recf,name,Some dp) ->
+ xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name]
+ [PCData (Names.DirPath.to_string dp)]
+ | VernacRemoveLoadPath name -> xmlRemoveLoadPath loc ~attr:["path",name] []
+ | VernacAddMLPath (recf,name) ->
+ xmlAddMLPath loc ~attr:["rec",string_of_bool recf;"path",name] []
+ | VernacDeclareMLModule sl -> xmlDeclareMLModule loc sl
+ | VernacChdir _ as x -> xmlTODO loc x
+
+ (* State management *)
+ | VernacWriteState _ as x -> xmlTODO loc x
+ | VernacRestoreState _ as x -> xmlTODO loc x
+
+ (* Resetting *)
+ | VernacResetName _ as x -> xmlTODO loc x
+ | VernacResetInitial as x -> xmlTODO loc x
+ | VernacBack _ as x -> xmlTODO loc x
+ | VernacBackTo _ -> PCData "VernacBackTo"
+
+ (* Commands *)
+ | VernacCreateHintDb _ as x -> xmlTODO loc x
+ | VernacRemoveHints _ as x -> xmlTODO loc x
+ | VernacHints _ as x -> xmlTODO loc x
+ | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) ->
+ let name = Id.to_string name in
+ let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in
+ xmlNotation attrs name loc [pp_expr ce]
+ | VernacDeclareImplicits _ as x -> xmlTODO loc x
+ | VernacArguments _ as x -> xmlTODO loc x
+ | VernacArgumentsScope _ as x -> xmlTODO loc x
+ | VernacReserve _ as x -> xmlTODO loc x
+ | VernacGeneralizable _ as x -> xmlTODO loc x
+ | VernacSetOpacity _ as x -> xmlTODO loc x
+ | VernacSetStrategy _ as x -> xmlTODO loc x
+ | VernacUnsetOption _ as x -> xmlTODO loc x
+ | VernacSetOption _ as x -> xmlTODO loc x
+ | VernacSetAppendOption _ as x -> xmlTODO loc x
+ | VernacAddOption _ as x -> xmlTODO loc x
+ | VernacRemoveOption _ as x -> xmlTODO loc x
+ | VernacMemOption _ as x -> xmlTODO loc x
+ | VernacPrintOption _ as x -> xmlTODO loc x
+ | VernacCheckMayEval (_,_,e) -> xmlCheck loc [pp_expr e]
+ | VernacGlobalCheck _ as x -> xmlTODO loc x
+ | VernacDeclareReduction _ as x -> xmlTODO loc x
+ | VernacPrint _ as x -> xmlTODO loc x
+ | VernacSearch _ as x -> xmlTODO loc x
+ | VernacLocate _ as x -> xmlTODO loc x
+ | VernacRegister _ as x -> xmlTODO loc x
+ | VernacComments (cl) ->
+ xmlComment loc (List.flatten (List.map pp_comment cl))
+
+ (* Stm backdoor *)
+ | VernacStm _ as x -> xmlTODO loc x
+
+ (* Proof management *)
+ | VernacGoal _ as x -> xmlTODO loc x
+ | VernacAbort _ as x -> xmlTODO loc x
+ | VernacAbortAll -> PCData "VernacAbortAll"
+ | VernacRestart as x -> xmlTODO loc x
+ | VernacUndo _ as x -> xmlTODO loc x
+ | VernacUndoTo _ as x -> xmlTODO loc x
+ | VernacBacktrack _ as x -> xmlTODO loc x
+ | VernacFocus _ as x -> xmlTODO loc x
+ | VernacUnfocus as x -> xmlTODO loc x
+ | VernacUnfocused as x -> xmlTODO loc x
+ | VernacBullet _ as x -> xmlTODO loc x
+ | VernacSubproof _ as x -> xmlTODO loc x
+ | VernacEndSubproof as x -> xmlTODO loc x
+ | VernacShow _ as x -> xmlTODO loc x
+ | VernacCheckGuard as x -> xmlTODO loc x
+ | VernacProof (tac,using) ->
+ let tac = Option.map (xmlRawTactic "closingtactic") tac in
+ let using = Option.map (xmlSectionSubsetDescr "using") using in
+ xmlProof loc (Option.List.(cons tac (cons using [])))
+ | VernacProofMode name -> xmlProofMode loc name
+
+ (* Toplevel control *)
+ | VernacToplevelControl _ as x -> xmlTODO loc x
+
+ (* For extension *)
+ | VernacExtend _ as x ->
+ xmlExtend loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+ (* Flags *)
+ | VernacProgram e -> xmlApply loc (Element("program",[],[]) :: [tmpp e loc])
+ | VernacLocal (b,e) ->
+ xmlApply loc (Element("local",["flag",string_of_bool b],[]) ::
+ [tmpp e loc])
+
+let tmpp v loc =
+ match tmpp v loc with
+ | Element("ltac",_,_) as x -> x
+ | xml -> xmlGallina loc [xml]
diff --git a/ide/texmacspp.mli b/ide/texmacspp.mli
new file mode 100644
index 00000000..858847fb
--- /dev/null
+++ b/ide/texmacspp.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+open Vernacexpr
+
+val tmpp : vernac_expr -> Loc.t -> xml
diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml
index 9f44e5c6..e9b19da6 100644
--- a/ide/utils/configwin_keys.ml
+++ b/ide/utils/configwin_keys.ml
@@ -154,7 +154,7 @@ let xk_KP_9 = 0xFFB9
(*
- * Auxilliary Functions; note the duplicate definitions for left and right
+ * Auxiliary Functions; note the duplicate definitions for left and right
* function keys; Sun keyboards and a few other manufactures have such
* function key groups on the left and/or right sides of the keyboard.
* We've not found a keyboard with more than 35 function keys total.
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
index 580f1fbc..8f6cb382 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -52,33 +52,6 @@ let int_of_modifier = function
| `RELEASE -> 1 lsl 30
| `SUPER -> 1 lsl 21
-let print_modifier l =
- List.iter
- (fun m ->
- print_string
- (((function
- `SHIFT -> "SHIFT"
- | `LOCK -> "LOCK"
- | `CONTROL -> "CONTROL"
- | `MOD1 -> "MOD1"
- | `MOD2 -> "MOD2"
- | `MOD3 -> "MOD3"
- | `MOD4 -> "MOD4"
- | `MOD5 -> "MOD5"
- | `BUTTON1 -> "B1"
- | `BUTTON2 -> "B2"
- | `BUTTON3 -> "B3"
- | `BUTTON4 -> "B4"
- | `BUTTON5 -> "B5"
- | `HYPER -> "HYPER"
- | `META -> "META"
- | `RELEASE -> ""
- | `SUPER -> "SUPER")
- m)^" ")
- )
- l;
- print_newline ()
-
let int_of_modifiers l =
List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
index a3e5ea3f..946aaf01 100644
--- a/ide/wg_Command.ml
+++ b/ide/wg_Command.ml
@@ -85,9 +85,11 @@ object(self)
~packing:(vbox#pack ~fill:true ~expand:true) () in
let result = GText.view ~packing:r_bin#add () in
views <- (frame#coerce, result, combo#entry) :: views;
- result#misc#modify_font current.text_font;
- let clr = Tags.color_of_string current.background_color in
- result#misc#modify_base [`NORMAL, `COLOR clr];
+ let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = result#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font result cb;
result#misc#set_can_focus true; (* false causes problems for selection *)
result#set_editable false;
let callback () =
@@ -98,11 +100,14 @@ object(self)
if Str.string_match (Str.regexp "\\. *$") com 0 then com
else com ^ " " ^ arg ^" . "
in
- let log level message = result#buffer#insert (message^"\n") in
+ let log level message =
+ Ideutils.insert_xml result#buffer message;
+ result#buffer#insert "\n";
+ in
let process =
Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
| Interface.Fail (_,l,str) ->
- result#buffer#insert str;
+ Ideutils.insert_xml result#buffer str;
notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
Coq.return ()
| Interface.Good res ->
@@ -144,13 +149,9 @@ object(self)
method visible =
frame#visible
-
- method refresh_font () =
- let iter (_,view,_) = view#misc#modify_font current.text_font in
- List.iter iter views
- method refresh_color () =
- let clr = Tags.color_of_string current.background_color in
+ method private refresh_color clr =
+ let clr = Tags.color_of_string clr in
let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
List.iter iter views
@@ -158,6 +159,8 @@ object(self)
self#new_page_maker;
self#new_query_aux ~grab_now:false ();
frame#misc#hide ();
+ let _ = background_color#connect#changed self#refresh_color in
+ self#refresh_color background_color#get;
ignore(notebook#event#connect#key_press ~callback:(fun ev ->
if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
else false
diff --git a/ide/wg_Command.mli b/ide/wg_Command.mli
index 97f96f45..fa50ba5f 100644
--- a/ide/wg_Command.mli
+++ b/ide/wg_Command.mli
@@ -10,8 +10,6 @@ class command_window : string -> Coq.coqtop ->
object
method new_query : ?command:string -> ?term:string -> unit -> unit
method pack_in : (GObj.widget -> unit) -> unit
- method refresh_font : unit -> unit
- method refresh_color : unit -> unit
method show : unit
method hide : unit
method visible : bool
diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml
index 3c228998..aeae3e1f 100644
--- a/ide/wg_Completion.ml
+++ b/ide/wg_Completion.ml
@@ -86,7 +86,7 @@ let signals = [
end_s#disconnect;
] in
object (self : 'a)
- inherit GUtil.ml_signals signals as super
+ inherit GUtil.ml_signals signals
method start_completion = start_s#connect ~after
method update_completion = update_s#connect ~after
method end_completion = end_s#connect ~after
@@ -258,7 +258,7 @@ object (self)
method private refresh_style () =
let (renderer, _) = renderer in
- let font = Preferences.current.Preferences.text_font in
+ let font = Pango.Font.from_string Preferences.text_font#get in
renderer#set_properties [`FONT_DESC font; `XPAD 10]
method private coordinates pos =
diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml
index 47901237..3d847ddc 100644
--- a/ide/wg_Find.ml
+++ b/ide/wg_Find.ml
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-type mode = [ `FIND | `REPLACE ]
-
let b2c = Ideutils.byte_offset_to_char_offset
class finder name (view : GText.view) =
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
index f2b8336c..0330b8ef 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -6,11 +6,13 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Preferences
+
class type message_view_signals =
object
inherit GObj.misc_signals
inherit GUtil.add_ml_signals
- method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+ method pushed : callback:Ideutils.logger -> GtkSignal.id
end
class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals =
@@ -26,14 +28,13 @@ class type message_view =
inherit GObj.widget
method connect : message_view_signals
method clear : unit
- method add : string -> unit
- method set : string -> unit
- method push : Pp.message_level -> string -> unit
+ method add : Richpp.richpp -> unit
+ method add_string : string -> unit
+ method set : Richpp.richpp -> unit
+ method push : Ideutils.logger
(** same as [add], but with an explicit level instead of [Notice] *)
method buffer : GText.buffer
(** for more advanced text edition *)
- method modify_font : Pango.font_description -> unit
- method refresh_color : unit -> unit
end
let message_view () : message_view =
@@ -42,6 +43,7 @@ let message_view () : message_view =
~tag_table:Tags.Message.table ()
in
let text_buffer = new GText.buffer buffer#as_buffer in
+ let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in
let box = GPack.vbox () in
let scroll = GBin.scrolled_window
~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in
@@ -53,6 +55,12 @@ let message_view () : message_view =
let default_clipboard = GData.clipboard Gdk.Atom.primary in
let _ = buffer#add_selection_clipboard default_clipboard in
let () = view#set_left_margin 2 in
+ view#misc#show ();
+ let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font view cb;
object (self)
inherit GObj.widget box#as_widget
@@ -62,31 +70,33 @@ let message_view () : message_view =
new message_view_signals_impl box#as_widget push
method clear =
- buffer#set_text ""
+ buffer#set_text "";
+ buffer#move_mark (`MARK mark) ~where:buffer#start_iter
method push level msg =
let tags = match level with
- | Pp.Error -> [Tags.Message.error]
- | Pp.Warning -> [Tags.Message.warning]
+ | Feedback.Error -> [Tags.Message.error]
+ | Feedback.Warning -> [Tags.Message.warning]
| _ -> []
in
- if msg <> "" then begin
- buffer#insert ~tags msg;
- buffer#insert ~tags "\n";
+ let rec non_empty = function
+ | Xml_datatype.PCData "" -> false
+ | Xml_datatype.PCData _ -> true
+ | Xml_datatype.Element (_, _, children) -> List.exists non_empty children
+ in
+ if non_empty (Richpp.repr msg) then begin
+ let mark = `MARK mark in
+ Ideutils.insert_xml ~mark buffer ~tags msg;
+ buffer#insert ~iter:(buffer#get_iter_at_mark mark) "\n";
push#call (level, msg)
end
- method add msg = self#push Pp.Notice msg
+ method add msg = self#push Feedback.Notice msg
+
+ method add_string s = self#add (Richpp.richpp_of_string s)
method set msg = self#clear; self#add msg
method buffer = text_buffer
- method modify_font fd = view#misc#modify_font fd
-
- method refresh_color () =
- let open Preferences in
- let clr = Tags.color_of_string current.background_color in
- view#misc#modify_base [`NORMAL, `COLOR clr]
-
end
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
index ebcb2163..2d34533d 100644
--- a/ide/wg_MessageView.mli
+++ b/ide/wg_MessageView.mli
@@ -10,7 +10,7 @@ class type message_view_signals =
object
inherit GObj.misc_signals
inherit GUtil.add_ml_signals
- method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id
+ method pushed : callback:Ideutils.logger -> GtkSignal.id
end
class type message_view =
@@ -18,14 +18,13 @@ class type message_view =
inherit GObj.widget
method connect : message_view_signals
method clear : unit
- method add : string -> unit
- method set : string -> unit
- method push : Pp.message_level -> string -> unit
+ method add : Richpp.richpp -> unit
+ method add_string : string -> unit
+ method set : Richpp.richpp -> unit
+ method push : Ideutils.logger
(** same as [add], but with an explicit level instead of [Notice] *)
method buffer : GText.buffer
(** for more advanced text edition *)
- method modify_font : Pango.font_description -> unit
- method refresh_color : unit -> unit
end
val message_view : unit -> message_view
diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml
index 0007203e..47c86045 100644
--- a/ide/wg_ProofView.ml
+++ b/ide/wg_ProofView.ml
@@ -7,6 +7,8 @@
(************************************************************************)
open Util
+open Preferences
+open Ideutils
class type proof_view =
object
@@ -82,26 +84,28 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
let () = hook_tag_cb tag hint sel_cb on_hover in
[tag], hints
in
- let () = proof#buffer#insert ~tags (hyp ^ "\n") in
+ let () = insert_xml ~tags proof#buffer hyp in
+ proof#buffer#insert "\n";
insert_hyp rem_hints hs
in
let () = proof#buffer#insert head_str in
let () = insert_hyp hyps_hints hyps in
let () =
- let tags = Tags.Proof.goal :: if goal_hints <> [] then
+ let _ = 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;
+ insert_xml proof#buffer cur_goal;
proof#buffer#insert "\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")
+ insert_xml proof#buffer g;
+ proof#buffer#insert "\n"
in
let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
@@ -110,17 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
(Some Tags.Proof.goal)));
ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT)
-let mode_cesar (proof : #GText.view_skel) = 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 rec flatten = function
| [] -> []
| (lg, rg) :: l ->
@@ -151,8 +144,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
(* The proof is finished, with the exception of given up goals. *)
view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n";
let iter goal =
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iter iter given_up_goals;
view#buffer#insert "\nYou need to go back and solve them."
@@ -160,8 +153,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
(* All the goals have been resolved but those on the shelf. *)
view#buffer#insert "All the remaining goals are on the shelf:\n\n";
let iter goal =
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iter iter shelved_goals
| _, _, _, _ ->
@@ -173,8 +166,8 @@ let display mode (view : #GText.view_skel) goals hints evars =
view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n";
let iter i goal =
let () = view#buffer#insert (goal_str (succ i)) in
- let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
- view#buffer#insert msg
+ insert_xml view#buffer goal.Interface.goal_ccl;
+ view#buffer#insert "\n"
in
List.iteri iter bg
end
@@ -193,6 +186,12 @@ let proof_view () =
let () = Gtk_parsing.fix_double_click view in
let default_clipboard = GData.clipboard Gdk.Atom.primary in
let _ = buffer#add_selection_clipboard default_clipboard in
+ let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = view#misc#connect#realize (fun () -> cb background_color#get) in
+ let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font view cb;
+
object
inherit GObj.widget view#as_widget
val mutable goals = None
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
index 5cdf8464..218cedb3 100644
--- a/ide/wg_ScriptView.ml
+++ b/ide/wg_ScriptView.ml
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Preferences
+
type insert_action = {
ins_val : string;
ins_off : int;
@@ -285,7 +287,7 @@ let completion = new Wg_Completion.complete_model ct view#buffer in
let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in
object (self)
- inherit GSourceView2.source_view (Gobject.unsafe_cast tv) as super
+ inherit GSourceView2.source_view (Gobject.unsafe_cast tv)
val undo_manager = new undo_manager view#buffer
@@ -456,6 +458,33 @@ object (self)
if not proceed then GtkSignal.stop_emit ()
in
let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
+ (** Plug on preferences *)
+ let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in
+ let _ = background_color#connect#changed cb in
+ let _ = self#misc#connect#realize (fun () -> cb background_color#get) in
+
+ let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in
+ stick dynamic_word_wrap self cb;
+ stick show_line_number self self#set_show_line_numbers;
+ stick auto_indent self self#set_auto_indent;
+ stick highlight_current_line self self#set_highlight_current_line;
+
+ (* Hack to handle missing binding in lablgtk *)
+ let cb b =
+ let flag = if b then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *) else 0 in
+ let conv = Gobject.({ name = "draw-spaces"; conv = Data.int }) in
+ Gobject.set conv self#as_widget flag
+ in
+ stick show_spaces self cb;
+
+ stick show_right_margin self self#set_show_right_margin;
+ stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs;
+ stick tab_length self self#set_tab_width;
+ stick auto_complete self self#set_auto_complete;
+
+ let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in
+ stick text_font self cb;
+
()
end
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
index b4b02a7f..dbc1740e 100644
--- a/ide/wg_Segment.ml
+++ b/ide/wg_Segment.ml
@@ -7,56 +7,17 @@
(************************************************************************)
open Util
+open Preferences
type color = GDraw.color
-module Segment :
-sig
- type +'a t
- val length : 'a t -> int
- val resize : 'a t -> int -> 'a t
- val empty : 'a t
- val add : int -> 'a -> 'a t -> 'a t
- val remove : int -> 'a t -> 'a t
- val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-end =
-struct
- type 'a t = {
- length : int;
- content : 'a Int.Map.t;
- }
-
- let empty = { length = 0; content = Int.Map.empty }
-
- let length s = s.length
-
- let resize s len =
- if s.length <= len then { s with length = len }
- else
- let filter i v = i < len in
- { length = len; content = Int.Map.filter filter s.content }
-
- let add i v s =
- if i < s.length then
- { s with content = Int.Map.add i v s.content }
- else s
-
- let remove i s = { s with content = Int.Map.remove i s.content }
-
- let fold eq f s accu =
- let make k v (cur, accu) = match cur with
- | None -> Some (k, k, v), accu
- | Some (i, j, w) ->
- if k = j + 1 && eq v w then Some (i, k, w), accu
- else Some (k, k, v), (i, j, w) :: accu
- in
- let p, segments = Int.Map.fold make s.content (None, []) in
- let segments = match p with
- | None -> segments
- | Some p -> p :: segments
- in
- List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments
+type model_event = [ `INSERT | `REMOVE | `SET of int * color ]
+class type model =
+object
+ method changed : callback:(model_event -> unit) -> unit
+ method length : int
+ method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a
end
let i2f = float_of_int
@@ -95,10 +56,12 @@ object (self)
val mutable width = 1
val mutable height = 20
- val mutable data = Segment.empty
+ val mutable model : model option = None
val mutable default : color = `WHITE
val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 ()
val clicked = new GUtil.signal ()
+ val mutable need_refresh = false
+ val refresh_timer = Ideutils.mktimer ()
initializer
box#misc#set_size_request ~height ();
@@ -113,29 +76,41 @@ object (self)
end
in
let _ = box#misc#connect#size_allocate cb in
- let clicked_cb ev =
+ let clicked_cb ev = match model with
+ | None -> true
+ | Some md ->
let x = GdkEvent.Button.x ev in
let (width, _) = pixmap#size in
- let len = Segment.length data in
+ let len = md#length in
let idx = f2i ((x *. i2f len) /. i2f width) in
let () = clicked#call idx in
true
in
let _ = eventbox#event#connect#button_press clicked_cb in
+ let cb show = if show then self#misc#show () else self#misc#hide () in
+ stick show_progress_bar self cb;
(** Initial pixmap *)
- draw#set_pixmap pixmap
-
- method length = Segment.length data
-
- method set_length len =
- data <- Segment.resize data len;
- if self#misc#visible then self#refresh ()
+ draw#set_pixmap pixmap;
+ refresh_timer.Ideutils.run ~ms:300
+ ~callback:(fun () -> if need_refresh then self#refresh (); true)
+
+ method set_model md =
+ model <- Some md;
+ let changed_cb = function
+ | `INSERT | `REMOVE ->
+ if self#misc#visible then need_refresh <- true
+ | `SET (i, color) ->
+ if self#misc#visible then self#fill_range color i (i + 1)
+ in
+ md#changed changed_cb
- method private fill_range color i j =
+ method private fill_range color i j = match model with
+ | None -> ()
+ | Some md ->
let i = i2f i in
let j = i2f j in
let width = i2f width in
- let len = i2f (Segment.length data) in
+ let len = i2f md#length in
let x = f2i ((i *. width) /. len) in
let x' = f2i ((j *. width) /. len) in
let w = x' - x in
@@ -143,14 +118,6 @@ object (self)
pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true ();
draw#set_mask None;
- method add i color =
- data <- Segment.add i color data;
- if self#misc#visible then self#fill_range color i (i + 1)
-
- method remove i =
- data <- Segment.remove i data;
- if self#misc#visible then self#fill_range default i (i + 1)
-
method set_default_color color = default <- color
method default_color = default
@@ -159,11 +126,24 @@ object (self)
draw#set_pixmap pixmap;
self#refresh ();
- method private refresh () =
+ method private refresh () = match model with
+ | None -> ()
+ | Some md ->
+ need_refresh <- false;
pixmap#set_foreground default;
pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
- let fold i j v () = self#fill_range v i (j + 1) in
- Segment.fold color_eq fold data ();
+ let make (k, cur, accu) v = match cur with
+ | None -> pred k, Some (k, k, v), accu
+ | Some (i, j, w) ->
+ if k = j - 1 && color_eq v w then pred k, Some (k, i, w), accu
+ else pred k, Some (k, k, v), (i, j, w) :: accu
+ in
+ let _, p, segments = md#fold make (md#length - 1, None, []) in
+ let segments = match p with
+ | None -> segments
+ | Some p -> p :: segments
+ in
+ List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments;
draw#set_mask None;
method connect =
diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli
index 0fc8ebd7..29cbbeda 100644
--- a/ide/wg_Segment.mli
+++ b/ide/wg_Segment.mli
@@ -8,6 +8,8 @@
type color = GDraw.color
+type model_event = [ `INSERT | `REMOVE | `SET of int * color ]
+
class type segment_signals =
object
inherit GObj.misc_signals
@@ -15,15 +17,19 @@ object
method clicked : callback:(int -> unit) -> GtkSignal.id
end
+class type model =
+object
+ method changed : callback:(model_event -> unit) -> unit
+ method length : int
+ method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a
+end
+
class segment : unit ->
object
inherit GObj.widget
val obj : Gtk.widget Gtk.obj
+ method set_model : model -> unit
method connect : segment_signals
- method length : int
- method set_length : int -> unit
method default_color : color
method set_default_color : color -> unit
- method add : int -> color -> unit
- method remove : int -> unit
end
diff --git a/ide/xml_lexer.mli b/ide/xml_lexer.mli
new file mode 100644
index 00000000..e61cb055
--- /dev/null
+++ b/ide/xml_lexer.mli
@@ -0,0 +1,44 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+type error =
+ | EUnterminatedComment
+ | EUnterminatedString
+ | EIdentExpected
+ | ECloseExpected
+ | ENodeExpected
+ | EAttributeNameExpected
+ | EAttributeValueExpected
+ | EUnterminatedEntity
+
+exception Error of error
+
+type token =
+ | Tag of string * (string * string) list * bool
+ | PCData of string
+ | Endtag of string
+ | Eof
+
+type pos = int * int * int * int
+
+val init : Lexing.lexbuf -> unit
+val close : unit -> unit
+val token : Lexing.lexbuf -> token
+val pos : Lexing.lexbuf -> pos
+val restore : pos -> unit
diff --git a/ide/xml_lexer.mll b/ide/xml_lexer.mll
new file mode 100644
index 00000000..290f2c89
--- /dev/null
+++ b/ide/xml_lexer.mll
@@ -0,0 +1,317 @@
+{(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+open Lexing
+
+type error =
+ | EUnterminatedComment
+ | EUnterminatedString
+ | EIdentExpected
+ | ECloseExpected
+ | ENodeExpected
+ | EAttributeNameExpected
+ | EAttributeValueExpected
+ | EUnterminatedEntity
+
+exception Error of error
+
+type pos = int * int * int * int
+
+type token =
+ | Tag of string * (string * string) list * bool
+ | PCData of string
+ | Endtag of string
+ | Eof
+
+let last_pos = ref 0
+and current_line = ref 0
+and current_line_start = ref 0
+
+let tmp = Buffer.create 200
+
+let idents = Hashtbl.create 0
+
+let _ = begin
+ Hashtbl.add idents "nbsp;" " ";
+ Hashtbl.add idents "gt;" ">";
+ Hashtbl.add idents "lt;" "<";
+ Hashtbl.add idents "amp;" "&";
+ Hashtbl.add idents "apos;" "'";
+ Hashtbl.add idents "quot;" "\"";
+end
+
+let init lexbuf =
+ current_line := 1;
+ current_line_start := lexeme_start lexbuf;
+ last_pos := !current_line_start
+
+let close lexbuf =
+ Buffer.reset tmp
+
+let pos lexbuf =
+ !current_line , !current_line_start ,
+ !last_pos ,
+ lexeme_start lexbuf
+
+let restore (cl,cls,lp,_) =
+ current_line := cl;
+ current_line_start := cls;
+ last_pos := lp
+
+let newline lexbuf =
+ incr current_line;
+ last_pos := lexeme_end lexbuf;
+ current_line_start := !last_pos
+
+let error lexbuf e =
+ last_pos := lexeme_start lexbuf;
+ raise (Error e)
+
+}
+
+let newline = ['\n']
+let break = ['\r']
+let space = [' ' '\t']
+let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-' '.']
+let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar*
+let entitychar = ['A'-'Z' 'a'-'z']
+let pcchar = [^ '\r' '\n' '<' '>' '&']
+
+rule token = parse
+ | newline | (newline break) | break
+ {
+ newline lexbuf;
+ PCData "\n"
+ }
+ | "<!--"
+ {
+ last_pos := lexeme_start lexbuf;
+ comment lexbuf;
+ token lexbuf
+ }
+ | "<?"
+ {
+ last_pos := lexeme_start lexbuf;
+ header lexbuf;
+ token lexbuf;
+ }
+ | '<' space* '/' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ close_tag lexbuf;
+ Endtag tag
+ }
+ | '<' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ let attribs, closed = attributes lexbuf in
+ Tag(tag, attribs, closed)
+ }
+ | "&#"
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | '&'
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (entity lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | pcchar+
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | eof { Eof }
+ | _
+ { error lexbuf ENodeExpected }
+
+and ignore_spaces = parse
+ | newline | (newline break) | break
+ {
+ newline lexbuf;
+ ignore_spaces lexbuf
+ }
+ | space +
+ { ignore_spaces lexbuf }
+ | ""
+ { () }
+
+and comment = parse
+ | newline | (newline break) | break
+ {
+ newline lexbuf;
+ comment lexbuf
+ }
+ | "-->"
+ { () }
+ | eof
+ { raise (Error EUnterminatedComment) }
+ | _
+ { comment lexbuf }
+
+and header = parse
+ | newline | (newline break) | break
+ {
+ newline lexbuf;
+ header lexbuf
+ }
+ | "?>"
+ { () }
+ | eof
+ { error lexbuf ECloseExpected }
+ | _
+ { header lexbuf }
+
+and pcdata = parse
+ | newline | (newline break) | break
+ {
+ Buffer.add_char tmp '\n';
+ newline lexbuf;
+ pcdata lexbuf
+ }
+ | pcchar+
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf
+ }
+ | "&#"
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf;
+ }
+ | '&'
+ {
+ Buffer.add_string tmp (entity lexbuf);
+ pcdata lexbuf
+ }
+ | ""
+ { Buffer.contents tmp }
+
+and entity = parse
+ | entitychar+ ';'
+ {
+ let ident = lexeme lexbuf in
+ try
+ Hashtbl.find idents (String.lowercase ident)
+ with
+ Not_found -> "&" ^ ident
+ }
+ | _ | eof
+ { raise (Error EUnterminatedEntity) }
+
+and ident_name = parse
+ | ident
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EIdentExpected }
+
+and close_tag = parse
+ | '>'
+ { () }
+ | _ | eof
+ { error lexbuf ECloseExpected }
+
+and attributes = parse
+ | '>'
+ { [], false }
+ | "/>"
+ { [], true }
+ | "" (* do not read a char ! *)
+ {
+ let key = attribute lexbuf in
+ let data = attribute_data lexbuf in
+ ignore_spaces lexbuf;
+ let others, closed = attributes lexbuf in
+ (key, data) :: others, closed
+ }
+
+and attribute = parse
+ | ident
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EAttributeNameExpected }
+
+and attribute_data = parse
+ | space* '=' space* '"'
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ dq_string lexbuf
+ }
+ | space* '=' space* '\''
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ q_string lexbuf
+ }
+ | _ | eof
+ { error lexbuf EAttributeValueExpected }
+
+and dq_string = parse
+ | '"'
+ { Buffer.contents tmp }
+ | '\\' [ '"' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ dq_string lexbuf
+ }
+ | '&'
+ {
+ Buffer.add_string tmp (entity lexbuf);
+ dq_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ dq_string lexbuf
+ }
+
+and q_string = parse
+ | '\''
+ { Buffer.contents tmp }
+ | '\\' [ '\'' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ q_string lexbuf
+ }
+ | '&'
+ {
+ Buffer.add_string tmp (entity lexbuf);
+ q_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ q_string lexbuf
+ }
diff --git a/ide/xml_parser.ml b/ide/xml_parser.ml
new file mode 100644
index 00000000..8db3f9e8
--- /dev/null
+++ b/ide/xml_parser.ml
@@ -0,0 +1,232 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ * Copyright (C) 2003 Jacques Garrigue
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+open Printf
+open Xml_datatype
+
+type xml = Xml_datatype.xml
+
+type error_pos = {
+ eline : int;
+ eline_start : int;
+ emin : int;
+ emax : int;
+}
+
+type error_msg =
+ | UnterminatedComment
+ | UnterminatedString
+ | UnterminatedEntity
+ | IdentExpected
+ | CloseExpected
+ | NodeExpected
+ | AttributeNameExpected
+ | AttributeValueExpected
+ | EndOfTagExpected of string
+ | EOFExpected
+ | Empty
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+type t = {
+ mutable check_eof : bool;
+ mutable concat_pcdata : bool;
+ source : Lexing.lexbuf;
+ stack : Xml_lexer.token Stack.t;
+}
+
+type source =
+ | SChannel of in_channel
+ | SString of string
+ | SLexbuf of Lexing.lexbuf
+
+exception Internal_error of error_msg
+exception NoMoreData
+
+let xml_error = ref (fun _ -> assert false)
+let file_not_found = ref (fun _ -> assert false)
+
+let is_blank s =
+ let len = String.length s in
+ let break = ref true in
+ let i = ref 0 in
+ while !break && !i < len do
+ let c = s.[!i] in
+ (* no '\r' because we replaced them in the lexer *)
+ if c = ' ' || c = '\n' || c = '\t' then incr i
+ else break := false
+ done;
+ !i = len
+
+let _raises e f =
+ xml_error := e;
+ file_not_found := f
+
+let make source =
+ let source = match source with
+ | SChannel chan -> Lexing.from_channel chan
+ | SString s -> Lexing.from_string s
+ | SLexbuf lexbuf -> lexbuf
+ in
+ let () = Xml_lexer.init source in
+ {
+ check_eof = false;
+ concat_pcdata = true;
+ source = source;
+ stack = Stack.create ();
+ }
+
+let check_eof p v = p.check_eof <- v
+
+let pop s =
+ try
+ Stack.pop s.stack
+ with
+ Stack.Empty ->
+ Xml_lexer.token s.source
+
+let push t s =
+ Stack.push t s.stack
+
+let canonicalize l =
+ let has_elt = List.exists (function Element _ -> true | _ -> false) l in
+ if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l
+ else l
+
+let rec read_xml do_not_canonicalize s =
+ let rec read_node s =
+ match pop s with
+ | Xml_lexer.PCData s -> PCData s
+ | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+ | Xml_lexer.Tag (tag, attr, false) ->
+ let elements = read_elems tag s in
+ let elements =
+ if do_not_canonicalize then elements else canonicalize elements
+ in
+ Element (tag, attr, elements)
+ | t ->
+ push t s;
+ raise NoMoreData
+
+ and read_elems tag s =
+ let elems = ref [] in
+ (try
+ while true do
+ let node = read_node s in
+ match node, !elems with
+ | PCData c , (PCData c2) :: q ->
+ elems := PCData (c2 ^ c) :: q
+ | _, l ->
+ elems := node :: l
+ done
+ with
+ NoMoreData -> ());
+ match pop s with
+ | Xml_lexer.Endtag s when s = tag -> List.rev !elems
+ | t -> raise (Internal_error (EndOfTagExpected tag))
+ in
+ match read_node s with
+ | (Element _) as node ->
+ node
+ | PCData c ->
+ if is_blank c then
+ read_xml do_not_canonicalize s
+ else
+ raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+
+let convert = function
+ | Xml_lexer.EUnterminatedComment -> UnterminatedComment
+ | Xml_lexer.EUnterminatedString -> UnterminatedString
+ | Xml_lexer.EIdentExpected -> IdentExpected
+ | Xml_lexer.ECloseExpected -> CloseExpected
+ | Xml_lexer.ENodeExpected -> NodeExpected
+ | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+ | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+ | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity
+
+let error_of_exn xparser = function
+ | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty
+ | NoMoreData -> NodeExpected
+ | Internal_error e -> e
+ | Xml_lexer.Error e -> convert e
+ | e ->
+ (*let e = Errors.push e in: We do not record backtrace here. *)
+ raise e
+
+let do_parse do_not_canonicalize xparser =
+ try
+ Xml_lexer.init xparser.source;
+ let x = read_xml do_not_canonicalize xparser in
+ if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+ Xml_lexer.close ();
+ x
+ with any ->
+ Xml_lexer.close ();
+ raise (!xml_error (error_of_exn xparser any) xparser.source)
+
+let parse ?(do_not_canonicalize=false) p =
+ do_parse do_not_canonicalize p
+
+let error_msg = function
+ | UnterminatedComment -> "Unterminated comment"
+ | UnterminatedString -> "Unterminated string"
+ | UnterminatedEntity -> "Unterminated entity"
+ | IdentExpected -> "Ident expected"
+ | CloseExpected -> "Element close expected"
+ | NodeExpected -> "Xml node expected"
+ | AttributeNameExpected -> "Attribute name expected"
+ | AttributeValueExpected -> "Attribute value expected"
+ | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+ | EOFExpected -> "End of file expected"
+ | Empty -> "Empty"
+
+let error (msg,pos) =
+ if pos.emin = pos.emax then
+ sprintf "%s line %d character %d" (error_msg msg) pos.eline
+ (pos.emin - pos.eline_start)
+ else
+ sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline
+ (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
+let line e = e.eline
+
+let range e =
+ e.emin - e.eline_start , e.emax - e.eline_start
+
+let abs_range e =
+ e.emin , e.emax
+
+let pos source =
+ let line, lstart, min, max = Xml_lexer.pos source in
+ {
+ eline = line;
+ eline_start = lstart;
+ emin = min;
+ emax = max;
+ }
+
+let () = _raises (fun x p ->
+ (* local cast : Xml.error_msg -> error_msg *)
+ Error (x, pos p))
+ (fun f -> File_not_found f)
diff --git a/ide/xml_parser.mli b/ide/xml_parser.mli
new file mode 100644
index 00000000..ac2eab35
--- /dev/null
+++ b/ide/xml_parser.mli
@@ -0,0 +1,106 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+(** Xml Light Parser
+
+ While basic parsing functions can be used in the {!Xml} module, this module
+ is providing a way to create, configure and run an Xml parser.
+
+*)
+
+
+(** An Xml node is either
+ [Element (tag-name, attributes, children)] or [PCData text] *)
+type xml = Xml_datatype.xml
+
+(** Abstract type for an Xml parser. *)
+type t
+
+(** {6:exc Xml Exceptions} *)
+
+(** Several exceptions can be raised when parsing an Xml document : {ul
+ {li {!Xml.Error} is raised when an xml parsing error occurs. the
+ {!Xml.error_msg} tells you which error occurred during parsing
+ and the {!Xml.error_pos} can be used to retrieve the document
+ location where the error occurred at.}
+ {li {!Xml.File_not_found} is raised when an error occurred while
+ opening a file with the {!Xml.parse_file} function.}
+ }
+ *)
+
+type error_pos
+
+type error_msg =
+ | UnterminatedComment
+ | UnterminatedString
+ | UnterminatedEntity
+ | IdentExpected
+ | CloseExpected
+ | NodeExpected
+ | AttributeNameExpected
+ | AttributeValueExpected
+ | EndOfTagExpected of string
+ | EOFExpected
+ | Empty
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+(** Get a full error message from an Xml error. *)
+val error : error -> string
+
+(** Get the Xml error message as a string. *)
+val error_msg : error_msg -> string
+
+(** Get the line the error occurred at. *)
+val line : error_pos -> int
+
+(** Get the relative character range (in current line) the error occurred at.*)
+val range : error_pos -> int * int
+
+(** Get the absolute character range the error occurred at. *)
+val abs_range : error_pos -> int * int
+
+val pos : Lexing.lexbuf -> error_pos
+
+(** Several kind of resources can contain Xml documents. *)
+type source =
+| SChannel of in_channel
+| SString of string
+| SLexbuf of Lexing.lexbuf
+
+(** This function returns a new parser with default options. *)
+val make : source -> t
+
+(** When a Xml document is parsed, the parser may check that the end of the
+ document is reached, so for example parsing ["<A/><B/>"] will fail instead
+ of returning only the A element. You can turn on this check by setting
+ [check_eof] to [true] {i (by default, check_eof is false, unlike
+ in the original Xmllight)}. *)
+val check_eof : t -> bool -> unit
+
+(** Once the parser is configured, you can run the parser on a any kind
+ of xml document source to parse its contents into an Xml data structure.
+
+ When [do_not_canonicalize] is set, the XML document is given as
+ is, without trying to remove blank PCDATA elements. *)
+val parse : ?do_not_canonicalize:bool -> t -> xml
diff --git a/ide/xml_printer.ml b/ide/xml_printer.ml
new file mode 100644
index 00000000..40ab4ce9
--- /dev/null
+++ b/ide/xml_printer.ml
@@ -0,0 +1,145 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Xml_datatype
+
+type xml = Xml_datatype.xml
+
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+type t = target
+
+let make x = x
+
+let buffer_pcdata tmp text =
+ let puts = Buffer.add_string tmp in
+ let putc = Buffer.add_char tmp in
+ let l = String.length text in
+ for p = 0 to l-1 do
+ match text.[p] with
+ | ' ' -> puts "&nbsp;";
+ | '>' -> puts "&gt;"
+ | '<' -> puts "&lt;"
+ | '&' ->
+ if p < l - 1 && text.[p + 1] = '#' then
+ putc '&'
+ else
+ puts "&amp;"
+ | '\'' -> puts "&apos;"
+ | '"' -> puts "&quot;"
+ | c -> putc c
+ done
+
+let buffer_attr tmp (n,v) =
+ let puts = Buffer.add_string tmp in
+ let putc = Buffer.add_char tmp in
+ putc ' ';
+ puts n;
+ puts "=\"";
+ let l = String.length v in
+ for p = 0 to l - 1 do
+ match v.[p] with
+ | '\\' -> puts "\\\\"
+ | '"' -> puts "\\\""
+ | '<' -> puts "&lt;"
+ | '&' -> puts "&amp;"
+ | c -> putc c
+ done;
+ putc '"'
+
+let to_buffer tmp x =
+ let pcdata = ref false in
+ let puts = Buffer.add_string tmp in
+ let putc = Buffer.add_char tmp in
+ let rec loop = function
+ | Element (tag,alist,[]) ->
+ putc '<';
+ puts tag;
+ List.iter (buffer_attr tmp) alist;
+ puts "/>";
+ pcdata := false;
+ | Element (tag,alist,l) ->
+ putc '<';
+ puts tag;
+ List.iter (buffer_attr tmp) alist;
+ putc '>';
+ pcdata := false;
+ List.iter loop l;
+ puts "</";
+ puts tag;
+ putc '>';
+ pcdata := false;
+ | PCData text ->
+ if !pcdata then putc ' ';
+ buffer_pcdata tmp text;
+ pcdata := true;
+ in
+ loop x
+
+let pcdata_to_string s =
+ let b = Buffer.create 13 in
+ buffer_pcdata b s;
+ Buffer.contents b
+
+let to_string x =
+ let b = Buffer.create 200 in
+ to_buffer b x;
+ Buffer.contents b
+
+let to_string_fmt x =
+ let tmp = Buffer.create 200 in
+ let puts = Buffer.add_string tmp in
+ let putc = Buffer.add_char tmp in
+ let rec loop ?(newl=false) tab = function
+ | Element (tag, alist, []) ->
+ puts tab;
+ putc '<';
+ puts tag;
+ List.iter (buffer_attr tmp) alist;
+ puts "/>";
+ if newl then putc '\n';
+ | Element (tag, alist, [PCData text]) ->
+ puts tab;
+ putc '<';
+ puts tag;
+ List.iter (buffer_attr tmp) alist;
+ puts ">";
+ buffer_pcdata tmp text;
+ puts "</";
+ puts tag;
+ putc '>';
+ if newl then putc '\n';
+ | Element (tag, alist, l) ->
+ puts tab;
+ putc '<';
+ puts tag;
+ List.iter (buffer_attr tmp) alist;
+ puts ">\n";
+ List.iter (loop ~newl:true (tab^" ")) l;
+ puts tab;
+ puts "</";
+ puts tag;
+ putc '>';
+ if newl then putc '\n';
+ | PCData text ->
+ buffer_pcdata tmp text;
+ if newl then putc '\n';
+ in
+ loop "" x;
+ Buffer.contents tmp
+
+let print t xml =
+ let tmp, flush = match t with
+ | TChannel oc ->
+ let b = Buffer.create 200 in
+ b, (fun () -> Buffer.output_buffer oc b; flush oc)
+ | TBuffer b ->
+ b, (fun () -> ())
+ in
+ to_buffer tmp xml;
+ flush ()
diff --git a/ide/xml_printer.mli b/ide/xml_printer.mli
new file mode 100644
index 00000000..f24f51ff
--- /dev/null
+++ b/ide/xml_printer.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+type xml = Xml_datatype.xml
+
+type t
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+val make : target -> t
+
+(** Print the xml data structure to a source into a compact xml string (without
+ any user-readable formating ). *)
+val print : t -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
+
+(** Print PCDATA as a string by escaping XML entities. *)
+val pcdata_to_string : string -> string
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 88bd2c17..aecb317b 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -10,7 +10,7 @@
(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
-let protocol_version = "20140312"
+let protocol_version = "20150913"
(** * Interface of calls to Coq by CoqIde *)
@@ -39,7 +39,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with
| "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
| "in_module" -> In_Module (to_list to_string (singleton args))
| "include_blacklist" -> Include_Blacklist
- | _ -> raise Marshal_error)
+ | x -> raise (Marshal_error("search",PCData x)))
let of_coq_object f ans =
let prefix = of_list of_string ans.coq_object_prefix in
@@ -56,7 +56,7 @@ let to_coq_object f = function
coq_object_qualid = qualid;
coq_object_object = obj;
}
-| _ -> raise Marshal_error
+| x -> raise (Marshal_error("coq_object",x))
let of_option_value = function
| IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
@@ -68,7 +68,7 @@ let to_option_value = do_match "option_value" (fun s args -> match s with
| "boolvalue" -> BoolValue (to_bool (singleton args))
| "stringvalue" -> StringValue (to_string (singleton args))
| "stringoptvalue" -> StringOptValue (to_option to_string (singleton args))
- | _ -> raise Marshal_error)
+ | x -> raise (Marshal_error("*value",PCData x)))
let of_option_state s =
Element ("option_state", [], [
@@ -82,8 +82,20 @@ let to_option_state = function
opt_depr = to_bool depr;
opt_name = to_string name;
opt_value = to_option_value value }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("option_state",x))
+let to_stateid = function
+ | Element ("state_id",["val",i],[]) ->
+ let id = int_of_string i in
+ Stateid.of_int id
+ | _ -> raise (Invalid_argument "to_state_id")
+
+let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[])
+
+let of_richpp x = Element ("richpp", [], [Richpp.repr x])
+let to_richpp xml = match xml with
+ | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x
+ | x -> raise Serialize.(Marshal_error("richpp",x))
let of_value f = function
| Good x -> Element ("value", ["val", "good"], [f x])
@@ -91,8 +103,9 @@ let of_value f = function
let loc = match loc with
| None -> []
| Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
- let id = Stateid.to_xml id in
- Element ("value", ["val", "fail"] @ loc, [id;PCData msg])
+ let id = of_stateid id in
+ Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg])
+
let to_value f = function
| Element ("value", attrs, l) ->
let ans = massoc "val" attrs in
@@ -103,13 +116,14 @@ let to_value f = function
let loc_s = int_of_string (Serialize.massoc "loc_s" attrs) in
let loc_e = int_of_string (Serialize.massoc "loc_e" attrs) in
Some (loc_s, loc_e)
- with Marshal_error | Failure _ -> None
+ with Marshal_error _ | Failure _ -> None
in
- let id = Stateid.of_xml (List.hd l) in
- let msg = raw_string (List.tl l) in
+ let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in
+ let id = to_stateid id in
+ let msg = to_richpp msg in
Fail (id, loc, msg)
- else raise Marshal_error
-| _ -> raise Marshal_error
+ else raise (Marshal_error("good or fail",PCData ans))
+| x -> raise (Marshal_error("value",x))
let of_status s =
let of_so = of_option of_string in
@@ -125,25 +139,25 @@ let to_status = function
status_proofname = to_option to_string name;
status_allproofs = to_list to_string prfs;
status_proofnum = to_int pnum; }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("status",x))
let of_evar s = Element ("evar", [], [PCData s.evar_info])
let to_evar = function
| Element ("evar", [], data) -> { evar_info = raw_string data; }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("evar",x))
let of_goal g =
- let hyp = of_list of_string g.goal_hyp in
- let ccl = of_string g.goal_ccl in
+ let hyp = of_list of_richpp g.goal_hyp in
+ let ccl = of_richpp g.goal_ccl in
let id = of_string g.goal_id in
Element ("goal", [], [id; hyp; ccl])
let to_goal = function
| Element ("goal", [], [id; hyp; ccl]) ->
- let hyp = to_list to_string hyp in
- let ccl = to_string ccl in
+ let hyp = to_list to_richpp hyp in
+ let ccl = to_richpp ccl in
let id = to_string id in
{ goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("goal",x))
let of_goals g =
let of_glist = of_list of_goal in
@@ -161,7 +175,7 @@ let to_goals = function
let given_up = to_list to_goal given_up in
{ fg_goals = fg; bg_goals = bg; shelved_goals = shelf;
given_up_goals = given_up }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("goals",x))
let of_coq_info info =
let version = of_string info.coqtop_version in
@@ -175,7 +189,7 @@ let to_coq_info = function
protocol_version = to_string protocol;
release_date = to_string release;
compile_date = to_string compile; }
- | _ -> raise Marshal_error
+ | x -> raise (Marshal_error("coq_info",x))
end
include Xml_marshalling
@@ -220,22 +234,31 @@ module ReifType : sig
end = struct
- type value_type =
- | Unit | String | Int | Bool | Xml
+ type _ val_t =
+ | Unit : unit val_t
+ | String : string val_t
+ | Int : int val_t
+ | Bool : bool val_t
+ | Xml : Xml_datatype.xml val_t
- | Option of value_type
- | List of value_type
- | Pair of value_type * value_type
- | Union of value_type * value_type
+ | Option : 'a val_t -> 'a option val_t
+ | List : 'a val_t -> 'a list val_t
+ | Pair : 'a val_t * 'b val_t -> ('a * 'b) val_t
+ | Union : 'a val_t * 'b val_t -> ('a, 'b) union val_t
- | Goals | Evar | State | Option_state | Option_value | Coq_info
- | Coq_object of value_type
- | State_id
- | Search_cst
+ | Goals : goals val_t
+ | Evar : evar val_t
+ | State : status val_t
+ | Option_state : option_state val_t
+ | Option_value : option_value val_t
+ | Coq_info : coq_info val_t
+ | Coq_object : 'a val_t -> 'a coq_object val_t
+ | State_id : state_id val_t
+ | Search_cst : search_constraint val_t
- type 'a val_t = value_type
+ type value_type = Value_type : 'a val_t -> value_type
- let erase (x : 'a val_t) : value_type = x
+ let erase (x : 'a val_t) = Value_type x
let unit_t = Unit
let string_t = String
@@ -259,48 +282,48 @@ end = struct
let search_cst_t = Search_cst
let of_value_type (ty : 'a val_t) : 'a -> xml =
- let rec convert ty : 'a -> xml = match ty with
- | Unit -> Obj.magic of_unit
- | Bool -> Obj.magic of_bool
- | Xml -> Obj.magic (fun x -> x)
- | String -> Obj.magic of_string
- | Int -> Obj.magic of_int
- | State -> Obj.magic of_status
- | Option_state -> Obj.magic of_option_state
- | Option_value -> Obj.magic of_option_value
- | Coq_info -> Obj.magic of_coq_info
- | Goals -> Obj.magic of_goals
- | Evar -> Obj.magic of_evar
- | List t -> Obj.magic (of_list (convert t))
- | Option t -> Obj.magic (of_option (convert t))
- | Coq_object t -> Obj.magic (of_coq_object (convert t))
- | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2))
- | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
- | State_id -> Obj.magic Stateid.to_xml
- | Search_cst -> Obj.magic of_search_cst
+ let rec convert : type a. a val_t -> a -> xml = function
+ | Unit -> of_unit
+ | Bool -> of_bool
+ | Xml -> (fun x -> x)
+ | String -> of_string
+ | Int -> of_int
+ | State -> of_status
+ | Option_state -> of_option_state
+ | Option_value -> of_option_value
+ | Coq_info -> of_coq_info
+ | Goals -> of_goals
+ | Evar -> of_evar
+ | List t -> (of_list (convert t))
+ | Option t -> (of_option (convert t))
+ | Coq_object t -> (of_coq_object (convert t))
+ | Pair (t1,t2) -> (of_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> (of_union (convert t1) (convert t2))
+ | State_id -> of_stateid
+ | Search_cst -> of_search_cst
in
convert ty
let to_value_type (ty : 'a val_t) : xml -> 'a =
- let rec convert ty : xml -> 'a = match ty with
- | Unit -> Obj.magic to_unit
- | Bool -> Obj.magic to_bool
- | Xml -> Obj.magic (fun x -> x)
- | String -> Obj.magic to_string
- | Int -> Obj.magic to_int
- | State -> Obj.magic to_status
- | Option_state -> Obj.magic to_option_state
- | Option_value -> Obj.magic to_option_value
- | Coq_info -> Obj.magic to_coq_info
- | Goals -> Obj.magic to_goals
- | Evar -> Obj.magic to_evar
- | List t -> Obj.magic (to_list (convert t))
- | Option t -> Obj.magic (to_option (convert t))
- | Coq_object t -> Obj.magic (to_coq_object (convert t))
- | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2))
- | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
- | State_id -> Obj.magic Stateid.of_xml
- | Search_cst -> Obj.magic to_search_cst
+ let rec convert : type a. a val_t -> xml -> a = function
+ | Unit -> to_unit
+ | Bool -> to_bool
+ | Xml -> (fun x -> x)
+ | String -> to_string
+ | Int -> to_int
+ | State -> to_status
+ | Option_state -> to_option_state
+ | Option_value -> to_option_value
+ | Coq_info -> to_coq_info
+ | Goals -> to_goals
+ | Evar -> to_evar
+ | List t -> (to_list (convert t))
+ | Option t -> (to_option (convert t))
+ | Coq_object t -> (to_coq_object (convert t))
+ | Pair (t1,t2) -> (to_pair (convert t1) (convert t2))
+ | Union (t1,t2) -> (to_union (convert t1) (convert t2))
+ | State_id -> to_stateid
+ | Search_cst -> to_search_cst
in
convert ty
@@ -320,10 +343,9 @@ end = struct
(List.length lg + List.length rg) pr_focus l in
Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
else
- let pr_menu s = s in
let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
- "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
- pr_menu goal ^ "]" in
+ "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^
+ Richpp.raw_print goal ^ "]" in
String.concat " " (List.map pr_goal g.fg_goals)
let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
let pr_status (s : status) =
@@ -350,6 +372,7 @@ end = struct
let pr_coq_object (o : 'a coq_object) = "FIXME"
let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x
+ let pr_state_id = Stateid.to_string
let pr_search_cst = function
| Name_Pattern s -> "Name_Pattern " ^ s
@@ -358,30 +381,30 @@ end = struct
| In_Module s -> "In_Module " ^ String.concat "." s
| Include_Blacklist -> "Include_Blacklist"
- let rec print = function
- | Unit -> Obj.magic pr_unit
- | Bool -> Obj.magic pr_bool
- | String -> Obj.magic pr_string
- | Xml -> Obj.magic Xml_printer.to_string_fmt
- | Int -> Obj.magic pr_int
- | State -> Obj.magic pr_status
- | Option_state -> Obj.magic pr_option_state
- | Option_value -> Obj.magic pr_option_value
- | Search_cst -> Obj.magic pr_search_cst
- | Coq_info -> Obj.magic pr_coq_info
- | Goals -> Obj.magic pr_goal
- | Evar -> Obj.magic pr_evar
- | List t -> Obj.magic (pr_list (print t))
- | Option t -> Obj.magic (pr_option (print t))
- | Coq_object t -> Obj.magic pr_coq_object
- | Pair (t1,t2) -> Obj.magic (pr_pair (print t1) (print t2))
- | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2))
- | State_id -> Obj.magic pr_int
+ let rec print : type a. a val_t -> a -> string = function
+ | Unit -> pr_unit
+ | Bool -> pr_bool
+ | String -> pr_string
+ | Xml -> Xml_printer.to_string_fmt
+ | Int -> pr_int
+ | State -> pr_status
+ | Option_state -> pr_option_state
+ | Option_value -> pr_option_value
+ | Search_cst -> pr_search_cst
+ | Coq_info -> pr_coq_info
+ | Goals -> pr_goal
+ | Evar -> pr_evar
+ | List t -> (pr_list (print t))
+ | Option t -> (pr_option (print t))
+ | Coq_object t -> pr_coq_object
+ | Pair (t1,t2) -> (pr_pair (print t1) (print t2))
+ | Union (t1,t2) -> (pr_union (print t1) (print t2))
+ | State_id -> pr_state_id
(* This is to break if a rename/refactoring makes the strings below outdated *)
type 'a exists = bool
- let rec print_type = function
+ let rec print_val_t : type a. a val_t -> string = function
| Unit -> "unit"
| Bool -> "bool"
| String -> "string"
@@ -394,33 +417,35 @@ end = struct
| Coq_info -> assert(true : coq_info exists); "Interface.coq_info"
| Goals -> assert(true : goals exists); "Interface.goals"
| Evar -> assert(true : evar exists); "Interface.evar"
- | List t -> Printf.sprintf "(%s list)" (print_type t)
- | Option t -> Printf.sprintf "(%s option)" (print_type t)
+ | List t -> Printf.sprintf "(%s list)" (print_val_t t)
+ | Option t -> Printf.sprintf "(%s option)" (print_val_t t)
| Coq_object t -> assert(true : 'a coq_object exists);
- Printf.sprintf "(%s Interface.coq_object)" (print_type t)
- | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2)
+ Printf.sprintf "(%s Interface.coq_object)" (print_val_t t)
+ | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_val_t t1) (print_val_t t2)
| Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
- Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+ Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2)
| State_id -> assert(true : Stateid.t exists); "Stateid.t"
+ let print_type = function Value_type ty -> print_val_t ty
+
let document_type_encoding pr_xml =
Printf.printf "\n=== Data encoding by examples ===\n\n";
- Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ()));
- Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool)
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Unit) (pr_xml (of_unit ()));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t Bool)
(pr_xml (of_bool true)) (pr_xml (of_bool false));
- Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello"));
- Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256));
- Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial));
- Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5]));
- Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello"));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (of_stateid Stateid.initial));
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5]));
+ Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (Option Int))
(pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None));
- Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int)))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (Pair (Bool,Int)))
(pr_xml (of_pair of_bool of_int (false,3)));
- Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int)))
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t (Union (Bool,Int)))
(pr_xml (of_union of_bool of_int (Inl false)));
print_endline ("All other types are records represented by a node named like the OCaml\n"^
"type which contains a flattened n-tuple. We provide one example.\n");
- Printf.printf "%s:\n\n%s\n\n" (print_type Option_state)
+ Printf.printf "%s:\n\n%s\n\n" (print_val_t Option_state)
(pr_xml (of_option_state { opt_sync = true; opt_depr = false;
opt_name = "name1"; opt_value = IntValue (Some 37) }));
@@ -496,27 +521,27 @@ let calls = [|
|]
type 'a call =
- | Add of add_sty
- | Edit_at of edit_at_sty
- | Query of query_sty
- | Goal of goals_sty
- | Evars of evars_sty
- | Hints of hints_sty
- | Status of status_sty
- | Search of search_sty
- | GetOptions of get_options_sty
- | SetOptions of set_options_sty
- | MkCases of mkcases_sty
- | Quit of quit_sty
- | About of about_sty
- | Init of init_sty
- | StopWorker of stop_worker_sty
+ | Add : add_sty -> add_rty call
+ | Edit_at : edit_at_sty -> edit_at_rty call
+ | Query : query_sty -> query_rty call
+ | Goal : goals_sty -> goals_rty call
+ | Evars : evars_sty -> evars_rty call
+ | Hints : hints_sty -> hints_rty call
+ | Status : status_sty -> status_rty call
+ | Search : search_sty -> search_rty call
+ | GetOptions : get_options_sty -> get_options_rty call
+ | SetOptions : set_options_sty -> set_options_rty call
+ | MkCases : mkcases_sty -> mkcases_rty call
+ | Quit : quit_sty -> quit_rty call
+ | About : about_sty -> about_rty call
+ | Init : init_sty -> init_rty call
+ | StopWorker : stop_worker_sty -> stop_worker_rty call
(* retrocompatibility *)
- | Interp of interp_sty
- | PrintAst of print_ast_sty
- | Annotate of annotate_sty
+ | Interp : interp_sty -> interp_rty call
+ | PrintAst : print_ast_sty -> print_ast_rty call
+ | Annotate : annotate_sty -> annotate_rty call
-let id_of_call = function
+let id_of_call : type a. a call -> int = function
| Add _ -> 0
| Edit_at _ -> 1
| Query _ -> 2
@@ -538,7 +563,7 @@ let id_of_call = function
let str_of_call c = pi1 calls.(id_of_call c)
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
(** We use phantom types and GADT to protect ourselves against wild casts *)
let add x : add_rty call = Add x
@@ -559,8 +584,8 @@ let stop_worker x : stop_worker_rty call = StopWorker x
let print_ast x : print_ast_rty call = PrintAst x
let annotate x : annotate_rty call = Annotate x
-let abstract_eval_call handler (c : 'a call) : 'a value =
- let mkGood x : 'a value = Good (Obj.magic x) in
+let abstract_eval_call : type a. _ -> a call -> a value = fun handler c ->
+ let mkGood : type a. a -> a value = fun x -> Good x in
try
match c with
| Add x -> mkGood (handler.add x)
@@ -582,51 +607,51 @@ let abstract_eval_call handler (c : 'a call) : 'a value =
| PrintAst x -> mkGood (handler.print_ast x)
| Annotate x -> mkGood (handler.annotate x)
with any ->
- let any = Errors.push any in
+ let any = CErrors.push any in
Fail (handler.handle_exn any)
(** brain dead code, edit if protocol messages are added/removed *)
-let of_answer (q : 'a call) (v : 'a value) : xml = match q with
- | Add _ -> of_value (of_value_type add_rty_t ) (Obj.magic v)
- | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) (Obj.magic v)
- | Query _ -> of_value (of_value_type query_rty_t ) (Obj.magic v)
- | Goal _ -> of_value (of_value_type goals_rty_t ) (Obj.magic v)
- | Evars _ -> of_value (of_value_type evars_rty_t ) (Obj.magic v)
- | Hints _ -> of_value (of_value_type hints_rty_t ) (Obj.magic v)
- | Status _ -> of_value (of_value_type status_rty_t ) (Obj.magic v)
- | Search _ -> of_value (of_value_type search_rty_t ) (Obj.magic v)
- | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v)
- | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v)
- | MkCases _ -> of_value (of_value_type mkcases_rty_t ) (Obj.magic v)
- | Quit _ -> of_value (of_value_type quit_rty_t ) (Obj.magic v)
- | About _ -> of_value (of_value_type about_rty_t ) (Obj.magic v)
- | Init _ -> of_value (of_value_type init_rty_t ) (Obj.magic v)
- | Interp _ -> of_value (of_value_type interp_rty_t ) (Obj.magic v)
- | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v)
- | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) (Obj.magic v)
- | Annotate _ -> of_value (of_value_type annotate_rty_t ) (Obj.magic v)
-
-let to_answer (q : 'a call) (x : xml) : 'a value = match q with
- | Add _ -> Obj.magic (to_value (to_value_type add_rty_t ) x)
- | Edit_at _ -> Obj.magic (to_value (to_value_type edit_at_rty_t ) x)
- | Query _ -> Obj.magic (to_value (to_value_type query_rty_t ) x)
- | Goal _ -> Obj.magic (to_value (to_value_type goals_rty_t ) x)
- | Evars _ -> Obj.magic (to_value (to_value_type evars_rty_t ) x)
- | Hints _ -> Obj.magic (to_value (to_value_type hints_rty_t ) x)
- | Status _ -> Obj.magic (to_value (to_value_type status_rty_t ) x)
- | Search _ -> Obj.magic (to_value (to_value_type search_rty_t ) x)
- | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x)
- | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x)
- | MkCases _ -> Obj.magic (to_value (to_value_type mkcases_rty_t ) x)
- | Quit _ -> Obj.magic (to_value (to_value_type quit_rty_t ) x)
- | About _ -> Obj.magic (to_value (to_value_type about_rty_t ) x)
- | Init _ -> Obj.magic (to_value (to_value_type init_rty_t ) x)
- | Interp _ -> Obj.magic (to_value (to_value_type interp_rty_t ) x)
- | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x)
- | PrintAst _ -> Obj.magic (to_value (to_value_type print_ast_rty_t ) x)
- | Annotate _ -> Obj.magic (to_value (to_value_type annotate_rty_t ) x)
-
-let of_call (q : 'a call) : xml =
+let of_answer : type a. a call -> a value -> xml = function
+ | Add _ -> of_value (of_value_type add_rty_t )
+ | Edit_at _ -> of_value (of_value_type edit_at_rty_t )
+ | Query _ -> of_value (of_value_type query_rty_t )
+ | Goal _ -> of_value (of_value_type goals_rty_t )
+ | Evars _ -> of_value (of_value_type evars_rty_t )
+ | Hints _ -> of_value (of_value_type hints_rty_t )
+ | Status _ -> of_value (of_value_type status_rty_t )
+ | Search _ -> of_value (of_value_type search_rty_t )
+ | GetOptions _ -> of_value (of_value_type get_options_rty_t)
+ | SetOptions _ -> of_value (of_value_type set_options_rty_t)
+ | MkCases _ -> of_value (of_value_type mkcases_rty_t )
+ | Quit _ -> of_value (of_value_type quit_rty_t )
+ | About _ -> of_value (of_value_type about_rty_t )
+ | Init _ -> of_value (of_value_type init_rty_t )
+ | Interp _ -> of_value (of_value_type interp_rty_t )
+ | StopWorker _ -> of_value (of_value_type stop_worker_rty_t)
+ | PrintAst _ -> of_value (of_value_type print_ast_rty_t )
+ | Annotate _ -> of_value (of_value_type annotate_rty_t )
+
+let to_answer : type a. a call -> xml -> a value = function
+ | Add _ -> to_value (to_value_type add_rty_t )
+ | Edit_at _ -> to_value (to_value_type edit_at_rty_t )
+ | Query _ -> to_value (to_value_type query_rty_t )
+ | Goal _ -> to_value (to_value_type goals_rty_t )
+ | Evars _ -> to_value (to_value_type evars_rty_t )
+ | Hints _ -> to_value (to_value_type hints_rty_t )
+ | Status _ -> to_value (to_value_type status_rty_t )
+ | Search _ -> to_value (to_value_type search_rty_t )
+ | GetOptions _ -> to_value (to_value_type get_options_rty_t)
+ | SetOptions _ -> to_value (to_value_type set_options_rty_t)
+ | MkCases _ -> to_value (to_value_type mkcases_rty_t )
+ | Quit _ -> to_value (to_value_type quit_rty_t )
+ | About _ -> to_value (to_value_type about_rty_t )
+ | Init _ -> to_value (to_value_type init_rty_t )
+ | Interp _ -> to_value (to_value_type interp_rty_t )
+ | StopWorker _ -> to_value (to_value_type stop_worker_rty_t)
+ | PrintAst _ -> to_value (to_value_type print_ast_rty_t )
+ | Annotate _ -> to_value (to_value_type annotate_rty_t )
+
+let of_call : type a. a call -> xml = fun q ->
let mkCall x = constructor "call" (str_of_call q) [x] in
match q with
| Add x -> mkCall (of_value_type add_sty_t x)
@@ -648,59 +673,59 @@ let of_call (q : 'a call) : xml =
| PrintAst x -> mkCall (of_value_type print_ast_sty_t x)
| Annotate x -> mkCall (of_value_type annotate_sty_t x)
-let to_call : xml -> unknown call =
+let to_call : xml -> unknown_call =
do_match "call" (fun s a ->
let mkCallArg vt a = to_value_type vt (singleton a) in
match s with
- | "Add" -> Add (mkCallArg add_sty_t a)
- | "Edit_at" -> Edit_at (mkCallArg edit_at_sty_t a)
- | "Query" -> Query (mkCallArg query_sty_t a)
- | "Goal" -> Goal (mkCallArg goals_sty_t a)
- | "Evars" -> Evars (mkCallArg evars_sty_t a)
- | "Hints" -> Hints (mkCallArg hints_sty_t a)
- | "Status" -> Status (mkCallArg status_sty_t a)
- | "Search" -> Search (mkCallArg search_sty_t a)
- | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a)
- | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a)
- | "MkCases" -> MkCases (mkCallArg mkcases_sty_t a)
- | "Quit" -> Quit (mkCallArg quit_sty_t a)
- | "About" -> About (mkCallArg about_sty_t a)
- | "Init" -> Init (mkCallArg init_sty_t a)
- | "Interp" -> Interp (mkCallArg interp_sty_t a)
- | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a)
- | "PrintAst" -> PrintAst (mkCallArg print_ast_sty_t a)
- | "Annotate" -> Annotate (mkCallArg annotate_sty_t a)
- | _ -> raise Marshal_error)
+ | "Add" -> Unknown (Add (mkCallArg add_sty_t a))
+ | "Edit_at" -> Unknown (Edit_at (mkCallArg edit_at_sty_t a))
+ | "Query" -> Unknown (Query (mkCallArg query_sty_t a))
+ | "Goal" -> Unknown (Goal (mkCallArg goals_sty_t a))
+ | "Evars" -> Unknown (Evars (mkCallArg evars_sty_t a))
+ | "Hints" -> Unknown (Hints (mkCallArg hints_sty_t a))
+ | "Status" -> Unknown (Status (mkCallArg status_sty_t a))
+ | "Search" -> Unknown (Search (mkCallArg search_sty_t a))
+ | "GetOptions" -> Unknown (GetOptions (mkCallArg get_options_sty_t a))
+ | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a))
+ | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a))
+ | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a))
+ | "About" -> Unknown (About (mkCallArg about_sty_t a))
+ | "Init" -> Unknown (Init (mkCallArg init_sty_t a))
+ | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a))
+ | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a))
+ | "PrintAst" -> Unknown (PrintAst (mkCallArg print_ast_sty_t a))
+ | "Annotate" -> Unknown (Annotate (mkCallArg annotate_sty_t a))
+ | x -> raise (Marshal_error("call",PCData x)))
(** Debug printing *)
let pr_value_gen pr = function
| Good v -> "GOOD " ^ pr v
- | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]"
+ | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]"
| Fail (id,Some(i,j),str) ->
"FAIL "^Stateid.to_string id^
- " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+ " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]"
let pr_value v = pr_value_gen (fun _ -> "FIXME") v
-let pr_full_value call value = match call with
- | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value)
- | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) (Obj.magic value)
- | Query _ -> pr_value_gen (print query_rty_t ) (Obj.magic value)
- | Goal _ -> pr_value_gen (print goals_rty_t ) (Obj.magic value)
- | Evars _ -> pr_value_gen (print evars_rty_t ) (Obj.magic value)
- | Hints _ -> pr_value_gen (print hints_rty_t ) (Obj.magic value)
- | Status _ -> pr_value_gen (print status_rty_t ) (Obj.magic value)
- | Search _ -> pr_value_gen (print search_rty_t ) (Obj.magic value)
- | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value)
- | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value)
- | MkCases _ -> pr_value_gen (print mkcases_rty_t ) (Obj.magic value)
- | Quit _ -> pr_value_gen (print quit_rty_t ) (Obj.magic value)
- | About _ -> pr_value_gen (print about_rty_t ) (Obj.magic value)
- | Init _ -> pr_value_gen (print init_rty_t ) (Obj.magic value)
- | Interp _ -> pr_value_gen (print interp_rty_t ) (Obj.magic value)
- | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value)
- | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) (Obj.magic value)
- | Annotate _ -> pr_value_gen (print annotate_rty_t ) (Obj.magic value)
-let pr_call call =
+let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with
+ | Add _ -> pr_value_gen (print add_rty_t ) value
+ | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) value
+ | Query _ -> pr_value_gen (print query_rty_t ) value
+ | Goal _ -> pr_value_gen (print goals_rty_t ) value
+ | Evars _ -> pr_value_gen (print evars_rty_t ) value
+ | Hints _ -> pr_value_gen (print hints_rty_t ) value
+ | Status _ -> pr_value_gen (print status_rty_t ) value
+ | Search _ -> pr_value_gen (print search_rty_t ) value
+ | GetOptions _ -> pr_value_gen (print get_options_rty_t) value
+ | SetOptions _ -> pr_value_gen (print set_options_rty_t) value
+ | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value
+ | Quit _ -> pr_value_gen (print quit_rty_t ) value
+ | About _ -> pr_value_gen (print about_rty_t ) value
+ | Init _ -> pr_value_gen (print init_rty_t ) value
+ | Interp _ -> pr_value_gen (print interp_rty_t ) value
+ | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) value
+ | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) value
+ | Annotate _ -> pr_value_gen (print annotate_rty_t ) value
+let pr_call : type a. a call -> string = fun call ->
let return what x = str_of_call call ^ " " ^ print what x in
match call with
| Add x -> return add_sty_t x
@@ -735,7 +760,133 @@ let document to_string_fmt =
(to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
(to_string_fmt (of_value (fun _ -> PCData "b")
- (Fail (Stateid.initial,Some (15,34),"error message"))));
+ (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message"))));
document_type_encoding to_string_fmt
+(* Moved from feedback.mli : This is IDE specific and we don't want to
+ pollute the core with it *)
+
+open Feedback
+
+let of_message_level = function
+ | Debug ->
+ Serialize.constructor "message_level" "debug" []
+ | Info -> Serialize.constructor "message_level" "info" []
+ | Notice -> Serialize.constructor "message_level" "notice" []
+ | Warning -> Serialize.constructor "message_level" "warning" []
+ | Error -> Serialize.constructor "message_level" "error" []
+let to_message_level =
+ Serialize.do_match "message_level" (fun s args -> match s with
+ | "debug" -> Debug
+ | "info" -> Info
+ | "notice" -> Notice
+ | "warning" -> Warning
+ | "error" -> Error
+ | x -> raise Serialize.(Marshal_error("error level",PCData x)))
+
+let of_message lvl loc msg =
+ let lvl = of_message_level lvl in
+ let xloc = of_option of_loc loc in
+ let content = of_richpp msg in
+ Xml_datatype.Element ("message", [], [lvl; xloc; content])
+
+let to_message xml = match xml with
+ | Xml_datatype.Element ("message", [], [lvl; xloc; content]) ->
+ Message(to_message_level lvl, to_option to_loc xloc, to_richpp content)
+ | x -> raise (Marshal_error("message",x))
+
+let is_message xml =
+ try begin match to_message xml with
+ | Message(l,c,m) -> Some (l,c,m)
+ | _ -> None
+ end with | Marshal_error _ -> None
+
+let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
+ | "addedaxiom", _ -> AddedAxiom
+ | "processed", _ -> Processed
+ | "processingin", [where] -> ProcessingIn (to_string where)
+ | "incomplete", _ -> Incomplete
+ | "complete", _ -> Complete
+ | "globref", [loc; filepath; modpath; ident; ty] ->
+ GlobRef(to_loc loc, to_string filepath,
+ to_string modpath, to_string ident, to_string ty)
+ | "globdef", [loc; ident; secpath; ty] ->
+ GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty)
+ | "inprogress", [n] -> InProgress (to_int n)
+ | "workerstatus", [ns] ->
+ let n, s = to_pair to_string to_string ns in
+ WorkerStatus(n,s)
+ | "goals", [loc;s] -> Goals (to_loc loc, to_string s)
+ | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x)
+ | "filedependency", [from; dep] ->
+ FileDependency (to_option to_string from, to_string dep)
+ | "fileloaded", [dirpath; filename] ->
+ FileLoaded (to_string dirpath, to_string filename)
+ | "message", [x] -> to_message x
+ | x,l -> raise (Marshal_error("feedback_content",PCData (x ^ " with attributes " ^ string_of_int (List.length l)))))
+
+let of_feedback_content = function
+ | AddedAxiom -> constructor "feedback_content" "addedaxiom" []
+ | Processed -> constructor "feedback_content" "processed" []
+ | ProcessingIn where ->
+ constructor "feedback_content" "processingin" [of_string where]
+ | Incomplete -> constructor "feedback_content" "incomplete" []
+ | Complete -> constructor "feedback_content" "complete" []
+ | GlobRef(loc, filepath, modpath, ident, ty) ->
+ constructor "feedback_content" "globref" [
+ of_loc loc;
+ of_string filepath;
+ of_string modpath;
+ of_string ident;
+ of_string ty ]
+ | GlobDef(loc, ident, secpath, ty) ->
+ constructor "feedback_content" "globdef" [
+ of_loc loc;
+ of_string ident;
+ of_string secpath;
+ of_string ty ]
+ | InProgress n -> constructor "feedback_content" "inprogress" [of_int n]
+ | WorkerStatus(n,s) ->
+ constructor "feedback_content" "workerstatus"
+ [of_pair of_string of_string (n,s)]
+ | Goals (loc,s) ->
+ constructor "feedback_content" "goals" [of_loc loc;of_string s]
+ | Custom (loc, name, x) ->
+ constructor "feedback_content" "custom" [of_loc loc; of_string name; x]
+ | FileDependency (from, depends_on) ->
+ constructor "feedback_content" "filedependency" [
+ of_option of_string from;
+ of_string depends_on]
+ | FileLoaded (dirpath, filename) ->
+ constructor "feedback_content" "fileloaded" [
+ of_string dirpath;
+ of_string filename ]
+ | Message (l,loc,m) -> constructor "feedback_content" "message" [ of_message l loc m ]
+
+let of_edit_or_state_id = function
+ | Edit id -> ["object","edit"], of_edit_id id
+ | State id -> ["object","state"], of_stateid id
+
+let of_feedback msg =
+ let content = of_feedback_content msg.contents in
+ let obj, id = of_edit_or_state_id msg.id in
+ let route = string_of_int msg.route in
+ Element ("feedback", obj @ ["route",route], [id;content])
+
+let to_feedback xml = match xml with
+ | Element ("feedback", ["object","edit";"route",route], [id;content]) -> {
+ id = Edit(to_edit_id id);
+ route = int_of_string route;
+ contents = to_feedback_content content }
+ | Element ("feedback", ["object","state";"route",route], [id;content]) -> {
+ id = State(to_stateid id);
+ route = int_of_string route;
+ contents = to_feedback_content content }
+ | x -> raise (Marshal_error("feedback",x))
+
+let is_feedback = function
+ | Element ("feedback", _, _) -> true
+ | _ -> false
+
(* vim: set foldmethod=marker: *)
+
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
index 3f851455..1bb99897 100644
--- a/ide/xmlprotocol.mli
+++ b/ide/xmlprotocol.mli
@@ -13,7 +13,7 @@ open Xml_datatype
type 'a call
-type unknown
+type unknown_call = Unknown : 'a call -> unknown_call
val add : add_sty -> add_rty call
val edit_at : edit_at_sty -> edit_at_rty call
@@ -43,7 +43,7 @@ val protocol_version : string
(** * XML data marshalling *)
val of_call : 'a call -> xml
-val to_call : xml -> unknown call
+val to_call : xml -> unknown_call
val of_answer : 'a call -> 'a value -> xml
val to_answer : 'a call -> xml -> 'a value
@@ -56,3 +56,17 @@ val document : (xml -> string) -> unit
val pr_call : 'a call -> string
val pr_value : 'a value -> string
val pr_full_value : 'a call -> 'a value -> string
+
+(** * Serialization of rich documents *)
+val of_richpp : Richpp.richpp -> Xml_datatype.xml
+val to_richpp : Xml_datatype.xml -> Richpp.richpp
+
+(** * Serializaiton of feedback *)
+val of_feedback : Feedback.feedback -> xml
+val to_feedback : xml -> Feedback.feedback
+val is_feedback : xml -> bool
+
+val is_message : xml -> (Feedback.level * Loc.t option * Richpp.richpp) option
+val of_message : Feedback.level -> Loc.t option -> Richpp.richpp -> xml
+(* val to_message : xml -> Feedback.message *)
+