-
Notifications
You must be signed in to change notification settings - Fork 0
/
gui.ml
783 lines (610 loc) · 21.3 KB
/
gui.ml
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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
open Common
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* old:
* This file was named gCommon.ml to be coherent with the other lalbgtk files.
*
*)
(*****************************************************************************)
(* Example of overall organisation to follow: *)
(*****************************************************************************)
(* Overall layout organisation:
* - menu (File, Edit, View, X, Help)
* - toolbar
* - mainview
* left right
* ---- -----
* playlist instrinc props
* objects
* source
* - statusbar
*
* Conventions:
* w = window, [hv]box = box, [hv]p, paned
* b = button, e = entry, m = menu, mi = menuitem, r = range, fc = factory
* l = list, lbl = label
*
* Model/View/Controller for global organization
* (model.ml, controller.ml, view.ml)
*
* Model/View/Controller organization for many columns too.
* - model = GTree columns+GTree store+fill function
* - view = GTree view+GTree view columns
* - controler = fill callback+change callback
* So sometimes have a double model, the real data model (model.ml) and
* then the model that is needed by Gtk to work with some TreeView.
*
*
* When want add a feature:
* - add it to the model
* - add helpers and maybe fields in database/, comments/, etc
* - add gui code
*
* Also try first to add the feature as a command line option by
* adding some -text_xx code in a test.ml file. That way
* you ensure that you separate concern clearly and then add in the gui
* just the gui specific stuff.
*)
(*###########################################################################*)
(* *)
(*###########################################################################*)
(*****************************************************************************)
(* Widgets composition *)
(*****************************************************************************)
(*
* I want to compose widgets easily. I want to have a declarative way to
* build the gui, a way where the code looks like the interface :) like
* a calligramme (cf http://fr.wikipedia.org/wiki/Calligramme).
*
* So I want ideally do do things like
* (build_vbox
* [build_menu
* build_item "File" callback:(fun () -> some_action);
* build_item "Close" callback:(fun () -> some_other_action);
* ]
* ....
*
* so that the imbrication, the nestedness of the code corresponds visually
* to the imbrication of the widgets. Note that sometimes we need
* from one widget to call some methods on other widgets, so in those
* case it requires to at least name with a let some intermediate widgets.
*
* In some way it's a little bit I guess like the xml file generated
* by glade except here it's code imbrication.
*
*
* The mk functions below are one attempt to allow this easy composition
* of widgets. With those functions one can write:
*
* w#add (GCommon.mk (GPack.vbox ~border_width:1 ~spacing:1) (fun vbox ->
* vbox#pack (GCommon.mk (GMenu.menu_bar) (fun m ->
* m#pack (CCommon.mk (GButton.button) (fun but ->
* do_stuff();
* ));
* ));
* ));
*
* instead of the more verbose and more space taking:
* w#add (
* let vbox = GPack.vbox ... in
* vbox#add (
* let m = Gmenu.menu_bar ... in
* m#pack (
* let but = GButton.button ... in
* do_stuff();
* buf#coerce
* );
* m#coerce;
* );
* vbox#coerce;
* );
*
* or instead of the even more verbose, flat, and so not very clear style
* described in the lablgtk2 tutorial.
*
*
* I could go even further, and as I ideally described before have
* some (build_vbox [widget1 ...; widget2 ...;]). But
* sometimes we want to say that some of the widgets in the vbox must
* fill the space, must expand, etc, so it would require at least
* to have inside the list a pair with a specifier and the widget, which
* gets more complicated. So it's easier to just use the multiple but flexible
* manual calls to vbox#add. Furthermore it's not very easy to define
* wrapper over the lablgtk functions because many of them use default
* parameters and types and wrappers get easily screwed by this.
*
* Nevertheless for some widgets there is very few need for flexibility,
* because for instance they are just wrappers around one widget, as for
* viewports, or frames, or are just vbox without parameters, such
* as the vpanes and hpanes. In those case I defined some wrappers
* over lablgtk which are more convienent. Cf the with_xxx below in this file.
*
*
* For example of uses, look at one of my gui.ml
*
*
*)
let mk widget f =
let widget = widget () in
f widget;
widget#coerce
let mk2 widget f =
let widget = widget () in
f widget;
widget
(* obsolete ? cos now use of factory is quite short:
* compare
* factory#add_submenu "_Edit" +> (fun menu ->
* and
* m#add (G.mk_menu (G.menu_item ~label:"_Edit") (fun menu ->
*)
let mk_menu menu_item f =
let menu_item = menu_item () in
let menu = GMenu.menu ~packing:menu_item#set_submenu () in
f menu;
menu_item
(*---------------------------------------------------------------------------*)
(* Functions to have even more concise style. Can then write
* w +> GCommon.add (GMenu.toolbar) (fun tb -> ...
* );
*
* to work, to not having typing pb, you need to specify the same
* default parameter when you define wrapper.
*)
let add widget f w =
let widget = widget () in
f widget;
w#add widget#coerce
let pack ?from ?expand ?fill ?padding = fun widget f w ->
let widget = widget () in
f widget;
w#pack ?from ?expand ?fill ?padding widget#coerce
let add_menu menu_item f w =
let menu_item = menu_item () in
let menu = GMenu.menu ~packing:menu_item#set_submenu () in
f menu;
w#add menu_item
(*---------------------------------------------------------------------------*)
let rec paneds orientation xs =
match xs with
| [] | [_] -> failwith "paneds: need at least 2 elements"
| [x;y] ->
let hp = GPack.paned orientation () in
hp#add1 x;
hp#add2 y;
hp#coerce
| x::xs ->
let hp = GPack.paned orientation () in
hp#add1 x;
hp#add2 (paneds orientation xs);
hp#coerce
(*****************************************************************************)
(* Widget wrappers *)
(*****************************************************************************)
(* Those functions allow to encapsulate some widgets with other one without
* the need to name those widgets.
*)
let with_frame widget =
let frame = GBin.frame (*~width:100*) () in
frame#add widget#coerce;
frame#coerce
let with_label text widget =
let box = GPack.hbox () in
let lbl = GMisc.label ~text () in
box#add lbl#coerce;
box#add (* ~expand:true ~fill:true *) widget;
box#coerce
(* this one works better than viewport2, because when change the selection
* with keyboard in a clist for instance, then this scolled window will
* follow automatically whereas viewport2 will not by default.
*)
let with_viewport widget =
let scrw = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ()
in
scrw#add widget;
scrw#coerce
(* apparently to use with widget without scrolling/adjusment built-in
* facility *)
let with_viewport2 widget =
let scrw = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ()
in
scrw#add_with_viewport widget;
scrw#coerce
(*****************************************************************************)
(* Keyboards/Mouse *)
(*****************************************************************************)
(*---------------------------------------------------------------------------*)
(* Mouse *)
(*---------------------------------------------------------------------------*)
let pos_of_ev ev =
let x = int_of_float (GdkEvent.Button.x ev) in
let y = int_of_float (GdkEvent.Button.y ev) in
x,y
(*---------------------------------------------------------------------------*)
(* Keyboard (key and also entry completion) *)
(*---------------------------------------------------------------------------*)
let key_press_escape_quit key =
if GdkEvent.Key.keyval key = GdkKeysyms._Escape then
GMain.Main.quit();
false
(*****************************************************************************)
(* Models (used by completion entry code) *)
(*****************************************************************************)
(* But take care, bad complexity:
* - with 25000 -> 6s
* - with 50000 -> 12s
* - with 100000 -> 44s
*)
let model_of_list conv l =
let cols = new GTree.column_list in
let column = cols#add conv in
let model = GTree.list_store cols in
pr2 (spf "model_of_list: length= %d" (List.length l));
Common.profile_code2 "model_of_list" (fun () ->
List.iter
(fun data ->
let row = model#append () in
model#set ~row ~column data)
l;
);
(model, column)
(*****************************************************************************)
(* Completion *)
(*****************************************************************************)
let entry_with_completion ~text ~completion =
let entry = GEdit.entry ~text () in
let (model, col) =
model_of_list Gobject.Data.string completion in
let c = GEdit.entry_completion ~model ~entry () in
c#set_text_column col;
entry
(* It takes time to build the model with model_of_list when
* have model with huge number of elements. The bottleneck is in the
* model building. So caller can cache this model and then call this
* function to be more efficient.
*
* Note that caching the widget instead of the underlying model
* apparently does not work well. The widget displays well the first
* time but not the second. Probably the gtk gc erase it and I don't know
* how to avoid that.
*)
let entry_with_completion_eff ~text ~model_col ?minimum_key_length () =
let entry = GEdit.entry ~text:"" () in
let (model, col) = model_col in
let c = GEdit.entry_completion ~model ~entry ?minimum_key_length () in
c#set_text_column col;
entry
(*###########################################################################*)
(* Special bigger widgets *)
(*###########################################################################*)
(*****************************************************************************)
(* CList widget Helpers *)
(*****************************************************************************)
let freeze_thaw f l =
begin
l#freeze ();
f();
l#thaw ();
end
let clist_connect ~callback:f (widget : string GList.clist) =
begin
widget#connect#select_row ~callback:(fun ~row ~column ~event ->
let s = widget#cell_text row 0 in
(match widget#row_is_visible row with
| `FULL ->
pr2 "full";
| _ ->
pr2 "here";
widget#moveto row column;
);
f (Some s);
);
widget#connect#unselect_row ~callback:(fun ~row ~column ~event ->
f None
);
end
let clist_update xs widget =
widget +> freeze_thaw (fun () ->
widget#clear ();
xs +> List.iter (fun dir ->
widget#append [dir;] +> ignore;
);
)
let clist_update_multicol xs widget =
widget +> freeze_thaw (fun () ->
widget#clear ();
xs +> List.iter (fun props ->
widget#append props +> ignore;
);
)
(*****************************************************************************)
(* GTree (model based) widget helpers *)
(*****************************************************************************)
(* todo? the manual say that should also disable the sorting of the view to
* be even faster *)
let model_modif f view =
let model = view#model in
view#set_model None;
f model;
view#set_model (Some model);
()
let sort_col column (model : #GTree.model) it_a it_b =
let a = model#get ~row:it_a ~column in
let b = model#get ~row:it_b ~column in
compare a b
(* (String.length a) (String.length b) *)
let view_column ~title ~renderer () =
let col = GTree.view_column ~title ~renderer () in
col#set_resizable true;
col
let view_expand_level (view: GTree.view) depth_limit =
view#collapse_all();
let store = view#model in
store#foreach (fun path iter ->
let depth = GTree.Path.get_depth path in
if depth <= depth_limit
then view#expand_row ~all:false path;
false
)
(*****************************************************************************)
(* GEdit and GSourceView *)
(*****************************************************************************)
(*****************************************************************************)
(* Html related *)
(*****************************************************************************)
(* todo? gHTML ? gtk_xmhtml ? but apparently only for gtk1.2 :( *)
(*###########################################################################*)
(* *)
(*###########################################################################*)
(*****************************************************************************)
(* Menu *)
(*****************************************************************************)
let menu_item ~label =
GMenu.menu_item ~use_mnemonic:true ~label
let mk_right_click_menu_on_store view fpath =
let popup_menu path ev =
let menu = GMenu.menu () in
GToolbox.build_menu menu ~entries:(fpath path);
menu#popup
~button:(GdkEvent.Button.button ev) ~time:(GdkEvent.Button.time ev);
in
(* right click *)
view#event#connect#button_press ~callback:(fun ev ->
if GdkEvent.Button.button ev = 3 then begin
pr2 "Right click";
let (x,y) = pos_of_ev ev in
(match view#get_path_at_pos ~x ~y with
| Some (path, _,_,_) ->
popup_menu path ev;
true
| None -> false
)
end
else false (* not a right click *)
)
(*****************************************************************************)
(* Dialogs *)
(*****************************************************************************)
(*---------------------------------------------------------------------------*)
(* Special case *)
(*---------------------------------------------------------------------------*)
let dialog_text ~text ~title =
let dialog = GWindow.dialog ~modal:true ~border_width:1 ~title () in
let _label = GMisc.label ~text ~packing:dialog#vbox#add () in
let dquit = GButton.button ~label:"Close" ~packing:dialog#vbox#add () in
begin
dquit#connect#clicked ~callback: (fun _ -> dialog#destroy ());
dialog#show ();
end
let todo_gui () =
dialog_text ~text:"This feature has not yet been implemented
but I encourage you to implement it yourself
as there is very few chances that I do it one day"
~title: "TODO"
(*---------------------------------------------------------------------------*)
(* Obsolete *)
(*---------------------------------------------------------------------------*)
(* Taken from uigtk2.ml from unison. Quite hard to communicate info between
* windows. I tried stuff but it does not work.
* update: look also at dialog_ask_filename, use a different mechanism.
*)
let dialog_ask_with_y_or_no_bis ~text ~title callerw =
let w = GWindow.dialog ~modal:true ~border_width:1 ~title () in
let entry = GEdit.entry ~text:"" ~editable:true () in
w#add_button_stock `YES `YES;
w#add_button_stock `NO `NO;
w#set_default_response `NO;
w#vbox#pack (with_label text entry#coerce);
w#set_transient_for (callerw#as_window);
callerw#misc#set_sensitive false;
w#show ();
let res = w#run () in
let text = entry#text in
w#destroy();
callerw#misc#set_sensitive true;
(match res with
| `YES -> Some text
| `NO | `DELETE_EVENT -> None
)
(* Note that polymorphism and inference works very well here.
* The 'answer' can be of any type.
*)
let dialog_ask_generic_bis ~title callerw fbuild fget_val =
let w = GWindow.dialog ~modal:true ~border_width:1 ~title () in
w#add_button_stock `YES `YES;
w#add_button_stock `NO `NO;
w#set_default_response `YES;
(* oldsimple:
let entry = GEdit.entry ~text:"" ~editable:true () in
w#vbox#pack (with_label text entry#coerce);
*)
fbuild w#vbox;
w#set_transient_for (callerw#as_window);
callerw#misc#set_sensitive false;
w#show ();
let res = w#run () in
(* oldsimple:
let text = entry#text in
*)
let answer = fget_val () in
w#destroy();
callerw#misc#set_sensitive true;
(match res with
| `YES -> Some answer
| `NO | `DELETE_EVENT -> None
)
(*---------------------------------------------------------------------------*)
(* Dialog_ask_generic *)
(*---------------------------------------------------------------------------*)
(* no need to callerw. src: cameleon ? *)
let dialog_ask_generic ?width ~title fbuild fget_val =
let res = ref None in
let w =
GWindow.dialog ~modal:true ~border_width:1 ~title ?width ()
in
w#connect#destroy ~callback: GMain.Main.quit;
let ok_button = GButton.button ~stock: `YES ()in
let no_button = GButton.button ~stock: `NO () in
let hbox = GPack.hbox () in
hbox#pack ~fill:true ok_button#coerce;
hbox#pack ~fill:true no_button#coerce;
fbuild w#vbox;
w#vbox#pack (*~fill:true *) hbox#coerce;
ok_button#connect#clicked ~callback:(fun () ->
res := Some (fget_val ());
w#destroy ()
);
no_button#connect#clicked ~callback:(fun () ->
res := None;
w#destroy ();
);
w#event#connect#key_press ~callback:(fun ev ->
let k = GdkEvent.Key.keyval ev in
if GdkKeysyms._Return = k then begin (* enter = 65293 *)
res := Some (fget_val ());
w#destroy ();
true
end
else begin
(* pr2 (i_to_s k); *)
false
end
);
w#show ();
GMain.Main.main ();
!res
(*---------------------------------------------------------------------------*)
(* Dialog_ask_generic users *)
(*---------------------------------------------------------------------------*)
let dialog_ask_with_y_or_no ~text ~title =
let entry = GEdit.entry ~text:"" ~editable:true () in
dialog_ask_generic ~title
(fun vbox ->
vbox#pack (with_label text entry#coerce);
)
(fun () ->
let text = entry#text in
text
)
let dialog_ask_y_or_no ~text ~title =
let lbl = GMisc.label ~text () in
let res =
dialog_ask_generic ~title
(fun vbox ->
vbox#pack (lbl#coerce);
)
(fun () ->
()
)
in
match res with
| Some () -> true
| None -> false
(*---------------------------------------------------------------------------*)
(* dialog_ask_filename *)
(*---------------------------------------------------------------------------*)
let dialog_ask_filename ~title ~filename =
let (res: filename option ref) = ref None in
let filew = GWindow.file_selection ~title ~filename ~modal:true () in
filew#connect#destroy ~callback: GMain.Main.quit;
filew#ok_button#connect#clicked ~callback:(fun () ->
res := Some (filew#filename);
filew#destroy ()
);
filew#cancel_button#connect#clicked ~callback:(fun () ->
res := None;
filew#destroy ();
);
filew#show ();
GMain.Main.main ();
!res
(* src: harrop. use pango markup langage *)
(*
let about () =
let md =
GWindow.message_dialog
~message:"<big>Minimal LablGTKGL program</big>\n\nAn example from the OCaml Journal."
~use_markup:true
~parent:window
~destroy_with_parent:true
~title:"About this program"
~message_type:`INFO
~buttons:GWindow.Buttons.ok
() in
ignore(md#run());
md#destroy()
*)
(*---------------------------------------------------------------------------*)
let dialog_text_large ~text ~title =
dialog_ask_generic ~title
(fun vbox ->
vbox#pack ~fill:true ~expand:true (with_viewport (mk (GText.view
~height:200 ~width:500
~editable:false)
(fun srcview ->
let buffer = srcview#buffer in
buffer#set_text text
)
)
))
(fun () ->
()
)
(*****************************************************************************)
(* Estethisme *)
(*****************************************************************************)
let mapping_color =
["Black";"DarkOrange";"DarkGreen";"DarkBlue";"DarkGray";"DarkYellow";]
(*****************************************************************************)
(* Misc *)
(*****************************************************************************)
let create_menu m label =
let item = GMenu.menu_item ~label ~packing:m#append () in
GMenu.menu ~packing:item#set_submenu ()
(* dumb widget *)
(* (G.mk (GMisc.label ~text:"other") (fun x -> ())); *)
(*****************************************************************************)
(* Main widget and loop *)
(*****************************************************************************)
let mk_gui_main ~title ?(width=800) ?(height=600) f =
GtkMain.Main.init();
let w = GWindow.window ~title ~width ~height () in
w#event#connect#delete ~callback:(fun _ -> GMain.Main.quit (); true);
w#connect#destroy ~callback: GMain.Main.quit;
f w;
(*
w#event#connect#key_press ~callback:(fun ev ->
let k = GdkEvent.Key.keyval ev in
if Char.code 'q' = k then begin
quit();
true
end
else begin
false
end
);
*)
w#show ();
GMain.Main.main ()