Source

mutated_ocaml / otherlibs / labltk / browser / viewer.ml

Full commit
  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
(*************************************************************************)
(*                                                                       *)
(*                         OCaml LablTk library                          *)
(*                                                                       *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
(*   en Automatique and Kyoto University.  All rights reserved.          *)
(*   This file is distributed under the terms of the GNU Library         *)
(*   General Public License, with the special exception on linking       *)
(*   described in file ../../../LICENSE.                                 *)
(*                                                                       *)
(*************************************************************************)

(* $Id: viewer.ml 12511 2012-05-30 13:29:48Z lefessan $ *)

open StdLabels
open Tk
open Jg_tk
open Mytypes
open Longident
open Types
open Typedtree
open Env
open Searchpos
open Searchid

(* Managing the module list *)

let list_modules ~path =
  List.fold_left path ~init:[] ~f:
  begin fun modules dir ->
    let l =
      List.filter (Useunix.get_files_in_directory dir)
        ~f:(fun x -> Filename.check_suffix x ".cmi") in
    let l = List.map l ~f:
    begin fun x ->
      String.capitalize (Filename.chop_suffix x ".cmi")
    end in
    List.fold_left l ~init:modules
     ~f:(fun modules item ->
          if List.mem item modules then modules else item :: modules)
  end

let reset_modules box =
  Listbox.delete box ~first:(`Num 0) ~last:`End;
  module_list := Sort.list (Jg_completion.lt_string ~nocase:true)
      (list_modules ~path:!Config.load_path);
  Listbox.insert box ~index:`End ~texts:!module_list;
  Jg_box.recenter box ~index:(`Num 0)


(* How to display a symbol *)

let view_symbol ~kind ~env ?path id =
  let name = match id with
      Lident x -> x
    | Ldot (_, x) -> x
    | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z"
  in
  match kind with
    Pvalue ->
      let path, vd = lookup_value id env in
      view_signature_item ~path ~env [Sig_value (Ident.create name, vd)]
  | Ptype -> view_type_id id ~env
  | Plabel -> let _,ld = lookup_label id env in
      begin match ld.lbl_res.desc with
        Tconstr (path, _, _) -> view_type_decl path ~env
      | _ -> ()
      end
  | Pconstructor ->
      let _,cd = lookup_constructor id env in
      begin match cd.cstr_res.desc with
        Tconstr (cpath, _, _) ->
        if Path.same cpath Predef.path_exn then
          view_signature ~title:(string_of_longident id) ~env ?path
            [Sig_exception (Ident.create name, {Types.exn_loc = Location.none; exn_args = cd.cstr_args})]
        else
          view_type_decl cpath ~env
      | _ -> ()
      end
  | Pmodule -> view_module_id id ~env
  | Pmodtype -> view_modtype_id id ~env
  | Pclass -> view_class_id id ~env
  | Pcltype -> view_cltype_id id ~env


(* Create a list of symbols you can choose from *)

let choose_symbol ~title ~env ?signature ?path l =
  if match path with
    None -> false
  | Some path -> is_shown_module path
  then () else
  let tl = Jg_toplevel.titled title in
  Jg_bind.escape_destroy tl;
  top_widgets := coe tl :: !top_widgets;
  let buttons = Frame.create tl in
  let all = Button.create buttons ~text:"Show all" ~padx:20
  and ok = Jg_button.create_destroyer tl ~parent:buttons
  and detach = Button.create buttons ~text:"Detach"
  and edit = Button.create buttons ~text:"Impl"
  and intf = Button.create buttons ~text:"Intf" in
  let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
  let nl = List.map l ~f:
    begin fun (li, k) ->
      string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
    end in
  let fb = Frame.create tl in
  let box =
    new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in
  box#init;
  box#bind_kbd ~events:[`KeyPressDetail"Escape"]
    ~action:(fun _ ~index -> destroy tl; break ());
  if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box);
  Jg_multibox.add_completion box ~action:
    begin fun pos ->
      let li, k = List.nth l pos in
      let path =
        match path, li with
          None, Ldot (lip, _) ->
            begin try
              Some (fst (lookup_module lip env))
            with Not_found -> None
            end
        | _ -> path
      in view_symbol li ~kind:k ~env ?path
    end;
  pack [buttons] ~side:`Bottom ~fill:`X;
  pack [fb] ~side:`Top ~fill:`Both ~expand:true;
  begin match signature with
    None -> pack [ok] ~fill:`X ~expand:true
  | Some signature ->
      Button.configure all ~command:
        begin fun () ->
          view_signature signature ~title ~env ?path
        end;
      pack [ok; all] ~side:`Right ~fill:`X ~expand:true
  end;
  begin match path with None -> ()
  | Some path ->
      let frame = Frame.create tl in
      pack [frame] ~side:`Bottom ~fill:`X;
      add_shown_module path
        ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach;
                   mw_edit = edit; mw_intf = intf }
  end

let choose_symbol_ref = ref choose_symbol


(* Search, both by type and name *)

let guess_search_mode s : [`Type | `Long | `Pattern] =
  let is_type = ref false and is_long = ref false in
  for i = 0 to String.length s - 2 do
    if s.[i] = '-' && s.[i+1] = '>' then is_type := true;
    if s.[i] = '.' then is_long := true
  done;
  if !is_type then `Type else if !is_long then `Long else `Pattern


let search_string ?(mode="symbol") ew =
  let text = Entry.get ew in
  try
    if text = "" then () else
    let l = match mode with
      "Name" ->
        begin match guess_search_mode text with
          `Long -> search_string_symbol text
        | `Pattern -> search_pattern_symbol text
        | `Type -> search_string_type text ~mode:`Included
        end
    | "Type" -> search_string_type text ~mode:`Included
    | "Exact" -> search_string_type text ~mode:`Exact
    | _ -> assert false
    in
    match l with [] -> ()
    | [lid,kind] -> view_symbol lid ~kind ~env:!start_env
    | l          -> choose_symbol ~title:"Choose symbol" ~env:!start_env l
  with Searchid.Error (s,e) ->
    Entry.icursor ew ~index:(`Num s)

let search_which = ref "Name"

let search_symbol () =
  if !module_list = [] then
  module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path);
  let tl = Jg_toplevel.titled "Search symbol" in
  Jg_bind.escape_destroy tl;
  let ew = Entry.create tl ~width:30 in
  let choice = Frame.create tl
  and which = Textvariable.create ~on:tl () in
  let itself = Radiobutton.create choice ~text:"Itself"
        ~variable:which ~value:"Name"
  and extype = Radiobutton.create choice ~text:"Exact type"
        ~variable:which ~value:"Exact"
  and iotype = Radiobutton.create choice ~text:"Included type"
        ~variable:which ~value:"Type"
  and buttons = Frame.create tl in
  let search = Button.create buttons ~text:"Search" ~command:
    begin fun () ->
      search_which := Textvariable.get which;
      search_string ew ~mode:!search_which
    end
  and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in

  Focus.set ew;
  Jg_bind.return_invoke ew ~button:search;
  Textvariable.set which !search_which;
  pack [itself; extype; iotype] ~side:`Left ~anchor:`W;
  pack [search; ok] ~side:`Left ~fill:`X ~expand:true;
  pack [coe ew; coe choice; coe buttons]
       ~side:`Top ~fill:`X ~expand:true


(* Display the contents of a module *)

let ident_of_decl ~modlid = function
    Sig_value (id, _) -> Lident (Ident.name id), Pvalue
  | Sig_type (id, _, _) -> Lident (Ident.name id), Ptype
  | Sig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor
  | Sig_module (id, _, _) -> Lident (Ident.name id), Pmodule
  | Sig_modtype (id, _) -> Lident (Ident.name id), Pmodtype
  | Sig_class (id, _, _) -> Lident (Ident.name id), Pclass
  | Sig_class_type (id, _, _) -> Lident (Ident.name id), Pcltype

let view_defined ~env ?(show_all=false) modlid =
  try match lookup_module modlid env with path, Mty_signature sign ->
    let rec iter_sign sign idents =
      match sign with
        [] -> List.rev idents
      | decl :: rem ->
          let rem = match decl, rem with
            Sig_class _, cty :: ty1 :: ty2 :: rem -> rem
          | Sig_class_type _, ty1 :: ty2 :: rem -> rem
          | _, rem -> rem
          in iter_sign rem (ident_of_decl ~modlid decl :: idents)
    in
    let l = iter_sign sign [] in
    let title = string_of_path path in
    let env = open_signature path sign env in
    !choose_symbol_ref l ~title ~signature:sign ~env ~path;
    if show_all then view_signature sign ~title ~env ~path
  | _ -> ()
  with Not_found -> ()
  | Env.Error err ->
      let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in
      Env.report_error Format.std_formatter err;
      finish ()
  | Cmi_format.Error err ->
      let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in
      Cmi_format.report_error Format.std_formatter err;
      finish ()


(* Manage toplevel windows *)

let close_all_views () =
    List.iter !top_widgets
      ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
    top_widgets := []


(* Launch a shell *)

let shell_counter = ref 1
let default_shell = ref "ocaml"

let start_shell master =
  let tl = Jg_toplevel.titled "Start New Shell" in
  Wm.transient_set tl ~master;
  let input = Frame.create tl
  and buttons = Frame.create tl in
  let ok = Button.create buttons ~text:"Ok"
  and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
  and labels = Frame.create input
  and entries = Frame.create input in
  let l1 = Label.create labels ~text:"Command:"
  and l2 = Label.create labels ~text:"Title:"
  and e1 =
    Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
  and e2 =
    Jg_entry.create entries ~command:(fun _ -> Button.invoke ok)
  and names = List.map ~f:fst (Shell.get_all ()) in
  Entry.insert e1 ~index:`End ~text:!default_shell;
  let shell_name () = "Shell #" ^ string_of_int !shell_counter in
  while List.mem (shell_name ()) names do
    incr shell_counter
  done;
  Entry.insert e2 ~index:`End ~text:(shell_name ());
  Button.configure ok ~command:(fun () ->
      if not (List.mem (Entry.get e2) names) then begin
        default_shell := Entry.get e1;
        Shell.f ~prog:!default_shell ~title:(Entry.get e2);
        destroy tl
      end);
  pack [l1;l2] ~side:`Top ~anchor:`W;
  pack [e1;e2] ~side:`Top ~fill:`X ~expand:true;
  pack [labels;entries] ~side:`Left ~fill:`X ~expand:true;
  pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
  pack [input;buttons] ~side:`Top ~fill:`X ~expand:true


(* Help window *)

let show_help () =
  let tl = Jg_toplevel.titled "OCamlBrowser Help" in
  Jg_bind.escape_destroy tl;
  let fw, tw, sb = Jg_text.create_with_scrollbar tl in
  let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in
  Text.insert tw ~index:tend ~text:Help.text;
  Text.configure tw ~state:`Disabled;
  Jg_bind.enter_focus tw;
  pack [tw] ~side:`Left ~fill:`Both ~expand:true;
  pack [sb] ~side:`Right ~fill:`Y;
  pack [fw] ~side:`Top ~expand:true ~fill:`Both;
  pack [ok] ~side:`Bottom ~fill:`X

(* Launch the classical viewer *)

let f ?(dir=Unix.getcwd()) ?on () =
  let (top, tl) = match on with
    None ->
      let tl = Jg_toplevel.titled "Module viewer" in
      ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
  | Some top ->
      Wm.title_set top "OCamlBrowser";
      Wm.iconname_set top "OCamlBrowser";
      let tl = Frame.create top in
      bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
      pack [tl] ~expand:true ~fill:`Both;
      (top, coe tl)
  in
  let menus = Jg_menu.menubar top in
  let filemenu = new Jg_menu.c "File" ~parent:menus
  and modmenu = new Jg_menu.c "Modules" ~parent:menus in
  let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in

  Jg_box.add_completion mbox ~nocase:true ~action:
    begin fun index ->
      view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
    end;
  Setpath.add_update_hook (fun () -> reset_modules mbox);

  let ew = Entry.create tl in
  let buttons = Frame.create tl in
  let search = Button.create buttons ~text:"Search" ~pady:1
      ~command:(fun () -> search_string ew)
  and close =
    Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views
  in
  (* bindings *)
  Jg_bind.enter_focus ew;
  Jg_bind.return_invoke ew ~button:search;
  bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
    ~action:(fun _ -> destroy tl);

  (* File menu *)
  filemenu#add_command "Open..."
    ~command:(fun () -> !editor_ref ~opendialog:true ());
  filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
  filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
  filemenu#add_command "Quit" ~command:(fun () -> destroy tl);

  (* modules menu *)
  modmenu#add_command "Path editor..."
    ~command:(fun () -> Setpath.set ~dir);
  modmenu#add_command "Reset cache"
    ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
  modmenu#add_command "Search symbol..." ~command:search_symbol;

  pack [close; search] ~fill:`X ~side:`Right ~expand:true;
  pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom;
  pack [msb] ~side:`Right ~fill:`Y;
  pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
  pack [fmbox] ~fill:`Both ~expand:true ~side:`Top;
  reset_modules mbox

(* Smalltalk-like version *)

class st_viewer ?(dir=Unix.getcwd()) ?on () =
  let (top, tl) = match on with
    None ->
      let tl = Jg_toplevel.titled "Module viewer" in
      ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
  | Some top ->
      Wm.title_set top "OCamlBrowser";
      Wm.iconname_set top "OCamlBrowser";
      let tl = Frame.create top in
      bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
      pack [tl] ~side:`Bottom ~expand:true ~fill:`Both;
      (top, coe tl)
  in
  let menus = Menu.create top ~name:"menubar" ~typ:`Menubar in
  let () = Toplevel.configure top ~menu:menus in
  let filemenu = new Jg_menu.c "File" ~parent:menus
  and modmenu = new Jg_menu.c "Modules" ~parent:menus
  and viewmenu = new Jg_menu.c "View" ~parent:menus
  and helpmenu = new Jg_menu.c "Help" ~parent:menus in
  let search_frame = Frame.create tl in
  let boxes_frame = Frame.create tl ~name:"boxes" in
  let label = Label.create tl ~anchor:`W ~padx:5 in
  let view = Frame.create tl in
  let buttons = Frame.create tl in
  let _all = Button.create buttons ~text:"Show all" ~padx:20
  and close = Button.create buttons ~text:"Close all" ~command:close_all_views
  and detach = Button.create buttons ~text:"Detach"
  and edit = Button.create buttons ~text:"Impl"
  and intf = Button.create buttons ~text:"Intf" in
object (self)
  val mutable boxes = []
  val mutable show_all = fun () -> ()

  method create_box =
    let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in
    bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
      ~action:(fun _ -> show_all ());
    bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")]
      ~action:(fun _ -> show_all ());
    boxes <- boxes @ [fmbox, mbox];
    pack [sb] ~side:`Right ~fill:`Y;
    pack [mbox] ~side:`Left ~fill:`Both ~expand:true;
    pack [fmbox] ~side:`Left ~fill:`Both ~expand:true;
    fmbox, mbox

  initializer
    (* Search *)
    let ew = Entry.create search_frame
    and searchtype = Textvariable.create ~on:tl () in
    bind ew ~events:[`KeyPressDetail "Return"] ~action:
      (fun _ -> search_string ew ~mode:(Textvariable.get searchtype));
    Jg_bind.enter_focus ew;
    let search_button ?value text =
      Radiobutton.create search_frame
        ~text ~variable:searchtype ~value:text in
    let symbol = search_button "Name"
    and atype = search_button "Type" in
    Radiobutton.select symbol;
    pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5;
    pack [ew] ~fill:`X ~expand:true ~side:`Left;
    pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5;
    pack [symbol; atype] ~side:`Left;
    pack [Label.create search_frame] ~side:`Right

  initializer
    (* Boxes *)
    let fmbox, mbox = self#create_box in
    Jg_box.add_completion mbox ~nocase:true ~double:false ~action:
      begin fun index ->
        view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
      end;
    Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1);
    List.iter [1;2] ~f:(fun _ -> ignore self#create_box);
    Searchpos.default_frame := Some
        { mw_frame = view; mw_title = Some label;
          mw_detach = detach; mw_edit = edit; mw_intf = intf };
    Searchpos.set_path := self#set_path;

    (* Buttons *)
    pack [close] ~side:`Right ~fill:`X ~expand:true;
    bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)]
      ~action:(fun _ -> destroy tl);

    (* File menu *)
    filemenu#add_command "Open..."
      ~command:(fun () -> !editor_ref ~opendialog:true ());
    filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ());
    filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl);
    filemenu#add_command "Quit" ~command:(fun () -> destroy tl);

    (* View menu *)
    viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ());
    let show_search = Textvariable.create ~on:tl () in
    Textvariable.set show_search "1";
    Menu.add_checkbutton viewmenu#menu ~label:"Search Entry"
      ~variable:show_search ~indicatoron:true ~state:`Active
      ~command:
      begin fun () ->
        let v = Textvariable.get show_search in
        if v = "1" then begin
          pack [search_frame] ~after:menus ~fill:`X
        end else Pack.forget [search_frame]
      end;

    (* modules menu *)
    modmenu#add_command "Path editor..."
      ~command:(fun () -> Setpath.set ~dir);
    modmenu#add_command "Reset cache"
      ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
    modmenu#add_command "Search symbol..." ~command:search_symbol;

    (* Help menu *)
    helpmenu#add_command "Manual..." ~command:show_help;

    pack [search_frame] ~fill:`X;
    pack [boxes_frame] ~fill:`Both ~expand:true;
    pack [buttons] ~fill:`X ~side:`Bottom;
    pack [view] ~fill:`Both ~side:`Bottom ~expand:true;
    reset_modules mbox

  val mutable shown_paths = []

  method hide_after n =
    for i = n to List.length boxes - 1 do
      let fm, box = List.nth boxes i in
      if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
      else destroy fm
    done;
    let rec firsts n = function [] -> []
      | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
    shown_paths <- firsts (n-1) shown_paths;
    boxes <- firsts (max 3 n) boxes

  method get_box ~path =
    let rec path_index p = function
        [] -> raise Not_found
      | a :: l -> if Path.same p a then 1 else path_index p l + 1 in
    try
      let n = path_index path shown_paths in
      self#hide_after (n+1);
      n
    with Not_found ->
      match path with
        Path.Pdot (path', _, _) ->
          let n = self#get_box ~path:path' in
          shown_paths <- shown_paths @ [path];
          if n + 1 >= List.length boxes then ignore self#create_box;
          n+1
      | _ ->
          self#hide_after 2;
          shown_paths <- [path];
          1

  method set_path path ~sign =
    let rec path_elems l path =
      match path with
        Path.Pdot (path, _, _) -> path_elems (path::l) path
      | _ -> []
    in
    let path_elems path =
      match path with
      | Path.Pident _ -> [path]
      | _ -> path_elems [] path
    in
    let see_path ~box:n ?(sign=[]) path =
      let (_, box) = List.nth boxes n in
      let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in
      let rec index s = function
          [] -> raise Not_found
        | a :: l -> if a = s then 0 else 1 + index s l
      in
      try
        let modlid, s =
          match path with
            Path.Pdot (p, s, _) -> longident_of_path p, s
          | Path.Pident i -> Longident.Lident "M", Ident.name i
          | _ -> assert false
        in
        let li, k =
          if sign = [] then Longident.Lident s, Pmodule else
          ident_of_decl ~modlid (List.hd sign) in
        let s =
          if n = 0 then string_of_longident li else
          string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in
        let n = index s texts in
        Listbox.see box (`Num n);
        Listbox.activate box (`Num n)
      with Not_found -> ()
    in
    let l = path_elems path in
    if l <> [] then begin
      List.iter l ~f:
        begin fun path ->
          if not (List.mem path shown_paths) then
            view_symbol (longident_of_path path) ~kind:Pmodule
              ~env:Env.initial ~path;
          let n = self#get_box path - 1 in
          see_path path ~box:n
        end;
      see_path path ~box:(self#get_box path) ~sign
    end

  method choose_symbol ~title ~env ?signature ?path l =
    let n =
      match path with None -> 1
      | Some path -> self#get_box ~path
    in
    let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in
    let nl = List.map l ~f:
        begin fun (li, k) ->
          string_of_longident li ^ " (" ^ string_of_kind k ^ ")"
        end in
    let _, box = List.nth boxes n in
    Listbox.delete box ~first:(`Num 0) ~last:`End;
    Listbox.insert box ~index:`End ~texts:nl;

    let current = ref None in
    let display index =
      let `Num pos = Listbox.index box ~index in
      try
        let li, k = List.nth l pos in
        self#hide_after (n+1);
        if !current = Some (li,k) then () else
        let path =
          match path, li with
            None, Ldot (lip, _) ->
              begin try
                Some (fst (lookup_module lip env))
              with Not_found -> None
              end
          | _ -> path
        in
        current := Some (li,k);
        view_symbol li ~kind:k ~env ?path
      with Failure "nth" -> ()
    in
    Jg_box.add_completion box ~double:false ~action:display;
    bind box ~events:[`KeyRelease] ~fields:[`Char]
      ~action:(fun ev -> display `Active);

    begin match signature with
      None -> ()
    | Some signature ->
        show_all <-
          begin fun () ->
            current := None;
            view_signature signature ~title ~env ?path
          end
    end
end

let st_viewer ?dir ?on () =
  let viewer = new st_viewer ?dir ?on () in
  choose_symbol_ref := viewer#choose_symbol