helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMisc.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6 open GtkBase
   7
   8 module GammaCurve = struct
   9   let cast w : gamma_curve obj = Object.try_cast w "GtkGammaCurve"
  10   external create : unit -> gamma_curve obj = "ml_gtk_gamma_curve_new"
  11   external get_gamma : [>`gamma] obj -> float = "ml_gtk_gamma_curve_get_gamma"
  12 end
  13
  14 module ColorSelection = struct
  15   let cast w : color_selection obj = Object.try_cast w "GtkColorSelection"
  16   external create : unit -> color_selection obj = "ml_gtk_color_selection_new"
  17   external create_dialog : string -> color_selection_dialog obj
  18       = "ml_gtk_color_selection_dialog_new"
  19   external set_update_policy : [>`colorsel] obj -> update_type -> unit
  20       = "ml_gtk_color_selection_set_update_policy"
  21   external set_opacity : [>`colorsel] obj -> bool -> unit
  22       = "ml_gtk_color_selection_set_opacity"
  23   let set ?update_policy ?opacity w =
  24     may update_policy ~f:(set_update_policy w);
  25     may opacity ~f:(set_opacity w)
  26   external set_color :
  27       [>`colorsel] obj ->
  28       red:float -> green:float -> blue:float -> ?opacity:float -> unit
  29       = "ml_gtk_color_selection_set_color"
  30   external get_color : [>`colorsel] obj -> color
  31       = "ml_gtk_color_selection_get_color"
  32
  33   external ok_button : [>`colorseldialog] obj -> button obj =
  34     "ml_gtk_color_selection_dialog_ok_button"
  35   external cancel_button : [>`colorseldialog] obj -> button obj =
  36     "ml_gtk_color_selection_dialog_cancel_button"
  37   external help_button : [>`colorseldialog] obj -> button obj =
  38     "ml_gtk_color_selection_dialog_help_button"
  39   external colorsel : [>`colorseldialog] obj -> color_selection obj =
  40     "ml_gtk_color_selection_dialog_colorsel"
  41   module Signals = struct
  42     open GtkSignal
  43     let color_changed : ([>`colorsel],_) t =
  44       { name = "color_changed"; marshaller = marshal_unit }
  45   end
  46 end
  47
  48 module Statusbar = struct
  49   let cast w : statusbar obj = Object.try_cast w "GtkStatusbar"
  50   external create : unit -> statusbar obj = "ml_gtk_statusbar_new"
  51   external get_context : [>`statusbar] obj -> string -> statusbar_context
  52       = "ml_gtk_statusbar_get_context_id"
  53   external push :
  54       [>`statusbar] obj ->
  55       statusbar_context -> text:string -> statusbar_message
  56       = "ml_gtk_statusbar_push"
  57   external pop : [>`statusbar] obj -> statusbar_context ->  unit
  58       = "ml_gtk_statusbar_pop"
  59   external remove :
  60       [>`statusbar] obj -> statusbar_context -> statusbar_message -> unit
  61       = "ml_gtk_statusbar_remove"
  62   module Signals = struct
  63     open GtkSignal
  64     let text_pushed : ([>`statusbar],_) t =
  65       let marshal f _ = function
  66         | GtkArgv.INT ctx :: GtkArgv.STRING s :: _ ->
  67             f (Obj.magic ctx : statusbar_context) s
  68         | _ -> invalid_arg "GtkMisc.Statusbar.Signals.marshal_text"
  69       in
  70       { name = "text_pushed"; marshaller = marshal }
  71   end
  72 end
  73
  74 module Calendar = struct
  75   let cast w : calendar obj = Object.try_cast w "GtkCalendar"
  76   external create : unit -> calendar obj = "ml_gtk_calendar_new"
  77   external select_month : [>`calendar] obj -> month:int -> year:int -> unit
  78       = "ml_gtk_calendar_select_month"
  79   external select_day : [>`calendar] obj -> int -> unit
  80       = "ml_gtk_calendar_select_day"
  81   external mark_day : [>`calendar] obj -> int -> unit
  82       = "ml_gtk_calendar_mark_day"
  83   external unmark_day : [>`calendar] obj -> int -> unit
  84       = "ml_gtk_calendar_unmark_day"
  85   external clear_marks : [>`calendar] obj -> unit
  86       = "ml_gtk_calendar_clear_marks"
  87   external display_options :
  88       [>`calendar] obj -> Tags.calendar_display_options list -> unit
  89       = "ml_gtk_calendar_display_options"
  90   external get_date : [>`calendar] obj -> int * int * int
  91       = "ml_gtk_calendar_get_date"   (* year * month * day *)
  92   external freeze : [>`calendar] obj -> unit
  93       = "ml_gtk_calendar_freeze"
  94   external thaw : [>`calendar] obj -> unit
  95       = "ml_gtk_calendar_thaw"
  96   module Signals = struct
  97     open GtkSignal
  98     let month_changed : ([>`calendar],_) t =
  99       { name = "month_changed"; marshaller = marshal_unit }
 100     let day_selected : ([>`calendar],_) t =
 101       { name = "day_selected"; marshaller = marshal_unit }
 102     let day_selected_double_click : ([>`calendar],_) t =
 103       { name = "day_selected_double_click"; marshaller = marshal_unit }
 104     let prev_month : ([>`calendar],_) t =
 105       { name = "prev_month"; marshaller = marshal_unit }
 106     let next_month : ([>`calendar],_) t =
 107       { name = "next_month"; marshaller = marshal_unit }
 108     let prev_year : ([>`calendar],_) t =
 109       { name = "prev_year"; marshaller = marshal_unit }
 110     let next_year : ([>`calendar],_) t =
 111       { name = "next_year"; marshaller = marshal_unit }
 112   end
 113 end
 114
 115 module DrawingArea = struct
 116   let cast w : drawing_area obj = Object.try_cast w "GtkDrawingArea"
 117   external create : unit -> drawing_area obj = "ml_gtk_drawing_area_new"
 118   external size : [>`drawing] obj -> width:int -> height:int -> unit
 119       = "ml_gtk_drawing_area_size"
 120 end
 121
 122 (* Does not seem very useful ...
 123 module Curve = struct
 124   type t = [widget drawing curve] obj
 125   let cast w : t = Object.try_cast w "GtkCurve"
 126   external create : unit -> t = "ml_gtk_curve_new"
 127   external reset : [>`curve] obj -> unit = "ml_gtk_curve_reset"
 128   external set_gamma : [>`curve] obj -> float -> unit
 129       = "ml_gtk_curve_set_gamma"
 130   external set_range :
 131       [>`curve] obj -> min_x:float -> max_x:float ->
 132       min_y:float -> max_y:float -> unit
 133       = "ml_gtk_curve_set_gamma"
 134 end
 135 *)
 136
 137 module Misc = struct
 138   let cast w : misc obj = Object.try_cast w "GtkMisc"
 139   external coerce : [>`misc] obj -> misc obj = "%identity"
 140   external set_alignment : [>`misc] obj -> x:float -> y:float -> unit
 141       = "ml_gtk_misc_set_alignment"
 142   external set_padding : [>`misc] obj -> x:int -> y:int -> unit
 143       = "ml_gtk_misc_set_padding"
 144   external get_xalign : [>`misc] obj -> float = "ml_gtk_misc_get_xalign"
 145   external get_yalign : [>`misc] obj -> float = "ml_gtk_misc_get_yalign"
 146   external get_xpad : [>`misc] obj -> int = "ml_gtk_misc_get_xpad"
 147   external get_ypad : [>`misc] obj -> int = "ml_gtk_misc_get_ypad"
 148   let set_alignment w ?x ?y () =
 149     set_alignment w ~x:(may_default get_xalign w ~opt:x)
 150       ~y:(may_default get_yalign w ~opt:y)
 151   let set_padding w ?x ?y () =
 152     set_padding w ~x:(may_default get_xpad w ~opt:x)
 153       ~y:(may_default get_ypad w ~opt:y)
 154   let set ?xalign ?yalign ?xpad ?ypad ?(width = -2) ?(height = -2) w =
 155     if xalign <> None || yalign <> None then
 156       set_alignment w ?x:xalign ?y:yalign ();
 157     if xpad <> None || ypad <> None then
 158       set_padding w ?x:xpad ?y:ypad ();
 159     if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
 160 end
 161
 162 module Arrow = struct
 163   let cast w : arrow obj = Object.try_cast w "GtkArrow"
 164   external create : kind:arrow_type -> shadow:shadow_type -> arrow obj
 165       = "ml_gtk_arrow_new"
 166   external set : [>`arrow] obj -> kind:arrow_type -> shadow:shadow_type -> unit
 167       = "ml_gtk_arrow_set"
 168 end
 169
 170 module Image = struct
 171   let cast w : image obj = Object.try_cast w "GtkImage"
 172   external create : Gdk.image -> ?mask:Gdk.bitmap -> image obj
 173       = "ml_gtk_image_new"
 174   let create ?mask img = create img ?mask
 175   external set : [>`image] obj -> Gdk.image -> ?mask:Gdk.bitmap -> unit
 176       = "ml_gtk_image_set"
 177 end
 178
 179 module Label = struct
 180   let cast w : label obj = Object.try_cast w "GtkLabel"
 181   external coerce : [>`label] obj -> label obj = "%identity"
 182   external create : string -> label obj = "ml_gtk_label_new"
 183   external set_text : [>`label] obj -> string -> unit = "ml_gtk_label_set_text"
 184   external set_justify : [>`label] obj -> justification -> unit
 185       = "ml_gtk_label_set_justify"
 186   external set_pattern : [>`label] obj -> string -> unit
 187       = "ml_gtk_label_set_pattern"
 188   external set_line_wrap : [>`label] obj -> bool -> unit
 189       = "ml_gtk_label_set_line_wrap"
 190   let set ?text ?justify ?line_wrap ?pattern w =
 191     may ~f:(set_text w) text;
 192     may ~f:(set_justify w) justify;
 193     may ~f:(set_line_wrap w) line_wrap;
 194     may ~f:(set_pattern w) pattern
 195   external get_text : [>`label] obj -> string = "ml_gtk_label_get_label"
 196 end
 197
 198 module TipsQuery = struct
 199   let cast w : tips_query obj = Object.try_cast w "GtkTipsQuery"
 200   external create : unit -> tips_query obj = "ml_gtk_tips_query_new"
 201   external start : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_start_query"
 202   external stop : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_stop_query"
 203   external set_caller : [>`tipsquery] obj -> [>`widget] obj -> unit
 204       = "ml_gtk_tips_query_set_caller"
 205   external set_labels :
 206       [>`tipsquery] obj -> inactive:string -> no_tip:string -> unit
 207       = "ml_gtk_tips_query_set_labels"
 208   external set_emit_always : [>`tipsquery] obj -> bool -> unit
 209       = "ml_gtk_tips_query_set_emit_always"
 210   external get_caller : [>`tipsquery] obj -> widget obj
 211       = "ml_gtk_tips_query_get_caller"
 212   external get_label_inactive : [>`tipsquery] obj -> string
 213       = "ml_gtk_tips_query_get_label_inactive"
 214   external get_label_no_tip : [>`tipsquery] obj -> string
 215       = "ml_gtk_tips_query_get_label_no_tip"
 216   external get_emit_always : [>`tipsquery] obj -> bool
 217       = "ml_gtk_tips_query_get_emit_always"
 218   let set_labels ?inactive ?no_tip w =
 219     set_labels w
 220       ~inactive:(may_default get_label_inactive w ~opt:inactive)
 221       ~no_tip:(may_default get_label_no_tip w ~opt:no_tip)
 222   let set ?caller ?emit_always ?label_inactive ?label_no_tip w =
 223     may caller ~f:(set_caller w);
 224     may emit_always ~f:(set_emit_always w);
 225     if label_inactive <> None || label_no_tip <> None then
 226       set_labels w ?inactive:label_inactive ?no_tip:label_no_tip
 227   module Signals = struct
 228     open GtkArgv
 229     open GtkSignal
 230     let start_query : ([>`tipsquery],_) t =
 231       { name = "start_query"; marshaller = marshal_unit }
 232     let stop_query : ([>`tipsquery],_) t =
 233       { name = "stop_query"; marshaller = marshal_unit }
 234     let widget_entered :
 235         ([>`tipsquery],
 236          widget obj option ->
 237          text:string option -> privat:string option -> unit) t =
 238       let marshal f _ = function
 239         | OBJECT opt :: STRING text :: STRING privat :: _ ->
 240             f (may_map ~f:Widget.cast opt) ~text ~privat
 241         | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_entered"
 242       in
 243       { name = "widget_entered"; marshaller = marshal }
 244     let widget_selected :
 245         ([>`tipsquery],
 246          widget obj option ->
 247          text:string option ->
 248          privat:string option -> GdkEvent.Button.t option -> bool) t =
 249       let marshal f argv = function
 250         | OBJECT obj :: STRING text :: STRING privat :: POINTER p :: _ ->
 251             let stop =
 252               f (may_map ~f:Widget.cast obj) ~text ~privat
 253                 (may_map ~f:GdkEvent.unsafe_copy p)
 254             in set_result argv (`BOOL stop)
 255         | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_selected"
 256       in
 257       { name = "widget_selected"; marshaller = marshal }
 258   end
 259 end
 260
 261 module Pixmap = struct
 262   let cast w : pixmap obj = Object.try_cast w "GtkPixmap"
 263   external create : Gdk.pixmap -> ?mask:Gdk.bitmap -> pixmap obj
 264       = "ml_gtk_pixmap_new"
 265   let create ?mask img = create img ?mask
 266   external set :
 267       [>`pixmap] obj -> ?pixmap:Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
 268       = "ml_gtk_pixmap_set"
 269   external pixmap : [>`pixmap] obj -> Gdk.pixmap = "ml_GtkPixmap_pixmap"
 270   external mask : [>`pixmap] obj -> Gdk.bitmap = "ml_GtkPixmap_mask"
 271 end
 272
 273 module Separator = struct
 274   let cast w : separator obj = Object.try_cast w "GtkSeparator"
 275   external hseparator_new : unit -> separator obj = "ml_gtk_hseparator_new"
 276   external vseparator_new : unit -> separator obj = "ml_gtk_vseparator_new"
 277   let create (dir : Tags.orientation) =
 278     if dir = `HORIZONTAL then hseparator_new () else vseparator_new ()
 279 end
 280
 281 module FontSelection = struct
 282   type null_terminated
 283   let null_terminated arg : null_terminated =
 284     match arg with None -> Obj.magic Gpointer.raw_null
 285     | Some l ->
 286         let len = List.length l in
 287         let arr = Array.create (len + 1) "" in
 288         let rec loop i = function
 289             [] -> arr.(i) <- Obj.magic Gpointer.raw_null
 290           | s::l -> arr.(i) <- s; loop (i+1) l
 291         in loop 0 l;
 292         Obj.magic (arr : string array)
 293   let cast w : font_selection obj =
 294     Object.try_cast w "GtkFontSelection"
 295   external create : unit -> font_selection obj
 296       = "ml_gtk_font_selection_new"
 297   external get_font : [>`fontsel] obj -> Gdk.font
 298       = "ml_gtk_font_selection_get_font"
 299   let get_font w =
 300     try Some (get_font w) with Gpointer.Null -> None
 301   external get_font_name : [>`fontsel] obj -> string
 302       = "ml_gtk_font_selection_get_font_name"
 303   let get_font_name w =
 304     try Some (get_font_name w) with Gpointer.Null -> None
 305   external set_font_name : [>`fontsel] obj -> string -> unit
 306       = "ml_gtk_font_selection_set_font_name"
 307   external set_filter :
 308     [>`fontsel] obj -> font_filter_type -> font_type list ->
 309     null_terminated -> null_terminated -> null_terminated ->
 310     null_terminated -> null_terminated -> null_terminated -> unit
 311     = "ml_gtk_font_selection_set_filter_bc"
 312       "ml_gtk_font_selection_set_filter"
 313   let set_filter w ?kind:(tl=[`ALL]) ?foundry
 314       ?weight ?slant ?setwidth ?spacing ?charset filter =
 315     set_filter w filter tl (null_terminated foundry)
 316       (null_terminated weight) (null_terminated slant)
 317       (null_terminated setwidth) (null_terminated spacing)
 318       (null_terminated charset)
 319   external get_preview_text : [>`fontsel] obj -> string
 320       = "ml_gtk_font_selection_get_preview_text"
 321   external set_preview_text : [>`fontsel] obj -> string -> unit
 322       = "ml_gtk_font_selection_set_preview_text"
 323 end