diff options
| -rw-r--r-- | ide/preferences.ml | 36 | ||||
| -rw-r--r-- | ide/preferences.mli | 1 | ||||
| -rw-r--r-- | ide/tags.ml | 24 | ||||
| -rw-r--r-- | ide/tags.mli | 10 |
4 files changed, 58 insertions, 13 deletions
diff --git a/ide/preferences.ml b/ide/preferences.ml index 25712f951..9a4fde2f6 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -144,6 +144,7 @@ type pref = 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; @@ -220,10 +221,11 @@ let current = { vertical_tabs = false; opposite_tabs = false; - background_color = "cornsilk"; - processed_color = "light green"; - processing_color = "light blue"; - error_color = "#FFCCCC"; + 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; @@ -296,6 +298,7 @@ let save_pref () = 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] ++ @@ -382,6 +385,7 @@ let load_pref () = 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); @@ -466,10 +470,15 @@ let configure ?(apply=(fun () -> ())) () = ~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) () @@ -486,15 +495,19 @@ let configure ?(apply=(fun () -> ())) () = ~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 "cornsilk"); - processing_button#set_color (Tags.color_of_string "light blue"); - processed_button#set_color (Tags.color_of_string "light green"); - error_button#set_color (Tags.color_of_string "#FFCCCC"); + 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); in let _ = reset_button#connect#clicked ~callback:reset_cb in let label = "Color configuration" in @@ -503,7 +516,12 @@ let configure ?(apply=(fun () -> ())) () = 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; - !refresh_editor_hook () + 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 in custom ~label box callback true in diff --git a/ide/preferences.mli b/ide/preferences.mli index 1b52d20a4..ab12e4c7b 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -71,6 +71,7 @@ type pref = 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; diff --git a/ide/tags.ml b/ide/tags.ml index 04ad9a519..40d5b4ded 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -13,15 +13,23 @@ let make_tag (tt:GText.tag_table) ~name prop = tt#add new_tag#as_tag; new_tag -let processed_color = ref "light green" -let processing_color = ref "light blue" -let error_color = ref "#FFCCCC" +(* These work fine for colorblind people too *) +let default_processed_color = "light green" +let default_processing_color = "light blue" +let default_error_color = "#FF3333" +let default_error_fg_color = "#FF5555" +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 "red"] + 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] @@ -94,3 +102,11 @@ 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 9c3261d66..e68015c99 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -53,3 +53,13 @@ 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 + |