(**************************************************************************)
(*                   Cameleon                                             *)
(*                                                                        *)
(*      Copyright (C) 2002 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 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 General Public License for more details.                      *)
(*                                                                        *)
(*      You should have received a copy of the GNU 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                                *)
(**************************************************************************)

(** GUI for configuration. *)

open Cam_types

module C = Configwin
module M = Cam_messages

let (!!) = Options.(!!)
let (=:=) = Options.(=:=)


let remove_char s c = 
  if s <> "" then
    for i = 0 to (String.length s) - 1 do
      if s.[i] = c then s.[i] <- ' '
    done;
  s


let params_for_file_type ft =
  let param_name = 
    C.string ~f: (fun s -> ft.ft_name <- remove_char s ';')
      Cam_messages.file_type ft.ft_name
  in
  let param_re = C.string 
      ~f: (fun s -> 
	    ft.ft_regexp_string <- remove_char s ';' ;
	    ft.ft_regexp <- Str.regexp ft.ft_regexp_string
	  )
      Cam_messages.pattern ft.ft_regexp_string
  in
  let param_color = C.color
      ~f: (fun s -> 
	     let new_c = 
	       match Str.global_replace (Str.regexp "[' ' '\t']") "" 
		   (remove_char s ';')
	       with
		 "" -> None
	       | s2 -> Some s2
	     in
	     ft.ft_color <- new_c
	  )
      Cam_messages.color (match ft.ft_color with None -> "" | Some c -> c)
  in
  let param_binary = C.bool
      ~f: (fun b -> ft.ft_binary <- b)
      Cam_messages.binary ft.ft_binary
  in
  let param_editor = C.combo
      ~f: (fun s -> ft.ft_edit <- Cam_types.editor_of_string s)
      Cam_messages.editor
      ((List.map fst Cam_types.editor_strings) @ (List.map fst !Cam_global.custom_editors))
      (Cam_types.string_of_editor ft.ft_edit)
  in
  let param_templates = C.filenames
      ~f: (fun l -> ft.ft_templates <- List.map (fun s -> remove_char s ',') l)
      Cam_messages.templates ft.ft_templates
  in
  [ param_name ; param_re ; param_color ; param_binary ; param_editor ; param_templates ]

(** File types configuration parameters. *)
let params_file_types () =
  let f_edit ft =
    ignore(C.simple_get Cam_messages.file_type (params_for_file_type ft));
    ft
  in
  let f_add () =
    let ft = {
      ft_name = "" ;
      ft_regexp_string = "" ;
      ft_regexp = Str.regexp "" ;
      ft_color = None ;
      ft_edit = !Cam_types.default_editor ;
      ft_templates = [] ;
      ft_binary = false ;
    }	
    in
    match C.simple_get Cam_messages.add 
	(params_for_file_type ft)
    with
      C.Return_cancel -> []
    | C.Return_apply
    | C.Return_ok -> 
	[ft]
  in
  let f_strings ft =
    [ ft.ft_name ;
      ft.ft_regexp_string ;
      (match ft.ft_color with None -> "" | Some c -> c) ;
      (if ft.ft_binary then Cam_messages.mYes else Cam_messages.mNo) ;
      (Cam_types.string_of_editor ft.ft_edit) ;
      (String.concat ", " ft.ft_templates) ;
    ] 
  in
  let param_l = C.list 
    ~f: (fun l -> Cam_config.file_types =:= l)
    ~eq: (fun f1 f2 -> f1.ft_regexp_string = f2.ft_regexp_string)
    ~edit: f_edit
    ~add: f_add
    ~titles: [ Cam_messages.file_type ;
	       Cam_messages.pattern ;
	       Cam_messages.color ;
	       Cam_messages.binary ;
	       Cam_messages.editor ;
	       Cam_messages.templates ;
	     ] 
    ~color: (fun ft -> ft.ft_color)
    Cam_messages.file_types
    f_strings
    !!Cam_config.file_types
  in
  let param_default_editor = C.combo
      ~f: (fun s -> Cam_types.default_editor := Cam_types.editor_of_string s)
      Cam_messages.default_editor
      ((List.map fst Cam_types.editor_strings) @ (List.map fst !Cam_global.custom_editors))
      (Cam_types.string_of_editor !Cam_types.default_editor)
  in
  [ param_l ; param_default_editor ]

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

let params_for_doc_source ds =
  let remove_column s = Str.global_replace (Str.regexp "::") "  " s in
  let param_file = C.filename
      ~f:(fun s -> ds.ds_file <- remove_column s)
      Cam_messages.file ds.ds_file
  in
  let param_label = C.string
      ~f: (fun s -> 
	     let new_v = 
	       match ds.ds_label_com with
		 None -> Some (s, "")
	       | Some (_, c) -> Some (s, c)
	     in
	     ds.ds_label_com <- new_v
	  )
      Cam_messages.label 
      (match ds.ds_label_com with None -> "" | Some (l,_) -> l)
  in
  let param_command = C.string
      ~f: (fun s -> 
	     let new_v = 
	       match ds.ds_label_com with
		 None -> Some ("", s)
	       | Some (l, _) -> Some (l, s)
	     in
	     ds.ds_label_com <- new_v
	  )
      Cam_messages.command 
      (match ds.ds_label_com with None -> "" | Some (_, c) -> c)
  in

  [ param_file ; param_label ; param_command ]


(** Doc sources configuration box. *)
let param_doc_sources () =
  let f_edit ds =
    ignore (C.simple_get Cam_messages.doc_file (params_for_doc_source ds)) ;
    ds
  in
  let f_add () =
    let ds = {
      ds_file = "" ;
      ds_label_com = None 
    }	
    in
    match C.simple_get Cam_messages.add 
	(params_for_doc_source ds)
    with
      C.Return_cancel -> []
    | C.Return_apply
    | C.Return_ok -> [ds]
  in
  C.list
    ~f: (fun l -> Cam_config.doc_sources =:= l)
    ~eq: (fun ds1 ds2 -> ds1.ds_file = ds2.ds_file)
    ~edit: f_edit
    ~add: f_add
    ~titles: [ Cam_messages.file ;
	       Cam_messages.label ;
	       Cam_messages.command
	     ] 
    Cam_messages.doc_files
    (fun ds ->
      (ds.ds_file ::
       (match ds.ds_label_com with
	 None -> [ "" ; "" ]
       | Some (l, c) -> [ l ; c ]
       )
      )
    )
    !!Cam_config.doc_sources


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

let params_for_custom_tool ct =
  let param_pixmap = C.filename
      ~f:(fun s -> ct.tool_pixmap <- remove_char s ';')
      Cam_messages.icon_file
      ct.tool_pixmap
  in
  let param_label = C.string
      ~f: (fun s -> ct.tool_label <- remove_char s ';')
      Cam_messages.label ct.tool_label
  in
  let param_command = C.string
      ~f: (fun s -> ct.tool_command <- remove_char s ';')
      Cam_messages.command ct.tool_command 
  in
  [ param_pixmap ; param_label ; param_command ]

(** Custom tool bar configuration box. *)
class toolbar () =
  let hbox = GPack.hbox () in
  let wscroll = GBin.scrolled_window
      ~vpolicy: `AUTOMATIC
      ~hpolicy: `AUTOMATIC
      ~packing: (hbox#pack ~expand: true) () 
  in
  let wlist = GList.clist 
      ~titles: [ Cam_messages.icon ;
		 Cam_messages.label ;
		 Cam_messages.command ;
	       ] 
      ~titles_show: true
      ~selection_mode: `SINGLE
      ~packing: wscroll#add 
      () 
  in
  let vbox = GPack.vbox ~packing: (hbox#pack ~expand: false ~padding: 4) () in
  let wb_add = GButton.button ~label: Cam_messages.add 
      ~packing: (vbox#pack ~expand: false ~padding: 2) ()
  in
  let wb_edit = GButton.button ~label: Cam_messages.edit 
      ~packing: (vbox#pack ~expand: false ~padding: 2) ()
  in
  let wb_up = GButton.button ~label: Cam_messages.up 
      ~packing: (vbox#pack ~expand: false ~padding: 2) ()
  in
  let wb_remove = GButton.button ~label: Cam_messages.remove 
      ~packing: (vbox#pack ~expand: false ~padding: 2) ()
  in
  object (self)
    val mutable custom_tools = []
    val mutable selection = (None : custom_tool option)

    method set_custom_tools l = custom_tools <- l

    method box = hbox
    method apply () = Cam_config.custom_tools =:= custom_tools
    method update =
      wlist#clear () ;
      wlist#freeze () ;
      let f ct = 
	let _ = wlist#append 
	    [ ct.tool_pixmap ;
	      ct.tool_label ;
	      ct.tool_command ;
	    ] 
	in
	try
	  let gdk_pix = GDraw.pixmap_from_xpm 
	      ~file: ct.tool_pixmap
	      ~colormap: (Gdk.Color.get_system_colormap ())
	      () 
	  in
	  ignore (wlist#set_cell ~pixmap: gdk_pix (wlist#rows -1) 0)
	with
	  _ ->
	    ignore (wlist#set_row ~foreground: (`NAME "Red") (wlist#rows -1))
      in
      List.iter f custom_tools;
      GToolbox.autosize_clist wlist ;
      wlist#thaw ()

    method up_selected =
      match selection with
	None -> ()
      |	Some ct ->
	  let rec f = function
              ele1 :: ele2 :: q -> 
		if ele2 == ct then
		  ele2 :: ele1 :: q
		else
		  ele1 :: (f (ele2 :: q))
            | l -> l
	  in
	  self#set_custom_tools (f custom_tools) ;
	  self#update

    method edit_selected =
      match selection with
	None -> ()
      |	Some ct ->
	  match C.simple_get Cam_messages.file_type
	      (params_for_custom_tool ct)
	  with
	    C.Return_cancel -> ()
	  | C.Return_apply -> ()
	  | C.Return_ok -> self#update

    method remove_selected =
      match selection with
	None -> ()
      |	Some ct ->
	  self#set_custom_tools
	    (List.filter
	       (fun ct2 -> ct2.tool_command <> ct.tool_command)
	       custom_tools) ;
	  self#update

    method add =
      let ct = {
	tool_pixmap = "" ;
	tool_label = "" ;
	tool_command = "" ;
      }	
      in
      match C.simple_get Cam_messages.add 
	  (params_for_custom_tool ct)
      with
	C.Return_cancel -> ()
      | C.Return_apply -> ()
      | C.Return_ok -> 
	  self#set_custom_tools (custom_tools @ [ct]) ;
	  self#update

    initializer 
      (* connect the selection and deselection of items in the clist *)
      let f_select ~row ~column ~event =
	try selection <- Some (List.nth custom_tools row)
	with Failure _ -> selection <- None
      in
      let f_unselect ~row ~column ~event = selection <- None in
      (* connect the select and deselect events *)
      let _ = wlist#connect#select_row f_select in
      let _ = wlist#connect#unselect_row f_unselect in

      let _ = wb_add#connect#clicked (fun () -> self#add) in
      let _ = wb_edit#connect#clicked (fun () -> self#edit_selected) in
      let _ = wb_up#connect#clicked (fun () -> self#up_selected) in
      let _ = wb_remove#connect#clicked (fun () -> self#remove_selected) in
      
      self#set_custom_tools !!Cam_config.custom_tools ;
      self#update
  end

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

module N = Cam_menus

let rec copy_menu m =
  { N.mn_label = m.N.mn_label ;
    N.mn_doc = m.N.mn_doc ;
    N.mn_children = List.map copy_menu_item m.N.mn_children ;
  } 

and copy_menu_item mi =
  match mi with
    N.Separator s -> N.Separator (String.copy s)
  | N.Command i -> N.Command { N.mii_label = i.N.mii_label ;
			       N.mii_command = i.N.mii_command }
  | N.Submenu m -> N.Submenu (copy_menu m)


let list_up l ele =
  let rec iter = function
      [] -> []
    | [e] -> [e]
    | e1 :: e2 :: q ->
	if e2 == ele then
	  e2 :: e1 :: q
	else
	  e1 :: (iter (e2 :: q))
  in
  iter l


let params_menu_item mi =
  match mi with
    N.Separator _ -> []
  | N.Command mii ->
      let coms = Cam_global.available_commands () in
      let param_label = C.string 
	  ~f: (fun s -> mii.N.mii_label <- s)
	  M.label
	  mii.N.mii_label
      in
      let param_command = C.combo
	  ~f: (fun s -> mii.N.mii_command <- s)
	  ~new_allowed: true
	  ~blank_allowed: false
	  M.command
	  coms
	  mii.N.mii_command
      in
      [ param_label ; param_command ]
  | N.Submenu m ->
      let param_label = C.string 
	  ~f: (fun s -> m.N.mn_label <- s)
	  M.label
	  m.N.mn_label
      in
      let param_doc = C.bool
	  ~f: (fun b -> m.N.mn_doc <- b)
	  M.doc_flag
	  m.N.mn_doc
      in
      [ param_label ; param_doc ]

(** Menu configuration box *)
class menu_box () =
  let hbox = GPack.hbox () in
  let wscroll = GBin.scrolled_window 
      ~hpolicy: `AUTOMATIC
      ~vpolicy: `AUTOMATIC
      ~packing: (hbox#pack ~expand: true)
      ()
  in
  let wtree = GTree.tree ~packing: wscroll#add_with_viewport () in
  let vbox = GPack.vbox ~packing: (hbox#pack ~expand: false ~padding: 4) () in
  let wb_copy = GButton.button ~label: M.copy
      ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_cut = GButton.button ~label: M.cut
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_paste = GButton.button ~label: M.paste
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_edit = GButton.button ~label: M.edit
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_up = GButton.button ~label: M.up
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_add = GButton.button ~label: M.add
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  
  object (self)
    val mutable menus = !Cam_global.menus

    val mutable selection = 
      (None : (N.menu option * GTree.tree * N.menu_item * GTree.tree_item) option)

    val mutable buffer = (None : N.menu_item option)

    method box = hbox
    method apply () = Cam_global.menus := menus

    method edit () =
      match selection with
	None -> ()
      |	Some (m_opt,wt,mi,item) ->
	  match C.simple_get M.edit (params_menu_item mi) with
	    C.Return_cancel -> ()
	  | C.Return_apply
	  | C.Return_ok ->
	      let pos = wt#child_position item in
	      wt#remove item;
	      match m_opt, mi with
		None, N.Submenu m ->
		  self#insert_menu ~pos: pos wtree m
	      |	None, _ -> 
		  prerr_endline "menu_box: strange case"
	      |	Some m, _ ->
		  self#insert_menu_item ~pos: pos m wt mi

    method copy () =
      match selection with
	None -> ()
      |	Some (_,_,mi,_) -> buffer <- Some (copy_menu_item mi)

    method cut () =
      match selection with
	None -> ()
      |	Some (None,wt,(N.Submenu menu),item) -> 
	  self#copy ();
	  menus <- List.filter (fun m -> not (m == menu)) menus;
	  wt#remove item;
	  selection <- None
      |	Some (None,_,_,_) ->
	  ()
      |	Some (Some menu,wt,mi,item) ->
	  self#copy ();
	  menu.N.mn_children <- 
	    List.filter (fun i -> not (i == mi)) menu.N.mn_children;
	  wt#remove item;
	  selection <- None

    method paste () =
      match buffer with
	None -> ()
      |	Some mi ->
	  match selection with
	    None ->
	      (match mi with
		N.Submenu m ->
		  menus <- menus @ [m];
		  self#insert_menu wtree m
	      |	_ ->
		  ()
	      )
	  | Some (_,_,N.Submenu m,item) ->
	      m.N.mn_children <- m.N.mn_children @ [mi];
	      let wt = 
		match item#subtree with
		  None -> 
		    let w = GTree.tree () in
		    item#set_subtree w;
		    item#expand ();
		    w
		| Some w -> w
	      in
	      self#insert_menu_item m wt mi
	  | _ ->
	      ()

    method up () =
      match selection with
	None -> ()
      |	Some (None,wt,(N.Submenu menu),item) -> 
	  let pos = wt#child_position item in
	  if pos = 0 then 
	    ()
	  else
	    (
	     menus <- list_up menus menu;
	     wt#remove item;
	     self#insert_menu ~pos: (pos - 1) wt menu;
	     wt#select_item (pos - 1)
	    )
      |	Some (None,_,_,_) ->
	  ()
      |	Some (Some menu,wt,mi,item) ->
	  let pos = wt#child_position item in
	  if pos = 0 then 
	    ()
	  else
	    (
	     menu.N.mn_children <- list_up menu.N.mn_children mi;
	     wt#remove item;
	     self#insert_menu_item ~pos: (pos - 1) menu wt mi;
	     wt#select_item (pos - 1)
	    )

    method insert_menu ?pos ?father tree m =
      let item = GTree.tree_item 
	  ~label: (Printf.sprintf "%s%s" 
		     (if m.N.mn_doc then "["^Cam_messages.m_doc^"]" else "")
		     m.N.mn_label)
	  ()
      in
      (match pos with
	None -> tree#append item
      | Some p -> tree#insert item p
      );
      let wt = GTree.tree () in
      item#set_subtree wt;
      item#expand ();
      List.iter (self#insert_menu_item m wt) m.N.mn_children;
      ignore 
	(item#connect#select
	   (fun () -> selection <- Some (father, tree, (N.Submenu m), item))
	);
      ignore 
	(item#connect#deselect (fun () -> selection <- None));

    method insert_menu_item ?pos menu wt mi =
      match mi with
	N.Separator _ ->
	  let item = GTree.tree_item ~label: "-----------" () in
	  (match pos with
	    None -> wt#append item
	  | Some p -> wt#insert item p
	  );
	  ignore 
	    (item#connect#select
	       (fun () -> selection <- Some (Some menu, wt, mi, item))
	    );
	  ignore 
	    (item#connect#deselect (fun () -> selection <- None))

      | N.Command mii ->
	  let item = GTree.tree_item 
	      ~label: (mii.N.mii_label^" ["^mii.N.mii_command^"]")
	      () 
	  in	    
	  (match pos with
	    None -> wt#append item
	  | Some p -> wt#insert item p
	  );
	  ignore 
	    (item#connect#select
	       (fun () -> selection <- Some (Some menu, wt, mi, item))
	    );
	  ignore 
	    (item#connect#deselect (fun () -> selection <- None))
	    
      | N.Submenu m ->
	  self#insert_menu ?pos ~father: menu wt m

    method add_menu_item title mi =
      match C.simple_get title (params_menu_item mi) with
	C.Return_cancel -> ()
      | C.Return_apply
      | C.Return_ok ->
	  let b = buffer in
	  buffer <- Some mi;
	  self#paste ();
	  buffer <- b

    method add_menu () =
      let m = { N.mn_label = "" ;
		N.mn_doc = false ;
		N.mn_children = [] }
      in
      self#add_menu_item M.add_menu (N.Submenu m)

    method add_command () =
      let c = { N.mii_label = "" ;
		N.mii_command = Cam_messages.a_new_file ;
	      }	
      in
      self#add_menu_item M.add_command (N.Command c)

    method add_separator () =
      let b = buffer in
      buffer <- Some (N.Separator " ");
      self#paste ();
      buffer <- b

    method add_select () =
      let choices = 
	match selection with
	  None -> [ M.menu, self#add_menu ]
	| Some (_,_,(N.Submenu menu),_) -> 
	    [ M.menu, self#add_menu ;
	      M.command, self#add_command ;
	      M.separator, self#add_separator ]
	| _ ->
	    []
      in
      match choices with
	[] -> ()
      |	l -> 
	  GToolbox.popup_menu ~button: 1 ~time: 0 
	    ~entries: (List.map (fun (l,f) -> `I (l,f)) l)

    method update =
      wtree#remove_items wtree#children;
      List.iter (self#insert_menu wtree) menus

    initializer
      self#update;
      ignore (wb_copy#connect#clicked self#copy);
      ignore (wb_cut#connect#clicked self#cut);
      ignore (wb_paste#connect#clicked self#paste);
      ignore (wb_edit#connect#clicked self#edit);
      ignore (wb_up#connect#clicked self#up);
      ignore (wb_add#connect#clicked self#add_select);
  end

let color op label = C.color ~f: (fun s -> op =:= s) label !!op 
let font op label = C.font ~f: (fun s -> op =:= s) label !!op 

(** Return the list of parameters for the colors and fonts in the doc browser. *)
let doc_colors_fonts_params () =
  let col_types = color Cam_config.color_doc_type M.types_color in
  let col_kws = color Cam_config.color_doc_keyword M.keywords_color in
  let col_cons = color Cam_config.color_doc_constructor M.constructors_color in
  let col_code = color Cam_config.color_doc_code M.code_color in
  let font_doc_normal = font Cam_config.font_doc_normal M.doc_normal_font in
  let font_doc_code = font Cam_config.font_doc_code M.doc_code_font in
  let font_doc_bold = font Cam_config.font_doc_bold M.doc_bold_font in
  let font_doc_code_bold = font Cam_config.font_doc_code_bold M.doc_code_bold_font in
  [ col_types ; col_kws ; col_cons ; col_code ; 
    font_doc_normal ; font_doc_code ; font_doc_code_bold ; font_doc_bold ;
  ]

(** Return the list of parameters for the colors and fonts in the execution window. *)
let exec_colors_fonts_params () =
  let col_stdout = color Cam_config.color_exec_stdout M.exec_stdout_color in
  let col_stderr = color Cam_config.color_exec_stderr M.exec_stderr_color in
  let font_exec = font Cam_config.font_exec M.exec_font in
  [col_stdout ; col_stderr ; font_exec]

(** Return the list of parameters for the colors and fonts in the modules view. *)
let view_colors_fonts_params () =
  let col_module = color Cam_config.color_view_module M.view_module_color in
  let col_class = color Cam_config.color_view_class M.view_class_color in
  let col_type = color Cam_config.color_view_type M.view_type_color in
  let col_value = color Cam_config.color_view_value M.view_value_color in
  let col_exception = color Cam_config.color_view_exception M.view_exception_color in
  [ col_module ; col_class ; col_type ; col_value ; col_exception ]

(** Edit a binding. *)
let edit_binding new_allowed avail_commands (binding, action) =
  let ref_b = ref binding in
  let ref_a = ref action in
  let p_key = C.hotkey ~f: (fun k -> ref_b := k) M.binding !ref_b in
  let p_action = C.combo
      ~f: (fun s -> ref_a := s)
      ~new_allowed
      ~blank_allowed: false
      M.command
      avail_commands
      !ref_a
  in
  let ret = (C.simple_get M.edit_binding [ p_key ; p_action ]) = C.Return_ok in
  (ret, (!ref_b, !ref_a))

let add_binding new_allowed avail_commands () =
  let (ret, (b, a)) = edit_binding new_allowed avail_commands 
      (([`CONTROL], GdkKeysyms._A), "")
  in
  if ret then [b, a] else []

(** The params for the doc browser key bindings. *)
let doc_browser_bindings_param () =
  [C.list
      ~f: (fun l -> Cam_config.keymap_doc =:= l)
      ~titles: [ M.binding ; M.command ]
      ~add: (add_binding false M.doc_browser_actions)
      ~edit: (fun (b,a) -> snd (edit_binding false M.doc_browser_actions (b,a)))
      M.doc_browser_bindings
      (fun (k,a) -> [Cam_config.KeyOption.key_to_string k ; a])
      !!Cam_config.keymap_doc
  ]  

(** The params for the mani window key bindings. *)
let main_window_bindings_param () =
  [C.list
      ~f: (fun l -> Cam_config.keymap_main =:= l)
      ~titles: [ M.binding ; M.command ]
      ~add: (add_binding true (Cam_global.available_commands ()))
      ~edit: (fun (b,a) -> snd (edit_binding true (Cam_global.available_commands ()) (b,a)))
      M.main_window_bindings
      (fun (k,a) -> [Cam_config.KeyOption.key_to_string k ; a])
      !!Cam_config.keymap_main
  ]  

(** Create the configuration window and handle the user actions. *)
let config f_update =
  let save_file_types = 
    (* make a backup copy for the case the user cancels. *)
    List.map
      (fun ft -> { ft with ft_name = ft.ft_name })
      !!Cam_config.file_types
  in
  let params_ft = params_file_types () in

  let save_doc_sources = 
    (* make a backup copy for the case the user cancels. *)
    List.map
      (fun ds -> { ds with ds_file = ds.ds_file })
      !!Cam_config.doc_sources
  in
  let param_ds = param_doc_sources () in

  let save_custom_tools = 
    (* make a backup copy for the case the user cancels. *)
    List.map
      (fun ct -> { ct with tool_pixmap = ct.tool_pixmap })
      !!Cam_config.custom_tools
  in
  let box_ct = new toolbar () in
  let param_ct = C.custom box_ct#box box_ct#apply true in
  
  (* make a backup copy for the case the user cancels. *)
  let save_menus = List.map copy_menu !Cam_global.menus in
  let box_menus = new menu_box () in
  let param_menus = C.custom box_menus#box box_menus#apply true in

  let opt_auto_update_file_view = C.bool
      ~f: (fun b -> Cam_config.auto_update_file_view =:= b)
      Cam_messages.auto_update_file_view
      !!Cam_config.auto_update_file_view
  in
  let coms = Cam_global.available_commands () in
  let opt_file_db_click_com = C.combo
      ~f: (fun s -> Cam_config.file_double_click_command =:= s)
      ~new_allowed: true
      ~blank_allowed: false
      M.file_double_click_command
      coms
      !!Cam_config.file_double_click_command
  in
  let params_misc = [opt_auto_update_file_view ; opt_file_db_click_com] in

  let structure = 
    [
      C.Section (Cam_messages.file_types, params_ft) ;
      C.Section (Cam_messages.doc_files, [ param_ds ]) ;
      C.Section (Cam_messages.custom_toolbar, [ param_ct ]) ;
      C.Section (Cam_messages.menus, [ param_menus ]) ;
      C.Section_list (Cam_messages.colors_and_fonts, 
		      [ C.Section (Cam_messages.doc_browser, doc_colors_fonts_params ());
			C.Section (Cam_messages.modules_view, view_colors_fonts_params ());
			C.Section (Cam_messages.command_execution, exec_colors_fonts_params ());
		      ]	
		     );
      C.Section_list (M.key_bindings,
		      [ 
			C.Section (Cam_messages.main_window, main_window_bindings_param ()) ;
			C.Section (Cam_messages.doc_browser, doc_browser_bindings_param ()) ;
		      ]	
		     ) ;
      C.Section (Cam_messages.misc_options, params_misc) ;
    ] @
    (List.map (fun f -> f ()) !Cam_global.config_boxes)
  in
  match C.get Cam_messages.configuration 
      ~width: 600 structure 
  with
    C.Return_cancel ->
      Cam_config.file_types =:= save_file_types ;
      Cam_config.doc_sources =:= save_doc_sources ;
      Cam_config.custom_tools =:= save_custom_tools ;
      Cam_global.menus := save_menus ;
  | C.Return_apply -> 
      () (* this case should not occur *)
  | C.Return_ok ->
      (* update the files *) 
      Cam_data.data#reassociate_filetypes ;
      (* rebuild some menus *)
      f_update (!!Cam_config.doc_sources <> save_doc_sources) () ;
      (* and save the config *)
      Options.(=:=) Cam_config.menus (List.map Cam_menus.string_of_menu !Cam_global.menus);
      Options.(=:=) Cam_config.default_editor (Cam_types.string_of_editor !Cam_types.default_editor);
      Cam_config.save_gui () ;
      Cam_config.save_core ()
	
