1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
class type detachable_signals =
object
inherit GContainer.container_signals
method attached : callback:(GObj.widget -> unit) -> unit
method detached : callback:(GObj.widget -> unit) -> unit
end
class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) =
object(self)
inherit GPack.box_skel (obj :> Gtk.box Gobject.obj) as super
val but = GButton.button ()
val win = GWindow.window ()
val frame = GBin.frame ~shadow_type:`NONE ()
val mutable detached = false
val mutable detached_cb = (fun _ -> ())
val mutable attached_cb = (fun _ -> ())
method child = frame#child
method add = frame#add
method pack ?from ?expand ?fill ?padding w =
if frame#all_children = [] then self#add w
else raise (Invalid_argument "detachable#pack")
method title = win#title
method set_title = win#set_title
method connect : detachable_signals = object
inherit GContainer.container_signals_impl obj
method attached ~callback = attached_cb <- callback
method detached ~callback = detached_cb <- callback
end
method show =
if detached then win#present ()
else self#misc#show ();
method hide =
if detached then win#misc#hide ()
else self#misc#hide ()
method visible = win#misc#visible || self#misc#visible
initializer
self#set_homogeneous false;
super#pack ~expand:false but#coerce;
super#pack ~expand:true ~fill:true frame#coerce;
win#misc#hide ();
but#add (GMisc.label
~markup:"<span size='x-small'>D\nE\nT\nA\nC\nH</span>" ())#coerce;
ignore(win#event#connect#delete ~callback:(fun _ ->
win#misc#hide ();
frame#misc#reparent self#coerce;
detached <- false;
attached_cb self#child;
true));
ignore(but#connect#clicked ~callback:(fun _ ->
frame#misc#reparent win#coerce;
self#misc#hide ();
win#present ();
detached <- true;
detached_cb self#child;
))
end
let detachable ?title =
GtkPack.Box.make_params [] ~cont:(
GContainer.pack_container
~create:(fun p ->
let d = new detachable (GtkPack.Box.create `HORIZONTAL p) in
Option.iter d#set_title title;
d))
open Preferences
class command_window name coqtop =
let frame = detachable ~title:"Query pane" () in
let _ = frame#hide in
let _ = GtkData.AccelGroup.create () in
let notebook =
GPack.notebook ~height:200 ~scrollable:true ~packing:frame#add () in
let _ = frame#connect#attached ~callback:(fun _ ->
notebook#misc#set_size_request ~height:200 ()) in
let _ = frame#connect#detached ~callback:(fun _ ->
notebook#misc#set_size_request ~width:600 ~height:500 ();
notebook#misc#grab_focus ()) in
object(self)
val frame = frame
val notebook = notebook
method pack_in (f : GObj.widget -> unit) = f frame#coerce
val mutable new_page : GObj.widget = (GMisc.label ())#coerce
val mutable views = []
method private new_page_maker =
let page = notebook#append_page
(GMisc.label ~text:"No query" ())#coerce in
let page = notebook#get_nth_page page in
let b = GButton.button () in
b#add (Ideutils.stock_to_widget ~size:`MENU `NEW);
ignore(b#connect#clicked ~callback:self#new_query);
notebook#set_page ~tab_label:b#coerce page;
new_page <- page
method new_query ?command ?term () =
let frame = GBin.frame ~shadow_type:`NONE () in
ignore(notebook#insert_page ~pos:(notebook#page_num new_page) frame#coerce);
let new_tab_lbl text =
let hbox = GPack.hbox ~homogeneous:false () in
ignore(GMisc.label ~width:100 ~ellipsize:`END ~text ~packing:hbox#pack());
let b = GButton.button ~packing:hbox#pack () in
ignore(b#connect#clicked ~callback:(fun () ->
views <-
List.filter (fun (f,_,_) -> f#get_oid <> frame#coerce#get_oid) views;
notebook#remove_page (notebook#page_num frame#coerce)));
b#add (Ideutils.stock_to_widget ~size:`MENU `CLOSE);
hbox#coerce in
notebook#set_page ~tab_label:(new_tab_lbl "New query") frame#coerce;
notebook#goto_page (notebook#page_num frame#coerce);
let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
let combo, entry, ok_b =
let bar =
GButton.toolbar ~style:`ICONS ~packing:(vbox#pack ~expand:false) () in
let bar_add ~expand w =
let item = GButton.tool_item ~expand () in
item#add w#coerce;
bar#insert item in
let combo, _ =
GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving () in
combo#entry#set_text "Search";
let entry = GEdit.entry () in
entry#misc#set_can_default true;
let ok_b = GButton.button () in
ok_b#add (Ideutils.stock_to_widget `OK);
bar_add ~expand:false combo;
bar_add ~expand:true entry;
bar_add ~expand:false ok_b;
combo, entry, ok_b in
let r_bin =
GBin.scrolled_window
~vpolicy:`AUTOMATIC
~hpolicy:`AUTOMATIC
~packing:(vbox#pack ~fill:true ~expand:true) () in
let result = GText.view ~packing:r_bin#add () in
views <- (frame#coerce, result, combo#entry) :: views;
result#misc#modify_font current.text_font;
let clr = Tags.color_of_string current.background_color in
result#misc#modify_base [`NORMAL, `COLOR clr];
result#misc#set_can_focus true; (* false causes problems for selection *)
result#set_editable false;
let callback () =
let com = combo#entry#text in
let arg = entry#text in
if Str.string_match (Str.regexp "^ *$") (com^arg) 0 then () else
let phrase =
if Str.string_match (Str.regexp "\\. *$") com 0 then com
else com ^ " " ^ arg ^" . "
in
let log level message = result#buffer#insert (message^"\n") in
let process =
Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
| Interface.Fail (_,l,str) ->
result#buffer#insert str;
notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
Coq.return ()
| Interface.Good res ->
result#buffer#insert res;
notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce;
Coq.return ())
in
result#buffer#set_text ("Result for command " ^ phrase ^ ":\n");
Coq.try_grab coqtop process ignore
in
ignore (combo#entry#connect#activate ~callback);
ignore (ok_b#connect#clicked ~callback);
begin match command with
| None -> ()
| Some c -> combo#entry#set_text c
end;
begin match term with
| None -> ()
| Some t -> entry#set_text t
end;
combo#entry#misc#grab_focus ();
entry#misc#grab_default ();
ignore (entry#connect#activate ~callback);
ignore (combo#entry#connect#activate ~callback);
ignore (combo#entry#event#connect#key_press ~callback:(fun ev ->
if GdkEvent.Key.keyval ev = GdkKeysyms._Tab then
(entry#misc#grab_focus ();true)
else false))
method show =
frame#show;
let cur_page = notebook#get_nth_page notebook#current_page in
let _, _, e =
List.find (fun (p,_,_) -> p#get_oid == cur_page#get_oid) views in
e#misc#grab_focus ()
method hide =
frame#hide
method visible =
frame#visible
method refresh_font () =
let iter (_,view,_) = view#misc#modify_font current.text_font in
List.iter iter views
method refresh_color () =
let clr = Tags.color_of_string current.background_color in
let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
List.iter iter views
initializer
self#new_page_maker;
self#new_query ();
frame#misc#hide ();
ignore(notebook#event#connect#key_press ~callback:(fun ev ->
if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
else false
));
end
|
