(*********************************************************************************)
(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005 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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** This module contains the gui functions of Configwin.*)

open Configwin_types

let set_help_tip wev = function
  | None -> ()
  | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help

let select_arch m m_osx =
  if Coq_config.arch = "Darwin" then m_osx else m

(* How the modifiers are named in the preference box *)
let modifiers_to_string m =
  let rec iter m s =
    match m with
        [] -> s
      | c :: m ->
          iter m ((
                    match c with
                        `CONTROL -> "<ctrl>"
                      | `SHIFT -> "<shft>"
                      | `LOCK -> "<lock>"
                      | `META -> select_arch "<meta>" "<cmd>"
                      | `MOD1 -> "<alt>"
                      | `MOD2 -> "<mod2>"
                      | `MOD3 -> "<mod3>"
                      | `MOD4 -> "<mod4>"
                      | `MOD5 -> "<mod5>"
                      | _  -> raise Not_found
                  ) ^ s)
  in
    iter m ""

class type widget =
  object
    method box : GObj.widget
    method apply : unit -> unit
  end

let debug = false
let dbg s = if debug then Minilib.log s else ()
(*
(** This class builds a frame with a clist and two buttons :
   one to add items and one to remove the selected items.
   The class takes in parameter a function used to add items and
   a string list ref which is used to store the content of the clist.
   At last, a title for the frame  is also in parameter, so that
   each instance of the class creates a frame. *)
class ['a] list_selection_box
    (listref : 'a list ref)
    titles_opt
    help_opt
    f_edit_opt
    f_strings
    f_color
    (eq : 'a -> 'a -> bool)
    add_function title editable
    =
  let _ = dbg "list_selection_box" in
  let wev = GBin.event_box () in
  let wf = GBin.frame ~label: title ~packing: wev#add () in
  let hbox = GPack.hbox ~packing: wf#add () in
  (* the scroll window and the clist *)
  let wscroll = GBin.scrolled_window
      ~vpolicy: `AUTOMATIC
      ~hpolicy: `AUTOMATIC
      ~packing: (hbox#pack ~expand: true) ()
  in
  let wlist = match titles_opt with
    None ->
      GList.clist ~selection_mode: `MULTIPLE
        ~titles_show: false
        ~packing: wscroll#add ()
  | Some l ->
      GList.clist ~selection_mode: `MULTIPLE
        ~titles: l
        ~titles_show: true
        ~packing: wscroll#add ()
  in
  let _ = set_help_tip wev help_opt in
  (* the vbox for the buttons *)
  let vbox_buttons = GPack.vbox () in
  let _ =
    if editable then
      let _ = hbox#pack ~expand: false vbox_buttons#coerce in
      ()
    else
      ()
  in
  let _ = dbg "list_selection_box: wb_add" in
  let wb_add = GButton.button
      ~label: Configwin_messages.mAdd
      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
      ()
  in
  let wb_edit = GButton.button
      ~label: Configwin_messages.mEdit
      ()
  in
  let _ = match f_edit_opt with
    None -> ()
  | Some _ -> vbox_buttons#pack ~expand:false ~padding:2 wb_edit#coerce
  in
  let wb_up = GButton.button
      ~label: Configwin_messages.mUp
      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
      ()
  in
  let wb_remove = GButton.button
      ~label: Configwin_messages.mRemove
      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
      ()
  in
  let _ = dbg "list_selection_box: object(self)" in
  object (self)
    (** the list of selected rows *)
    val mutable list_select = []

    (** This method returns the frame created. *)
    method box = wev

    method update l =
      (* set the new list in the provided listref *)
      listref := l;
      (* insert the elements in the clist *)
      wlist#freeze ();
      wlist#clear ();
      List.iter
        (fun ele ->
          ignore (wlist#append (f_strings ele));
          match f_color ele with
            None -> ()
          | Some c ->
              try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1)
              with _ -> ()
        )
        !listref;

      (match titles_opt with
        None -> wlist#columns_autosize ()
      |	Some _ -> GToolbox.autosize_clist wlist);
      wlist#thaw ();
      (* the list of selectd elements is now empty *)
      list_select <- []

    (** Move up the selected rows. *)
    method up_selected =
      let rec iter n selrows l =
        match selrows with
          [] -> (l, [])
        | m :: qrows ->
            match l with
              [] -> ([],[])
            | [_] -> (l,[])
            | e1 :: e2 :: q when m = n + 1 ->
                let newl, newrows = iter (n+1) qrows (e1 :: q) in
                (e2 :: newl, n :: newrows)
            | e1 :: q ->
                let newl, newrows = iter (n+1) selrows q in
                (e1 ::  newl, newrows)
      in
      let sorted_select = List.sort compare list_select in
      let new_list, new_rows = iter 0 sorted_select !listref in
      self#update new_list;
      List.iter (fun n -> wlist#select n 0) new_rows

    (** Make the user edit the first selected row. *)
    method edit_selected f_edit =
      let sorted_select = List.sort compare list_select in
      match sorted_select with
        [] -> ()
      |	n :: _ ->
          try
            let ele = List.nth !listref n in
            let ele2 = f_edit ele in
            let rec iter m = function
                [] -> []
              |	e :: q ->
                  if n = m then
                    ele2 :: q
                  else
                    e :: (iter (m+1) q)
            in
            self#update (iter 0 !listref);
            wlist#select n 0
          with
            Not_found ->
              ()

    initializer

      (* create the functions called when the buttons are clicked *)
      let f_add () =
        (* get the files to add with the function provided *)
        let l = add_function () in
        (* remove from the list the ones which are already in
           the listref, using the eq predicate *)
        let l2 = List.fold_left
            (fun acc -> fun ele ->
              if List.exists (eq ele) acc then
                acc
              else
                acc @ [ele])
            !listref
            l
        in
        self#update l2
      in
      let f_remove () =
        (* remove the selected items from the listref and the clist *)
        let rec iter n = function
            [] -> []
          | h :: q ->
              if List.mem n list_select then
                iter (n+1) q
              else
                h :: (iter (n+1) q)
        in
        let new_list = iter 0 !listref in
        self#update new_list
      in
      let _ = dbg "list_selection_box: connecting wb_add" in
      (* connect the functions to the buttons *)
      ignore (wb_add#connect#clicked ~callback:f_add);
      let _ = dbg "list_selection_box: connecting wb_remove" in
      ignore (wb_remove#connect#clicked ~callback:f_remove);
      let _ = dbg "list_selection_box: connecting wb_up" in
      ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected));
      (
       match f_edit_opt with
         None -> ()
       | Some f ->
           let _ = dbg "list_selection_box: connecting wb_edit" in
           ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f))
      );
      (* connect the selection and deselection of items in the clist *)
      let f_select ~row ~column ~event =
        try
          list_select <- row :: list_select
        with
          Failure _ ->
            ()
      in
      let f_unselect ~row ~column ~event =
        try
          let new_list_select = List.filter (fun n -> n <> row) list_select in
          list_select <- new_list_select
        with
          Failure _ ->
            ()
      in
      (* connect the select and deselect events *)
      let _ = dbg "list_selection_box: connecting select_row" in
      ignore(wlist#connect#select_row ~callback:f_select);
      let _ = dbg "list_selection_box: connecting unselect_row" in
      ignore(wlist#connect#unselect_row ~callback:f_unselect);

      (* initialize the clist with the listref *)
      self#update !listref
  end;;
*)

(** This class is used to build a box for a string parameter.*)
class string_param_box param =
  let _ = dbg "string_param_box" in
  let hbox = GPack.hbox () in
  let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
  let _wl = GMisc.label ~text: param.string_label ~packing: wev#add () in
  let we = GEdit.entry
      ~editable: param.string_editable
      ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2)
      ()
  in
  let _ = set_help_tip wev param.string_help in
  let _ = we#set_text (param.string_to_string param.string_value) in

  object (self)

    (** This method returns the main box ready to be packed. *)
    method box = hbox#coerce

    (** This method applies the new value of the parameter. *)
    method apply =
      let new_value = param.string_of_string we#text in
      if new_value <> param.string_value then
        let _ = param.string_f_apply new_value in
        param.string_value <- new_value
      else
        ()
  end ;;

(** This class is used to build a box for a combo parameter.*)
class combo_param_box param =
    let _ = dbg "combo_param_box" in
    let hbox = GPack.hbox () in
    let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
    let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in
    let _ = set_help_tip wev param.combo_help in
    let get_value = if not param.combo_new_allowed then
      let wc = GEdit.combo_box_text
        ~strings: param.combo_choices
        ?active:(let rec aux i = function
                   |[] -> None
                   |h::_ when h = param.combo_value -> Some i
                   |_::t -> aux (succ i) t
                 in aux 0 param.combo_choices)
        ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
        ()
      in
        fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s
    else
      let (wc,_) = GEdit.combo_box_entry_text
       ~strings: param.combo_choices
       ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
       ()
      in
      let _ = wc#entry#set_editable param.combo_editable in
      let _ = wc#entry#set_text param.combo_value in
       fun () -> wc#entry#text
    in
object (self)

  (** This method returns the main box ready to be packed. *)
  method box = hbox#coerce

  (** This method applies the new value of the parameter. *)
  method apply =
    let new_value = get_value () in
      if new_value <> param.combo_value then
        let _ = param.combo_f_apply new_value in
          param.combo_value <- new_value
      else
        ()
end ;;

(** Class used to pack a custom box. *)
class custom_param_box param =
  let _ = dbg "custom_param_box" in
  let top =
    match param.custom_framed with
      None -> param.custom_box#coerce
    | Some l ->
        let wf = GBin.frame ~label: l () in
        wf#add param.custom_box#coerce;
        wf#coerce
  in
  object (self)
    method box = top
    method apply = param.custom_f_apply ()
  end

(** This class is used to build a box for a text parameter.*)
class text_param_box param =
  let _ = dbg "text_param_box" in
  let wf = GBin.frame ~label: param.string_label ~height: 100 () in
  let wev = GBin.event_box ~packing: wf#add () in
  let wscroll = GBin.scrolled_window
      ~vpolicy: `AUTOMATIC
      ~hpolicy: `AUTOMATIC
      ~packing: wev#add ()
  in
  let wview = GText.view
      ~editable: param.string_editable
      ~packing: wscroll#add
      ()
  in
  let _ = set_help_tip wev param.string_help in
  let _ = dbg "text_param_box: buffer creation" in
  let buffer = GText.buffer () in

  let _ = wview#set_buffer buffer in
  let _ = buffer#insert (param.string_to_string param.string_value) in
  let _ = dbg "text_param_box: object(self)" in
  object (self)
    val wview = wview

    (** This method returns the main box ready to be packed. *)
    method box = wf#coerce

    (** This method applies the new value of the parameter. *)
    method apply =
      let v = param.string_of_string (buffer#get_text ()) in
      if v <> param.string_value then
        (
         dbg "apply new value!";
         let _ = param.string_f_apply v in
         param.string_value <- v
        )
      else
        ()
  end ;;

(** This class is used to build a box for a boolean parameter.*)
class bool_param_box param =
  let _ = dbg "bool_param_box" in
  let wchk = GButton.check_button
      ~label: param.bool_label
      ()
  in
  let _ = set_help_tip wchk param.bool_help in
  let _ = wchk#set_active param.bool_value in
  let _ = wchk#misc#set_sensitive param.bool_editable in

  object (self)

    (** This method returns the check button ready to be packed. *)
    method box = wchk#coerce

    (** This method applies the new value of the parameter. *)
    method apply =
      let new_value = wchk#active in
      if new_value <> param.bool_value then
        let _ = param.bool_f_apply new_value in
        param.bool_value <- new_value
      else
        ()
  end ;;

class modifiers_param_box param =
  let hbox = GPack.hbox () in
  let wev = GBin.event_box ~packing: (hbox#pack ~expand:true ~fill:true ~padding: 2) () in
  let _wl = GMisc.label ~text: param.md_label ~packing: wev#add () in
  let value = ref param.md_value in
  let _ = List.map (fun modifier ->
                      let but = GButton.toggle_button
                                  ~label:(modifiers_to_string [modifier])
                                  ~active:(List.mem modifier param.md_value)
                                  ~packing:(hbox#pack ~expand:false) () in
                      ignore (but#connect#toggled
                                ~callback:(fun _ -> if but#active then value := modifier::!value
                                 else value := List.filter ((<>) modifier) !value)))
            param.md_allow
  in
  let _ = set_help_tip wev param.md_help in
  object (self)

    (** This method returns the main box ready to be packed. *)
    method box = hbox#coerce

    (** This method applies the new value of the parameter. *)
    method apply =
      let new_value = !value in
      if new_value <> param.md_value then
        let _ = param.md_f_apply new_value in
        param.md_value <- new_value
      else
        ()
  end ;;
(*
(** This class is used to build a box for a parameter whose values are a list.*)
class ['a] list_param_box (param : 'a list_param) =
  let _ = dbg "list_param_box" in
  let listref = ref param.list_value in
  let frame_selection = new list_selection_box
      listref
      param.list_titles
      param.list_help
      param.list_f_edit
      param.list_strings
      param.list_color
      param.list_eq
      param.list_f_add param.list_label param.list_editable
      tt
  in

  object (self)

    (** This method returns the main box ready to be packed. *)
    method box = frame_selection#box#coerce

    (** This method applies the new value of the parameter. *)
    method apply =
      param.list_f_apply !listref ;
      param.list_value <- !listref
  end ;;
*)

(** This class creates a configuration box from a configuration structure *)
class configuration_box conf_struct =

  let main_box = GPack.hbox () in

  let columns = new GTree.column_list in
  let icon_col = columns#add GtkStock.conv in
  let label_col = columns#add Gobject.Data.string in
  let box_col = columns#add Gobject.Data.caml in
  let () = columns#lock () in

  let pane = GPack.paned `HORIZONTAL ~packing:main_box#add () in

  (* Tree view part *)
  let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~packing:pane#pack1 () in
  let tree = GTree.tree_store columns in
  let view = GTree.view ~model:tree ~headers_visible:false ~packing:scroll#add_with_viewport () in
  let selection = view#selection in
  let _ = selection#set_mode `SINGLE in

  let menu_box = GPack.vbox ~packing:pane#pack2 () in

  let renderer = (GTree.cell_renderer_pixbuf [], ["stock-id", icon_col]) in
  let col = GTree.view_column ~renderer () in
  let _ = view#append_column col in

  let renderer = (GTree.cell_renderer_text [], ["text", label_col]) in
  let col = GTree.view_column ~renderer () in
  let _ = view#append_column col in

  let make_param (main_box : #GPack.box) = function
  | String_param p ->
    let box = new string_param_box p in
    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
    box
  | Combo_param p ->
    let box = new combo_param_box p in
    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
    box
  | Text_param p ->
    let box = new text_param_box p in
    let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
    box
  | Bool_param p ->
    let box = new bool_param_box p in
    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
    box
  | List_param f ->
    let box = f () in
    let _ = main_box#pack ~expand: true ~padding: 2 box#box in
    box
  | Custom_param p ->
    let box = new custom_param_box p in
    let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
    box
  | Modifiers_param p ->
    let box = new modifiers_param_box p in
    let _ = main_box#pack ~expand: false ~padding: 2 box#box in
    box
  in

  let set_icon iter = function
  | None -> ()
  | Some icon -> tree#set ~row:iter ~column:icon_col icon
  in

  (* Populate the tree *)

  let rec make_tree iter conf_struct =
    (* box is not shown at first *)
    let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in
    let new_iter = match iter with
    | None -> tree#append ()
    | Some parent -> tree#append ~parent ()
    in
    match conf_struct with
    | Section (label, icon, param_list) ->
      let params = List.map (make_param box) param_list in
      let widget =
        object
          method box = box#coerce
          method apply () = List.iter (fun param -> param#apply) params
        end
      in
      let () = tree#set ~row:new_iter ~column:label_col label in
      let () = set_icon new_iter icon in
      let () = tree#set ~row:new_iter ~column:box_col widget in
      ()
    | Section_list (label, icon, struct_list) ->
      let widget =
        object
      (* Section_list does not contain any effect widget, so we do not have to
         apply anything. *)
          method apply () = ()
          method box = box#coerce
        end
      in
      let () = tree#set ~row:new_iter ~column:label_col label in
      let () = set_icon new_iter icon in
      let () = tree#set ~row:new_iter ~column:box_col widget in
      List.iter (make_tree (Some new_iter)) struct_list
  in

  let () = List.iter (make_tree None) conf_struct in

  (* Dealing with signals *)

  let current_prop : widget option ref = ref None in

  let select_iter iter =
    let () = match !current_prop with
    | None -> ()
    | Some box -> box#box#misc#hide ()
    in
    let box = tree#get ~row:iter ~column:box_col in
    let () = box#box#misc#show () in
    current_prop := Some box
  in

  let when_selected () =
    let rows = selection#get_selected_rows in
    match rows with
    | [] -> ()
    | row :: _ ->
      let iter = tree#get_iter row in
      select_iter iter
  in

  (* Focus on a box when selected *)

  let _ = selection#connect#changed ~callback:when_selected in

  let _ = match tree#get_iter_first with
  | None -> ()
  | Some iter -> select_iter iter
  in

  object

    method box = main_box

    method apply =
      let foreach _ iter =
        let widget = tree#get ~row:iter ~column:box_col in
        widget#apply(); false
      in
      tree#foreach foreach

  end

(** This function takes a configuration structure list and creates a window
   to configure the various parameters. *)
let edit ?(with_apply=true)
    ?(apply=(fun () -> ()))
    title ?parent ?width ?height
    conf_struct =
  let dialog = GWindow.dialog
    ~position:`CENTER
    ~modal: true ~title: title
    ~type_hint:`DIALOG
    ?parent ?height ?width
    ()
  in
  let config_box = new configuration_box conf_struct in

  let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in

  if with_apply then
    dialog#add_button Configwin_messages.mApply `APPLY;

  dialog#add_button Configwin_messages.mOk `OK;
  dialog#add_button Configwin_messages.mCancel `CANCEL;

  let destroy () =
    dialog#destroy ();
  in
  let rec iter rep =
    try
      match dialog#run () with
        | `APPLY  -> config_box#apply; iter Return_apply
        | `OK -> config_box#apply; destroy (); Return_ok
        | _ -> destroy (); rep
    with
        Failure s ->
          GToolbox.message_box ~title:"Error" s; iter rep
      | e ->
          GToolbox.message_box ~title:"Error" (Printexc.to_string e); iter rep
  in
    iter Return_cancel

(*
let edit_string l s =
  match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with
    None -> s
  | Some s2 -> s2
*)

(** Create a string param. *)
let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
  String_param
    {
      string_label = label ;
      string_help = help ;
      string_value = v ;
      string_editable = editable ;
      string_f_apply = f ;
      string_expand = expand ;
      string_to_string = (fun x -> x) ;
      string_of_string = (fun x -> x) ;
    }

(** Create a bool param. *)
let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
  Bool_param
    {
      bool_label = label ;
      bool_help = help ;
      bool_value = v ;
      bool_editable = editable ;
      bool_f_apply = f ;
    }

(*
(** Create a list param. *)
let list ?(editable=true) ?help
    ?(f=(fun (_:'a list) -> ()))
    ?(eq=Pervasives.(=))
    ?(edit:('a -> 'a) option)
    ?(add=(fun () -> ([] : 'a list)))
    ?titles ?(color=(fun (_:'a) -> (None : string option)))
    label (f_strings : 'a -> string list) v =
  List_param
    (fun () ->
        new list_param_box
          {
            list_label = label ;
            list_help = help ;
            list_value = v ;
            list_editable = editable ;
            list_titles = titles;
            list_eq = eq ;
            list_strings = f_strings ;
            list_color = color ;
            list_f_edit = edit ;
            list_f_add = add ;
            list_f_apply = f ;
          }
    )

(** Create a strings param. *)
let strings ?(editable=true) ?help
    ?(f=(fun _ -> ()))
    ?(eq=Pervasives.(=))
    ?(add=(fun () -> [])) label v =
  list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v
*)

(** Create a combo param. *)
let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
    ?(new_allowed=false)
    ?(blank_allowed=false) label choices v =
  Combo_param
    {
      combo_label = label ;
      combo_help = help ;
      combo_value = v ;
      combo_editable = editable ;
      combo_choices = choices ;
      combo_new_allowed = new_allowed ;
      combo_blank_allowed = blank_allowed ;
      combo_f_apply = f ;
      combo_expand = expand ;
    }

let modifiers
  ?(editable=true)
  ?(expand=true)
  ?help
  ?(allow=[`CONTROL;`SHIFT;`LOCK;`META;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5])
  ?(f=(fun _ -> ())) label v =
  Modifiers_param
    {
      md_label = label ;
      md_help = help ;
      md_value = v ;
      md_editable = editable ;
      md_f_apply = f ;
      md_expand = expand ;
      md_allow = allow ;
    }

(** Create a custom param.*)
let custom ?label box f expand =
  Custom_param
    {
      custom_box = box ;
      custom_f_apply = f ;
      custom_expand = expand ;
      custom_framed = label ;
    }

(* Copying lablgtk question_box + forbidding hiding *)

let question_box ~title ~buttons ?(default=1) ?icon ?parent message =
  let button_nb = ref 0 in
  let window = GWindow.dialog ~position:`CENTER ~modal:true ?parent ~type_hint:`DIALOG ~title () in
  let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in
  let bbox = window#action_area in
  begin match icon with
    None -> ()
  | Some i -> hbox#pack i#coerce ~padding:4
  end;
  ignore (GMisc.label ~text: message ~packing: hbox#add ());
  (* the function called to create each button by iterating *)
  let rec iter_buttons n = function
      [] ->
        ()
    | button_label :: q ->
        let b = GButton.button ~label: button_label
            ~packing:(bbox#pack ~expand:true ~padding:4) ()
        in
        ignore (b#connect#clicked ~callback:
          (fun () -> button_nb := n; window#destroy ()));
        (* If it's the first button then give it the focus *)
        if n = default then b#grab_default () else ();

        iter_buttons (n+1) q
  in
  iter_buttons 1 buttons;
  ignore (window#connect#destroy ~callback: GMain.Main.quit);
  window#set_position `CENTER;
  window#show ();
  GMain.Main.main ();
  !button_nb

let message_box ~title ?icon ?parent ?(ok="Ok") message =
  ignore (question_box ?icon ?parent ~title message ~buttons:[ ok ])
