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

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6 open GtkBase
   7
   8 module ListItem = struct
   9   let cast w : list_item obj = Object.try_cast w "GtkListItem"
  10   external create : unit -> list_item obj = "ml_gtk_list_item_new"
  11   external create_with_label : string -> list_item obj
  12       = "ml_gtk_list_item_new_with_label"
  13   let create ?label () =
  14     match label with None -> create ()
  15     | Some label -> create_with_label label
  16 end
  17
  18 module Liste = struct
  19   let cast w : liste obj = Object.try_cast w "GtkList"
  20   external create : unit -> liste obj = "ml_gtk_list_new"
  21   external insert_item :
  22       [>`list] obj -> [>`listitem] obj -> pos:int -> unit
  23       = "ml_gtk_list_insert_item"
  24   let insert_items l wl ~pos =
  25     let wl = if pos < 0 then wl else List.rev wl in
  26     List.iter wl ~f:(insert_item l ~pos)
  27   let append_items l = insert_items l ~pos:(-1)
  28   let prepend_items l = insert_items l ~pos:0
  29   external clear_items : [>`list] obj -> start:int -> stop:int -> unit =
  30     "ml_gtk_list_clear_items"
  31   external select_item : [>`list] obj -> pos:int -> unit
  32       = "ml_gtk_list_select_item"
  33   external unselect_item : [>`list] obj -> pos:int -> unit
  34       = "ml_gtk_list_unselect_item"
  35   external select_child : [>`list] obj -> [>`listitem] obj -> unit
  36       = "ml_gtk_list_select_child"
  37   external unselect_child : [>`list] obj -> [>`listitem] obj -> unit
  38       = "ml_gtk_list_unselect_child"
  39   external child_position : [>`list] obj -> [>`listitem] obj -> int
  40       = "ml_gtk_list_child_position"
  41   external set_selection_mode : [>`list] obj -> selection_mode -> unit
  42       = "ml_gtk_list_set_selection_mode"
  43   module Signals = struct
  44     open GtkSignal
  45     let selection_changed : ([>`list],_) t =
  46       { name = "selection_changed"; marshaller = marshal_unit }
  47     let select_child : ([>`list],_) t =
  48       { name = "select_child"; marshaller = Widget.Signals.marshal }
  49     let unselect_child : ([>`list],_) t =
  50       { name = "unselect_child"; marshaller = Widget.Signals.marshal }
  51   end
  52 end
  53
  54 module CList = struct
  55   let cast w : clist obj = Object.try_cast w "GtkCList"
  56   external create : cols:int -> clist obj = "ml_gtk_clist_new"
  57   external create_with_titles : string array -> clist obj
  58       = "ml_gtk_clist_new_with_titles"
  59   external get_rows : [>`clist] obj -> int = "ml_gtk_clist_get_rows"
  60   external get_columns : [>`clist] obj -> int = "ml_gtk_clist_get_columns"
  61   external get_focus_row : [>`clist] obj -> int
  62       = "ml_gtk_clist_get_focus_row"
  63   external set_hadjustment : [>`clist] obj -> [>`adjustment] obj -> unit
  64       = "ml_gtk_clist_set_hadjustment"
  65   external set_vadjustment : [>`clist] obj -> [>`adjustment] obj -> unit
  66       = "ml_gtk_clist_set_vadjustment"
  67   external get_hadjustment : [>`clist] obj -> adjustment obj
  68       = "ml_gtk_clist_get_hadjustment"
  69   external get_vadjustment : [>`clist] obj -> adjustment obj
  70       = "ml_gtk_clist_get_vadjustment"
  71   external set_shadow_type : [>`clist] obj -> shadow_type -> unit
  72       = "ml_gtk_clist_set_shadow_type"
  73   external set_selection_mode : [>`clist] obj -> selection_mode -> unit
  74       = "ml_gtk_clist_set_selection_mode"
  75   external set_reorderable : [>`clist] obj -> bool -> unit
  76       = "ml_gtk_clist_set_reorderable"
  77   external set_use_drag_icons : [>`clist] obj -> bool -> unit
  78       = "ml_gtk_clist_set_use_drag_icons"
  79   external set_button_actions :
  80       [>`clist] obj -> int -> button_action list -> unit
  81       = "ml_gtk_clist_set_button_actions"
  82   external freeze : [>`clist] obj -> unit = "ml_gtk_clist_freeze"
  83   external thaw : [>`clist] obj -> unit = "ml_gtk_clist_thaw"
  84   external column_titles_show : [>`clist] obj -> unit
  85       = "ml_gtk_clist_column_titles_show"
  86   external column_titles_hide : [>`clist] obj -> unit
  87       = "ml_gtk_clist_column_titles_hide"
  88   external column_title_active : [>`clist] obj -> int -> unit
  89       = "ml_gtk_clist_column_title_active"
  90   external column_title_passive : [>`clist] obj -> int -> unit
  91       = "ml_gtk_clist_column_title_passive"
  92   external column_titles_active : [>`clist] obj -> unit
  93       = "ml_gtk_clist_column_titles_active"
  94   external column_titles_passive : [>`clist] obj -> unit
  95       = "ml_gtk_clist_column_titles_passive"
  96   external set_column_title : [>`clist] obj -> int -> string -> unit
  97       = "ml_gtk_clist_set_column_title"
  98   external get_column_title : [>`clist] obj -> int -> string
  99       = "ml_gtk_clist_get_column_title"
 100   external set_column_widget : [>`clist] obj -> int -> [>`widget] obj -> unit
 101       = "ml_gtk_clist_set_column_widget"
 102   external get_column_widget : [>`clist] obj -> int -> widget obj
 103       = "ml_gtk_clist_get_column_widget"
 104   external set_column_justification :
 105       [>`clist] obj -> int -> justification -> unit
 106       = "ml_gtk_clist_set_column_justification"
 107   external set_column_visibility : [>`clist] obj -> int -> bool -> unit
 108       = "ml_gtk_clist_set_column_visibility"
 109   external set_column_resizeable : [>`clist] obj -> int -> bool -> unit
 110       = "ml_gtk_clist_set_column_resizeable"
 111   external set_column_auto_resize : [>`clist] obj -> int -> bool -> unit
 112       = "ml_gtk_clist_set_column_auto_resize"
 113   external columns_autosize : [>`clist] obj -> unit
 114       = "ml_gtk_clist_columns_autosize"
 115   external optimal_column_width : [>`clist] obj -> int -> int
 116       = "ml_gtk_clist_optimal_column_width"
 117   external set_column_width : [>`clist] obj -> int -> int -> unit
 118       = "ml_gtk_clist_set_column_width"
 119   external set_column_min_width : [>`clist] obj -> int -> int -> unit
 120       = "ml_gtk_clist_set_column_min_width"
 121   external set_column_max_width : [>`clist] obj -> int -> int -> unit
 122       = "ml_gtk_clist_set_column_max_width"
 123   external set_row_height : [>`clist] obj -> int -> unit
 124       = "ml_gtk_clist_set_row_height"
 125   external moveto :
 126       [>`clist] obj ->
 127       int -> int -> row_align:clampf -> col_align:clampf -> unit
 128       = "ml_gtk_clist_moveto"
 129   external row_is_visible : [>`clist] obj -> int -> visibility
 130       = "ml_gtk_clist_row_is_visible"
 131   external get_cell_type : [>`clist] obj -> int -> int -> cell_type
 132       = "ml_gtk_clist_get_cell_type"
 133   external set_text : [>`clist] obj -> int -> int -> string -> unit
 134       = "ml_gtk_clist_set_text"
 135   external get_text : [>`clist] obj -> int -> int -> string
 136       = "ml_gtk_clist_get_text"
 137   external set_pixmap :
 138       [>`clist] obj ->
 139       int -> int -> Gdk.pixmap -> Gdk.bitmap Gpointer.optboxed -> unit
 140       = "ml_gtk_clist_set_pixmap"
 141   external get_pixmap :
 142       [>`clist] obj -> int -> int -> Gdk.pixmap option * Gdk.bitmap option
 143       = "ml_gtk_clist_get_pixmap"
 144   external set_pixtext :
 145       [>`clist] obj -> int -> int ->
 146       string -> int -> Gdk.pixmap -> Gdk.bitmap Gpointer.optboxed -> unit
 147       = "ml_gtk_clist_set_pixtext_bc" "ml_gtk_clist_set_pixtext"
 148   external set_foreground :
 149       [>`clist] obj -> row:int -> Gdk.Color.t Gpointer.optboxed -> unit
 150       = "ml_gtk_clist_set_foreground"
 151   external set_background :
 152       [>`clist] obj -> row:int -> Gdk.Color.t Gpointer.optboxed -> unit
 153       = "ml_gtk_clist_set_background"
 154   external get_cell_style : [>`clist] obj -> int -> int -> Gtk.style
 155       = "ml_gtk_clist_get_cell_style"
 156   external set_cell_style : [>`clist] obj -> int -> int -> Gtk.style -> unit
 157       = "ml_gtk_clist_set_cell_style"
 158   external get_row_style : [>`clist] obj -> row:int -> Gtk.style
 159       = "ml_gtk_clist_get_row_style"
 160   external set_row_style : [>`clist] obj -> row:int -> Gtk.style -> unit
 161       = "ml_gtk_clist_set_row_style"
 162   external set_selectable : [>`clist] obj -> row:int -> bool -> unit
 163       = "ml_gtk_clist_set_selectable"
 164   external get_selectable : [>`clist] obj -> row:int -> bool
 165       = "ml_gtk_clist_get_selectable"
 166   external set_shift :
 167       [>`clist] obj -> int -> int -> vertical:int -> horizontal:int -> unit
 168       = "ml_gtk_clist_set_shift"
 169   external insert : [>`clist] obj -> row:int -> Gpointer.optstring array -> int
 170       = "ml_gtk_clist_insert"
 171   let insert w ~row texts =
 172     let len = get_columns w in
 173     if List.length texts > len then invalid_arg "CList.insert";
 174     let arr = Array.create (get_columns w) None in
 175     List.fold_left texts ~init:0
 176       ~f:(fun pos text -> arr.(pos) <- text; pos+1);
 177     let r = insert w ~row (Array.map ~f:Gpointer.optstring arr) in
 178     if r = -1 then invalid_arg "GtkCList::insert";
 179     r
 180   external remove : [>`clist] obj -> row:int -> unit
 181       = "ml_gtk_clist_remove"
 182   external set_row_data : [>`clist] obj -> row:int -> Obj.t -> unit
 183       = "ml_gtk_clist_set_row_data"
 184   external get_row_data : [>`clist] obj -> row:int -> Obj.t
 185       = "ml_gtk_clist_get_row_data"
 186   external select : [>`clist] obj -> int -> int -> unit
 187       = "ml_gtk_clist_select_row"
 188   external unselect : [>`clist] obj -> int -> int -> unit
 189       = "ml_gtk_clist_unselect_row"
 190   external clear : [>`clist] obj -> unit = "ml_gtk_clist_clear"
 191   external get_row_column : [>`clist] obj -> x:int -> y:int -> int * int
 192       = "ml_gtk_clist_get_selection_info"
 193   external select_all : [>`clist] obj -> unit = "ml_gtk_clist_select_all"
 194   external unselect_all : [>`clist] obj -> unit = "ml_gtk_clist_unselect_all"
 195   external swap_rows : [>`clist] obj -> int -> int -> unit
 196       = "ml_gtk_clist_swap_rows"
 197   external row_move : [>`clist] obj -> int -> dst:int -> unit
 198       = "ml_gtk_clist_row_move"
 199   external set_sort_column : [>`clist] obj -> int -> unit
 200       = "ml_gtk_clist_set_sort_column"
 201   external set_sort_type : [>`clist] obj -> sort_type -> unit
 202       = "ml_gtk_clist_set_sort_type"
 203   external sort : [>`clist] obj -> unit
 204       = "ml_gtk_clist_sort"
 205   external set_auto_sort : [>`clist] obj -> bool -> unit
 206       = "ml_gtk_clist_set_auto_sort"
 207   let set_titles_show w = function
 208       true -> column_titles_show w
 209     | false -> column_titles_hide w
 210   let set_titles_active w = function
 211       true -> column_titles_active w
 212     | false -> column_titles_passive w
 213   let set ?hadjustment ?vadjustment ?shadow_type
 214       ?(button_actions=[]) ?selection_mode ?reorderable
 215       ?use_drag_icons ?row_height ?titles_show ?titles_active w =
 216     let may_set f param = may param ~f:(f w) in
 217     may_set set_hadjustment hadjustment;
 218     may_set set_vadjustment vadjustment;
 219     may_set set_shadow_type shadow_type;
 220     List.iter button_actions ~f:(fun (n,act) -> set_button_actions w n act);
 221     may_set set_selection_mode selection_mode;
 222     may_set set_reorderable reorderable;
 223     may_set set_use_drag_icons use_drag_icons;
 224     may_set set_row_height row_height;
 225     may_set set_titles_show titles_show;
 226     may_set set_titles_active titles_active
 227   let set_sort w ?auto ?column ?dir:sort_type () =
 228     may auto ~f:(set_auto_sort w);
 229     may column ~f:(set_sort_column w);
 230     may sort_type ~f:(set_sort_type w)
 231   let set_cell w ?text ?pixmap ?mask ?(spacing=0) ?style row col =
 232     begin match text, pixmap with
 233     | Some text, None ->
 234         set_text w row col text
 235     | None, Some pm ->
 236         set_pixmap w row col pm (Gpointer.optboxed mask)
 237     | Some text, Some pm ->
 238         set_pixtext w row col text spacing pm (Gpointer.optboxed mask)
 239     | _ -> ()
 240     end;
 241     may style ~f:(set_cell_style w row col)
 242   let set_column w ?widget ?title ?title_active ?justification
 243       ?visibility ?resizeable ?auto_resize ?width ?min_width ?max_width
 244       col =
 245     let may_set f param = may param ~f:(f w col) in
 246     may_set set_column_widget widget;
 247     may_set set_column_title title;
 248     may title_active
 249       ~f:(fun active -> if active then column_title_active w col
 250                                    else column_title_passive w col);
 251     may_set set_column_justification justification;
 252     may_set set_column_visibility visibility;
 253     may_set set_column_resizeable resizeable;
 254     may_set set_column_auto_resize auto_resize;
 255     may_set set_column_width width;
 256     may_set set_column_min_width min_width;
 257     may_set set_column_max_width max_width
 258   let set_row w ?foreground ?background ?selectable ?style row =
 259     let may_set f = may ~f:(f w ~row) in
 260     may_set set_foreground foreground;
 261     may_set set_background  background;
 262     may_set set_selectable  selectable;
 263     may_set set_row_style style
 264   module Signals = struct
 265     open GtkArgv
 266     open GtkSignal
 267     let marshal_select f argv = function
 268       | INT row :: INT column :: POINTER p :: _ ->
 269           let event : GdkEvent.Button.t option =
 270             may_map ~f:GdkEvent.unsafe_copy p
 271           in
 272           f ~row ~column ~event
 273       | _ -> invalid_arg "GtkList.CList.Signals.marshal_select"
 274     let select_row : ([>`clist],_) t =
 275       { name = "select_row"; marshaller = marshal_select }
 276     let unselect_row : ([>`clist],_) t =
 277       { name = "unselect_row"; marshaller = marshal_select }
 278     let click_column : ([>`clist],_) t =
 279       { name = "click_column"; marshaller = marshal_int }
 280     external val_scroll_type : int -> scroll_type = "ml_Val_scroll_type"
 281     let marshal_scroll f argv = function
 282       | INT st :: FLOAT (pos : clampf) :: _ ->
 283           f (val_scroll_type st) ~pos
 284       | _ -> invalid_arg "GtkList.CList.Signals.marshal_scroll"
 285     let scroll_horizontal : ([>`clist],_) t =
 286       { name = "scroll_horizontal"; marshaller = marshal_scroll }
 287     let scroll_vertical : ([>`clist],_) t =
 288       { name = "scroll_vertical"; marshaller = marshal_scroll }
 289     external emit_scroll :
 290         'a obj -> name:string -> Tags.scroll_type -> pos:clampf -> unit
 291         = "ml_gtk_signal_emit_scroll"
 292     let emit_scroll = emit ~emitter:emit_scroll
 293   end
 294 end