From 4c202177e7d1a26f3b8bc105a1ceb604f178b584 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 16 Aug 2015 05:00:48 +0200 Subject: Using the new preference mechanism for colors in CoqIDE. A lot of legacy code has been removed in the process in favour of signal-based interactions. --- ide/preferences.ml | 117 ++++++++++++++++++++++------------------------------- 1 file changed, 49 insertions(+), 68 deletions(-) (limited to 'ide/preferences.ml') diff --git a/ide/preferences.ml b/ide/preferences.ml index ceae6d1be..74ca6ca83 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -57,6 +57,8 @@ object (self) 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 (** Useful marshallers *) @@ -269,19 +271,35 @@ let opposite_tabs = new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool) let background_color = - new preference ~name:["background_color"] ~init:Tags.default_color ~repr:Repr.(string) + 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:Tags.default_processing_color ~repr:Repr.(string) + 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 processed_color = - new preference ~name:["processed_color"] ~init:Tags.default_processed_color ~repr:Repr.(string) + new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string) + +let _ = attach_bg processed_color Tags.Script.processed +let _ = attach_bg processed_color Tags.Proof.highlight let error_color = - new preference ~name:["error_color"] ~init:Tags.default_error_color ~repr:Repr.(string) + new preference ~name:["error_color"] ~init:"#FFCCCC" ~repr:Repr.(string) + +let _ = attach_bg error_color Tags.Script.error_bg let error_fg_color = - new preference ~name:["error_fg_color"] ~init:Tags.default_error_fg_color ~repr:Repr.(string) + new preference ~name:["error_fg_color"] ~init:"red" ~repr:Repr.(string) + +let _ = attach_fg error_fg_color Tags.Script.error let dynamic_word_wrap = new preference ~name:["dynamic_word_wrap"] ~init:false ~repr:Repr.(bool) @@ -470,75 +488,38 @@ 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 (background_color#get)) - ~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 () = - background_color#set (Tags.string_of_color background_button#color); - processing_color#set (Tags.string_of_color processing_button#color); - processed_color#set (Tags.string_of_color processed_button#color); - error_color#set (Tags.string_of_color error_button#color); - error_fg_color#set (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 - in + let callback () = () in custom ~label box callback true in -- cgit v1.2.3