aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr>2015-08-17 23:30:16 +0200
committerGravatar Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr>2015-09-20 15:20:32 +0200
commit06d1ad739b952febce3220c372aa2dedf18e1c79 (patch)
treee930f49b5b825dd6cb5562fb98855b6a96cc35d8
parent8bba34395e520ac606fc3efd0a875699fe968e69 (diff)
Adding a tag preference
-rw-r--r--ide/preferences.ml152
-rw-r--r--ide/preferences.mli10
2 files changed, 162 insertions, 0 deletions
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 765dc7e59..aea00d98d 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -17,6 +17,14 @@ let style_manager = GSourceView2.source_style_scheme_manager ~default:true
let () = style_manager#set_search_path
((Minilib.coqide_data_dirs ())@style_manager#search_path)
+type tag = {
+ tag_fg_color : string option;
+ tag_bg_color : string option;
+ tag_bold : bool;
+ tag_italic : bool;
+ tag_underline : bool;
+}
+
(** Generic preferences *)
type obj = {
@@ -170,6 +178,30 @@ object
| _ -> 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 =
@@ -354,6 +386,18 @@ let processing_color =
let _ = attach_bg processing_color Tags.Script.to_process
let _ = attach_bg processing_color Tags.Script.incomplete
+let default_tag = {
+ tag_fg_color = None;
+ tag_bg_color = None;
+ tag_bold = false;
+ tag_italic = false;
+ tag_underline = false;
+}
+
+let tags = ref Util.String.Map.empty
+
+let list_tags () = !tags
+
let processed_color =
new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string)
@@ -400,6 +444,74 @@ let highlight_current_line =
let nanoPG =
new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool)
+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 () =
@@ -503,6 +615,44 @@ let configure ?(apply=(fun () -> ())) () =
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 reset_button = GButton.button
+ ~label:"Reset"
+ ~packing:box#pack ()
+ 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
@@ -706,6 +856,8 @@ 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;
diff --git a/ide/preferences.mli b/ide/preferences.mli
index d815c01dd..b5c7ea222 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -12,6 +12,14 @@ 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 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
@@ -33,6 +41,8 @@ object
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