helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gMisc.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open GtkBase
   6 open GtkMisc
   7 open GObj
   8
   9 let separator dir ?(width = -2) ?(height = -2) ?packing ?show () =
  10   let w = Separator.create dir in
  11   if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
  12   pack_return (new widget_full w) ~packing ~show
  13
  14 class statusbar_context obj ctx = object (self)
  15   val obj : statusbar obj = obj
  16   val context : Gtk.statusbar_context = ctx
  17   method context = context
  18   method push text = Statusbar.push obj context ~text
  19   method pop () = Statusbar.pop obj context
  20   method remove = Statusbar.remove obj context
  21   method flash ?(delay=1000) text =
  22     let msg = self#push text in
  23     GtkMain.Timeout.add ~ms:delay ~callback:(fun () -> self#remove msg; false);
  24     ()
  25 end
  26
  27 class statusbar obj = object
  28   inherit GContainer.container_full (obj : Gtk.statusbar obj)
  29   method new_context ~name =
  30     new statusbar_context obj (Statusbar.get_context obj name)
  31 end
  32
  33 let statusbar ?border_width ?width ?height ?packing ?show () =
  34   let w = Statusbar.create () in
  35   Container.set w ?border_width ?width ?height;
  36   pack_return (new statusbar w) ~packing ~show
  37
  38 class calendar_signals obj = object
  39   inherit widget_signals obj
  40   method month_changed =
  41     GtkSignal.connect obj ~sgn:Calendar.Signals.month_changed ~after
  42   method day_selected =
  43     GtkSignal.connect obj ~sgn:Calendar.Signals.day_selected ~after
  44   method day_selected_double_click =
  45     GtkSignal.connect obj
  46       ~sgn:Calendar.Signals.day_selected_double_click ~after
  47   method prev_month =
  48     GtkSignal.connect obj ~sgn:Calendar.Signals.prev_month ~after
  49   method next_month =
  50     GtkSignal.connect obj ~sgn:Calendar.Signals.next_month ~after
  51   method prev_year =
  52     GtkSignal.connect obj ~sgn:Calendar.Signals.prev_year ~after
  53   method next_year =
  54     GtkSignal.connect obj ~sgn:Calendar.Signals.next_year ~after
  55 end
  56
  57 class calendar obj = object
  58   inherit widget (obj : Gtk.calendar obj)
  59   method event = new GObj.event_ops obj
  60   method connect = new calendar_signals obj
  61   method select_month = Calendar.select_month obj
  62   method select_day = Calendar.select_day obj
  63   method mark_day = Calendar.mark_day obj
  64   method unmark_day = Calendar.unmark_day obj
  65   method clear_marks = Calendar.clear_marks obj
  66   method display_options = Calendar.display_options obj
  67   method date = Calendar.get_date obj
  68   method freeze () = Calendar.freeze obj
  69   method thaw () = Calendar.thaw obj
  70 end
  71
  72 let calendar ?options ?(width = -2) ?(height = -2) ?packing ?show () =
  73   let w = Calendar.create () in
  74   if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
  75   may options ~f:(Calendar.display_options w);
  76   pack_return (new calendar w) ~packing ~show
  77
  78 class drawing_area obj = object
  79   inherit widget_full (obj : Gtk.drawing_area obj)
  80   method event = new GObj.event_ops obj
  81   method set_size = DrawingArea.size obj
  82 end
  83
  84 let drawing_area ?(width=0) ?(height=0) ?packing ?show () =
  85   let w = DrawingArea.create () in
  86   if width <> 0 || height <> 0 then DrawingArea.size w ~width ~height;
  87   pack_return (new drawing_area w) ~packing ~show
  88
  89 class misc obj = object
  90   inherit widget obj
  91   method set_alignment = Misc.set_alignment obj
  92   method set_padding = Misc.set_padding obj
  93 end
  94
  95 class arrow obj = object
  96   inherit misc obj
  97   method set_arrow kind ~shadow = Arrow.set obj ~kind ~shadow
  98 end
  99
 100 let arrow ~kind ~shadow
 101     ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
 102   let w = Arrow.create ~kind ~shadow in
 103   Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
 104   pack_return (new arrow w) ~packing ~show
 105
 106 class image obj = object
 107   inherit misc obj
 108   method set_image ?mask image = Image.set obj image ?mask
 109 end
 110
 111 let image image ?mask
 112     ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
 113   let w = Image.create image ?mask in
 114   Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
 115   pack_return (new image w) ~packing ~show
 116
 117 class label_skel obj = object
 118   inherit misc obj
 119   method set_text = Label.set_text obj
 120   method set_justify = Label.set_justify obj
 121   method set_pattern = Label.set_pattern obj
 122   method set_line_wrap = Label.set_line_wrap obj
 123   method text = Label.get_text obj
 124 end
 125
 126 class label obj = object
 127   inherit label_skel (Label.coerce obj)
 128   method connect = new widget_signals obj
 129 end
 130
 131 let label ?(text="") ?justify ?line_wrap ?pattern
 132     ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
 133   let w = Label.create text in
 134   Label.set w ?justify ?line_wrap ?pattern;
 135   Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
 136   pack_return (new label w) ~packing ~show
 137
 138 let label_cast w = new label (Label.cast w#as_widget)
 139
 140 class tips_query_signals obj = object
 141   inherit widget_signals obj
 142   method widget_entered ~callback =
 143     GtkSignal.connect ~sgn:TipsQuery.Signals.widget_entered obj ~after
 144       ~callback:(function None -> callback None
 145         | Some w -> callback (Some (new widget w)))
 146   method widget_selected ~callback =
 147     GtkSignal.connect ~sgn:TipsQuery.Signals.widget_selected obj ~after
 148       ~callback:(function None -> callback None
 149         | Some w -> callback (Some (new widget w)))
 150 end
 151
 152 class tips_query obj = object
 153   inherit label_skel (obj : Gtk.tips_query obj)
 154   method start () = TipsQuery.start obj
 155   method stop () = TipsQuery.stop obj
 156   method set_caller (w : widget) = TipsQuery.set_caller obj w#as_widget
 157   method set_emit_always = TipsQuery.set_emit_always obj
 158   method set_label_inactive inactive = TipsQuery.set_labels obj ~inactive
 159   method set_label_no_tip no_tip = TipsQuery.set_labels obj ~no_tip
 160   method connect = new tips_query_signals obj
 161 end
 162
 163 let tips_query ?caller ?emit_always ?label_inactive ?label_no_tip
 164     ?xalign ?yalign ?xpad ?ypad ?width ?height ?packing ?show () =
 165   let w = TipsQuery.create () in
 166   let caller = may_map caller ~f:(fun (w : #widget) -> w#as_widget) in
 167   TipsQuery.set w ?caller ?emit_always ?label_inactive ?label_no_tip;
 168   Misc.set w ?xalign ?yalign ?xpad ?ypad ?width ?height;
 169   pack_return (new tips_query w) ~packing ~show
 170
 171 class color_selection obj = object
 172   inherit GObj.widget_full (obj : Gtk.color_selection obj)
 173   method set_update_policy = ColorSelection.set_update_policy obj
 174   method set_opacity = ColorSelection.set_opacity obj
 175   method set_color ~red ~green ~blue ?opacity () =
 176     ColorSelection.set_color obj ~red ~green ~blue ?opacity
 177   method get_color = ColorSelection.get_color obj
 178 end
 179
 180 let color_selection ?border_width ?width ?height ?packing ?show () =
 181   let w = ColorSelection.create () in
 182   Container.set w ?border_width ?width ?height;
 183   pack_return (new color_selection w) ~packing ~show
 184
 185 class pixmap obj = object
 186   inherit misc (obj : Gtk.pixmap obj)
 187   method connect = new widget_signals obj
 188   method set_pixmap (pm : GDraw.pixmap) =
 189     Pixmap.set obj ~pixmap:pm#pixmap ?mask:pm#mask
 190   method pixmap =
 191     new GDraw.pixmap (Pixmap.pixmap obj)
 192       ?mask:(try Some(Pixmap.mask obj) with Gpointer.Null -> None)
 193 end
 194
 195 let pixmap (pm : #GDraw.pixmap) ?xalign ?yalign ?xpad ?ypad
 196     ?(width = -2) ?(height = -2) ?packing ?show () =
 197   let w = Pixmap.create pm#pixmap ?mask:pm#mask in
 198   Misc.set w ?xalign ?yalign ?xpad ?ypad;
 199   if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height;
 200   pack_return (new pixmap w) ~packing ~show
 201
 202 class font_selection obj = object
 203   inherit widget_full (obj : Gtk.font_selection obj)
 204   method notebook = new GPack.notebook obj
 205   method event = new event_ops obj
 206   method font = FontSelection.get_font obj
 207   method font_name = FontSelection.get_font_name obj
 208   method set_font_name = FontSelection.set_font_name obj
 209   method preview_text = FontSelection.get_preview_text obj
 210   method set_preview_text = FontSelection.set_preview_text obj
 211   method set_filter = FontSelection.set_filter obj
 212 end
 213
 214 let font_selection ?border_width ?width ?height ?packing ?show () =
 215   let w = FontSelection.create () in
 216   Container.set w ?border_width ?width ?height;
 217   pack_return (new font_selection w) ~packing ~show