Source file inspect.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
(** Debugging tools. *)
let tree_spec =
let is_leaf (_,subs) = subs = [] in
let subs (w,subs) = Lwt.return
(List.map (function (Widget.N (w,l)) -> (w,l)) subs)
in
let can_select _ = true in
let can_unselect _ = true in
Tree.tree_spec ~can_select ~can_unselect ~is_leaf ~subs ()
let node_label =
let create group = Canvas.label ~group "" in
let remove (group:Canvas.group) (l:Canvas.label) = group#remove_item l#as_full_item in
let update ~selected ~expanded (w,_) (lab:Canvas.label) = lab#set_text w#me in
Tree.node_label ~create ~update ~remove
class inspect_window (w:Window.window) =
let title = Printf.sprintf "%s (inspect %s)" w#title w#me in
let win = App.create_window ~w:800 ~h:600 ~x:0 ~y:0 ~resizable:true title in
let vbox = Box.vbox ~pack:win#set_child () in
let paned = Paned.hpaned ~pack:vbox#pack () in
let scr_tree = Scrollbox.scrollbox ~pack:paned#pack () in
let wtree = Tree.tree ~selection_mode:Props.Sel_single
~pack:scr_tree#set_child tree_spec node_label
in
let () = wtree#set_show_on_focus false in
let scr_info = Scrollbox.scrollbox ~pack:paned#pack () in
let vbox_info = Box.vbox ~pack:scr_info#set_child () in
let table_info = Table.table ~rows:4 ~columns:2 ~pack:(vbox_info#pack ~vexpand:0) () in
let frame_props_set = Frame.frame ~pack:vbox_info#pack
~label:(Text.label ~text:"Properties set"())#coerce ()
in
let table_props_set = Table.table ~rows:0 ~columns:2
~pack:frame_props_set#set_child ()
in
let frame_props_other = Frame.frame ~pack:vbox_info#pack
~label:(Text.label ~text:"Other properties"())#coerce ()
in
let table_props_other = Table.table ~rows:0 ~columns:2
~pack:frame_props_other#set_child ()
in
object(self)
val mutable expanded = Oid.Set.empty
val mutable selected = (None:Oid.t option)
method window : Window.window = win
method fill_props_table (table:Table.table) props =
let comp (s1,_) (s2,_) = String.compare s1 s2 in
let props = List.sort comp props in
table#ignore_need_resize_do
(fun () ->
table#set_rows (List.length props);
List.iteri (fun i (name, v) ->
let _label_name = Text.label ~halign:1. ~text:(name^":")
~pack:(table#pack ~pos:(i,0)) ()
in
let _label_v = Text.label ~halign:0. ~text:v
~pack:(table#pack ~pos:(i,1)) ()
in
())
props
);
table#need_resize
method update_table_info ((w:Widget.widget),_subs) =
let label pos text =
let (i,j) = pos in
let halign = if j = 0 then 1. else 0. in
Text.label ~halign ~text ~pack:(table_info#pack ~pos) ()
in
let _ = label (0,0) "Geometry:" in
let _ = label (0,1) (G.to_string w#geometry) in
let _ = label (1,0) "Width constraints:" in
let _ = label (1,1) (Misc.pp_string
Widget.pp_size_constraints w#width_constraints) in
let _ = label (2,0) "Height constraints:" in
let _ = label (2,1) (Misc.pp_string
Widget.pp_size_constraints w#height_constraints) in
let _ = label (3,0) "Classes:" in
let _ = label (3,1) (String.concat ", " (Sset.elements w#classes)) in
()
method update_table_props ((w:Widget.widget),subs) =
let props = w#props in
let f ?default p (acc_set,acc_other) =
let name = Props.name p in
let to_string v =
match Props.prop_wrapper p with
| None -> "(no wrapper)"
| Some w ->
Yojson.Safe.to_string
(w.Ocf.Wrapper.to_json v)
in
match Props.opt props p with
| Some v -> (name, to_string v)::acc_set, acc_other
| None ->
match default with
| None -> acc_set, (name,"(no default)")::acc_other
| Some v -> acc_set, (name, to_string v)::acc_other
in
let (props_set,props_other) = Props.fold_registered_properties f ([],[]) in
self#fill_props_table table_props_set props_set ;
self#fill_props_table table_props_other props_other
method on_node_selected ((wid,_),node) =
selected <- Some wid#id ;
self#update_table_info node.Tree.data ;
self#update_table_props node.Tree.data ;
w#highlight_widget (Some wid);
node.label#show ;
true
method on_node_unselected (_,node) =
selected <- None;
w#highlight_widget None ;
true
method on_node_expanded ((wid,_),node) =
expanded <- Oid.Set.add wid#id expanded;
true
method on_node_collapsed ((wid,_),node) =
expanded <- Oid.Set.remove wid#id expanded;
true
method update =
let selected (w,_) = match selected with
| Some id -> Oid.equal id w#id
| None -> false
in
let expanded (w,_) = Oid.Set.mem w#id expanded in
wtree#ignore_need_resize_do
(fun () ->
wtree#set_roots ~expanded ~selected
(match w#wtree with Widget.N (x,l) -> [x,l])
);
wtree#need_resize
method select_widget (w:Widget.widget) =
let rec iter acc w =
match w#parent with
| None -> acc
| Some p -> iter (p :: acc) p
in
let path = iter [w] w in
let find l w = List.find_opt
(fun node -> let (w2,_) = node.Tree.data in w2#equal w)
l
in
let rec expand nodes path =
match path with
| [] -> ()
| w :: q ->
match find nodes w with
| None -> ()
| Some node ->
wtree#expand node;
match q with
| [] -> ignore(wtree#select_node node)
| _ -> expand node.children q
in
self#update ;
expand wtree#roots path
initializer
paned#set_handle_positions [Some (`Absolute 250)] ;
paned#set_user_handle_positionning `Absolute ;
ignore(win#connect Widget.Destroy (fun () -> w#set_inspect_mode false; false));
ignore(w#connect Widget.Destroy (fun () -> win#close; false));
ignore(wtree#connect_node_selected self#on_node_selected);
ignore(wtree#connect_node_unselected self#on_node_unselected);
ignore(wtree#connect_node_expanded self#on_node_expanded);
ignore(wtree#connect_node_collapsed self#on_node_collapsed);
Wkey.add win#coerce (Key.keystate_of_string "F5")
(fun () -> self#update) ;
Wkey.add win#coerce (Key.keystate_of_string "C-w")
(fun () -> win#close) ;
self#update
end
let inspect_window w = ((new inspect_window w) :> Window.window Window.inspect_window)
let () = App.register_inspect_window_fun inspect_window