]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkBin.ml
* implemented a more efficient selection to avoid flickering
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / gtkBin.ml
1 (* $Id$ *)
2
3 open Gaux
4 open Gtk
5 open Tags
6 open GtkBase
7
8 module Alignment = struct
9   let cast w : alignment obj = Object.try_cast w "GtkAlignment"
10   external create :
11       x:clampf -> y:clampf -> xscale:clampf -> yscale:clampf -> alignment obj
12       = "ml_gtk_alignment_new"
13   let create ?(x=0.5) ?(y=0.5) ?(xscale=1.) ?(yscale=1.) () =
14     create ~x ~y ~xscale ~yscale
15   external set :
16       ?x:clampf -> ?y:clampf -> ?xscale:clampf -> ?yscale:clampf ->
17       [>`alignment] obj -> unit
18       = "ml_gtk_alignment_set"
19 end
20
21 module EventBox = struct
22   let cast w : event_box obj = Object.try_cast w "GtkEventBox"
23   external create : unit -> event_box obj = "ml_gtk_event_box_new"
24 end
25
26 module Frame = struct
27   let cast w : frame obj = Object.try_cast w "GtkFrame"
28   external coerce : [>`frame] obj -> frame obj = "%identity"
29   external create : string -> frame obj = "ml_gtk_frame_new"
30   external set_label : [>`frame] obj -> string -> unit
31       = "ml_gtk_frame_set_label"
32   external set_label_align : [>`frame] obj -> x:clampf -> y:clampf -> unit
33       = "ml_gtk_frame_set_label_align"
34   external set_shadow_type : [>`frame] obj -> shadow_type -> unit
35       = "ml_gtk_frame_set_shadow_type"
36   external get_label_xalign : [>`frame] obj -> float
37       = "ml_gtk_frame_get_label_xalign"
38   external get_label_yalign : [>`frame] obj -> float
39       = "ml_gtk_frame_get_label_yalign"
40   let set_label_align' ?x ?y w =
41     set_label_align w
42       ~x:(may_default get_label_xalign w ~opt:x)
43       ~y:(may_default get_label_yalign w ~opt:y)
44   let set ?label ?label_xalign ?label_yalign ?shadow_type w =
45     may label ~f:(set_label w);
46     if label_xalign <> None || label_yalign <> None then
47       set_label_align' w ?x:label_xalign ?y:label_yalign;
48     may shadow_type ~f:(set_shadow_type w)
49 end
50
51 module AspectFrame = struct
52   let cast w : aspect_frame obj = Object.try_cast w "GtkAspectFrame"
53   external create :
54       label:string -> xalign:clampf ->
55       yalign:clampf -> ratio:float -> obey_child:bool -> aspect_frame obj
56       = "ml_gtk_aspect_frame_new"
57   let create ?(label="") ?(xalign=0.5) ?(yalign=0.5)
58       ?(ratio=1.0) ?(obey_child=true) () =
59     create ~label ~xalign ~yalign ~ratio ~obey_child
60   external set :
61       [>`aspect] obj ->
62       xalign:clampf -> yalign:clampf -> ratio:float -> obey_child:bool -> unit
63       = "ml_gtk_aspect_frame_set"
64   external get_xalign : [>`aspect] obj -> clampf
65       = "ml_gtk_aspect_frame_get_xalign"
66   external get_yalign : [>`aspect] obj -> clampf
67       = "ml_gtk_aspect_frame_get_yalign"
68   external get_ratio : [>`aspect] obj -> clampf
69       = "ml_gtk_aspect_frame_get_ratio"
70   external get_obey_child : [>`aspect] obj -> bool
71       = "ml_gtk_aspect_frame_get_obey_child"
72   let set ?xalign ?yalign ?ratio ?obey_child w =
73     if xalign <> None || yalign <> None || ratio <> None || obey_child <> None
74     then set w
75         ~xalign:(may_default get_xalign w ~opt:xalign)
76         ~yalign:(may_default get_yalign w ~opt:yalign)
77         ~ratio:(may_default get_ratio w ~opt:ratio)
78         ~obey_child:(may_default get_obey_child w ~opt:obey_child)
79 end
80
81 module HandleBox = struct
82   let cast w : handle_box obj = Object.try_cast w "GtkHandleBox"
83   external create : unit -> handle_box obj = "ml_gtk_handle_box_new"
84   external set_shadow_type : [>`handlebox] obj -> shadow_type -> unit =
85    "ml_gtk_handle_box_set_shadow_type"
86   external set_handle_position : [>`handlebox] obj -> position -> unit =
87    "ml_gtk_handle_box_set_handle_position"
88   external set_snap_edge : [>`handlebox] obj -> position -> unit =
89    "ml_gtk_handle_box_set_snap_edge"
90   module Signals = struct
91     open GtkSignal
92     let child_attached : ([>`handlebox],_) t =
93       { name = "child_attached"; marshaller = Widget.Signals.marshal }
94     let child_detached : ([>`handlebox],_) t =
95       { name = "child_detached"; marshaller = Widget.Signals.marshal }
96   end
97 end
98
99 module Viewport = struct
100   let cast w : viewport obj = Object.try_cast w "GtkViewport"
101   external create :
102       [>`adjustment] optobj -> [>`adjustment] optobj -> viewport obj
103       = "ml_gtk_viewport_new"
104   let create ?hadjustment ?vadjustment () =
105     create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
106   external get_hadjustment : [>`viewport] obj -> adjustment obj
107       = "ml_gtk_viewport_get_hadjustment"
108   external get_vadjustment : [>`viewport] obj -> adjustment obj
109       = "ml_gtk_viewport_get_vadjustment"
110   external set_hadjustment : [>`viewport] obj -> [>`adjustment] obj -> unit
111       = "ml_gtk_viewport_set_hadjustment"
112   external set_vadjustment : [>`viewport] obj -> [>`adjustment] obj -> unit
113       = "ml_gtk_viewport_set_vadjustment"
114   external set_shadow_type : [>`viewport] obj -> shadow_type -> unit
115       = "ml_gtk_viewport_set_shadow_type"
116   let set ?hadjustment ?vadjustment ?shadow_type w =
117     may hadjustment ~f:(set_hadjustment w);
118     may vadjustment ~f:(set_vadjustment w);
119     may shadow_type ~f:(set_shadow_type w)
120 end
121
122 module ScrolledWindow = struct
123   let cast w : scrolled_window obj = Object.try_cast w "GtkScrolledWindow"
124   external create :
125       [>`adjustment] optobj -> [>`adjustment] optobj -> scrolled_window obj
126       = "ml_gtk_scrolled_window_new"
127   let create ?hadjustment ?vadjustment () =
128     create (Gpointer.optboxed hadjustment) (Gpointer.optboxed vadjustment)
129   external set_hadjustment : [>`scrolled] obj -> [>`adjustment] obj -> unit
130       = "ml_gtk_scrolled_window_set_hadjustment"
131   external set_vadjustment : [>`scrolled] obj -> [>`adjustment] obj -> unit
132       = "ml_gtk_scrolled_window_set_vadjustment"
133   external get_hadjustment : [>`scrolled] obj -> adjustment obj
134       = "ml_gtk_scrolled_window_get_hadjustment"
135   external get_vadjustment : [>`scrolled] obj -> adjustment obj
136       = "ml_gtk_scrolled_window_get_vadjustment"
137   external set_policy : [>`scrolled] obj -> policy_type -> policy_type -> unit
138       = "ml_gtk_scrolled_window_set_policy"
139   external add_with_viewport : [>`scrolled] obj -> [>`widget] obj -> unit
140       = "ml_gtk_scrolled_window_add_with_viewport"
141   external get_hscrollbar_policy : [>`scrolled] obj -> policy_type
142       = "ml_gtk_scrolled_window_get_hscrollbar_policy"
143   external get_vscrollbar_policy : [>`scrolled] obj -> policy_type
144       = "ml_gtk_scrolled_window_get_vscrollbar_policy"
145   external set_placement : [>`scrolled] obj -> corner_type -> unit
146       = "ml_gtk_scrolled_window_set_placement"
147   let set_policy' ?hpolicy ?vpolicy w =
148     set_policy w
149       (may_default get_hscrollbar_policy w ~opt:hpolicy)
150       (may_default get_vscrollbar_policy w ~opt:vpolicy)
151   let set ?hpolicy ?vpolicy ?placement w =
152     if hpolicy <> None || vpolicy <> None then
153       set_policy' w ?hpolicy ?vpolicy;
154     may placement ~f:(set_placement w)
155 end
156
157 module Socket = struct
158   let cast w : socket obj = Object.try_cast w "GtkSocket"
159   external coerce : [>`socket] obj -> socket obj = "%identity"
160   external create : unit -> socket obj = "ml_gtk_socket_new"
161   external steal : [>`socket] obj -> Gdk.xid -> unit = "ml_gtk_socket_steal"
162 end
163
164 (*
165 module Invisible = struct
166   let cast w : socket obj = Object.try_cast w "GtkInvisible"
167   external coerce : [>`invisible] obj -> invisible obj = "%identity"
168   external create : unit -> invisible obj = "ml_gtk_invisible_new"
169 end
170 *)