open Utils
open Property

open TiBase
open TiContainer

(* the button inherits from widget because it can't accept
   a child; 
   needs to add the border_width property *)
class tibutton ~(widget : #GButton.button) ~name ~parent_tree ~pos
    ?(insert_evbox=true) parent_window =
object(self)
  val button = widget
  inherit tiwidget ~name ~widget ~parent_tree ~pos ~insert_evbox
       parent_window as widget

  method private class_name = "GButton.button"

  method private get_mandatory_props = [ "label" ]

  initializer
    classe <- "button";
    proplist <-  proplist @
      [ "border_width",	new prop_int ~name:"border_width" ~init:"0"
	                  ~set:(ftrue button#set_border_width);
	"label",
	new prop_string ~name:"label" ~init:name ~set:
	  begin fun v ->
	    button#remove (List.hd button#children)#coerce;
	    GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
	    true
	  end ]
end

let new_tibutton ~name ?(listprop = []) =
  let b = GButton.button ~label:name () in
  b#event#connect#enter_notify
    ~callback:(fun _ -> GtkSignal.stop_emit (); true);
  b#event#connect#leave_notify
    ~callback:(fun _ -> GtkSignal.stop_emit (); true);
  new tibutton ~widget:b ~name


class ticheck_button ~(widget : #GButton.toggle_button) ~name
    ~parent_tree ~pos ?(insert_evbox=true) parent_window =
object(self)
  val button = widget
  inherit tiwidget ~name ~widget ~insert_evbox
      ~parent_tree ~pos parent_window as widget


  method private class_name = "GButton.check_button"

  method private get_mandatory_props = [ "label" ]

  initializer
    classe <- "check_button";
    proplist <-  proplist @
      [ "border_width",	new prop_int ~name:"border_width" ~init:"0"
	                 ~set:(ftrue button#set_border_width);
	"label",
	new prop_string ~name:"label" ~init:name ~set:
	  begin fun v ->
	    button#remove (List.hd button#children)#coerce;
	    GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
	    true
	  end
      ]
end

let new_ticheck_button ~name ?(listprop = []) =
  new ticheck_button ~widget:(GButton.check_button ~label:name ()) ~name



class titoggle_button ~(widget : #GButton.toggle_button) ~name
    ~parent_tree ~pos ?(insert_evbox=true) parent_window =
object(self)
  val button = widget
  inherit tiwidget ~name ~widget ~insert_evbox
      ~parent_tree ~pos parent_window as widget

  method private class_name = "GButton.toggle_button"

  method private get_mandatory_props = [ "label" ]

  initializer
    classe <- "toggle_button";
    proplist <-  proplist @
      [ "border width",	new prop_int ~name:"border_width" ~init:"0"
	                  ~set:(ftrue button#set_border_width);
	"label",
	new prop_string ~name:"label" ~init:name ~set:
	  begin fun v ->
	    button#remove (List.hd button#children)#coerce;
	    GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
	    true
	  end ]
end

let new_titoggle_button ~name ?(listprop = []) =
  let b = GButton.toggle_button ~label:name () in
(*  b#connect#event#enter_notify
    ~callback:(fun _ -> GtkSignal.stop_emit ());
  b#connect#event#leave_notify
    ~callback:(fun _ -> GtkSignal.stop_emit ());
*)
  new titoggle_button ~name ~widget:b


class tiradio_button ~(widget : #GButton.radio_button) ~name:nname
    ~parent_tree ~pos ?(insert_evbox=true) parent_window =
object(self)
  val button = widget
  inherit tiwidget ~name:nname ~widget ~insert_evbox
      ~parent_tree ~pos parent_window as widget

  val group_prop =
    new prop_enum_dyn ~values:(fun () -> !radio_button_pool) ~name:"group"
      ~set:(fun () -> true) ~init:nname


  method private class_name = "GButton.radio_button"

  method remove_me_without_undo () =
    radio_button_pool := list_remove !radio_button_pool
	~f:(fun x -> x = name);
    widget#remove_me_without_undo ()

  method private get_mandatory_props = [ "label" ]

  method private emit_clean_proplist =
    List.remove_assoc "group" widget#emit_clean_proplist

  method emit_initializer_code formatter =
    let groupname = group_prop#get in
    if name <> groupname then
      Format.fprintf formatter "@ %s#set_group %s#group;" name groupname

  initializer
    classe <- "radio_button";
    radio_button_pool := name :: !radio_button_pool;
    List.iter
      ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) true)
      (List.tl !radio_button_pool);

    proplist <-  proplist @
      [ "border_width",	new prop_int ~name:"border_width" ~init:"0"
	                  ~set:(ftrue button#set_border_width);
	"label",
	new prop_string ~name:"label" ~init:name ~set:
	  begin fun v ->
	    button#remove (List.hd button#children)#coerce;
	    GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
	    true
	  end ;
	"group", group_prop
      ]
end

let new_tiradio_button ~name ?(listprop = []) =
  let b = GButton.radio_button ~label:name () in
  (*
  b#event#connect#enter_notify
    ~callback:(fun _ -> b#misc#stop_emit ~name:"enter_notify_event"; true);
  b#event#connect#leave_notify
    ~callback:(fun _ -> b#misc#stop_emit ~name:"leave_notify_event"; true);
  *)
  new tiradio_button ~name ~widget:b




class tibutton_toolbar ~(widget : #GButton.button) ~name ~parent_tree ~pos
    ?(insert_evbox=true) parent_window ~toolbar =
object(self)
  val button = widget
  inherit tibutton ~name ~widget ~parent_tree ~pos ~insert_evbox
       parent_window as button

  method private get_mandatory_props =
    [ "text"; "tooltip"; "tooltip_private" ]

  method emit_init_code formatter ~packing =
    Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_button"
      name toolbar#name;
    List.iter self#get_mandatory_props ~f:
      begin fun name ->
	Format.fprintf formatter "@ ~%s:%s" name
	  (List.assoc name proplist)#code
      end;
    Format.fprintf formatter "@ ()@ in@]@]"

  initializer
    proplist <- List.remove_assoc "label" proplist
end


class titoggle_button_toolbar ~(widget : #GButton.toggle_button) ~name
    ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
object(self)
  val button = widget
  inherit titoggle_button ~name ~widget ~parent_tree ~pos ~insert_evbox
       parent_window as button

  method private get_mandatory_props =
    [ "text"; "tooltip"; "tooltip_private" ]

  method emit_init_code formatter ~packing =
    Format.fprintf formatter
      "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_toggle_button"
      name toolbar#name;
    List.iter self#get_mandatory_props ~f:
      begin fun name ->
	Format.fprintf formatter "@ ~%s:%s" name
	  (List.assoc name proplist)#code
      end;
    Format.fprintf formatter "@ ()@ in@]@]"

  initializer
    proplist <- List.remove_assoc "label" proplist
end


class tiradio_button_toolbar ~(widget : #GButton.radio_button) ~name
    ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
object(self)
  val button = widget
  inherit tiradio_button ~name ~widget ~parent_tree ~pos ~insert_evbox
       parent_window as button

  method private get_mandatory_props =
    [ "text"; "tooltip"; "tooltip_private" ]

  method emit_init_code formatter ~packing =
    Format.fprintf formatter
      "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_radio_button"
      name toolbar#name;
    List.iter self#get_mandatory_props ~f:
      begin fun name ->
	Format.fprintf formatter "@ ~%s:%s" name
	  (List.assoc name proplist)#code
      end;
    Format.fprintf formatter "@ ()@ in@]@]"

  initializer
    proplist <- List.remove_assoc "label" proplist
end




class titoolbar ~(widget : GToolbar2.toolbar2) ~name ~parent_tree ~pos
    ?(insert_evbox=true) parent_window =
object(self)
  val toolbar = widget
  inherit ticontainer ~name ~widget ~parent_tree ~pos
    ~insert_evbox parent_window

  method private class_name = "GButton.toolbar"

  method private add child ~pos =
    children <- children @ [child, `START]

  method private get_pos child =
    let rec aux n = function
      |	[] -> failwith "toolbar::get_pos"
      |	(hd, _)::tl -> if hd = child then n else aux (n+1) tl in
    aux 0 children

  method private make_child ~classe ?(pos = -1) ~name ~parent_tree
      ?(insert_evbox = true) ?(listprop = []) parent_window =
    match classe with
    | "button" ->
	let t = try List.assoc "text" listprop with Not_found -> "" in
	let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
	let ptt = try List.assoc "tooltip_private" listprop
	with Not_found -> "" in
	let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
	    ~init:listprop
	    [ "text"; "tooltip"; "tooltip_private" ] in
	let b = toolbar#insert_button ~text:t ~tooltip:tt
	    ~tooltip_private:ptt () in
	let child = new tibutton_toolbar ~name ~widget:b ~pos:(-1)
	      ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
	let tp = new prop_string ~name:"text" ~init:t
	    ~set:(fun v -> 
	      toolbar#set_text v (self#get_pos child); true)
	and ttp = new prop_string ~name:"tooltip" ~init:tt
	    ~set:(fun _ -> true)
	and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
	    ~set:(fun _ -> true) in
	child#add_to_proplist
	  [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
	child
    | "toggle_button" ->
	let t = try List.assoc "text" listprop with Not_found -> "" in
	let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
	let ptt = try List.assoc "tooltip_private" listprop
	with Not_found -> "" in
	let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
	    ~init:listprop
	    [ "text"; "tooltip"; "tooltip_private" ] in
	let b = toolbar#insert_toggle_button ~text:t ~tooltip:tt
	    ~tooltip_private:ptt () in
	let child = new titoggle_button_toolbar ~name ~widget:b ~pos:(-1)
	      ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
	let tp = new prop_string ~name:"text" ~init:t
	    ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
	and ttp = new prop_string ~name:"tooltip" ~init:tt
	    ~set:(fun _ -> true)
	and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
	    ~set:(fun _ -> true) in
	child#add_to_proplist
	  [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
	child
    | "radio_button" ->
	let t = try List.assoc "text" listprop with Not_found -> "" in
	let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
	let ptt = try List.assoc "tooltip_private" listprop
	with Not_found -> "" in
	let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
	    ~init:listprop
	    [ "text"; "tooltip"; "tooltip_private" ] in
	let b = toolbar#insert_radio_button ~text:t ~tooltip:tt
	    ~tooltip_private:ptt () in
	let child = new tiradio_button_toolbar ~name ~widget:b ~pos:(-1)
	      ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
	let tp = new prop_string ~name:"text" ~init:t
	    ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
	and ttp = new prop_string ~name:"tooltip" ~init:tt
	    ~set:(fun _ -> true)
	and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
	    ~set:(fun _ -> true) in
	child#add_to_proplist
	  [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
	child
    | _ -> failwith "toolbar"



  method remove child =
    toolbar#remove (child#base);
    children <- list_remove ~f:(fun (ch, _) -> ch = child) children;

  initializer
    classe <- "toolbar";
    proplist <- proplist @
      [ "orientation",
	new prop_orientation ~name:"orientation" ~init:"HORIZONTAL"
	  ~set:(ftrue toolbar#set_orientation);
	"style",
	new prop_toolbar_style ~name:"style" ~init:"BOTH"
	  ~set:(ftrue toolbar#set_style);
	"space_size",
	new prop_int ~name:"space_size" ~init:"5"
	  ~set:(ftrue toolbar#set_space_size);
	"space_style",
	new prop_toolbar_space_style ~name:"space_style" ~init:"EMPTY"
	  ~set:(ftrue toolbar#set_space_style);
	"tooltips",
	new prop_bool ~name:"tooltips" ~init:"true"
	  ~set:(ftrue toolbar#set_tooltips);
	"button_relief",
	new prop_relief_style ~name:"button_relief" ~init:"NORMAL"
	  ~set:(ftrue toolbar#set_button_relief)
      ]
end

let new_toolbar ~name ?(listprop = []) =
  new titoolbar ~name ~widget:(GToolbar2.toolbar2 ())