helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/tiButton.ml

   1 open Utils
   2 open Property
   3
   4 open TiBase
   5 open TiContainer
   6
   7 (* the button inherits from widget because it can't accept
   8    a child;
   9    needs to add the border_width property *)
  10 class tibutton ~(widget : #GButton.button) ~name ~parent_tree ~pos
  11     ?(insert_evbox=true) parent_window =
  12 object(self)
  13   val button = widget
  14   inherit tiwidget ~name ~widget ~parent_tree ~pos ~insert_evbox
  15        parent_window as widget
  16
  17   method private class_name = "GButton.button"
  18
  19   method private get_mandatory_props = [ "label" ]
  20
  21   initializer
  22     classe <- "button";
  23     proplist <-  proplist @
  24       [ "border_width", new prop_int ~name:"border_width" ~init:"0"
  25                           ~set:(ftrue button#set_border_width);
  26         "label",
  27         new prop_string ~name:"label" ~init:name ~set:
  28           begin fun v ->
  29             button#remove (List.hd button#children)#coerce;
  30             GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
  31             true
  32           end ]
  33 end
  34
  35 let new_tibutton ~name ?(listprop = []) =
  36   let b = GButton.button ~label:name () in
  37   b#event#connect#enter_notify
  38     ~callback:(fun _ -> GtkSignal.stop_emit (); true);
  39   b#event#connect#leave_notify
  40     ~callback:(fun _ -> GtkSignal.stop_emit (); true);
  41   new tibutton ~widget:b ~name
  42
  43
  44 class ticheck_button ~(widget : #GButton.toggle_button) ~name
  45     ~parent_tree ~pos ?(insert_evbox=true) parent_window =
  46 object(self)
  47   val button = widget
  48   inherit tiwidget ~name ~widget ~insert_evbox
  49       ~parent_tree ~pos parent_window as widget
  50
  51
  52   method private class_name = "GButton.check_button"
  53
  54   method private get_mandatory_props = [ "label" ]
  55
  56   initializer
  57     classe <- "check_button";
  58     proplist <-  proplist @
  59       [ "border_width", new prop_int ~name:"border_width" ~init:"0"
  60                          ~set:(ftrue button#set_border_width);
  61         "label",
  62         new prop_string ~name:"label" ~init:name ~set:
  63           begin fun v ->
  64             button#remove (List.hd button#children)#coerce;
  65             GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
  66             true
  67           end
  68       ]
  69 end
  70
  71 let new_ticheck_button ~name ?(listprop = []) =
  72   new ticheck_button ~widget:(GButton.check_button ~label:name ()) ~name
  73
  74
  75
  76 class titoggle_button ~(widget : #GButton.toggle_button) ~name
  77     ~parent_tree ~pos ?(insert_evbox=true) parent_window =
  78 object(self)
  79   val button = widget
  80   inherit tiwidget ~name ~widget ~insert_evbox
  81       ~parent_tree ~pos parent_window as widget
  82
  83   method private class_name = "GButton.toggle_button"
  84
  85   method private get_mandatory_props = [ "label" ]
  86
  87   initializer
  88     classe <- "toggle_button";
  89     proplist <-  proplist @
  90       [ "border width", new prop_int ~name:"border_width" ~init:"0"
  91                           ~set:(ftrue button#set_border_width);
  92         "label",
  93         new prop_string ~name:"label" ~init:name ~set:
  94           begin fun v ->
  95             button#remove (List.hd button#children)#coerce;
  96             GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
  97             true
  98           end ]
  99 end
 100
 101 let new_titoggle_button ~name ?(listprop = []) =
 102   let b = GButton.toggle_button ~label:name () in
 103 (*  b#connect#event#enter_notify
 104     ~callback:(fun _ -> GtkSignal.stop_emit ());
 105   b#connect#event#leave_notify
 106     ~callback:(fun _ -> GtkSignal.stop_emit ());
 107 *)
 108   new titoggle_button ~name ~widget:b
 109
 110
 111 class tiradio_button ~(widget : #GButton.radio_button) ~name:nname
 112     ~parent_tree ~pos ?(insert_evbox=true) parent_window =
 113 object(self)
 114   val button = widget
 115   inherit tiwidget ~name:nname ~widget ~insert_evbox
 116       ~parent_tree ~pos parent_window as widget
 117
 118   val group_prop =
 119     new prop_enum_dyn ~values:(fun () -> !radio_button_pool) ~name:"group"
 120       ~set:(fun () -> true) ~init:nname
 121
 122
 123   method private class_name = "GButton.radio_button"
 124
 125   method remove_me_without_undo () =
 126     radio_button_pool := list_remove !radio_button_pool
 127         ~f:(fun x -> x = name);
 128     widget#remove_me_without_undo ()
 129
 130   method private get_mandatory_props = [ "label" ]
 131
 132   method private emit_clean_proplist =
 133     List.remove_assoc "group" widget#emit_clean_proplist
 134
 135   method emit_initializer_code formatter =
 136     let groupname = group_prop#get in
 137     if name <> groupname then
 138       Format.fprintf formatter "@ %s#set_group %s#group;" name groupname
 139
 140   initializer
 141     classe <- "radio_button";
 142     radio_button_pool := name :: !radio_button_pool;
 143     List.iter
 144       ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) true)
 145       (List.tl !radio_button_pool);
 146
 147     proplist <-  proplist @
 148       [ "border_width", new prop_int ~name:"border_width" ~init:"0"
 149                           ~set:(ftrue button#set_border_width);
 150         "label",
 151         new prop_string ~name:"label" ~init:name ~set:
 152           begin fun v ->
 153             button#remove (List.hd button#children)#coerce;
 154             GMisc.label ~text:v ~xalign:0.5 ~yalign:0.5 ~packing:button#add ();
 155             true
 156           end ;
 157         "group", group_prop
 158       ]
 159 end
 160
 161 let new_tiradio_button ~name ?(listprop = []) =
 162   let b = GButton.radio_button ~label:name () in
 163   (*
 164   b#event#connect#enter_notify
 165     ~callback:(fun _ -> b#misc#stop_emit ~name:"enter_notify_event"; true);
 166   b#event#connect#leave_notify
 167     ~callback:(fun _ -> b#misc#stop_emit ~name:"leave_notify_event"; true);
 168   *)
 169   new tiradio_button ~name ~widget:b
 170
 171
 172
 173
 174 class tibutton_toolbar ~(widget : #GButton.button) ~name ~parent_tree ~pos
 175     ?(insert_evbox=true) parent_window ~toolbar =
 176 object(self)
 177   val button = widget
 178   inherit tibutton ~name ~widget ~parent_tree ~pos ~insert_evbox
 179        parent_window as button
 180
 181   method private get_mandatory_props =
 182     [ "text"; "tooltip"; "tooltip_private" ]
 183
 184   method emit_init_code formatter ~packing =
 185     Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_button"
 186       name toolbar#name;
 187     List.iter self#get_mandatory_props ~f:
 188       begin fun name ->
 189         Format.fprintf formatter "@ ~%s:%s" name
 190           (List.assoc name proplist)#code
 191       end;
 192     Format.fprintf formatter "@ ()@ in@]@]"
 193
 194   initializer
 195     proplist <- List.remove_assoc "label" proplist
 196 end
 197
 198
 199 class titoggle_button_toolbar ~(widget : #GButton.toggle_button) ~name
 200     ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
 201 object(self)
 202   val button = widget
 203   inherit titoggle_button ~name ~widget ~parent_tree ~pos ~insert_evbox
 204        parent_window as button
 205
 206   method private get_mandatory_props =
 207     [ "text"; "tooltip"; "tooltip_private" ]
 208
 209   method emit_init_code formatter ~packing =
 210     Format.fprintf formatter
 211       "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_toggle_button"
 212       name toolbar#name;
 213     List.iter self#get_mandatory_props ~f:
 214       begin fun name ->
 215         Format.fprintf formatter "@ ~%s:%s" name
 216           (List.assoc name proplist)#code
 217       end;
 218     Format.fprintf formatter "@ ()@ in@]@]"
 219
 220   initializer
 221     proplist <- List.remove_assoc "label" proplist
 222 end
 223
 224
 225 class tiradio_button_toolbar ~(widget : #GButton.radio_button) ~name
 226     ~parent_tree ~pos ?(insert_evbox=true) parent_window ~toolbar =
 227 object(self)
 228   val button = widget
 229   inherit tiradio_button ~name ~widget ~parent_tree ~pos ~insert_evbox
 230        parent_window as button
 231
 232   method private get_mandatory_props =
 233     [ "text"; "tooltip"; "tooltip_private" ]
 234
 235   method emit_init_code formatter ~packing =
 236     Format.fprintf formatter
 237       "@ @[<hv 2>let %s =@ @[<hov 2>%s#insert_radio_button"
 238       name toolbar#name;
 239     List.iter self#get_mandatory_props ~f:
 240       begin fun name ->
 241         Format.fprintf formatter "@ ~%s:%s" name
 242           (List.assoc name proplist)#code
 243       end;
 244     Format.fprintf formatter "@ ()@ in@]@]"
 245
 246   initializer
 247     proplist <- List.remove_assoc "label" proplist
 248 end
 249
 250
 251
 252
 253 class titoolbar ~(widget : GToolbar2.toolbar2) ~name ~parent_tree ~pos
 254     ?(insert_evbox=true) parent_window =
 255 object(self)
 256   val toolbar = widget
 257   inherit ticontainer ~name ~widget ~parent_tree ~pos
 258     ~insert_evbox parent_window
 259
 260   method private class_name = "GButton.toolbar"
 261
 262   method private add child ~pos =
 263     children <- children @ [child, `START]
 264
 265   method private get_pos child =
 266     let rec aux n = function
 267       | [] -> failwith "toolbar::get_pos"
 268       | (hd, _)::tl -> if hd = child then n else aux (n+1) tl in
 269     aux 0 children
 270
 271   method private make_child ~classe ?(pos = -1) ~name ~parent_tree
 272       ?(insert_evbox = true) ?(listprop = []) parent_window =
 273     match classe with
 274     | "button" ->
 275         let t = try List.assoc "text" listprop with Not_found -> "" in
 276         let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
 277         let ptt = try List.assoc "tooltip_private" listprop
 278         with Not_found -> "" in
 279         let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
 280             ~init:listprop
 281             [ "text"; "tooltip"; "tooltip_private" ] in
 282         let b = toolbar#insert_button ~text:t ~tooltip:tt
 283             ~tooltip_private:ptt () in
 284         let child = new tibutton_toolbar ~name ~widget:b ~pos:(-1)
 285               ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
 286         let tp = new prop_string ~name:"text" ~init:t
 287             ~set:(fun v ->
 288               toolbar#set_text v (self#get_pos child); true)
 289         and ttp = new prop_string ~name:"tooltip" ~init:tt
 290             ~set:(fun _ -> true)
 291         and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
 292             ~set:(fun _ -> true) in
 293         child#add_to_proplist
 294           [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
 295         child
 296     | "toggle_button" ->
 297         let t = try List.assoc "text" listprop with Not_found -> "" in
 298         let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
 299         let ptt = try List.assoc "tooltip_private" listprop
 300         with Not_found -> "" in
 301         let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
 302             ~init:listprop
 303             [ "text"; "tooltip"; "tooltip_private" ] in
 304         let b = toolbar#insert_toggle_button ~text:t ~tooltip:tt
 305             ~tooltip_private:ptt () in
 306         let child = new titoggle_button_toolbar ~name ~widget:b ~pos:(-1)
 307               ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
 308         let tp = new prop_string ~name:"text" ~init:t
 309             ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
 310         and ttp = new prop_string ~name:"tooltip" ~init:tt
 311             ~set:(fun _ -> true)
 312         and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
 313             ~set:(fun _ -> true) in
 314         child#add_to_proplist
 315           [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
 316         child
 317     | "radio_button" ->
 318         let t = try List.assoc "text" listprop with Not_found -> "" in
 319         let tt = try List.assoc "tooltip" listprop with Not_found -> "" in
 320         let ptt = try List.assoc "tooltip_private" listprop
 321         with Not_found -> "" in
 322         let listp = List.fold_left ~f:(fun l p -> List.remove_assoc p l)
 323             ~init:listprop
 324             [ "text"; "tooltip"; "tooltip_private" ] in
 325         let b = toolbar#insert_radio_button ~text:t ~tooltip:tt
 326             ~tooltip_private:ptt () in
 327         let child = new tiradio_button_toolbar ~name ~widget:b ~pos:(-1)
 328               ~insert_evbox:false ~parent_tree:stree parent_window ~toolbar:self in
 329         let tp = new prop_string ~name:"text" ~init:t
 330             ~set:(fun v -> toolbar#set_text v (self#get_pos child); true)
 331         and ttp = new prop_string ~name:"tooltip" ~init:tt
 332             ~set:(fun _ -> true)
 333         and pttp = new prop_string ~name:"tooltip_private" ~init:ptt
 334             ~set:(fun _ -> true) in
 335         child#add_to_proplist
 336           [ "text", tp; "tooltip", ttp; "tooltip_private", pttp ];
 337         child
 338     | _ -> failwith "toolbar"
 339
 340
 341
 342   method remove child =
 343     toolbar#remove (child#base);
 344     children <- list_remove ~f:(fun (ch, _) -> ch = child) children;
 345
 346   initializer
 347     classe <- "toolbar";
 348     proplist <- proplist @
 349       [ "orientation",
 350         new prop_orientation ~name:"orientation" ~init:"HORIZONTAL"
 351           ~set:(ftrue toolbar#set_orientation);
 352         "style",
 353         new prop_toolbar_style ~name:"style" ~init:"BOTH"
 354           ~set:(ftrue toolbar#set_style);
 355         "space_size",
 356         new prop_int ~name:"space_size" ~init:"5"
 357           ~set:(ftrue toolbar#set_space_size);
 358         "space_style",
 359         new prop_toolbar_space_style ~name:"space_style" ~init:"EMPTY"
 360           ~set:(ftrue toolbar#set_space_style);
 361         "tooltips",
 362         new prop_bool ~name:"tooltips" ~init:"true"
 363           ~set:(ftrue toolbar#set_tooltips);
 364         "button_relief",
 365         new prop_relief_style ~name:"button_relief" ~init:"NORMAL"
 366           ~set:(ftrue toolbar#set_button_relief)
 367       ]
 368 end
 369
 370 let new_toolbar ~name ?(listprop = []) =
 371   new titoolbar ~name ~widget:(GToolbar2.toolbar2 ())
 372