--- /dev/null
+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 ())
+
projects / helm.git / blobdiff