(*********************************************************************************)

(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005,2006 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Library General Public License as            *)
(*    published by the Free Software Foundation; either version 2 of the         *)
(*    License, or  any later version.                                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Library General Public          *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)


(** *)


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
  
  (** tag name * 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

    (*c==v=[String.split_string]=1.0====*)
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
    (*/c==v=[String.split_string]=1.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 =
  (* [ `NORMAL|`ACTIVE|`PRELIGHT|`SELECTED|`INSENSITIVE ] *)
  (
   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

    
    (**

Editing

*)


    (*c==v=[String.replace_in_string]=1.0====*)
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
    (*/c==v=[String.replace_in_string]=1.0====*)

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 ()