type style =
{
mutable st_background : string option;
mutable st_bold : bool ;
mutable st_foreground : string option;
mutable st_italic : bool ;
mutable st_strikethrough : bool ;
mutable st_underline : bool ;
}
type tag_style = string * style
type source_view_props =
{ mutable sv_background : string option ;
mutable sv_foreground : string option ;
mutable sv_font : string option ;
mutable sv_sel_background : string option ;
mutable sv_sel_foreground : string option ;
mutable sv_auto_indent : bool ;
mutable sv_tabs_width : int option ;
mutable sv_tabs_spaces : bool ;
}
let home =
try Sys.getenv "HOME"
with Not_found -> ""
let rc_dir =
let d = Filename.concat home ".mlgtksourceview" in
let _ =
try Unix.mkdir d 0o700
with _ -> ()
in
d
let xml_of_string_prop name v =
Xml.Element ("prop",["name",name;"value",v],[])
let string_of_opt = function
None -> ""
| Some s -> s
let xml_of_string_opt_prop name v =
xml_of_string_prop name (string_of_opt v)
let xml_of_bool_prop name v =
xml_of_string_prop name (if v then "true" else "false")
let xml_of_int_prop name v =
xml_of_string_prop name (string_of_int v)
let xml_of_int_opt_prop name v =
xml_of_string_opt_prop name
(match v with None -> None | Some n -> Some (string_of_int n))
let xml_of_tag_style (name,st) =
let l =
[ xml_of_string_opt_prop "background" st.st_background ;
xml_of_bool_prop "bold" st.st_bold ;
xml_of_string_opt_prop "foreground" st.st_foreground ;
xml_of_bool_prop "italic" st.st_italic ;
xml_of_bool_prop "strikethrough" st.st_strikethrough ;
xml_of_bool_prop "underline" st.st_underline ;
]
in
Xml.Element ("entry",["name",name],l)
let xml_store_lang_style ~file ~lang tag_styles =
let l = List.map xml_of_tag_style tag_styles in
let xml = Xml.Element ("language", ["_name", lang], l) in
let oc = open_out file in
output_string oc "<?xml version=\"1.0\"?>\n";
output_string oc (Xml.to_string_fmt xml);
close_out oc
let xml_of_svprops st =
[
xml_of_string_opt_prop "background" st.sv_background ;
xml_of_string_opt_prop "foreground" st.sv_foreground ;
xml_of_string_opt_prop "sel-background" st.sv_sel_background ;
xml_of_string_opt_prop "sel-foreground" st.sv_sel_foreground ;
xml_of_string_opt_prop "font" st.sv_font ;
xml_of_bool_prop "auto-indent" st.sv_auto_indent ;
xml_of_int_opt_prop "tabs-width" st.sv_tabs_width ;
xml_of_bool_prop "tabs-spaces" st.sv_tabs_spaces ;
]
let xml_store_sourceview_props ~file svprops =
let l = xml_of_svprops svprops in
let xml = Xml.Element ("sourceview", [], l) in
let oc = open_out file in
output_string oc "<?xml version=\"1.0\"?>\n";
output_string oc (Xml.to_string_fmt xml);
close_out oc
let empty_style () =
{ st_background = None ;
st_bold = false ;
st_foreground = None ;
st_italic = false ;
st_strikethrough = false ;
st_underline = false ;
}
let empty_sourceview_props () =
{
sv_background = None ;
sv_foreground = None ;
sv_font = None ;
sv_sel_background = None ;
sv_sel_foreground = None ;
sv_auto_indent = false ;
sv_tabs_width = None ;
sv_tabs_spaces = false ;
}
let find_prop_of_xml name l =
try
let pred = function
Xml.Element ("prop",atts,_) ->
List.exists
(function ("name",s) -> s = name | _ -> false)
atts
| _ -> false
in
match List.find pred l with
Xml.Element ("prop",atts,_) ->
Some (List.assoc "value" atts)
| _ -> assert false
with
Not_found -> None
let map_opt f = function
None -> None
| Some v -> Some (f v)
let string_opt_prop_of_xml name l =
match find_prop_of_xml name l with
None | Some "" -> None
| Some s -> Some s
let string_prop_of_xml name l =
match find_prop_of_xml name l with
None -> ""
| Some s -> s
let int_opt_prop_of_xml name l =
try map_opt int_of_string (find_prop_of_xml name l)
with Invalid_argument _ -> None
let bool_prop_of_xml name l =
match find_prop_of_xml name l with
| Some "true" -> true
| _ -> false
let source_view_props_of_xml = function
Xml.Element ("sourceview", _, l) ->
Some
{
sv_background = string_opt_prop_of_xml "background" l ;
sv_foreground = string_opt_prop_of_xml "foreground" l ;
sv_font = string_opt_prop_of_xml "font" l ;
sv_sel_background = string_opt_prop_of_xml "sel-background" l ;
sv_sel_foreground = string_opt_prop_of_xml "sel-foreground" l ;
sv_auto_indent = bool_prop_of_xml "auto-indent" l ;
sv_tabs_width = int_opt_prop_of_xml "tabs-width" l ;
sv_tabs_spaces = bool_prop_of_xml "tabs-spaces" l ;
}
| _ ->
None
let xml_read_sourceview_props ~file =
let error s = failwith (Printf.sprintf "File %s: %s" file s) in
try
let xml = Xml.parse_file file in
source_view_props_of_xml xml
with
Xml.Error e ->
error (Xml.error e)
let tag_style_of_xml = function
Xml.Element("entry",atts,l) ->
(
try
let name = List.assoc "name" atts in
let bool_prop atts =
try List.assoc "value" atts = "true"
with Not_found -> false
in
let color_prop atts =
try
match List.assoc "value" atts with
"" -> None
| s -> Some s
with Not_found -> None
in
let f st = function
Xml.Element ("prop",atts,[]) ->
begin
match List.assoc "name" atts with
"bold" -> { st with st_bold = bool_prop atts }
| "italic" -> { st with st_italic = bool_prop atts }
| "strikethrough" -> { st with st_strikethrough = bool_prop atts }
| "underline" -> { st with st_underline = bool_prop atts }
| "background" -> { st with st_background = color_prop atts }
| "foreground" -> { st with st_foreground = color_prop atts }
| _ -> st
end
| _ -> st
in
let st = List.fold_left f (empty_style()) l in
Some (name, st)
with
Not_found -> None
)
| _ -> None
let tag_styles_of_xml =
List.fold_left
(fun acc xml ->
match tag_style_of_xml xml with
None -> acc
| Some ts -> ts :: acc
)
[]
let xml_read_lang_style ~file =
let error s = failwith (Printf.sprintf "File %s: %s" file s) in
try
let xml = Xml.parse_file file in
match xml with
Xml.Element ("language",atts,l) ->
(
let name =
try List.assoc "_name" atts
with Not_found -> error "No _name for language."
in
(name, tag_styles_of_xml l)
)
| _ ->
error "No language element."
with
Xml.Error e ->
error (Xml.error e)
let file_of_lang lang = Filename.concat rc_dir lang
let file_sourceviews = Filename.concat rc_dir "sourceviews"
let string_of_color c =
let (r,g,b) =
(Gdk.Color.red c, Gdk.Color.green c, Gdk.Color.blue c)
in
Printf.sprintf "#%04X%04X%04X" r g b
let split_string s chars =
let len = String.length s in
let rec iter acc pos =
if pos >= len then
match acc with
"" -> []
| _ -> [acc]
else
if List.mem s.[pos] chars then
match acc with
"" -> iter "" (pos + 1)
| _ -> acc :: (iter "" (pos + 1))
else
iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
in
iter "" 0
let tag_style_of_lang st =
let bg = if st#use_background then Some (string_of_color st#background) else None in
let fg = if st#use_foreground then Some (string_of_color st#foreground) else None in
{ st_background = bg ;
st_bold = st#bold ;
st_foreground = fg ;
st_italic = st#italic ;
st_strikethrough = st#strikethrough ;
st_underline = st#underline ;
}
let apply_tag_style_to_lang lang (name,st) =
let name = String.concat "@32@" (split_string name [' ']) in
let style = (lang#get_tag_style name)#copy in
(match st.st_background with
None -> style#set_use_background false
| Some s ->
style#set_use_background true;
style#set_background_by_name s
);
(match st.st_foreground with
None -> style#set_use_foreground false
| Some s ->
style#set_use_foreground true;
style#set_foreground_by_name s
);
style#set_bold st.st_bold;
style#set_italic st.st_italic;
style#set_strikethrough st.st_strikethrough;
style#set_underline st.st_underline;
lang#set_tag_style name style
let store_lang_style (lang : GSourceView.source_language) =
let file = file_of_lang lang#get_name in
let f_tag t =
(t#id, tag_style_of_lang (lang#get_tag_style t#id))
in
let tag_styles = List.map f_tag lang#get_tags in
xml_store_lang_style ~file ~lang: lang#get_name tag_styles
let read_lang_style (lang : GSourceView.source_language) =
let file = file_of_lang lang#get_name in
try
let (_,tag_styles) = xml_read_lang_style ~file in
List.iter (apply_tag_style_to_lang lang) tag_styles
with
Xml.File_not_found _ ->
store_lang_style lang
let svprops_of_source_view sv =
{ sv_background = None ;
sv_font = None ;
sv_foreground = None ;
sv_sel_background = None ;
sv_sel_foreground = None ;
sv_auto_indent = sv#auto_indent ;
sv_tabs_width = Some sv#tabs_width ;
sv_tabs_spaces = sv#insert_spaces_instead_of_tabs ;
}
let apply_sourceview_props sv st =
(
match st.sv_background with
None -> ()
| Some s ->
let c = `NAME s in
sv#misc#modify_base [`NORMAL, c]
);
(
match st.sv_foreground with
None -> ()
| Some s ->
let c = `NAME s in
sv#misc#modify_text [`NORMAL, c];
sv#set_cursor_color_by_name s
);
(
match st.sv_sel_background with
None -> ()
| Some s ->
let c = `NAME s in
sv#misc#modify_base [`PRELIGHT, c ; `SELECTED, c ; `ACTIVE, c]
);
(
match st.sv_sel_foreground with
None -> ()
| Some s ->
let c = `NAME s in
sv#misc#modify_text [`PRELIGHT, c ; `SELECTED, c ; `ACTIVE, c]
);
(
match st.sv_font with
None -> ()
| Some s -> sv#misc#modify_font_by_name s
);
sv#set_auto_indent st.sv_auto_indent;
(
match st.sv_tabs_width with
None -> ()
| Some n -> sv#set_tabs_width n
);
sv#set_insert_spaces_instead_of_tabs st.sv_tabs_spaces
let store_sourceview_props st =
xml_store_sourceview_props ~file: file_sourceviews st
let registered_source_views = ref []
let remove_source_view sv =
registered_source_views :=
List.filter (fun sv2 -> sv2#get_oid <> sv#get_oid)
!registered_source_views
let register_source_view (sv : GSourceView.source_view) =
remove_source_view sv;
registered_source_views := sv :: !registered_source_views;
ignore(sv#misc#connect#destroy (fun () -> remove_source_view sv))
let apply_sourceview_props_to_registered st =
List.iter
(fun sv -> apply_sourceview_props sv st)
!registered_source_views
let read_sourceview_props () =
let file = file_sourceviews in
try
match xml_read_sourceview_props ~file with
None -> empty_sourceview_props ()
| Some st -> st
with
Xml.File_not_found _ ->
empty_sourceview_props ()
let source_languages_manager = GSourceView.source_languages_manager ()
let _ = List.iter read_lang_style
source_languages_manager#get_available_languages
let replace_in_string ~pat ~subs ~s =
let len_pat = String.length pat in
let len = String.length s in
let b = Buffer.create len in
let rec iter pos =
if pos >= len then
()
else
if pos + len_pat > len then
Buffer.add_string b (String.sub s pos (len - pos))
else
if String.sub s pos len_pat = pat then
(
Buffer.add_string b subs;
iter (pos+len_pat)
)
else
(
Buffer.add_char b s.[pos];
iter (pos+1);
)
in
iter 0;
Buffer.contents b
class tag_list () =
let remove_arobas32 s = replace_in_string ~pat: "@32@" ~subs: " " ~s in
let ref_on_select = ref (fun _ -> ()) in
let ref_on_deselect = ref (fun _ -> ()) in
object
inherit [string] Gmylist.plist `SINGLE [None,Gmylist.String remove_arobas32] false
method on_select s = !ref_on_select s
method on_deselect s = !ref_on_deselect s
method set_on_select f = ref_on_select := f
method set_on_deselect f = ref_on_deselect := f
end
let sort_languages_by_name =
List.sort
(fun l1 l2 -> Pervasives.compare (String.lowercase l1#get_name) (String.lowercase l2#get_name))
class lang_style_box () =
let wf = GBin.frame ~label: "Elements" () in
let hbox = GPack.hbox ~packing: wf#add () in
let taglist = new tag_list () in
let _ = hbox#pack ~expand: true ~fill: true ~padding: 2 taglist#box#coerce in
let vbox = GPack.vbox ~packing: (hbox#pack ~expand: false ~fill: true ~padding: 2) () in
let tb = GButton.toolbar ~orientation: `HORIZONTAL
~style: `ICONS ~packing: (vbox#pack ~expand: false ~fill: true) () in
let table = GPack.table ~columns: 2 ~rows: 2
~packing: (vbox#pack ~expand: true ~fill: true) () in
let wc_foreground = GButton.check_button ~label: "Foreground: "
~packing: (table#attach ~left: 0 ~top: 0) () in
let wc_background = GButton.check_button ~label: "Background: "
~packing: (table#attach ~left: 0 ~top: 1) () in
let wcol_foreground = GButton.color_button
~packing: (table#attach ~left: 1 ~top: 0) () in
let wcol_background = GButton.color_button
~packing: (table#attach ~left: 1 ~top: 1) () in
let wc_bold = GButton.toggle_tool_button ~stock: `BOLD ~packing: tb#insert () in
let wc_italic = GButton.toggle_tool_button ~stock: `ITALIC ~packing: tb#insert () in
let wc_strike = GButton.toggle_tool_button ~stock: `STRIKETHROUGH ~packing: tb#insert () in
let wc_under = GButton.toggle_tool_button ~stock: `UNDERLINE ~packing: tb#insert () in
object(self)
method box = wf#coerce
val mutable lang = (None : GSourceView.source_language option)
method lang = lang
method set_lang o =
lang <- o;
match lang with
None -> taglist#update_data []
| Some l ->
let tags = List.map (fun t -> t#id) l#get_tags in
taglist#update_data tags;
self#update_params_widgets
method private update_params_widgets =
match lang with
None -> hbox#misc#set_sensitive false
| Some lang ->
hbox#misc#set_sensitive true;
match taglist#selection with
[] -> vbox#misc#set_sensitive false
| tagname :: _ ->
vbox#misc#set_sensitive true;
let st = lang#get_tag_style tagname in
wc_foreground#set_active st#use_foreground ;
wcol_foreground#set_color st#foreground;
wc_background#set_active st#use_background ;
wcol_background#set_color st#background;
wc_bold#set_active st#bold;
wc_italic#set_active st#italic;
wc_strike#set_active st#strikethrough;
wc_under#set_active st#underline
method private current_lang_tag =
match lang with
None -> None
| Some lang ->
match taglist#selection with
[] -> None
| s :: _ -> Some (lang, s)
method reset =
match lang with
None -> ()
| Some lang ->
read_lang_style lang;
self#update_params_widgets
method private on_tag_select s =
self#update_params_widgets
method private on_tag_deselect s =
self#update_params_widgets
initializer
taglist#set_on_select self#on_tag_select;
taglist#set_on_deselect self#on_tag_deselect;
let handle_change f =
fun () ->
match self#current_lang_tag with
None -> ()
| Some (lang,tagname) ->
let st = (lang#get_tag_style tagname)#copy in
f st;
lang#set_tag_style tagname st
in
let on_fg_toggled st =
let fg = wc_foreground#active in
wcol_foreground#misc#set_sensitive fg;
st#set_use_foreground fg
in
let on_bg_toggled st =
let bg = wc_background#active in
wcol_background#misc#set_sensitive bg;
st#set_use_background bg;
in
let on_fg_set st =
st#set_foreground wcol_foreground#color
in
let on_bg_set st =
st#set_background wcol_background#color
in
let on_bool_toggled wc f st = f st wc#get_active in
let on_bold_toggled = on_bool_toggled wc_bold (fun st -> st#set_bold) in
let on_italic_toggled = on_bool_toggled wc_italic (fun st -> st#set_italic) in
let on_strike_toggled = on_bool_toggled wc_strike (fun st -> st#set_strikethrough) in
let on_under_toggled = on_bool_toggled wc_under (fun st -> st#set_underline) in
ignore(wc_foreground#connect#toggled (handle_change on_fg_toggled));
ignore(wc_background#connect#toggled (handle_change on_bg_toggled));
ignore(wcol_foreground#connect#color_set (handle_change on_fg_set));
ignore(wcol_background#connect#color_set (handle_change on_bg_set));
ignore(wc_bold#connect#toggled (handle_change on_bold_toggled));
ignore(wc_italic#connect#toggled (handle_change on_italic_toggled));
ignore(wc_strike#connect#toggled (handle_change on_strike_toggled));
ignore(wc_under#connect#toggled (handle_change on_under_toggled));
end
let edit_lang_style ?modal lang =
let d = GWindow.dialog ?modal ~type_hint: `DIALOG ~width: 400 ~height: 400 () in
let ledit = new lang_style_box () in
let f_ok () =
store_lang_style lang;
d#destroy ()
in
let f_cancel () =
read_lang_style lang;
d#destroy ()
in
ledit#set_lang (Some lang);
d#vbox#pack ~expand: true ~fill: true ledit#box;
d#add_button_stock `OK `OK;
d#add_button_stock `CANCEL `CANCEL;
match d#run () with
`OK -> f_ok ()
| `CANCEL
| `DELETE_EVENT -> f_cancel ()
class multi_lang_style_box () =
let vbox = GPack.vbox () in
let languages =
sort_languages_by_name
source_languages_manager#get_available_languages
in
let (combo,get_lang) =
let hb = GPack.hbox ~packing: (vbox#pack ~expand: false ~fill: true) () in
let _ = GMisc.label ~text: "Highlight mode: "
~packing: (hb#pack ~expand: false ~fill: true) () in
let (combo,_) as ct = GEdit.combo_box_text
~packing: (hb#pack ~expand: true ~fill: true)
~strings: (List.map (fun l -> l#get_name) languages)
()
in
(combo,fun () -> GEdit.text_combo_get_active ct)
in
let lang_box = new lang_style_box () in
let _ = vbox#pack ~expand: true ~fill: true lang_box#box in
object(self)
method box = vbox#coerce
method private set_lang =
let lang =
match get_lang() with
None -> None
| Some name ->
try Some (List.find (fun l -> l#get_name = name) languages)
with Not_found -> None
in
lang_box#set_lang lang
method save = List.iter store_lang_style languages
method restore = List.iter read_lang_style languages
initializer
ignore(combo#connect#changed (fun () -> self#set_lang));
(
match languages with
[] -> ()
| l :: _ -> combo#set_active 0
);
end
let edit_available_languages_styles ?modal () =
let d = GWindow.dialog ?modal ~type_hint: `DIALOG ~width: 400 ~height: 400 () in
let b = new multi_lang_style_box () in
let f_ok () = b#save; d#destroy () in
let f_cancel () = b#restore; d#destroy () in
d#vbox#pack ~expand: true ~fill: true b#box;
d#add_button_stock `OK `OK;
d#add_button_stock `CANCEL `CANCEL;
match d#run () with
`OK -> f_ok ()
| `CANCEL
| `DELETE_EVENT -> f_cancel ()
let color_of_string s =
Gdk.Color.alloc ~colormap: (Gdk.Color.get_system_colormap())
(`NAME s)
class sourceview_props_box f_preview =
let vbox = GPack.vbox () in
let wftabs = GBin.frame ~label: "Tab stops"
~packing: (vbox#pack ~fill: true ~padding: 3) () in
let vbtabs = GPack.vbox ~packing: wftabs#add () in
let hbtabs = GPack.hbox ~packing: (vbtabs#pack ~expand: false ~fill: true) () in
let _ = GMisc.label ~text: "Tab width: " ~packing: (hbtabs#pack ~expand: false) () in
let spin_tabs_width = GEdit.spin_button
~rate: 1.0 ~digits: 0 ~numeric: true
~snap_to_ticks: true ~value: 2.0 ~wrap: false
~packing: (hbtabs#pack ~expand: false) () in
let _ = spin_tabs_width#adjustment#set_bounds ~lower: 1.0 ~upper: 40.0
~step_incr: 1.0 () in
let wc_tabs_spaces = GButton.check_button
~label: "Insert spaces instead of tabs"
~packing: (vbtabs#pack ~expand: false ~fill: true) () in
let wfautoindent = GBin.frame ~label: "Automatic indentation"
~packing: (vbox#pack ~fill: true ~padding: 3) () in
let wc_auto_indent = GButton.check_button
~label: "Enable automatic indentation"
~packing: wfautoindent#add () in
let wffont = GBin.frame ~label: "Font"
~packing: (vbox#pack ~fill: true ~padding: 3) () in
let vbfont = GPack.vbox ~packing: wffont#add () in
let wc_default_font = GButton.check_button
~label: "Use default theme font"
~packing: (vbfont#pack ~expand: false ~fill: true) () in
let hbfont = GPack.hbox ~packing: (vbfont#pack ~expand: false ~fill: true) () in
let _ = GMisc.label ~text: "Use this font: "
~packing: (hbfont#pack ~expand: false ~fill: true) () in
let wb_font = GButton.font_button
~packing: (hbfont#pack ~expand: true ~fill: true) () in
let wfcolors = GBin.frame ~label: "Colors"
~packing: (vbox#pack ~fill: true ~padding: 3) () in
let tblcolors = GPack.table ~columns: 3 ~rows: 3 ~packing: wfcolors#add () in
let f_colbut top text =
let _ = GMisc.label ~text: (text^": ") ~packing: (tblcolors#attach ~left: 0 ~top) () in
let wc = GButton.check_button ~label: "default" ~packing: (tblcolors#attach ~left: 1 ~top) () in
let _ = GMisc.label ~text: " or use this color: " ~packing: (tblcolors#attach ~left: 2 ~top) () in
(wc, GButton.color_button ~packing: (tblcolors#attach ~left: 3 ~top) ())
in
let (wc_fg, wcol_fg) = f_colbut 0 "Normal text color" in
let (wc_bg, wcol_bg) = f_colbut 1 "Background color" in
let (wc_sel_fg, wcol_sel_fg) = f_colbut 2 "Selected text color" in
let (wc_sel_bg, wcol_sel_bg) = f_colbut 3 "Selection color" in
object(self)
method box = vbox#coerce
val mutable props = (None : source_view_props option)
method props = props
method set_props o =
props <- o;
self#update_params_widgets
method private update_params_widgets =
match props with
None -> vbox#misc#set_sensitive false
| Some st ->
vbox#misc#set_sensitive true;
let n = match st.sv_tabs_width with
None -> 2
| Some n -> n
in
spin_tabs_width#set_value (float n);
wc_tabs_spaces#set_active st.sv_tabs_spaces;
wc_auto_indent#set_active st.sv_auto_indent;
wc_bg#set_active (st.sv_background = None);
(match st.sv_background with
None -> ()
| Some c -> wcol_bg#set_color (color_of_string c)
);
wc_fg#set_active (st.sv_foreground = None);
(match st.sv_foreground with
None -> ()
| Some c -> wcol_fg#set_color (color_of_string c)
);
wc_sel_bg#set_active (st.sv_sel_background = None);
(match st.sv_sel_background with
None -> ()
| Some c -> wcol_sel_bg#set_color (color_of_string c)
);
wc_sel_fg#set_active (st.sv_sel_foreground = None);
(match st.sv_sel_foreground with
None -> ()
| Some c -> wcol_sel_fg#set_color (color_of_string c)
);
wc_default_font#set_active (st.sv_font = None);
(
match st.sv_font with
None -> ()
| Some s -> wb_font#set_font_name s
);
initializer
let handle_change (f : source_view_props -> unit) =
fun () ->
match props with
None -> ()
| Some st -> f st; f_preview st
in
let on_fg_toggled st =
let fg = not wc_fg#active in
wcol_fg#misc#set_sensitive fg;
if fg then
st.sv_foreground <- Some (string_of_color wcol_fg#color)
else
st.sv_foreground <- None
in
let on_bg_toggled st =
let bg = not wc_bg#active in
wcol_bg#misc#set_sensitive bg;
if bg then
st.sv_background <- Some (string_of_color wcol_bg#color)
else
st.sv_background <- None
in
let on_sel_fg_toggled st =
let fg = not wc_sel_fg#active in
wcol_sel_fg#misc#set_sensitive fg;
if fg then
st.sv_sel_foreground <- Some (string_of_color wcol_sel_fg#color)
else
st.sv_sel_foreground <- None
in
let on_sel_bg_toggled st =
let bg = not wc_sel_bg#active in
wcol_sel_bg#misc#set_sensitive bg;
if bg then
st.sv_sel_background <- Some (string_of_color wcol_sel_bg#color)
else
st.sv_sel_background <- None
in
let on_fg_set st =
if st.sv_foreground <> None then
st.sv_foreground <- Some (string_of_color wcol_fg#color)
in
let on_bg_set st =
if st.sv_background <> None then
st.sv_background <- Some (string_of_color wcol_bg#color)
in
let on_sel_fg_set st =
if st.sv_sel_foreground <> None then
st.sv_sel_foreground <- Some (string_of_color wcol_sel_fg#color)
in
let on_sel_bg_set st =
if st.sv_sel_background <> None then
st.sv_sel_background <- Some (string_of_color wcol_sel_bg#color)
in
let on_font_toggled st =
let fn = not wc_default_font#active in
wb_font#misc#set_sensitive fn;
if fn then
st.sv_font <- Some wb_font#font_name
else
st.sv_font <- None
in
let on_font_set st =
if st.sv_font <> None then
st.sv_font <- Some wb_font#font_name
in
let on_bool_toggled (wc : GButton.toggle_button) f st = f st wc#active in
let on_auto_indent_toggled =
on_bool_toggled wc_auto_indent (fun st b -> st.sv_auto_indent <- b)
in
let on_tabs_spaces_toggled =
on_bool_toggled wc_tabs_spaces (fun st b -> st.sv_tabs_spaces <- b)
in
let on_tabs_width_changed st =
st.sv_tabs_width <- Some spin_tabs_width#value_as_int
in
ignore(wcol_fg#connect#color_set (handle_change on_fg_set));
ignore(wcol_bg#connect#color_set (handle_change on_bg_set));
ignore(wcol_sel_fg#connect#color_set (handle_change on_sel_fg_set));
ignore(wcol_sel_bg#connect#color_set (handle_change on_sel_bg_set));
ignore(wb_font#connect#font_set (handle_change on_font_set));
List.iter
(fun ((wc : GButton.toggle_button),f) -> ignore (wc#connect#toggled (handle_change f)))
[
wc_bg, on_bg_toggled ;
wc_fg, on_fg_toggled ;
wc_sel_bg, on_sel_bg_toggled ;
wc_sel_fg, on_sel_fg_toggled ;
wc_default_font, on_font_toggled ;
wc_auto_indent, on_auto_indent_toggled ;
wc_tabs_spaces, on_tabs_spaces_toggled ;
];
ignore(spin_tabs_width#connect#value_changed (handle_change on_tabs_width_changed));
end
let edit_sourceview_props ?modal ?(preview=apply_sourceview_props_to_registered) () =
let d = GWindow.dialog ?modal ~type_hint: `DIALOG ~width: 400 ~height: 600 () in
let box = new sourceview_props_box preview in
let f_ok () =
(
match box#props with
None -> ()
| Some p -> store_sourceview_props p; preview p
);
d#destroy ()
in
let f_cancel () =
let p = read_sourceview_props () in
preview p;
d#destroy ()
in
box#set_props (Some (read_sourceview_props ()));
d#vbox#pack ~expand: true ~fill: true box#box;
d#add_button_stock `OK `OK;
d#add_button_stock `CANCEL `CANCEL;
match d#run () with
`OK -> f_ok ()
| `CANCEL
| `DELETE_EVENT -> f_cancel ()