aboutsummaryrefslogtreecommitdiff
path: root/ide
diff options
context:
space:
mode:
Diffstat (limited to 'ide')
-rw-r--r--ide/coqOps.ml2
-rw-r--r--ide/idetop.ml40
-rw-r--r--ide/macos_prehook.ml6
-rw-r--r--ide/preferences.ml6
-rw-r--r--ide/preferences.mli2
-rw-r--r--ide/session.ml7
-rw-r--r--ide/wg_Command.ml12
-rw-r--r--ide/wg_MessageView.ml7
-rw-r--r--ide/wg_ProofView.ml7
-rw-r--r--ide/wg_ScriptView.ml7
-rw-r--r--ide/wg_Segment.ml83
-rw-r--r--ide/wg_Segment.mli2
12 files changed, 81 insertions, 100 deletions
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index 4aa801c2b2..8da9900724 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -250,7 +250,6 @@ object(self)
feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback;
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
@@ -267,7 +266,6 @@ object(self)
ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter)
in
let _ = segment#connect#clicked ~callback:on_click in
-*)
()
method private tooltip_callback ~x ~y ~kbd tooltip =
diff --git a/ide/idetop.ml b/ide/idetop.ml
index 608577b297..543ff924bd 100644
--- a/ide/idetop.ml
+++ b/ide/idetop.ml
@@ -57,9 +57,9 @@ let coqide_known_option table = List.mem table [
["Diffs"]]
let is_known_option cmd = match Vernacprop.under_control cmd with
- | VernacSetOption (_, o, BoolValue true)
- | VernacSetOption (_, o, StringValue _)
- | VernacUnsetOption (_, o) -> coqide_known_option o
+ | VernacSetOption (_, o, OptionSetTrue)
+ | VernacSetOption (_, o, OptionSetString _)
+ | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o
| _ -> false
(** Check whether a command is forbidden in the IDE *)
@@ -231,30 +231,30 @@ let goals () =
let doc = get_doc () in
set_doc @@ Stm.finish ~doc;
try
- let newp = Proof_global.give_me_the_proof () in
+ let newp = Vernacstate.Proof_global.give_me_the_proof () in
if Proof_diffs.show_diffs () then begin
let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in
let diff_goal_map = Proof_diffs.make_goal_map oldp newp in
Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp))
end else
Some (export_pre_goals Proof.(data newp) process_goal)
- with Proof_global.NoCurrentProof -> None;;
+ with Vernacstate.Proof_global.NoCurrentProof -> None;;
let evars () =
try
let doc = get_doc () in
set_doc @@ Stm.finish ~doc;
- let pfts = Proof_global.give_me_the_proof () in
+ let pfts = Vernacstate.Proof_global.give_me_the_proof () in
let Proof.{ sigma } = Proof.data pfts in
let exl = Evar.Map.bindings (Evd.undefined_map sigma) in
let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in
let el = List.map map_evar exl in
Some el
- with Proof_global.NoCurrentProof -> None
+ with Vernacstate.Proof_global.NoCurrentProof -> None
let hints () =
try
- let pfts = Proof_global.give_me_the_proof () in
+ let pfts = Vernacstate.Proof_global.give_me_the_proof () in
let Proof.{ goals; sigma } = Proof.data pfts in
match goals with
| [] -> None
@@ -263,7 +263,7 @@ let hints () =
let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
Some (hint_hyps, concl_next_tac)
- with Proof_global.NoCurrentProof -> None
+ with Vernacstate.Proof_global.NoCurrentProof -> None
(** Other API calls *)
@@ -284,11 +284,11 @@ let status force =
List.rev_map Names.Id.to_string l
in
let proof =
- try Some (Names.Id.to_string (Proof_global.get_current_proof_name ()))
- with Proof_global.NoCurrentProof -> None
+ try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ()))
+ with Vernacstate.Proof_global.NoCurrentProof -> None
in
let allproofs =
- let l = Proof_global.get_all_proof_names () in
+ let l = Vernacstate.Proof_global.get_all_proof_names () in
List.map Names.Id.to_string l
in
{
@@ -336,7 +336,8 @@ let import_search_constraint = function
| Interface.Include_Blacklist -> Search.Include_Blacklist
let search flags =
- List.map export_coq_object (Search.interface_search (
+ let pstate = Vernacstate.Proof_global.get () in
+ List.map export_coq_object (Search.interface_search ?pstate (
List.map (fun (c, b) -> (import_search_constraint c, b)) flags)
)
@@ -365,12 +366,13 @@ let get_options () =
Goptions.OptionMap.fold fold table []
let set_options options =
+ let open Goptions in
let iter (name, value) = match import_option_value value with
- | BoolValue b -> Goptions.set_bool_option_value name b
- | IntValue i -> Goptions.set_int_option_value name i
- | StringValue s -> Goptions.set_string_option_value name s
- | StringOptValue (Some s) -> Goptions.set_string_option_value name s
- | StringOptValue None -> Goptions.unset_option_value_gen name
+ | BoolValue b -> set_bool_option_value name b
+ | IntValue i -> set_int_option_value name i
+ | StringValue s -> set_string_option_value name s
+ | StringOptValue (Some s) -> set_string_option_value name s
+ | StringOptValue None -> unset_option_value_gen name
in
List.iter iter options
@@ -465,7 +467,7 @@ let print_xml =
let m = Mutex.create () in
fun oc xml ->
Mutex.lock m;
- try Xml_printer.print oc xml; Mutex.unlock m
+ try Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m
with e -> let e = CErrors.push e in Mutex.unlock m; iraise e
let slave_feeder fmt xml_oc msg =
diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml
index d668788954..dc8fd0e85d 100644
--- a/ide/macos_prehook.ml
+++ b/ide/macos_prehook.ml
@@ -24,13 +24,13 @@ let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir
let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir
let () = Unix.putenv "GTK_PATH" resources_dir
let () =
- Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc")
+ Unix.putenv "GTK3_RC_FILES" (Filename.concat etc_dir "gtk-3.0/gtkrc")
let () =
Unix.putenv "GTK_IM_MODULE_FILE"
- (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders")
+ (Filename.concat etc_dir "gtk-3.0/gtk-immodules.loaders")
let () =
Unix.putenv "GDK_PIXBUF_MODULE_FILE"
- (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders")
+ (Filename.concat etc_dir "gtk-3.0/gdk-pixbuf.loaders")
let () = Unix.putenv "PANGO_LIBDIR" lib_dir
let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir
let () = Unix.putenv "CHARSETALIASDIR" lib_dir
diff --git a/ide/preferences.ml b/ide/preferences.ml
index e04001974e..47cd4c58b6 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -410,8 +410,8 @@ let vertical_tabs =
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 background_color = *)
+(* new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) *)
let attach_tag (pref : string preference) (tag : GText.tag) f =
tag#set_property (f pref#get);
@@ -737,7 +737,7 @@ let configure ?(apply=(fun () -> ())) parent =
()
in
let () = Util.List.iteri iter [
- ("Background color", background_color);
+(* ("Background color", background_color); *)
("Background color of processed text", processed_color);
("Background color of text being processed", processing_color);
("Background color of incompletely processed Qed", incompletely_processed_color);
diff --git a/ide/preferences.mli b/ide/preferences.mli
index d2f1b5ba29..785c191b46 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -88,7 +88,7 @@ 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 background_color : string preference *)
val processing_color : string preference
val processed_color : string preference
val error_color : string preference
diff --git a/ide/session.ml b/ide/session.ml
index fd21515ca5..90412f53f0 100644
--- a/ide/session.ml
+++ b/ide/session.ml
@@ -257,9 +257,10 @@ 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 clr = data#misc#modify_bg [`NORMAL, `NAME clr] in
- let _ = background_color#connect#changed ~callback:refresh in
- let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in
+(* FIXME: handle this using CSS *)
+(* let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in *)
+(* let _ = background_color#connect#changed ~callback:refresh in *)
+(* let _ = data#misc#connect#realize ~callback:(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) ->
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
index be400a5f2d..2cadd7ffbf 100644
--- a/ide/wg_Command.ml
+++ b/ide/wg_Command.ml
@@ -100,9 +100,10 @@ object(self)
router#register_route route_id result;
r_bin#add_with_viewport (result :> GObj.widget);
views <- (frame#coerce, result, combo#entry) :: views;
- let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in
- let _ = background_color#connect#changed ~callback:cb in
- let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in
+(* FIXME: handle this using CSS *)
+(* let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in *)
+(* let _ = background_color#connect#changed ~callback:cb in *)
+(* let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *)
let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in
stick text_font result cb;
result#misc#set_can_focus true; (* false causes problems for selection *)
@@ -171,8 +172,9 @@ object(self)
self#new_page_maker;
self#new_query_aux ~grab_now:false ();
frame#misc#hide ();
- let _ = background_color#connect#changed ~callback:self#refresh_color in
- self#refresh_color background_color#get;
+(* FIXME: handle this using CSS *)
+(* let _ = background_color#connect#changed ~callback: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_MessageView.ml b/ide/wg_MessageView.ml
index 7943b099fc..53e004c4e3 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -59,9 +59,10 @@ let message_view () : message_view =
let _ = buffer#add_selection_clipboard default_clipboard in
let () = view#set_left_margin 2 in
view#misc#show ();
- let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in
- let _ = background_color#connect#changed ~callback:cb in
- let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in
+(* FIXME: handle this using CSS *)
+(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *)
+(* let _ = background_color#connect#changed ~callback:cb in *)
+(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *)
let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in
stick text_font view cb;
diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml
index 596df227b7..7bf73b5ebe 100644
--- a/ide/wg_ProofView.ml
+++ b/ide/wg_ProofView.ml
@@ -204,9 +204,10 @@ 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_bg [`NORMAL, `NAME clr] in
- let _ = background_color#connect#changed ~callback:cb in
- let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in
+(* FIXME: handle this using CSS *)
+(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *)
+(* let _ = background_color#connect#changed ~callback:cb in *)
+(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *)
let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in
stick text_font view cb;
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
index 8802eb0f1c..c1ed9b7506 100644
--- a/ide/wg_ScriptView.ml
+++ b/ide/wg_ScriptView.ml
@@ -506,9 +506,10 @@ object (self)
in
let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
(* Plug on preferences *)
- let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in
- let _ = background_color#connect#changed ~callback:cb in
- let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in
+(* FIXME: handle this using CSS *)
+(* let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in *)
+(* let _ = background_color#connect#changed ~callback:cb in *)
+(* let _ = self#misc#connect#realize ~callback:(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;
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
index 2e5de64254..b62c0a2190 100644
--- a/ide/wg_Segment.ml
+++ b/ide/wg_Segment.ml
@@ -8,10 +8,8 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
-(*
open Util
open Preferences
-*)
type color = GDraw.color
@@ -24,7 +22,6 @@ object
method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a
end
-(*
let i2f = float_of_int
let f2i = int_of_float
@@ -35,14 +32,20 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with
| `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2
| `WHITE, `WHITE -> true
| _ -> false
-*)
+
+let set_cairo_color ctx c =
+ let open Gdk.Color in
+ let c = GDraw.color c in
+ let cast i = i2f i /. 65536. in
+ Cairo.set_source_rgb ctx (cast @@ red c) (cast @@ green c) (cast @@ blue c)
+
class type segment_signals =
object
inherit GObj.misc_signals
inherit GUtil.add_ml_signals
method clicked : callback:(int -> unit) -> GtkSignal.id
end
-(*
+
class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals =
object
val after = false
@@ -50,14 +53,11 @@ object
inherit GUtil.add_ml_signals obj [clicked#disconnect]
method clicked = clicked#connect ~after
end
-*)
class segment () =
let box = GBin.frame () in
-(*
-let eventbox = GBin.event_box ~packing:box#add () in
-let draw = GMisc.image ~packing:eventbox#add () in
-*)
+let draw = GMisc.drawing_area ~packing:box#add () in
+
object (self)
inherit GObj.widget box#as_widget
@@ -66,56 +66,40 @@ object (self)
val mutable height = 20
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 ();
let cb rect =
let w = rect.Gtk.width in
let h = rect.Gtk.height in
- (* Only refresh when size actually changed, otherwise loops *)
- if self#misc#visible && (width <> w || height <> h) then begin
- width <- w;
- height <- h;
- self#redraw ();
- end
+ width <- w;
+ height <- h
in
let _ = box#misc#connect#size_allocate ~callback:cb in
+ let () = draw#event#add [`BUTTON_PRESS] in
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 = 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 ~callback:clicked_cb in
+ let _ = draw#event#connect#button_press ~callback: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;
- refresh_timer.Ideutils.run ~ms:300
- ~callback:(fun () -> if need_refresh then self#refresh (); true)
-*)
+ let cb ctx = self#refresh ctx; false in
+ let _ = draw#misc#connect#draw ~callback:cb in
+ ()
+
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
+ let changed_cb _ = self#misc#queue_draw () in
md#changed ~callback:changed_cb
-(*
- method private fill_range color i j = match model with
+
+ method private fill_range ctx color i j = match model with
| None -> ()
| Some md ->
let i = i2f i in
@@ -125,24 +109,19 @@ object (self)
let x = f2i ((i *. width) /. len) in
let x' = f2i ((j *. width) /. len) in
let w = x' - x in
- pixmap#set_foreground color;
- pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true ();
- draw#set_mask None;
+ set_cairo_color ctx color;
+ Cairo.rectangle ctx (i2f x) 0. ~w:(i2f w) ~h:(i2f height);
+ Cairo.fill ctx
method set_default_color color = default <- color
method default_color = default
- method private redraw () =
- pixmap <- GDraw.pixmap ~width ~height ();
- draw#set_pixmap pixmap;
- self#refresh ();
-
- method private refresh () = match model with
+ method private refresh ctx = match model with
| None -> ()
| Some md ->
- need_refresh <- false;
- pixmap#set_foreground default;
- pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+ set_cairo_color ctx default;
+ Cairo.rectangle ctx 0. 0. ~w:(i2f width) ~h:(i2f height);
+ Cairo.fill ctx;
let make (k, cur, accu) v = match cur with
| None -> pred k, Some (k, k, v), accu
| Some (i, j, w) ->
@@ -154,11 +133,9 @@ object (self)
| 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;
+ List.iter (fun (i, j, v) -> self#fill_range ctx v i (j + 1)) segments
method connect =
new segment_signals_impl box#as_widget clicked
-*)
end
diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli
index 84d487f35f..07f545fee7 100644
--- a/ide/wg_Segment.mli
+++ b/ide/wg_Segment.mli
@@ -31,9 +31,7 @@ class segment : unit ->
inherit GObj.widget
val obj : Gtk.widget Gtk.obj
method set_model : model -> unit
-(*
method connect : segment_signals
method default_color : color
method set_default_color : color -> unit
-*)
end
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-04 20:53:48 +0000