+++ /dev/null
-(* $Id$ *)
-
-open Gaux
-open Gtk
-open Tags
-open GtkBase
-
-module GammaCurve = struct
- let cast w : gamma_curve obj = Object.try_cast w "GtkGammaCurve"
- external create : unit -> gamma_curve obj = "ml_gtk_gamma_curve_new"
- external get_gamma : [>`gamma] obj -> float = "ml_gtk_gamma_curve_get_gamma"
-end
-
-module ColorSelection = struct
- let cast w : color_selection obj = Object.try_cast w "GtkColorSelection"
- external create : unit -> color_selection obj = "ml_gtk_color_selection_new"
- external create_dialog : string -> color_selection_dialog obj
- = "ml_gtk_color_selection_dialog_new"
- external set_update_policy : [>`colorsel] obj -> update_type -> unit
- = "ml_gtk_color_selection_set_update_policy"
- external set_opacity : [>`colorsel] obj -> bool -> unit
- = "ml_gtk_color_selection_set_opacity"
- let set ?update_policy ?opacity w =
- may update_policy ~f:(set_update_policy w);
- may opacity ~f:(set_opacity w)
- external set_color :
- [>`colorsel] obj ->
- red:float -> green:float -> blue:float -> ?opacity:float -> unit
- = "ml_gtk_color_selection_set_color"
- external get_color : [>`colorsel] obj -> color
- = "ml_gtk_color_selection_get_color"
-
- external ok_button : [>`colorseldialog] obj -> button obj =
- "ml_gtk_color_selection_dialog_ok_button"
- external cancel_button : [>`colorseldialog] obj -> button obj =
- "ml_gtk_color_selection_dialog_cancel_button"
- external help_button : [>`colorseldialog] obj -> button obj =
- "ml_gtk_color_selection_dialog_help_button"
- external colorsel : [>`colorseldialog] obj -> color_selection obj =
- "ml_gtk_color_selection_dialog_colorsel"
- module Signals = struct
- open GtkSignal
- let color_changed : ([>`colorsel],_) t =
- { name = "color_changed"; marshaller = marshal_unit }
- end
-end
-
-module Statusbar = struct
- let cast w : statusbar obj = Object.try_cast w "GtkStatusbar"
- external create : unit -> statusbar obj = "ml_gtk_statusbar_new"
- external get_context : [>`statusbar] obj -> string -> statusbar_context
- = "ml_gtk_statusbar_get_context_id"
- external push :
- [>`statusbar] obj ->
- statusbar_context -> text:string -> statusbar_message
- = "ml_gtk_statusbar_push"
- external pop : [>`statusbar] obj -> statusbar_context -> unit
- = "ml_gtk_statusbar_pop"
- external remove :
- [>`statusbar] obj -> statusbar_context -> statusbar_message -> unit
- = "ml_gtk_statusbar_remove"
- module Signals = struct
- open GtkSignal
- let text_pushed : ([>`statusbar],_) t =
- let marshal f _ = function
- | GtkArgv.INT ctx :: GtkArgv.STRING s :: _ ->
- f (Obj.magic ctx : statusbar_context) s
- | _ -> invalid_arg "GtkMisc.Statusbar.Signals.marshal_text"
- in
- { name = "text_pushed"; marshaller = marshal }
- end
-end
-
-module Calendar = struct
- let cast w : calendar obj = Object.try_cast w "GtkCalendar"
- external create : unit -> calendar obj = "ml_gtk_calendar_new"
- external select_month : [>`calendar] obj -> month:int -> year:int -> unit
- = "ml_gtk_calendar_select_month"
- external select_day : [>`calendar] obj -> int -> unit
- = "ml_gtk_calendar_select_day"
- external mark_day : [>`calendar] obj -> int -> unit
- = "ml_gtk_calendar_mark_day"
- external unmark_day : [>`calendar] obj -> int -> unit
- = "ml_gtk_calendar_unmark_day"
- external clear_marks : [>`calendar] obj -> unit
- = "ml_gtk_calendar_clear_marks"
- external display_options :
- [>`calendar] obj -> Tags.calendar_display_options list -> unit
- = "ml_gtk_calendar_display_options"
- external get_date : [>`calendar] obj -> int * int * int
- = "ml_gtk_calendar_get_date" (* year * month * day *)
- external freeze : [>`calendar] obj -> unit
- = "ml_gtk_calendar_freeze"
- external thaw : [>`calendar] obj -> unit
- = "ml_gtk_calendar_thaw"
- module Signals = struct
- open GtkSignal
- let month_changed : ([>`calendar],_) t =
- { name = "month_changed"; marshaller = marshal_unit }
- let day_selected : ([>`calendar],_) t =
- { name = "day_selected"; marshaller = marshal_unit }
- let day_selected_double_click : ([>`calendar],_) t =
- { name = "day_selected_double_click"; marshaller = marshal_unit }
- let prev_month : ([>`calendar],_) t =
- { name = "prev_month"; marshaller = marshal_unit }
- let next_month : ([>`calendar],_) t =
- { name = "next_month"; marshaller = marshal_unit }
- let prev_year : ([>`calendar],_) t =
- { name = "prev_year"; marshaller = marshal_unit }
- let next_year : ([>`calendar],_) t =
- { name = "next_year"; marshaller = marshal_unit }
- end
-end
-
-module DrawingArea = struct
- let cast w : drawing_area obj = Object.try_cast w "GtkDrawingArea"
- external create : unit -> drawing_area obj = "ml_gtk_drawing_area_new"
- external size : [>`drawing] obj -> width:int -> height:int -> unit
- = "ml_gtk_drawing_area_size"
-end
-
-(* Does not seem very useful ...
-module Curve = struct
- type t = [widget drawing curve] obj
- let cast w : t = Object.try_cast w "GtkCurve"
- external create : unit -> t = "ml_gtk_curve_new"
- external reset : [>`curve] obj -> unit = "ml_gtk_curve_reset"
- external set_gamma : [>`curve] obj -> float -> unit
- = "ml_gtk_curve_set_gamma"
- external set_range :
- [>`curve] obj -> min_x:float -> max_x:float ->
- min_y:float -> max_y:float -> unit
- = "ml_gtk_curve_set_gamma"
-end
-*)
-
-module Misc = struct
- let cast w : misc obj = Object.try_cast w "GtkMisc"
- external coerce : [>`misc] obj -> misc obj = "%identity"
- external set_alignment : [>`misc] obj -> x:float -> y:float -> unit
- = "ml_gtk_misc_set_alignment"
- external set_padding : [>`misc] obj -> x:int -> y:int -> unit
- = "ml_gtk_misc_set_padding"
- external get_xalign : [>`misc] obj -> float = "ml_gtk_misc_get_xalign"
- external get_yalign : [>`misc] obj -> float = "ml_gtk_misc_get_yalign"
- external get_xpad : [>`misc] obj -> int = "ml_gtk_misc_get_xpad"
- external get_ypad : [>`misc] obj -> int = "ml_gtk_misc_get_ypad"
- let set_alignment w ?x ?y () =
- set_alignment w ~x:(may_default get_xalign w ~opt:x)
- ~y:(may_default get_yalign w ~opt:y)
- let set_padding w ?x ?y () =
- set_padding w ~x:(may_default get_xpad w ~opt:x)
- ~y:(may_default get_ypad w ~opt:y)
- let set ?xalign ?yalign ?xpad ?ypad ?(width = -2) ?(height = -2) w =
- if xalign <> None || yalign <> None then
- set_alignment w ?x:xalign ?y:yalign ();
- if xpad <> None || ypad <> None then
- set_padding w ?x:xpad ?y:ypad ();
- if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
-end
-
-module Arrow = struct
- let cast w : arrow obj = Object.try_cast w "GtkArrow"
- external create : kind:arrow_type -> shadow:shadow_type -> arrow obj
- = "ml_gtk_arrow_new"
- external set : [>`arrow] obj -> kind:arrow_type -> shadow:shadow_type -> unit
- = "ml_gtk_arrow_set"
-end
-
-module Image = struct
- let cast w : image obj = Object.try_cast w "GtkImage"
- external create : Gdk.image -> ?mask:Gdk.bitmap -> image obj
- = "ml_gtk_image_new"
- let create ?mask img = create img ?mask
- external set : [>`image] obj -> Gdk.image -> ?mask:Gdk.bitmap -> unit
- = "ml_gtk_image_set"
-end
-
-module Label = struct
- let cast w : label obj = Object.try_cast w "GtkLabel"
- external coerce : [>`label] obj -> label obj = "%identity"
- external create : string -> label obj = "ml_gtk_label_new"
- external set_text : [>`label] obj -> string -> unit = "ml_gtk_label_set_text"
- external set_justify : [>`label] obj -> justification -> unit
- = "ml_gtk_label_set_justify"
- external set_pattern : [>`label] obj -> string -> unit
- = "ml_gtk_label_set_pattern"
- external set_line_wrap : [>`label] obj -> bool -> unit
- = "ml_gtk_label_set_line_wrap"
- let set ?text ?justify ?line_wrap ?pattern w =
- may ~f:(set_text w) text;
- may ~f:(set_justify w) justify;
- may ~f:(set_line_wrap w) line_wrap;
- may ~f:(set_pattern w) pattern
- external get_text : [>`label] obj -> string = "ml_gtk_label_get_label"
-end
-
-module TipsQuery = struct
- let cast w : tips_query obj = Object.try_cast w "GtkTipsQuery"
- external create : unit -> tips_query obj = "ml_gtk_tips_query_new"
- external start : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_start_query"
- external stop : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_stop_query"
- external set_caller : [>`tipsquery] obj -> [>`widget] obj -> unit
- = "ml_gtk_tips_query_set_caller"
- external set_labels :
- [>`tipsquery] obj -> inactive:string -> no_tip:string -> unit
- = "ml_gtk_tips_query_set_labels"
- external set_emit_always : [>`tipsquery] obj -> bool -> unit
- = "ml_gtk_tips_query_set_emit_always"
- external get_caller : [>`tipsquery] obj -> widget obj
- = "ml_gtk_tips_query_get_caller"
- external get_label_inactive : [>`tipsquery] obj -> string
- = "ml_gtk_tips_query_get_label_inactive"
- external get_label_no_tip : [>`tipsquery] obj -> string
- = "ml_gtk_tips_query_get_label_no_tip"
- external get_emit_always : [>`tipsquery] obj -> bool
- = "ml_gtk_tips_query_get_emit_always"
- let set_labels ?inactive ?no_tip w =
- set_labels w
- ~inactive:(may_default get_label_inactive w ~opt:inactive)
- ~no_tip:(may_default get_label_no_tip w ~opt:no_tip)
- let set ?caller ?emit_always ?label_inactive ?label_no_tip w =
- may caller ~f:(set_caller w);
- may emit_always ~f:(set_emit_always w);
- if label_inactive <> None || label_no_tip <> None then
- set_labels w ?inactive:label_inactive ?no_tip:label_no_tip
- module Signals = struct
- open GtkArgv
- open GtkSignal
- let start_query : ([>`tipsquery],_) t =
- { name = "start_query"; marshaller = marshal_unit }
- let stop_query : ([>`tipsquery],_) t =
- { name = "stop_query"; marshaller = marshal_unit }
- let widget_entered :
- ([>`tipsquery],
- widget obj option ->
- text:string option -> privat:string option -> unit) t =
- let marshal f _ = function
- | OBJECT opt :: STRING text :: STRING privat :: _ ->
- f (may_map ~f:Widget.cast opt) ~text ~privat
- | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_entered"
- in
- { name = "widget_entered"; marshaller = marshal }
- let widget_selected :
- ([>`tipsquery],
- widget obj option ->
- text:string option ->
- privat:string option -> GdkEvent.Button.t option -> bool) t =
- let marshal f argv = function
- | OBJECT obj :: STRING text :: STRING privat :: POINTER p :: _ ->
- let stop =
- f (may_map ~f:Widget.cast obj) ~text ~privat
- (may_map ~f:GdkEvent.unsafe_copy p)
- in set_result argv (`BOOL stop)
- | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_selected"
- in
- { name = "widget_selected"; marshaller = marshal }
- end
-end
-
-module Pixmap = struct
- let cast w : pixmap obj = Object.try_cast w "GtkPixmap"
- external create : Gdk.pixmap -> ?mask:Gdk.bitmap -> pixmap obj
- = "ml_gtk_pixmap_new"
- let create ?mask img = create img ?mask
- external set :
- [>`pixmap] obj -> ?pixmap:Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
- = "ml_gtk_pixmap_set"
- external pixmap : [>`pixmap] obj -> Gdk.pixmap = "ml_GtkPixmap_pixmap"
- external mask : [>`pixmap] obj -> Gdk.bitmap = "ml_GtkPixmap_mask"
-end
-
-module Separator = struct
- let cast w : separator obj = Object.try_cast w "GtkSeparator"
- external hseparator_new : unit -> separator obj = "ml_gtk_hseparator_new"
- external vseparator_new : unit -> separator obj = "ml_gtk_vseparator_new"
- let create (dir : Tags.orientation) =
- if dir = `HORIZONTAL then hseparator_new () else vseparator_new ()
-end
-
-module FontSelection = struct
- type null_terminated
- let null_terminated arg : null_terminated =
- match arg with None -> Obj.magic Gpointer.raw_null
- | Some l ->
- let len = List.length l in
- let arr = Array.create (len + 1) "" in
- let rec loop i = function
- [] -> arr.(i) <- Obj.magic Gpointer.raw_null
- | s::l -> arr.(i) <- s; loop (i+1) l
- in loop 0 l;
- Obj.magic (arr : string array)
- let cast w : font_selection obj =
- Object.try_cast w "GtkFontSelection"
- external create : unit -> font_selection obj
- = "ml_gtk_font_selection_new"
- external get_font : [>`fontsel] obj -> Gdk.font
- = "ml_gtk_font_selection_get_font"
- let get_font w =
- try Some (get_font w) with Gpointer.Null -> None
- external get_font_name : [>`fontsel] obj -> string
- = "ml_gtk_font_selection_get_font_name"
- let get_font_name w =
- try Some (get_font_name w) with Gpointer.Null -> None
- external set_font_name : [>`fontsel] obj -> string -> unit
- = "ml_gtk_font_selection_set_font_name"
- external set_filter :
- [>`fontsel] obj -> font_filter_type -> font_type list ->
- null_terminated -> null_terminated -> null_terminated ->
- null_terminated -> null_terminated -> null_terminated -> unit
- = "ml_gtk_font_selection_set_filter_bc"
- "ml_gtk_font_selection_set_filter"
- let set_filter w ?kind:(tl=[`ALL]) ?foundry
- ?weight ?slant ?setwidth ?spacing ?charset filter =
- set_filter w filter tl (null_terminated foundry)
- (null_terminated weight) (null_terminated slant)
- (null_terminated setwidth) (null_terminated spacing)
- (null_terminated charset)
- external get_preview_text : [>`fontsel] obj -> string
- = "ml_gtk_font_selection_get_preview_text"
- external set_preview_text : [>`fontsel] obj -> string -> unit
- = "ml_gtk_font_selection_set_preview_text"
-end
projects / helm.git / blobdiff