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

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6 open GtkBase
   7
   8 module Editable = struct
   9   let cast w : editable obj = Object.try_cast w "GtkEditable"
  10   external coerce : [>`editable] obj -> editable obj = "%identity"
  11   external select_region : [>`editable] obj -> start:int -> stop:int -> unit
  12       = "ml_gtk_editable_select_region"
  13   external insert_text : [>`editable] obj -> string -> pos:int -> int
  14       = "ml_gtk_editable_insert_text"
  15   external delete_text : [>`editable] obj -> start:int -> stop:int -> unit
  16       = "ml_gtk_editable_delete_text"
  17   external get_chars : [>`editable] obj -> start:int -> stop:int -> string
  18       = "ml_gtk_editable_get_chars"
  19   external cut_clipboard : [>`editable] obj -> unit
  20       = "ml_gtk_editable_cut_clipboard"
  21   external copy_clipboard : [>`editable] obj -> unit
  22       = "ml_gtk_editable_copy_clipboard"
  23   external paste_clipboard : [>`editable] obj -> unit
  24       = "ml_gtk_editable_paste_clipboard"
  25   external claim_selection :
  26       [>`editable] obj -> claim:bool -> time:int -> unit
  27       = "ml_gtk_editable_claim_selection"
  28   external delete_selection : [>`editable] obj -> unit
  29       = "ml_gtk_editable_delete_selection"
  30   external changed : [>`editable] obj -> unit = "ml_gtk_editable_changed"
  31   external set_position : [>`editable] obj -> int -> unit
  32       = "ml_gtk_editable_set_position"
  33   external get_position : [>`editable] obj -> int
  34       = "ml_gtk_editable_get_position"
  35   external set_editable : [>`editable] obj -> bool -> unit
  36       = "ml_gtk_editable_set_editable"
  37   external selection_start_pos : [>`editable] obj -> int
  38       = "ml_gtk_editable_selection_start_pos"
  39   external selection_end_pos : [>`editable] obj -> int
  40       = "ml_gtk_editable_selection_end_pos"
  41   external has_selection : [>`editable] obj -> bool
  42       = "ml_gtk_editable_has_selection"
  43   module Signals = struct
  44     open GtkArgv
  45     open GtkSignal
  46     let activate : ([>`editable],_) t =
  47       { name = "activate"; marshaller = marshal_unit }
  48     let changed : ([>`editable],_) t =
  49       { name = "changed"; marshaller = marshal_unit }
  50     let marshal_insert f argv = function
  51       | STRING _ :: INT len :: POINTER(Some pos) :: _ ->
  52           (* XXX These two accesses are implementation-dependent *)
  53           let s = string_at_pointer (get_pointer argv ~pos:0) ~len
  54           and pos = int_at_pointer pos in
  55           f s ~pos
  56       | _ -> invalid_arg "GtkEdit.Editable.Signals.marshal_insert"
  57     let insert_text : ([>`editable],_) t =
  58       { name = "insert_text"; marshaller = marshal_insert }
  59     let marshal_delete f _ = function
  60       | INT start :: INT stop :: _ ->
  61           f ~start ~stop
  62       | _ -> invalid_arg "GtkEdit.Editable.Signals.marshal_delete"
  63     let delete_text : ([>`editable],_) t =
  64       { name = "delete_text"; marshaller = marshal_delete }
  65   end
  66 end
  67
  68 module Entry = struct
  69   let cast w : entry obj = Object.try_cast w "GtkEntry"
  70   external coerce : [>`entry] obj -> entry obj = "%identity"
  71   external create : unit -> entry obj = "ml_gtk_entry_new"
  72   external create_with_max_length : int -> entry obj
  73       = "ml_gtk_entry_new_with_max_length"
  74   let create ?max_length () =
  75     match max_length with None -> create ()
  76     | Some len -> create_with_max_length len
  77   external set_text : [>`entry] obj -> string -> unit
  78       = "ml_gtk_entry_set_text"
  79   external append_text : [>`entry] obj -> string -> unit
  80       = "ml_gtk_entry_append_text"
  81   external prepend_text : [>`entry] obj -> string -> unit
  82       = "ml_gtk_entry_prepend_text"
  83   external get_text : [>`entry] obj -> string = "ml_gtk_entry_get_text"
  84   external set_visibility : [>`entry] obj -> bool -> unit
  85       = "ml_gtk_entry_set_visibility"
  86   external set_max_length : [>`entry] obj -> int -> unit
  87       = "ml_gtk_entry_set_max_length"
  88   let set ?text ?visibility ?max_length w =
  89     let may_set f = may ~f:(f w) in
  90     may_set set_text text;
  91     may_set set_visibility visibility;
  92     may_set set_max_length max_length
  93   external text_length : [>`entry] obj -> int
  94       = "ml_GtkEntry_text_length"
  95 end
  96
  97 module SpinButton = struct
  98   let cast w : spin_button obj = Object.try_cast w "GtkSpinButton"
  99   external create :
 100       [>`adjustment] optobj -> rate:float -> digits:int -> spin_button obj
 101       = "ml_gtk_spin_button_new"
 102   let create ?adjustment ?(rate=0.5) ?(digits=0) () =
 103     create (Gpointer.optboxed adjustment) ~rate ~digits
 104   external configure :
 105     [>`spinbutton] obj -> adjustment:[>`adjustment] obj ->
 106     rate:float -> digits:int -> unit
 107     = "ml_gtk_spin_button_configure"
 108   external set_adjustment : [>`spinbutton] obj -> [>`adjustment] obj -> unit
 109       = "ml_gtk_spin_button_set_adjustment"
 110   external get_adjustment : [>`spinbutton] obj -> adjustment obj
 111       = "ml_gtk_spin_button_get_adjustment"
 112   external set_digits : [>`spinbutton] obj -> int -> unit
 113       = "ml_gtk_spin_button_set_digits"
 114   external get_value : [>`spinbutton] obj -> float
 115       = "ml_gtk_spin_button_get_value_as_float"
 116   let get_value_as_int w = truncate (get_value w +. 0.5)
 117   external set_value : [>`spinbutton] obj -> float -> unit
 118       = "ml_gtk_spin_button_set_value"
 119   external set_update_policy :
 120       [>`spinbutton] obj -> [`ALWAYS|`IF_VALID] -> unit
 121       = "ml_gtk_spin_button_set_update_policy"
 122   external set_numeric : [>`spinbutton] obj -> bool -> unit
 123       = "ml_gtk_spin_button_set_numeric"
 124   external spin : [>`spinbutton] obj -> spin_type -> unit
 125       = "ml_gtk_spin_button_spin"
 126   external set_wrap : [>`spinbutton] obj -> bool -> unit
 127       = "ml_gtk_spin_button_set_wrap"
 128   external set_shadow_type : [>`spinbutton] obj -> shadow_type -> unit
 129       = "ml_gtk_spin_button_set_shadow_type"
 130   external set_snap_to_ticks : [>`spinbutton] obj -> bool -> unit
 131       = "ml_gtk_spin_button_set_snap_to_ticks"
 132   external update : [>`spinbutton] obj -> unit
 133       = "ml_gtk_spin_button_update"
 134   let set ?adjustment ?digits ?value ?update_policy
 135       ?numeric ?wrap ?shadow_type ?snap_to_ticks w =
 136     let may_set f = may ~f:(f w) in
 137     may_set set_adjustment adjustment;
 138     may_set set_digits digits;
 139     may_set set_value value;
 140     may_set set_update_policy update_policy;
 141     may_set set_numeric numeric;
 142     may_set set_wrap wrap;
 143     may_set set_shadow_type shadow_type;
 144     may_set set_snap_to_ticks snap_to_ticks
 145 end
 146
 147 module Text = struct
 148   let cast w : text obj = Object.try_cast w "GtkText"
 149   external create : [>`adjustment] optobj -> [>`adjustment] optobj -> text obj
 150       = "ml_gtk_text_new"
 151   let create ?hadjustment ?vadjustment () =
 152     create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
 153   external set_word_wrap : [>`text] obj -> bool -> unit
 154       = "ml_gtk_text_set_word_wrap"
 155   external set_line_wrap : [>`text] obj -> bool -> unit
 156       = "ml_gtk_text_set_line_wrap"
 157   external set_adjustment :
 158       [>`text] obj -> ?horizontal:[>`adjustment] obj ->
 159       ?vertical:[>`adjustment] obj -> unit -> unit
 160       = "ml_gtk_text_set_adjustments"
 161   external get_hadjustment : [>`text] obj -> adjustment obj
 162       = "ml_gtk_text_get_hadj"
 163   external get_vadjustment : [>`text] obj -> adjustment obj
 164       = "ml_gtk_text_get_vadj"
 165   external set_point : [>`text] obj -> int -> unit
 166       = "ml_gtk_text_set_point"
 167   external get_point : [>`text] obj -> int = "ml_gtk_text_get_point"
 168   external get_length : [>`text] obj -> int = "ml_gtk_text_get_length"
 169   external freeze : [>`text] obj -> unit = "ml_gtk_text_freeze"
 170   external thaw : [>`text] obj -> unit = "ml_gtk_text_thaw"
 171   external insert :
 172       [>`text] obj -> ?font:Gdk.font -> ?foreground:Gdk.Color.t ->
 173       ?background:Gdk.Color.t -> string -> unit
 174       = "ml_gtk_text_insert"
 175   let set ?hadjustment ?vadjustment ?word_wrap w =
 176     if hadjustment <> None || vadjustment <> None then
 177       set_adjustment w ?horizontal: hadjustment ?vertical: vadjustment ();
 178     may word_wrap ~f:(set_word_wrap w)
 179 end
 180
 181 module Combo = struct
 182   let cast w : combo obj = Object.try_cast w "GtkCombo"
 183   external create : unit -> combo obj = "ml_gtk_combo_new"
 184   external set_value_in_list :
 185       [>`combo] obj -> ?required:bool -> ?ok_if_empty:bool -> unit -> unit
 186       = "ml_gtk_combo_set_value_in_list"
 187   external set_use_arrows : [>`combo] obj -> bool -> unit
 188       = "ml_gtk_combo_set_use_arrows"
 189   external set_use_arrows_always : [>`combo] obj -> bool -> unit
 190       = "ml_gtk_combo_set_use_arrows_always"
 191   external set_case_sensitive : [>`combo] obj -> bool -> unit
 192       = "ml_gtk_combo_set_case_sensitive"
 193   external set_item_string : [>`combo] obj -> [>`item] obj -> string -> unit
 194       = "ml_gtk_combo_set_item_string"
 195   external entry : [>`combo] obj -> entry obj= "ml_gtk_combo_entry"
 196   external list : [>`combo] obj -> liste obj= "ml_gtk_combo_list"
 197   let set_popdown_strings combo strings =
 198     GtkList.Liste.clear_items (list combo) ~start:0 ~stop:(-1);
 199     List.iter strings ~f:
 200       begin fun s ->
 201         let li = GtkList.ListItem.create_with_label s in
 202         Widget.show li;
 203         Container.add (list combo) li
 204       end
 205   let set_use_arrows' w (mode : [`NEVER|`DEFAULT|`ALWAYS]) =
 206     let def,always =
 207       match mode with
 208         `NEVER -> false, false
 209       | `DEFAULT -> true, false
 210       | `ALWAYS -> true, true
 211     in
 212     set_use_arrows w def;
 213     set_use_arrows_always w always
 214   let set ?popdown_strings ?use_arrows
 215       ?case_sensitive ?value_in_list ?ok_if_empty w =
 216     may popdown_strings ~f:(set_popdown_strings w);
 217     may use_arrows ~f:(set_use_arrows' w);
 218     may case_sensitive ~f:(set_case_sensitive w);
 219     if value_in_list <> None || ok_if_empty <> None then
 220       set_value_in_list w ?required:value_in_list ?ok_if_empty ()
 221   external disable_activate : [>`combo] obj -> unit
 222       = "ml_gtk_combo_disable_activate"
 223 end