diff options
Diffstat (limited to 'ocaml-binary-annot/otherlibs/labltk/browser')
55 files changed, 6178 insertions, 0 deletions
diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/.cvsignore b/ocaml-binary-annot/otherlibs/labltk/browser/.cvsignore new file mode 100644 index 0000000000..8ced21de22 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/.cvsignore @@ -0,0 +1,2 @@ +ocamlbrowser +dummy.mli diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/.depend b/ocaml-binary-annot/otherlibs/labltk/browser/.depend new file mode 100644 index 0000000000..4438a1dd83 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/.depend @@ -0,0 +1,66 @@ +editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ + searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ + jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ + fileselect.cmi editor.cmi +editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ + searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ + jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ + fileselect.cmx editor.cmi +fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ + jg_entry.cmo jg_box.cmo fileselect.cmi +fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ + jg_entry.cmx jg_box.cmx fileselect.cmi +jg_bind.cmo: jg_bind.cmi +jg_bind.cmx: jg_bind.cmi +jg_box.cmo: jg_completion.cmi jg_bind.cmi +jg_box.cmx: jg_completion.cmx jg_bind.cmx +jg_completion.cmo: jg_completion.cmi +jg_completion.cmx: jg_completion.cmi +jg_config.cmo: jg_tk.cmo jg_config.cmi +jg_config.cmx: jg_tk.cmx jg_config.cmi +jg_entry.cmo: jg_bind.cmi +jg_entry.cmx: jg_bind.cmx +jg_memo.cmo: jg_memo.cmi +jg_memo.cmx: jg_memo.cmi +jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ + jg_message.cmi +jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ + jg_message.cmi +jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi +jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi +jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi +jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi +lexical.cmo: jg_tk.cmo lexical.cmi +lexical.cmx: jg_tk.cmx lexical.cmi +main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ + editor.cmi +main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ + editor.cmx +searchid.cmo: list2.cmo searchid.cmi +searchid.cmx: list2.cmx searchid.cmi +searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ + jg_memo.cmi jg_bind.cmi searchpos.cmi +searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ + jg_memo.cmx jg_bind.cmx searchpos.cmi +setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ + jg_bind.cmi setpath.cmi +setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ + jg_bind.cmx setpath.cmi +shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ + jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi +shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ + jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi +typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi +typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi +useunix.cmo: useunix.cmi +useunix.cmx: useunix.cmi +viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ + mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ + jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ + jg_box.cmo jg_bind.cmi help.cmo viewer.cmi +viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ + mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ + jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ + jg_box.cmx jg_bind.cmx help.cmx viewer.cmi +mytypes.cmi: shell.cmi +typecheck.cmi: mytypes.cmi diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/Makefile b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile new file mode 100644 index 0000000000..5caed2bf60 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile @@ -0,0 +1,8 @@ +# $Id$ + +OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str + +include Makefile.shared + +dummy.mli: + cp dummyUnix.mli dummy.mli diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.nt b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.nt new file mode 100644 index 0000000000..405f47e746 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.nt @@ -0,0 +1,21 @@ +# $Id$ + +OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads + +CCFLAGS=-I../../../byterun $(TK_DEFS) + +include ../support/Makefile.common + +ifeq ($(CCOMPTYPE),cc) +WINDOWS_APP=-ccopt "-link -Wl,--subsystem,windows" +else +WINDOWS_APP=-ccopt "-link /subsystem:windows" +endif + +XTRAOBJ=winmain.$(O) +XTRALIBS=threads.cma -custom $(WINDOWS_APP) + +include Makefile.shared + +dummy.mli: + cp dummyWin.mli dummy.mli diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.shared b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.shared new file mode 100644 index 0000000000..b80967086f --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/Makefile.shared @@ -0,0 +1,64 @@ +include ../support/Makefile.common + +LABLTKLIB=-I ../labltk -I ../lib -I ../support +OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing +INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) + +OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ + fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ + help.cmo \ + viewer.cmo typecheck.cmo editor.cmo main.cmo + +JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ + jg_box.cmo \ + jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ + jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo + +# Default rules + +.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O) + +.ml.cmo: + $(CAMLCOMP) $(INCLUDES) $< + +.mli.cmi: + $(CAMLCOMP) $(INCLUDES) $< + +.c.$(O): + $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< + +all: ocamlbrowser$(EXE) + +ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ + ../support/lib$(LIBNAME).$(A) $(XTRAOBJ) + $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ + $(TOPDIR)/toplevel/toplevellib.cma \ + unix.cma str.cma $(XTRALIBS) $(LIBNAME).cma jglib.cma \ + $(OBJ) $(XTRAOBJ) + +ocamlbrowser.cma: jglib.cma $(OBJ) + $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) + +jglib.cma: $(JG) + $(CAMLC) -a -o $@ $(JG) + +help.ml: + echo 'let text = "\\' > $@ + sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ + echo '";;' >> $@ + +install: + if test -f ocamlbrowser$(EXE); then : ; \ + cp ocamlbrowser$(EXE) $(BINDIR); fi + +clean: + rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) + +depend: + $(CAMLDEP) *.ml *.mli > .depend + +shell.cmo: dummy.cmi +setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma +mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi + +include .depend diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/README b/ocaml-binary-annot/otherlibs/labltk/browser/README new file mode 100644 index 0000000000..e8953541bf --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/README @@ -0,0 +1,170 @@ + + Installing and Using OCamlBrowser + + +INSTALLATION + If you installed it with LablTk, nothing to do. + Otherwise, the source is in labltk/browser. + After installing LablTk, simply do "make" and "make install". + The name of the command is `ocamlbrowser'. + +USE + OCamlBrowser is composed of three tools, the Viewer, to walk around + compiled modules, the Editor, which allows one to + edit/typecheck/analyse .mli and .ml files, and the Shell, to run an + OCaml subshell. You may only have one instance of Editor and + Viewer, but you may use several subshells. + + As with the compiler, you may specify a different path for the + standard library by setting CAMLLIB. You may also extend the + initial load path (only standard library by default) by using the + -I command line option, or set various other options (see -help). + + If you prefered the old GUI, it is still available with the option + -oldui, otherwise you get a new Smalltalkish user interface. + +1) Viewer + + Menus + + File - Open and File - Editor give access to the editor. + + File - Shell opens an OCaml shell. + + View - Show all defs displays all the interface of the currently + selected module + View - Search entry shows/hides the search entry at the top of the + window + + Modules - Path editor changes the load path. + Pressing [Add to path] or Insert key adds selected directories + to the load path. + Pressing [Remove from path] or Delete key removes selected + paths from the load path. + Modules - Reset cache rescans the load path and resets the module + cache. Do it if you recompile some interface, or change the load + path in a conflictual way. + + Modules - Search symbol allows to search a symbol either by its + name, like the bottom line of the viewer, or, more + interestingly, by its type. Exact type searches for a type + with exactly the same information as the pattern (variables + match only variables), included type allows to give only + partial information: the actual type may take more arguments + and return more results, and variables in the pattern match + anything. In both cases, argument and tuple order is + irrelevant (*), and unlabeled arguments in the pattern match + any label. + + (*) To avoid combinatorial explosion of the search space, optional + arguments in the actual type are ignored if (1) there are to many + of them, and (2) they do not appear explicitly in the pattern. + + Search entry + + The entry line at the top allows one to search for an identifier + in all modules, either by its name (? and * patterns allowed) or by + its type. When search by type is used, it is done in inclusion mode + (cf. Modules - search symbol) + + The Close all button at the bottom is there to dismiss the windows + created by the Detach button. By double-clicking on it you will + quit the browser. + + Module browsing + + You select a module in the leftmost box by either cliking on it or + pressing return when it is selected. Fast access is available in + all boxes pressing the first few letter of the desired + name. Double-clicking / double-return displays the whole signature + for the module. + + Defined identifiers inside the module are displayed in a box to the + right of the previous one. If you click on one, this will either + display its contents in another box (if this is a sub-module) or + display the signature for this identifier below. + + Signatures are clickable. Double clicking with the left mouse + button on an identifier in a signature brings you to its signature. + A single click on the right button pops up a menu displaying the + type declaration for the selected identifier. Its title, when + selectable, also brings you to its signature. + + At the bottom, a series of buttons, depending on the context. + * Detach copies the currently displayed signature in a new window, + to keep it. You can discard these windows with Close all. + * Impl and Intf bring you to the implementation or interface of + the currently displayed signature, if it is available. + + C-s opens a text search dialog for the displayed signature. + +2) Editor + You can edit files with it, but there is no auto-save nor undo at + the moment. Otherwise you can use it as a browser, making + occasional corrections. + + The Edit menu contains commands for jump (C-g), search (C-s), and + sending the current selection to a sub-shell (M-x). For this last + option, you may choose the shell via a dialog. + + Essential function are in the Compiler menu. + + Preferences opens a dialog to set internals of the editor and + type checker. + + Lex (M-l) adds colors according to lexical categories. + + Typecheck (M-t) verifies typing, and memorizes it to let one see an + expression's type by double-clicking on it. This is also valid for + interfaces. If an error occurs, the part of the interface preceding + the error is computed. + + After typechecking, pressing the right button pops up a menu giving + the type of the pointed expression, and eventually allowing to + follow some links. + + Clear errors dismisses type checker error messages and warnings. + + Signature shows the signature of the current file. + +3) Shell + When you create a shell, a dialog is presented to you, letting you + choose which command you want to run, and the title of the shell + (to choose it in the Editor). + + You may change the default command by setting the OLABL environment + variable. + + The executed subshell is given the current load path. + File: use a source file or load a bytecode file. + You may also import the browser's path into the subprocess. + History: M-p and M-n browse up and down. + Signal: C-c interrupts and you can kill the subprocess. + +BUGS + +* This not really a bug, but OCamlBrowser is a huge memory consumer. + Go and buy some. + +* When you quit the editor and some file was modified, a dialogue is + displayed asking wether you want to really quit or not. But 1) if + you quit directly from the viewer, there is no dialogue at all, and + 2) if you close from the window manager, the dialogue is displayed, + but you cannot cancel the destruction... Beware. + +* When you run it through xon, the shell hangs at the first error. But + its ok if you start ocamlbrowser from a remote shell... + +TODO + +* Complete cross-references. + +* Power up editor. + +* Add support for the debugger. + +* Make this a real programming environment, both for beginners an + experimented users. + + +Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp> diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/dummyUnix.mli b/ocaml-binary-annot/otherlibs/labltk/browser/dummyUnix.mli new file mode 100644 index 0000000000..2272419236 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/dummyUnix.mli @@ -0,0 +1,27 @@ +(*************************************************************************) +(* *) +(* Objective Caml LablTk library *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2000 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$ *) + +module Mutex : sig + type t + external create : unit -> t = "%ignore" + external lock : t -> unit = "%ignore" + external unlock : t -> unit = "%ignore" +end + +module Thread : sig + type t + external create : ('a -> 'b) -> 'a -> t = "caml_ml_input" +end diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/dummyWin.mli b/ocaml-binary-annot/otherlibs/labltk/browser/dummyWin.mli new file mode 100644 index 0000000000..a4b75ee37b --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/dummyWin.mli @@ -0,0 +1,15 @@ +(*************************************************************************) +(* *) +(* Objective Caml LablTk library *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2000 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$ *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/editor.ml b/ocaml-binary-annot/otherlibs/labltk/browser/editor.ml new file mode 100644 index 0000000000..617cdfa855 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/editor.ml @@ -0,0 +1,667 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk +open Parsetree +open Location +open Jg_tk +open Mytypes + +let lex_on_load = ref true +and type_on_load = ref false + +let compiler_preferences master = + let tl = Jg_toplevel.titled "Compiler" in + Wm.transient_set tl ~master; + let mk_chkbutton ~text ~ref ~invert = + let variable = Textvariable.create ~on:tl () in + if (if invert then not !ref else !ref) then + Textvariable.set variable "1"; + Checkbutton.create tl ~text ~variable, + (fun () -> + ref := Textvariable.get variable = (if invert then "0" else "1")) + in + let use_pp = ref (!Clflags.preprocessor <> None) in + let chkbuttons, setflags = List.split + (List.map + ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert) + [ "No pervasives", Clflags.nopervasives, false; + "No warnings", Typecheck.nowarnings, false; + "No labels", Clflags.classic, false; + "Recursive types", Clflags.recursive_types, false; + "Lex on load", lex_on_load, false; + "Type on load", type_on_load, false; + "Preprocessor", use_pp, false ]) + in + let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in + begin match !Clflags.preprocessor with None -> () + | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp + end; + let buttons = Frame.create tl in + let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command: + begin fun () -> + List.iter ~f:(fun f -> f ()) setflags; + Clflags.preprocessor := + if !use_pp then Some (Entry.get pp_command) else None; + destroy tl + end + and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" + in + pack chkbuttons ~side:`Top ~anchor:`W; + pack [pp_command] ~side:`Top ~anchor:`E; + pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; + pack [buttons] ~side:`Bottom ~fill:`X + +let rec exclude txt = function + [] -> [] + | x :: l -> if txt.number = x.number then l else x :: exclude txt l + +let goto_line tw = + let tl = Jg_toplevel.titled "Go to" in + Wm.transient_set tl ~master:(Winfo.toplevel tw); + Jg_bind.escape_destroy tl; + let ef = Frame.create tl in + let fl = Frame.create ef + and fi = Frame.create ef in + let ll = Label.create fl ~text:"Line ~number:" + and il = Entry.create fi ~width:10 + and lc = Label.create fl ~text:"Col ~number:" + and ic = Entry.create fi ~width:10 + and get_int ew = + try int_of_string (Entry.get ew) + with Failure "int_of_string" -> 0 + in + let buttons = Frame.create tl in + let ok = Button.create buttons ~text:"Ok" ~command: + begin fun () -> + let l = get_int il + and c = get_int ic in + Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]); + Text.see tw ~index:(`Mark "insert", []); + destroy tl + end + and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in + + Focus.set il; + List.iter [il; ic] ~f: + begin fun w -> + Jg_bind.enter_focus w; + Jg_bind.return_invoke w ~button:ok + end; + pack [ll; lc] ~side:`Top ~anchor:`W; + pack [il; ic] ~side:`Top ~fill:`X ~expand:true; + pack [fl; fi] ~side:`Left ~fill:`X ~expand:true; + pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true; + pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true + +let select_shell txt = + let shells = Shell.get_all () in + let shells = List.sort shells ~cmp:compare in + let tl = Jg_toplevel.titled "Select Shell" in + Jg_bind.escape_destroy tl; + Wm.transient_set tl ~master:(Winfo.toplevel txt.tw); + let label = Label.create tl ~text:"Send to:" + and box = Listbox.create tl + and frame = Frame.create tl in + Jg_bind.enter_focus box; + let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel" + and ok = Button.create frame ~text:"Ok" ~command: + begin fun () -> + try + let name = Listbox.get box ~index:`Active in + txt.shell <- Some (name, List.assoc name shells); + destroy tl + with Not_found -> txt.shell <- None; destroy tl + end + in + Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells); + Listbox.configure box ~height:(List.length shells); + bind box ~events:[`KeyPressDetail"Return"] ~breakable:true + ~action:(fun _ -> Button.invoke ok; break ()); + bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); + Button.invoke ok; break ()); + pack [label] ~side:`Top ~anchor:`W; + pack [box] ~side:`Top ~fill:`Both; + pack [frame] ~side:`Bottom ~fill:`X ~expand:true; + pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true + +open Parser + +let send_phrase txt = + if txt.shell = None then begin + match Shell.get_all () with [] -> () + | [sh] -> txt.shell <- Some sh + | l -> select_shell txt + end; + match txt.shell with None -> () + | Some (_,sh) -> + try + let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in + let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in + sh#send phrase; + if Str.string_match (Str.regexp ";;") phrase 0 + then sh#send "\n" else sh#send ";;\n" + with Not_found | Protocol.TkError _ -> + let text = Text.get txt.tw ~start:tstart ~stop:tend in + let buffer = Lexing.from_string text in + let start = ref 0 + and block_start = ref [] + and pend = ref (-1) + and after = ref false in + while !pend = -1 do + let token = Lexer.token buffer in + let pos = + if token = SEMISEMI then Lexing.lexeme_end buffer + else Lexing.lexeme_start buffer + in + let bol = (pos = 0) || text.[pos-1] = '\n' in + if not !after && + Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge) + ~index:(`Mark"insert",[]) + then begin + after := true; + let anon, real = + List.partition !block_start ~f:(fun x -> x = -1) in + block_start := anon; + if real <> [] then start := List.hd real; + end; + match token with + CLASS | EXTERNAL | EXCEPTION | FUNCTOR + | LET | MODULE | OPEN | TYPE | VAL | SHARP when bol -> + if !block_start = [] then + if !after then pend := pos else start := pos + else block_start := pos :: List.tl !block_start + | SEMISEMI -> + if !block_start = [] then + if !after then pend := Lexing.lexeme_start buffer + else start := pos + else block_start := pos :: List.tl !block_start + | BEGIN | OBJECT -> + block_start := -1 :: !block_start + | STRUCT | SIG -> + block_start := Lexing.lexeme_end buffer :: !block_start + | END -> + if !block_start = [] then + if !after then pend := pos else () + else block_start := List.tl !block_start + | EOF -> + pend := pos + | _ -> + () + done; + let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in + sh#send phrase; + sh#send ";;\n" + +let search_pos_window txt ~x ~y = + if txt.type_info = [] && txt.psignature = [] then () else + let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in + let text = Jg_text.get_all txt.tw in + let pos = Searchpos.lines_to_chars l ~text + c in + try if txt.type_info <> [] then begin match + Searchpos.search_pos_info txt.type_info ~pos + with [] -> () + | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env + end else begin match + Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env + with [] -> () + | ((kind, lid), env, loc) :: _ -> + Searchpos.view_decl lid ~kind ~env + end + with Not_found -> () + +let search_pos_menu txt ~x ~y = + if txt.type_info = [] && txt.psignature = [] then () else + let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in + let text = Jg_text.get_all txt.tw in + let pos = Searchpos.lines_to_chars l ~text + c in + try if txt.type_info <> [] then begin match + Searchpos.search_pos_info txt.type_info ~pos + with [] -> () + | (kind, env, loc) :: _ -> + let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in + let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in + Menu.popup menu ~x ~y + end else begin match + Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env + with [] -> () + | ((kind, lid), env, loc) :: _ -> + let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in + let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in + Menu.popup menu ~x ~y + end + with Not_found -> () + +let string_width s = + let width = ref 0 in + for i = 0 to String.length s - 1 do + if s.[i] = '\t' then width := (!width / 8 + 1) * 8 + else incr width + done; + !width + +let indent_line = + let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in + fun tw -> + let `Linechar(l,c) = Text.index tw ~index:(ins,[]) + and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in + ignore (Str.string_match reg line 0); + let len = Str.match_end () in + if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else + let width = string_width (Str.matched_string line) in + Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]); + let indent = + if l <= 1 then 2 else + let previous = + Text.get tw ~start:(ins,[`Line(-1);`Linestart]) + ~stop:(ins,[`Line(-1);`Lineend]) in + ignore (Str.string_match reg previous 0); + let previous = Str.matched_string previous in + let width_previous = string_width previous in + if width_previous <= width then 2 else width_previous - width + in + Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ') + +(* The editor class *) + +class editor ~top ~menus = object (self) + val file_menu = new Jg_menu.c "File" ~parent:menus + val edit_menu = new Jg_menu.c "Edit" ~parent:menus + val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus + val module_menu = new Jg_menu.c "Modules" ~parent:menus + val window_menu = new Jg_menu.c "Windows" ~parent:menus + initializer + Menu.add_checkbutton menus ~state:`Disabled + ~onvalue:"modified" ~offvalue:"unchanged" + val mutable current_dir = Unix.getcwd () + val mutable error_messages = [] + val mutable windows = [] + val mutable current_tw = Text.create top + val vwindow = Textvariable.create ~on:top () + val mutable window_counter = 0 + + method has_window name = + List.exists windows ~f:(fun x -> x.name = name) + + method reset_window_menu = + Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End; + List.iter + (List.sort windows ~cmp: + (fun w1 w2 -> + compare (Filename.basename w1.name) (Filename.basename w2.name))) + ~f: + begin fun txt -> + Menu.add_radiobutton window_menu#menu + ~label:(Filename.basename txt.name) + ~variable:vwindow ~value:txt.number + ~command:(fun () -> self#set_edit txt) + end + + method set_file_name txt = + Menu.configure_checkbutton menus `Last + ~label:(Filename.basename txt.name) + ~variable:txt.modified + + method set_edit txt = + if windows <> [] then + Pack.forget [(List.hd windows).frame]; + windows <- txt :: exclude txt windows; + self#reset_window_menu; + current_tw <- txt.tw; + self#set_file_name txt; + Textvariable.set vwindow txt.number; + Text.yview txt.tw ~scroll:(`Page 0); + pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom + + method new_window name = + let tl, tw, sb = Jg_text.create_with_scrollbar top in + Text.configure tw ~background:`White; + Jg_bind.enter_focus tw; + window_counter <- window_counter + 1; + let txt = + { name = name; tw = tw; frame = tl; + number = string_of_int window_counter; + modified = Textvariable.create ~on:tw (); + shell = None; + structure = []; type_info = []; signature = []; psignature = [] } + in + let control c = Char.chr (Char.code c - 96) in + bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore; + bind tw ~events:[`KeyPress] ~fields:[`Char] + ~action:(fun ev -> + if ev.ev_Char <> "" && + (ev.ev_Char.[0] >= ' ' || + List.mem ev.ev_Char.[0] + (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) + then Textvariable.set txt.modified "modified"); + bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true + ~action:(fun _ -> + indent_line tw; + Textvariable.set txt.modified "modified"; + break ()); + bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")] + ~action:(fun _ -> + let text = + Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend]) + in ignore (Str.string_match (Str.regexp "[ \t]*") text 0); + if Str.match_end () <> String.length text then begin + Clipboard.clear (); + Clipboard.append ~data:text () + end); + bind tw ~events:[`KeyRelease] ~fields:[`Char] + ~action:(fun ev -> + if ev.ev_Char <> "" then + Lexical.tag tw ~start:(`Mark"insert", [`Linestart]) + ~stop:(`Mark"insert", [`Lineend])); + bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw); + bind tw ~events:[`ButtonPressDetail 2] + ~action:(fun _ -> + Textvariable.set txt.modified "modified"; + Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart]) + ~stop:(`Mark"insert", [`Lineend])); + bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); + bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); + + pack [sb] ~fill:`Y ~side:`Right; + pack [tw] ~fill:`Both ~expand:true ~side:`Left; + self#set_edit txt; + Textvariable.set txt.modified "unchanged"; + Lexical.init_tags txt.tw + + method clear_errors () = + Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; + List.iter error_messages + ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); + error_messages <- [] + + method typecheck () = + self#clear_errors (); + error_messages <- Typecheck.f (List.hd windows) + + method lex () = + List.iter [ Widget.default_toplevel; top ] + ~f:(Toplevel.configure ~cursor:(`Xcursor "watch")); + Text.configure current_tw ~cursor:(`Xcursor "watch"); + ignore (Timer.add ~ms:1 ~callback: + begin fun () -> + Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; + Lexical.tag current_tw; + Text.configure current_tw ~cursor:(`Xcursor "xterm"); + List.iter [ Widget.default_toplevel; top ] + ~f:(Toplevel.configure ~cursor:(`Xcursor "")) + end) + + method save_text ?name:l txt = + let l = match l with None -> [txt.name] | Some l -> l in + if l = [] then () else + let name = List.hd l in + if txt.name <> name then current_dir <- Filename.dirname name; + try + if Sys.file_exists name then + if txt.name = name then begin + let backup = name ^ "~" in + if Sys.file_exists backup then Sys.remove backup; + try Sys.rename name backup with Sys_error _ -> () + end else begin + match Jg_message.ask ~master:top ~title:"Save" + ("File `" ^ name ^ "' exists. Overwrite it?") + with `Yes -> Sys.remove name + | `No -> raise (Sys_error "") + | `Cancel -> raise Exit + end; + let file = open_out name in + let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in + output_string file text; + close_out file; + txt.name <- name; + self#set_file_name txt + with + Sys_error _ -> + Jg_message.info ~master:top ~title:"Error" + ("Could not save `" ^ name ^ "'.") + | Exit -> () + + method load_text l = + if l = [] then () else + let name = List.hd l in + try + let index = + try + self#set_edit (List.find windows ~f:(fun x -> x.name = name)); + let txt = List.hd windows in + if Textvariable.get txt.modified = "modified" then + begin match Jg_message.ask ~master:top ~title:"Open" + ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") + with `Yes -> self#save_text txt + | `No -> () + | `Cancel -> raise Exit + end; + Textvariable.set txt.modified "unchanged"; + (Text.index current_tw ~index:(`Mark"insert", []), []) + with Not_found -> self#new_window name; tstart + in + current_dir <- Filename.dirname name; + let file = open_in name + and tw = current_tw + and len = ref 0 + and buf = String.create 4096 in + Text.delete tw ~start:tstart ~stop:tend; + while + len := input file buf 0 4096; + !len > 0 + do + Jg_text.output tw ~buf ~pos:0 ~len:!len + done; + close_in file; + Text.mark_set tw ~mark:"insert" ~index; + Text.see tw ~index; + if Filename.check_suffix name ".ml" || + Filename.check_suffix name ".mli" + then begin + if !lex_on_load then self#lex (); + if !type_on_load then self#typecheck () + end + with + Sys_error _ | Exit -> () + + method close_window txt = + try + if Textvariable.get txt.modified = "modified" then + begin match Jg_message.ask ~master:top ~title:"Close" + ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") + with `Yes -> self#save_text txt + | `No -> () + | `Cancel -> raise Exit + end; + windows <- exclude txt windows; + if windows = [] then + self#new_window (current_dir ^ "/untitled") + else self#set_edit (List.hd windows); + destroy txt.frame + with Exit -> () + + method open_file () = + Fileselect.f ~title:"Open File" ~action:self#load_text + ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true () + + method save_file () = self#save_text (List.hd windows) + + method close_file () = self#close_window (List.hd windows) + + method quit ?(cancel=true) () = + try + List.iter windows ~f: + begin fun txt -> + if Textvariable.get txt.modified = "modified" then + match Jg_message.ask ~master:top ~title:"Quit" ~cancel + ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") + with `Yes -> self#save_text txt + | `No -> () + | `Cancel -> raise Exit + end; + bind top ~events:[`Destroy]; + destroy top + with Exit -> () + + method reopen ~file ~pos = + if not (Winfo.ismapped top) then Wm.deiconify top; + match file with None -> () + | Some file -> + self#load_text [file]; + Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos); + try + let index = + Text.search current_tw ~switches:[`Backwards] ~pattern:"*)" + ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in + let index = + Text.search current_tw ~switches:[`Backwards] ~pattern:"(*" + ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in + let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart]) + ~stop:(index,[`Line(-1);`Lineend]) in + for i = 0 to String.length s - 1 do + match s.[i] with '\t'|' ' -> () | _ -> raise Not_found + done; + Text.yview_index current_tw ~index:(index,[`Line(-1)]) + with _ -> + Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)]) + + initializer + (* Create a first window *) + self#new_window (current_dir ^ "/untitled"); + + (* Bindings for the main window *) + List.iter + [ [`Control], "s", (fun () -> Jg_text.search_string current_tw); + [`Control], "g", (fun () -> goto_line current_tw); + [`Alt], "s", self#save_file; + [`Alt], "x", (fun () -> send_phrase (List.hd windows)); + [`Alt], "l", self#lex; + [`Alt], "t", self#typecheck ] + ~f:begin fun (modi,key,act) -> + bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true + ~action:(fun _ -> act (); break ()) + end; + + bind top ~events:[`Destroy] ~fields:[`Widget] ~action: + begin fun ev -> + if Widget.name ev.ev_Widget = Widget.name top + then self#quit ~cancel:false () + end; + + (* File menu *) + file_menu#add_command "Open File..." ~command:self#open_file; + file_menu#add_command "Reopen" + ~command:(fun () -> self#load_text [(List.hd windows).name]); + file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s"; + file_menu#add_command "Save As..." ~underline:5 ~command: + begin fun () -> + let txt = List.hd windows in + Fileselect.f ~title:"Save as File" + ~action:(fun name -> self#save_text txt ~name) + ~dir:(Filename.dirname txt.name) + ~filter:"*.{ml,mli}" + ~file:(Filename.basename txt.name) + ~sync:true ~usepath:false () + end; + file_menu#add_command "Close File" ~command:self#close_file; + file_menu#add_command "Close Window" ~command:self#quit ~underline:6; + + (* Edit menu *) + edit_menu#add_command "Paste selection" ~command: + begin fun () -> + Text.insert current_tw ~index:(`Mark"insert",[]) + ~text:(Selection.get ~displayof:top ()) + end; + edit_menu#add_command "Goto..." ~accelerator:"C-g" + ~command:(fun () -> goto_line current_tw); + edit_menu#add_command "Search..." ~accelerator:"C-s" + ~command:(fun () -> Jg_text.search_string current_tw); + edit_menu#add_command "To shell" ~accelerator:"M-x" + ~command:(fun () -> send_phrase (List.hd windows)); + edit_menu#add_command "Select shell..." + ~command:(fun () -> select_shell (List.hd windows)); + + (* Compiler menu *) + compiler_menu#add_command "Preferences..." + ~command:(fun () -> compiler_preferences top); + compiler_menu#add_command "Lex" ~accelerator:"M-l" + ~command:self#lex; + compiler_menu#add_command "Typecheck" ~accelerator:"M-t" + ~command:self#typecheck; + compiler_menu#add_command "Clear errors" + ~command:self#clear_errors; + compiler_menu#add_command "Signature..." ~command: + begin fun () -> + let txt = List.hd windows in if txt.signature <> [] then + let basename = Filename.basename txt.name in + let modname = String.capitalize + (try Filename.chop_extension basename with _ -> basename) in + let env = + Env.add_module (Ident.create modname) + (Types.Tmty_signature txt.signature) + Env.initial + in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true + end; + + (* Modules *) + module_menu#add_command "Path editor..." + ~command:(fun () -> Setpath.set ~dir:current_dir); + module_menu#add_command "Reset cache" + ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); + module_menu#add_command "Search symbol..." + ~command:Viewer.search_symbol; + module_menu#add_command "Close all" + ~command:Viewer.close_all_views; +end + +(* The main function starts here ! *) + +let already_open : editor list ref = ref [] + +let editor ?file ?(pos=0) ?(reuse=false) () = + + if !already_open <> [] && + let ed = List.hd !already_open + (* try + let name = match file with Some f -> f | None -> raise Not_found in + List.find !already_open ~f:(fun ed -> ed#has_window name) + with Not_found -> List.hd !already_open *) + in try + ed#reopen ~file ~pos; + true + with Protocol.TkError _ -> + already_open := [] (* List.filter !already_open ~f:((<>) ed) *); + false + then () else + let top = Jg_toplevel.titled "OCamlBrowser Editor" in + let menus = Jg_menu.menubar top in + let ed = new editor ~top ~menus in + already_open := !already_open @ [ed]; + if file <> None then ed#reopen ~file ~pos + +let f ?file ?pos ?(opendialog=false) () = + if opendialog then + Fileselect.f ~title:"Open File" + ~action:(function [file] -> editor ~file () | _ -> ()) + ~filter:("*.{ml,mli}") ~sync:true () + else editor ?file ?pos ~reuse:(file <> None) () diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/editor.mli b/ocaml-binary-annot/otherlibs/labltk/browser/editor.mli new file mode 100644 index 0000000000..665ee813f3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/editor.mli @@ -0,0 +1,20 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit + (* open the file editor *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.ml b/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.ml new file mode 100644 index 0000000000..22052b4237 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.ml @@ -0,0 +1,290 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +(* file selection box *) + +open StdLabels +open Str +open Filename +open Tk + +open Useunix + +(**** Memoized rexgexp *) + +let (~!) = Jg_memo.fast ~f:Str.regexp + +(************************************************************ Path name *) + +(* Convert Windows-style directory separator '\' to caml-style '/' *) +let caml_dir path = + if Sys.os_type = "Win32" then + global_replace ~!"\\\\" "/" path + else path + +let parse_filter s = + let s = caml_dir s in + (* replace // by / *) + let s = global_replace ~!"/+" "/" s in + (* replace /./ by / *) + let s = global_replace ~!"/\\./" "/" s in + (* replace hoge/../ by "" *) + let s = global_replace + ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in + (* replace hoge/..$ by *) + let s = global_replace + ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in + (* replace ^/hoge/../ by / *) + let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in + if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then + let dirs = matched_group 1 s + and ptrn = matched_group 2 s + in + dirs, ptrn + else "", s + +let rec fixpoint ~f v = + let v' = f v in + if v = v' then v else fixpoint ~f v' + +let unix_regexp s = + let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in + let s = Str.global_replace ~!"\\*" ".*" s in + let s = Str.global_replace ~!"\\?" ".?" s in + let s = + fixpoint s + ~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in + let s = + Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in + Str.regexp s + +let exact_match ~pat s = + Str.string_match pat s 0 && Str.match_end () = String.length s + +let ls ~dir ~pattern = + let files = get_files_in_directory dir in + let regexp = unix_regexp pattern in + List.filter files ~f:(exact_match ~pat:regexp) + +(********************************************* Creation *) +let load_in_path = ref false + +let search_in_path ~name = Misc.find_in_path !Config.load_path name + +let f ~title ~action:proc ?(dir = Unix.getcwd ()) + ?filter:(deffilter ="*") ?file:(deffile ="") + ?(multi=false) ?(sync=false) ?(usepath=true) () = + + let current_pattern = ref "" + and current_dir = ref (caml_dir dir) in + + let may_prefix name = + if Filename.is_relative name then concat !current_dir name else name in + + let tl = Jg_toplevel.titled title in + Focus.set tl; + + let new_var () = Textvariable.create ~on:tl () in + let filter_var = new_var () + and selection_var = new_var () + and sync_var = new_var () in + Textvariable.set filter_var deffilter; + + let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in + let df = Frame.create frm in + let dfl = Frame.create df in + let dfll = Label.create dfl ~text:"Directories" in + let dflf, directory_listbox, directory_scrollbar = + Jg_box.create_with_scrollbar dfl in + let dfr = Frame.create df in + let dfrl = Label.create dfr ~text:"Files" in + let dfrf, filter_listbox, filter_scrollbar = + Jg_box.create_with_scrollbar dfr in + let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in + + let configure ~filter = + let filter = may_prefix filter in + let dir, pattern = parse_filter filter in + let dir = if !load_in_path && usepath then "" else + (current_dir := Filename.dirname dir; dir) + and pattern = if pattern = "" then "*" else pattern in + current_pattern := pattern; + let filter = + if !load_in_path && usepath then pattern else dir ^ pattern in + let directories = get_directories_in_files ~path:dir + (get_files_in_directory dir) in + let matched_files = (* get matched file by subshell call. *) + if !load_in_path && usepath then + List.fold_left !Config.load_path ~init:[] ~f: + begin fun acc dir -> + let files = ls ~dir ~pattern in + Sort.merge (<) files + (List.fold_left files ~init:acc + ~f:(fun acc name -> List2.exclude name acc)) + end + else + List.fold_left directories ~init:(ls ~dir ~pattern) + ~f:(fun acc dir -> List2.exclude dir acc) + in + Textvariable.set filter_var filter; + Textvariable.set selection_var (dir ^ deffile); + Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; + Listbox.insert filter_listbox ~index:`End ~texts:matched_files; + Jg_box.recenter filter_listbox ~index:(`Num 0); + if !load_in_path && usepath then + Listbox.configure directory_listbox ~takefocus:false + else + begin + Listbox.configure directory_listbox ~takefocus:true; + Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; + Listbox.insert directory_listbox ~index:`End ~texts:directories; + Jg_box.recenter directory_listbox ~index:(`Num 0) + end + in + + let selected_files = ref [] in (* used for synchronous mode *) + let activate l = + Grab.release tl; + destroy tl; + let l = + if !load_in_path && usepath then + List.fold_right l ~init:[] ~f: + begin fun name acc -> + if not (Filename.is_implicit name) then + may_prefix name :: acc + else try search_in_path ~name :: acc with Not_found -> acc + end + else + List.map l ~f:may_prefix + in + if sync then + begin + selected_files := l; + Textvariable.set sync_var "1" + end + else proc l + in + + (* entries *) + let fl = Label.create frm ~text:"Filter" in + let sl = Label.create frm ~text:"Selection" in + let filter_entry = Jg_entry.create frm ~textvariable:filter_var + ~command:(fun filter -> configure ~filter) in + let selection_entry = Jg_entry.create frm ~textvariable:selection_var + ~command:(fun file -> activate [file]) in + + (* and buttons *) + let set_path = Button.create dfl ~text:"Path editor" ~command: + begin fun () -> + Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern); + let w = Setpath.f ~dir:!current_dir in + Grab.set w; + bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl) + end in + let toggle_in_path = Checkbutton.create dfl ~text:"Use load path" + ~command: + begin fun () -> + load_in_path := not !load_in_path; + if !load_in_path then + pack [set_path] ~side:`Bottom ~fill:`X ~expand:true + else + Pack.forget [set_path]; + configure ~filter:(Textvariable.get filter_var) + end + and okb = Button.create cfrm ~text:"Ok" ~command: + begin fun () -> + let files = + List.map (Listbox.curselection filter_listbox) ~f: + begin fun x -> + !current_dir ^ Listbox.get filter_listbox ~index:x + end + in + let files = if files = [] then [Textvariable.get selection_var] + else files in + activate files + end + and flb = Button.create cfrm ~text:"Filter" + ~command:(fun () -> configure ~filter:(Textvariable.get filter_var)) + and ccb = Button.create cfrm ~text:"Cancel" + ~command:(fun () -> activate []) in + + (* binding *) + bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []); + Jg_box.add_completion filter_listbox + ~action:(fun index -> activate [Listbox.get filter_listbox ~index]); + if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else + bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY] + ~action:(fun ev -> + let name = Listbox.get filter_listbox + ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in + if !load_in_path && usepath then + try Textvariable.set selection_var (search_in_path ~name) + with Not_found -> () + else Textvariable.set selection_var (may_prefix name)); + + Jg_box.add_completion directory_listbox ~action: + begin fun index -> + let filter = + may_prefix (Listbox.get directory_listbox ~index) ^ + "/" ^ !current_pattern + in configure ~filter + end; + + pack [frm] ~fill:`Both ~expand:true; + (* filter *) + pack [fl] ~side:`Top ~anchor:`W; + pack [filter_entry] ~side:`Top ~fill:`X; + + (* directory + files *) + pack [df] ~side:`Top ~fill:`Both ~expand:true; + (* directory *) + pack [dfl] ~side:`Left ~fill:`Both ~expand:true; + pack [dfll] ~side:`Top ~anchor:`W; + if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W; + pack [dflf] ~side:`Top ~fill:`Both ~expand:true; + pack [directory_scrollbar] ~side:`Right ~fill:`Y; + pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true; + (* files *) + pack [dfr] ~side:`Right ~fill:`Both ~expand:true; + pack [dfrl] ~side:`Top ~anchor:`W; + pack [dfrf] ~side:`Top ~fill:`Both ~expand:true; + pack [filter_scrollbar] ~side:`Right ~fill:`Y; + pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true; + + (* selection *) + pack [sl] ~before:df ~side:`Bottom ~anchor:`W; + pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X; + + (* create OK, Filter and Cancel buttons *) + pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true; + pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X; + + if !load_in_path && usepath then begin + load_in_path := false; + Checkbutton.invoke toggle_in_path; + Checkbutton.select toggle_in_path + end + else configure ~filter:deffilter; + + Tkwait.visibility tl; + Grab.set tl; + + if sync then + begin + Tkwait.variable sync_var; + proc !selected_files + end; + () diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.mli b/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.mli new file mode 100644 index 0000000000..b723c626d5 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/fileselect.mli @@ -0,0 +1,39 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +val f : + title:string -> + action:(string list -> unit) -> + ?dir:string -> + ?filter:string -> + ?file:string -> + ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit + +(* action + [] means canceled + if multi select is false, then the list is null or a singleton *) + +(* multi + If true then more than one file are selectable *) + +(* sync + If true then synchronous mode *) + +(* usepath + Enables/disables load path search. Defaults to true *) + +val caml_dir : string -> string +(* Convert Windows-style directory separator '\' to caml-style '/' *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/help.ml b/ocaml-binary-annot/otherlibs/labltk/browser/help.ml new file mode 100644 index 0000000000..632e762fdb --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/help.ml @@ -0,0 +1,168 @@ +let text = "\ +\032 OCamlBrowser Help\n\ +\n\ +USE\n\ +\n\ +\032 OCamlBrowser is composed of three tools, the Editor, which allows\n\ +\032 one to edit/typecheck/analyse .mli and .ml files, the Viewer, to\n\ +\032 walk around compiled modules, and the Shell, to run an OCaml\n\ +\032 subshell. You may only have one instance of Editor and Viewer, but\n\ +\032 you may use several subshells.\n\ +\n\ +\032 As with the compiler, you may specify a different path for the\n\ +\032 standard library by setting OCAMLLIB. You may also extend the\n\ +\032 initial load path (only standard library by default) by using the\n\ +\032 -I command line option. The -nolabels, -rectypes and -w options are\n\ +\032 also accepted, and inherited by subshells.\n\ +\032 The -oldui options selects the old multi-window interface. The\n\ +\032 default is now more like Smalltalk's class browser.\n\ +\n\ +1) Viewer\n\ +\n\ +\032 This is the first window you get when you start OCamlBrowser. It\n\ +\032 displays a search window, and the list of modules in the load path.\n\ +\032 At the top a row of menus.\n\ +\n\ +\032 File - Open and File - Editor give access to the editor.\n\ +\n\ +\032 File - Shell opens an OCaml shell.\n\ +\n\ +\032 View - Show all defs displays the signature of the currently\n\ +\032 selected module.\n\ +\n\ +\032 View - Search entry shows/hides the search entry just\n\ +\032 below the menu bar.\n\ +\n\ +\032 Modules - Path editor changes the load path.\n\ +\032 Pressing [Add to path] or Insert key adds selected directories\n\ +\032 to the load path.\n\ +\032 Pressing [Remove from path] or Delete key removes selected\n\ +\032 paths from the load path.\n\ +\n\ +\032 Modules - Reset cache rescans the load path and resets the module\n\ +\032 cache. Do it if you recompile some interface, or change the load\n\ +\032 path in a conflictual way.\n\ +\n\ +\032 Modules - Search symbol allows to search a symbol either by its\n\ +\032 name, like the bottom line of the viewer, or, more interestingly,\n\ +\032 by its type. Exact type searches for a type with exactly the same\n\ +\032 information as the pattern (variables match only variables),\n\ +\032 included type allows to give only partial information: the actual\n\ +\032 type may take more arguments and return more results, and variables\n\ +\032 in the pattern match anything. In both cases, argument and tuple\n\ +\032 order is irrelevant (*), and unlabeled arguments in the pattern\n\ +\032 match any label.\n\ +\n\ +\032 (*) To avoid combinatorial explosion of the search space, optional\n\ +\032 arguments in the actual type are ignored if (1) there are to many\n\ +\032 of them, and (2) they do not appear explicitly in the pattern.\n\ +\n\ +\032 The Search entry just below the menu bar allows one to search for\n\ +\032 an identifier in all modules, either by its name (? and * patterns\n\ +\032 allowed) or by its type (if there is an arrow in the input). When\n\ +\032 search by type is used, it is done in inclusion mode (cf. Modules -\n\ +\032 search symbol)\n\ +\n\ +\032 The Close all button is there to dismiss the windows created\n\ +\032 by the Detach button. By double-clicking on it you will quit the\n\ +\032 browser.\n\ +\n\ +\n\ +2) Module browsing\n\ +\n\ +\032 You select a module in the leftmost box by either cliking on it or\n\ +\032 pressing return when it is selected. Fast access is available in\n\ +\032 all boxes pressing the first few letter of the desired name.\n\ +\032 Double-clicking / double-return displays the whole signature for\n\ +\032 the module.\n\ +\n\ +\032 Defined identifiers inside the module are displayed in a box to the\n\ +\032 right of the previous one. If you click on one, this will either\n\ +\032 display its contents in another box (if this is a sub-module) or\n\ +\032 display the signature for this identifier below.\n\ +\n\ +\032 Signatures are clickable. Double clicking with the left mouse\n\ +\032 button on an identifier in a signature brings you to its signature,\n\ +\032 inside its module box.\n\ +\032 A single click on the right button pops up a menu displaying the\n\ +\032 type declaration for the selected identifier. Its title, when\n\ +\032 selectable, also brings you to its signature.\n\ +\n\ +\032 At the bottom, a series of buttons, depending on the context.\n\ +\032 * Detach copies the currently displayed signature in a new window,\n\ +\032 to keep it.\n\ +\032 * Impl and Intf bring you to the implementation or interface of\n\ +\032 the currently displayed signature, if it is available.\n\ +\n\ +\032 C-s opens a text search dialog for the displayed signature.\n\ +\n\ +3) File editor\n\ +\n\ +\032 You can edit files with it, but there is no auto-save nor undo at\n\ +\032 the moment. Otherwise you can use it as a browser, making\n\ +\032 occasional corrections.\n\ +\n\ +\032 The Edit menu contains commands for jump (C-g), search (C-s), and\n\ +\032 sending the current selection to a sub-shell (M-x). For this last\n\ +\032 option, you may choose the shell via a dialog.\n\ +\n\ +\032 Essential function are in the Compiler menu.\n\ +\n\ +\032 Preferences opens a dialog to set internals of the editor and\n\ +\032 type checker.\n\ +\n\ +\032 Lex (M-l) adds colors according to lexical categories.\n\ +\n\ +\032 Typecheck (M-t) verifies typing, and memorizes it to let one see an\n\ +\032 expression's type by double-clicking on it. This is also valid for\n\ +\032 interfaces. If an error occurs, the part of the interface preceding\n\ +\032 the error is computed.\n\ +\n\ +\032 After typechecking, pressing the right button pops up a menu giving\n\ +\032 the type of the pointed expression, and eventually allowing to\n\ +\032 follow some links.\n\ +\n\ +\032 Clear errors dismisses type checker error messages and warnings.\n\ +\n\ +\032 Signature shows the signature of the current file.\n\ +\n\ +4) Shell\n\ +\n\ +\032 When you create a shell, a dialog is presented to you, letting you\n\ +\032 choose which command you want to run, and the title of the shell\n\ +\032 (to choose it in the Editor).\n\ +\n\ +\032 You may change the default command by setting the OLABL environment\n\ +\032 variable.\n\ +\n\ +\032 The executed subshell is given the current load path.\n\ +\032 File: use a source file or load a bytecode file.\n\ +\032 You may also import the browser's path into the subprocess.\n\ +\032 History: M-p and M-n browse up and down.\n\ +\032 Signal: C-c interrupts and you can kill the subprocess.\n\ +\n\ +BUGS\n\ +\n\ +* When you quit the editor and some file was modified, a dialogue is\n\ +\032 displayed asking wether you want to really quit or not. But 1) if\n\ +\032 you quit directly from the viewer, there is no dialogue at all, and\n\ +\032 2) if you close from the window manager, the dialogue is displayed,\n\ +\032 but you cannot cancel the destruction... Beware.\n\ +\n\ +* When you run it through xon, the shell hangs at the first error. But\n\ +\032 its ok if you start ocamlbrowser from a remote shell...\n\ +\n\ +TODO\n\ +\n\ +* Complete cross-references.\n\ +\n\ +* Power up editor.\n\ +\n\ +* Add support for the debugger.\n\ +\n\ +* Make this a real programming environment, both for beginners an\n\ +\032 experimented users.\n\ +\n\ +\n\ +Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>\n\ +";; diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/help.txt b/ocaml-binary-annot/otherlibs/labltk/browser/help.txt new file mode 100644 index 0000000000..62bfc59211 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/help.txt @@ -0,0 +1,166 @@ + OCamlBrowser Help + +USE + + OCamlBrowser is composed of three tools, the Editor, which allows + one to edit/typecheck/analyse .mli and .ml files, the Viewer, to + walk around compiled modules, and the Shell, to run an OCaml + subshell. You may only have one instance of Editor and Viewer, but + you may use several subshells. + + As with the compiler, you may specify a different path for the + standard library by setting OCAMLLIB. You may also extend the + initial load path (only standard library by default) by using the + -I command line option. The -nolabels, -rectypes and -w options are + also accepted, and inherited by subshells. + The -oldui options selects the old multi-window interface. The + default is now more like Smalltalk's class browser. + +1) Viewer + + This is the first window you get when you start OCamlBrowser. It + displays a search window, and the list of modules in the load path. + At the top a row of menus. + + File - Open and File - Editor give access to the editor. + + File - Shell opens an OCaml shell. + + View - Show all defs displays the signature of the currently + selected module. + + View - Search entry shows/hides the search entry just + below the menu bar. + + Modules - Path editor changes the load path. + Pressing [Add to path] or Insert key adds selected directories + to the load path. + Pressing [Remove from path] or Delete key removes selected + paths from the load path. + + Modules - Reset cache rescans the load path and resets the module + cache. Do it if you recompile some interface, or change the load + path in a conflictual way. + + Modules - Search symbol allows to search a symbol either by its + name, like the bottom line of the viewer, or, more interestingly, + by its type. Exact type searches for a type with exactly the same + information as the pattern (variables match only variables), + included type allows to give only partial information: the actual + type may take more arguments and return more results, and variables + in the pattern match anything. In both cases, argument and tuple + order is irrelevant (*), and unlabeled arguments in the pattern + match any label. + + (*) To avoid combinatorial explosion of the search space, optional + arguments in the actual type are ignored if (1) there are to many + of them, and (2) they do not appear explicitly in the pattern. + + The Search entry just below the menu bar allows one to search for + an identifier in all modules, either by its name (? and * patterns + allowed) or by its type (if there is an arrow in the input). When + search by type is used, it is done in inclusion mode (cf. Modules - + search symbol) + + The Close all button is there to dismiss the windows created + by the Detach button. By double-clicking on it you will quit the + browser. + + +2) Module browsing + + You select a module in the leftmost box by either cliking on it or + pressing return when it is selected. Fast access is available in + all boxes pressing the first few letter of the desired name. + Double-clicking / double-return displays the whole signature for + the module. + + Defined identifiers inside the module are displayed in a box to the + right of the previous one. If you click on one, this will either + display its contents in another box (if this is a sub-module) or + display the signature for this identifier below. + + Signatures are clickable. Double clicking with the left mouse + button on an identifier in a signature brings you to its signature, + inside its module box. + A single click on the right button pops up a menu displaying the + type declaration for the selected identifier. Its title, when + selectable, also brings you to its signature. + + At the bottom, a series of buttons, depending on the context. + * Detach copies the currently displayed signature in a new window, + to keep it. + * Impl and Intf bring you to the implementation or interface of + the currently displayed signature, if it is available. + + C-s opens a text search dialog for the displayed signature. + +3) File editor + + You can edit files with it, but there is no auto-save nor undo at + the moment. Otherwise you can use it as a browser, making + occasional corrections. + + The Edit menu contains commands for jump (C-g), search (C-s), and + sending the current selection to a sub-shell (M-x). For this last + option, you may choose the shell via a dialog. + + Essential function are in the Compiler menu. + + Preferences opens a dialog to set internals of the editor and + type checker. + + Lex (M-l) adds colors according to lexical categories. + + Typecheck (M-t) verifies typing, and memorizes it to let one see an + expression's type by double-clicking on it. This is also valid for + interfaces. If an error occurs, the part of the interface preceding + the error is computed. + + After typechecking, pressing the right button pops up a menu giving + the type of the pointed expression, and eventually allowing to + follow some links. + + Clear errors dismisses type checker error messages and warnings. + + Signature shows the signature of the current file. + +4) Shell + + When you create a shell, a dialog is presented to you, letting you + choose which command you want to run, and the title of the shell + (to choose it in the Editor). + + You may change the default command by setting the OLABL environment + variable. + + The executed subshell is given the current load path. + File: use a source file or load a bytecode file. + You may also import the browser's path into the subprocess. + History: M-p and M-n browse up and down. + Signal: C-c interrupts and you can kill the subprocess. + +BUGS + +* When you quit the editor and some file was modified, a dialogue is + displayed asking wether you want to really quit or not. But 1) if + you quit directly from the viewer, there is no dialogue at all, and + 2) if you close from the window manager, the dialogue is displayed, + but you cannot cancel the destruction... Beware. + +* When you run it through xon, the shell hangs at the first error. But + its ok if you start ocamlbrowser from a remote shell... + +TODO + +* Complete cross-references. + +* Power up editor. + +* Add support for the debugger. + +* Make this a real programming environment, both for beginners an + experimented users. + + +Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp> diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.ml new file mode 100644 index 0000000000..2e3ec9870b --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.ml @@ -0,0 +1,28 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let enter_focus w = + bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) + +let escape_destroy ?destroy:tl w = + let tl = match tl with Some w -> w | None -> w in + bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl) + +let return_invoke w ~button = + bind w ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> Button.invoke button) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.mli new file mode 100644 index 0000000000..e09c2ba460 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_bind.mli @@ -0,0 +1,21 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val enter_focus : 'a widget -> unit +val escape_destroy : ?destroy:'a widget -> 'a widget ->unit +val return_invoke : 'a widget -> button:button widget -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_box.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_box.ml new file mode 100644 index 0000000000..3675f4bfa8 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_box.ml @@ -0,0 +1,82 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let add_scrollbar lb = + let sb = + Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in + Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb + +let create_with_scrollbar ?selectmode parent = + let frame = Frame.create parent in + let lb = Listbox.create frame ?selectmode in + frame, lb, add_scrollbar lb + +(* from frx_listbox,adapted *) + +let recenter lb ~index = + Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + Listbox.activate lb ~index; + Listbox.selection_anchor lb ~index; + Listbox.yview_index lb ~index + +class timed ?wait ?nocase get_texts = object + val get_texts = get_texts + inherit Jg_completion.timed [] ?wait ?nocase as super + method! reset = + texts <- get_texts (); + super#reset +end + +let add_completion ?action ?wait ?nocase ?(double=true) lb = + let comp = + new timed ?wait ?nocase + (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in + + Jg_bind.enter_focus lb; + + bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: + begin fun ev -> + (* consider only keys producing characters. The callback is called + even if you press Shift. *) + if ev.ev_Char <> "" then + recenter lb ~index:(`Num (comp#add ev.ev_Char)) + end; + + begin match action with + Some action -> + bind lb ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> action `Active); + let bmod = if double then [`Double] else [] in + bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)] + ~breakable:true ~fields:[`MouseY] + ~action: + begin fun ev -> + let index = Listbox.nearest lb ~y:ev.ev_MouseY in + if not double then begin + Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; + Listbox.selection_set lb ~first:index ~last:index; + end; + action index; + break () + end + | None -> () + end; + + recenter lb ~index:(`Num 0) (* so that first item is active *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_button.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_button.ml new file mode 100644 index 0000000000..11abd68aba --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_button.ml @@ -0,0 +1,25 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let create_destroyer ~parent ?(text="Ok") tl = + Button.create parent ~text ~command:(fun () -> destroy tl) + +let add_destroyer ?text tl = + let b = create_destroyer tl ~parent:tl ?text in + pack [b] ~side:`Bottom ~fill:`X; + b diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.ml new file mode 100644 index 0000000000..c93b099b3a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.ml @@ -0,0 +1,53 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +let lt_string ?(nocase=false) s1 s2 = + if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2 + +class completion ?nocase texts = object + val mutable texts = texts + val nocase = nocase + val mutable prefix = "" + val mutable current = 0 + method add c = + prefix <- prefix ^ c; + while current < List.length texts - 1 && + lt_string (List.nth texts current) prefix ?nocase + do + current <- current + 1 + done; + current + method current = current + method get_current = List.nth texts current + method reset = + prefix <- ""; + current <- 0 +end + +class timed ?nocase ?wait texts = object (self) + inherit completion texts ?nocase as super + val wait = match wait with None -> 500 | Some n -> n + val mutable timer = None + method! add c = + begin match timer with + None -> self#reset + | Some t -> Timer.remove t + end; + timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); + super#add c + method! reset = + timer <- None; super#reset +end diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.mli new file mode 100644 index 0000000000..69c7a134c2 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_completion.mli @@ -0,0 +1,25 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +val lt_string : ?nocase:bool -> string -> string -> bool + +class timed : ?nocase:bool -> ?wait:int -> string list -> object + val mutable texts : string list + method add : string -> int + method current : int + method get_current : string + method reset : unit +end diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.ml new file mode 100644 index 0000000000..bce0e50e76 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.ml @@ -0,0 +1,40 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Jg_tk + +let fixed = if wingui then "{Courier New} 8" else "fixed" +let variable = if wingui then "Arial 9" else "variable" + +let init () = + if wingui then Option.add ~path:"*font" fixed; + let font = + let font = + Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in + if font = "" then variable else font + in + List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] + ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font); + Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile; + Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile; + Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile; + Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile; + let foreground = + Option.get Widget.default_toplevel + ~name:"disabledForeground" ~clas:"Foreground" in + if foreground = "" then + Option.add ~path:"*disabledForeground" "black" diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.mli new file mode 100644 index 0000000000..511e2b3a67 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_config.mli @@ -0,0 +1,17 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +val init: unit -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_entry.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_entry.ml new file mode 100644 index 0000000000..c09a273e82 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_entry.ml @@ -0,0 +1,27 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let create ?command ?width ?textvariable parent = + let ew = Entry.create parent ?width ?textvariable in + Jg_bind.enter_focus ew; + begin match command with Some command -> + bind ew ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> command (Entry.get ew)) + | None -> () + end; + ew diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.ml new file mode 100644 index 0000000000..e238929a08 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.ml @@ -0,0 +1,33 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +type ('a, 'b) assoc_list = + Nil + | Cons of 'a * 'b * ('a, 'b) assoc_list + +let rec assq key = function + Nil -> raise Not_found + | Cons (a, b, l) -> + if key == a then b else assq key l + +let fast ~f = + let memo = ref Nil in + fun key -> + try assq key !memo + with Not_found -> + let data = f key in + memo := Cons(key, data, !memo); + data diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.mli new file mode 100644 index 0000000000..5491dee32f --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_memo.mli @@ -0,0 +1,19 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +val fast : f:('a -> 'b) -> 'a -> 'b +(* "fast" memoizer: uses a List.assq like function *) +(* Good for a smallish number of keys, phisically equal *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_menu.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_menu.ml new file mode 100644 index 0000000000..b399d10d87 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_menu.ml @@ -0,0 +1,44 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +class c ~parent ?(underline=0) label = object (self) + val menu = + let menu = Menu.create parent in + Menu.add_cascade parent ~menu ~label ~underline; + menu + method menu = menu + method virtual add_command : + ?underline:int -> + ?accelerator:string -> ?activebackground:color -> + ?activeforeground:color -> ?background:color -> + ?bitmap:bitmap -> ?command:(unit -> unit) -> + ?font:string -> ?foreground:color -> + ?image:image -> ?state:state -> + string -> unit + method add_command ?(underline=0) ?accelerator ?activebackground + ?activeforeground ?background ?bitmap ?command ?font ?foreground + ?image ?state label = + Menu.add_command menu ~label ~underline ?accelerator + ?activebackground ?activeforeground ?background ?bitmap + ?command ?font ?foreground ?image ?state +end + +let menubar tl = + let menu = Menu.create tl ~name:"menubar" ~typ:`Menubar in + Toplevel.configure tl ~menu; + menu diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.ml new file mode 100644 index 0000000000..3c18f193c4 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.ml @@ -0,0 +1,111 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk +open Jg_tk + +(* +class formatted ~parent ~width ~maxheight ~minheight = + val parent = (parent : Widget.any Widget.widget) + val width = width + val maxheight = maxheight + val minheight = minheight + val tw = Text.create ~parent ~width ~wrap:`Word + val fof = Format.get_formatter_output_functions () + method parent = parent + method init = + pack [tw] ~side:`Left ~fill:`Both ~expand:true; + Format.print_flush (); + Format.set_margin (width - 2); + Format.set_formatter_output_functions ~out:(Jg_text.output tw) + ~flush:(fun () -> ()) + method finish = + Format.print_flush (); + Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof); + let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in + Text.configure tw ~height:(max minheight (min l maxheight)); + if l > 5 then + pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y +end +*) + +let formatted ~title ?on ?(ppf = Format.std_formatter) + ?(width=60) ?(maxheight=10) ?(minheight=0) () = + let tl, frame = + match on with + Some frame -> +(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in + pack [label] ~side:`Top ~fill:`X; + let frame2 = Frame.create frame in + pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *) + coe frame, frame + | None -> + let tl = Jg_toplevel.titled title in + Jg_bind.escape_destroy tl; + let frame = Frame.create tl in + pack [frame] ~side:`Top ~fill:`Both ~expand:true; + coe tl, frame + in + let tw = Text.create frame ~width ~wrap:`Word in + pack [tw] ~side:`Left ~fill:`Both ~expand:true; + Format.pp_print_flush ppf (); + Format.pp_set_margin ppf (width - 2); + let fof,fff = Format.pp_get_formatter_output_functions ppf () in + Format.pp_set_formatter_output_functions ppf + (fun buf pos len -> Jg_text.output tw ~buf ~pos ~len) + ignore; + tl, tw, + begin fun () -> + Format.pp_print_flush ppf (); + Format.pp_set_formatter_output_functions ppf fof fff; + let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in + Text.configure tw ~height:(max minheight (min l maxheight)); + if l > 5 then + pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y + end + +let ask ~title ?master ?(no=true) ?(cancel=true) text = + let tl = Jg_toplevel.titled title in + begin match master with None -> () + | Some master -> Wm.transient_set tl ~master + end; + let mw = Message.create tl ~text ~padx:20 ~pady:10 + ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W + and fw = Frame.create tl + and sync = Textvariable.create ~on:tl () + and r = ref (`Cancel : [`Yes|`No|`Cancel]) in + let accept = Button.create fw + ~text:(if no || cancel then "Yes" else "Dismiss") + ~command:(fun () -> r := `Yes; destroy tl) + and refuse = Button.create fw ~text:"No" + ~command:(fun () -> r := `No; destroy tl) + and cancelB = Button.create fw ~text:"Cancel" + ~command:(fun () -> r := `Cancel; destroy tl) + in + bind tl ~events:[`Destroy] ~extend:true + ~action:(fun _ -> Textvariable.set sync "1"); + pack [accept] ~side:`Left ~fill:`X ~expand:true; + if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true; + if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true; + pack [mw] ~side:`Top ~fill:`Both; + pack [fw] ~side:`Bottom ~fill:`X ~expand:true; + Grab.set tl; + Tkwait.variable sync; + !r + +let info ~title ?master text = + ignore (ask ~title ?master ~no:false ~cancel:false text) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.mli new file mode 100644 index 0000000000..0a83a594ff --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_message.mli @@ -0,0 +1,33 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val formatted : + title:string -> + ?on:frame widget -> + ?ppf:Format.formatter -> + ?width:int -> + ?maxheight:int -> + ?minheight:int -> + unit -> any widget * text widget * (unit -> unit) + +val ask : + title:string -> ?master:toplevel widget -> + ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes] + +val info : + title:string -> ?master:toplevel widget -> string -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.ml new file mode 100644 index 0000000000..febec8e5de --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.ml @@ -0,0 +1,185 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels + +let rec gen_list ~f:f ~len = + if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1) + +let rec make_list ~len ~fill = + if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill + +(* By column version +let rec firsts ~len l = + if len = 0 then ([],l) else + match l with + a::l -> + let (f,l) = firsts l len:(len - 1) in + (a::f,l) + | [] -> + (l,[]) + +let rec split ~len = function + [] -> [] + | l -> + let (f,r) = firsts l ~len in + let ret = split ~len r in + f :: ret + +let extend l ~len ~fill = + if List.length l >= len then l + else l @ make_list ~fill len:(len - List.length l) +*) + +(* By row version *) + +let rec first l ~len = + if len = 0 then [], l else + match l with + [] -> make_list ~len ~fill:"", [] + | a::l -> + let (l',r) = first ~len:(len - 1) l in a::l',r + +let rec split l ~len = + if l = [] then make_list ~len ~fill:[] else + let (cars,r) = first l ~len in + let cdrs = split r ~len in + List.map2 cars cdrs ~f:(fun a l -> a::l) + + +open Tk + +class c ~cols ~texts ?maxheight ?width parent = object (self) + val parent' = coe parent + val length = List.length texts + val boxes = + let height = (List.length texts - 1) / cols + 1 in + let height = + match maxheight with None -> height + | Some max -> min max height + in + gen_list ~len:cols ~f: + begin fun () -> + Listbox.create parent ~height ?width + ~highlightthickness:0 + ~borderwidth:1 + end + val mutable current = 0 + method cols = cols + method texts = texts + method parent = parent' + method boxes = boxes + method current = current + method recenter ?(aligntop=false) n = + current <- + if n < 0 then 0 else + if n < length then n else length - 1; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + let box = List.nth boxes (current mod cols) + and index = `Num (current / cols) in + List.iter boxes ~f: + begin fun box -> + Listbox.selection_clear box ~first:(`Num 0) ~last:`End; + Listbox.selection_anchor box ~index; + Listbox.activate box ~index + end; + Focus.set box; + if aligntop then Listbox.yview_index box ~index + else Listbox.see box ~index; + let (first,last) = Listbox.yview_get box in + List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first)) + method init = + let textl = split ~len:cols texts in + List.iter2 boxes textl ~f: + begin fun box texts -> + Jg_bind.enter_focus box; + Listbox.insert box ~texts ~index:`End + end; + pack boxes ~side:`Left ~expand:true ~fill:`Both; + self#bind_mouse ~events:[`ButtonPressDetail 1] + ~action:(fun _ ~index:n -> self#recenter n; break ()); + let current_height () = + let (top,bottom) = Listbox.yview_get (List.hd boxes) in + truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes)) + +. 0.99) + in + List.iter + [ "Right", (fun n -> n+1); + "Left", (fun n -> n-1); + "Up", (fun n -> n-cols); + "Down", (fun n -> n+cols); + "Prior", (fun n -> n - current_height () * cols); + "Next", (fun n -> n + current_height () * cols); + "Home", (fun _ -> 0); + "End", (fun _ -> List.length texts) ] + ~f:begin fun (key,f) -> + self#bind_kbd ~events:[`KeyPressDetail key] + ~action:(fun _ ~index:n -> self#recenter (f n); break ()) + end; + self#recenter 0 + method bind_mouse ~events ~action = + let i = ref 0 in + List.iter boxes ~f: + begin fun box -> + let b = !i in + bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let `Num n = Listbox.nearest box ~y:ev.ev_MouseY + in action ev ~index:(n * cols + b)); + incr i + end + method bind_kbd ~events ~action = + let i = ref 0 in + List.iter boxes ~f: + begin fun box -> + let b = !i in + bind box ~events ~breakable:true ~fields:[`Char] + ~action:(fun ev -> + let `Num n = Listbox.index box ~index:`Active in + action ev ~index:(n * cols + b)); + incr i + end +end + +let add_scrollbar (box : c) = + let boxes = box#boxes in + let sb = + Scrollbar.create (box#parent) + ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in + List.iter boxes + ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb)); + pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y; + sb + +let add_completion ?action ?wait (box : c) = + let comp = new Jg_completion.timed (box#texts) ?wait in + box#bind_kbd ~events:[`KeyPress] + ~action:(fun ev ~index -> + (* consider only keys producing characters. The callback is called + * even if you press Shift. *) + if ev.ev_Char <> "" then + box#recenter (comp#add ev.ev_Char) ~aligntop:true); + match action with + Some action -> + box#bind_kbd ~events:[`KeyPressDetail "space"] + ~action:(fun ev ~index -> action (box#current)); + box#bind_kbd ~events:[`KeyPressDetail "Return"] + ~action:(fun ev ~index -> action (box#current)); + box#bind_mouse ~events:[`ButtonPressDetail 1] + ~action:(fun ev ~index -> + box#recenter index; action (box#current); break ()) + | None -> () diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.mli new file mode 100644 index 0000000000..6dfe7d8fb3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_multibox.mli @@ -0,0 +1,35 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +class c : + cols:int -> texts:string list -> + ?maxheight:int -> ?width:int -> 'a Widget.widget -> +object + method cols : int + method texts : string list + method parent : Widget.any Widget.widget + method boxes : Widget.listbox Widget.widget list + method current : int + method init : unit + method recenter : ?aligntop:bool -> int -> unit + method bind_mouse : + events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit + method bind_kbd : + events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit +end + +val add_scrollbar : c -> Widget.scrollbar Widget.widget +val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.ml new file mode 100644 index 0000000000..067b9dac55 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.ml @@ -0,0 +1,104 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk +open Jg_tk + +let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1) + +let tag_and_see tw ~tag ~start ~stop = + Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag; + Text.tag_add tw ~start ~stop ~tag; + try + Text.see tw ~index:(`Tagfirst tag, []); + Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, []) + with Protocol.TkError _ -> () + +let output tw ~buf ~pos ~len = + Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len) + +let add_scrollbar tw = + let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw) + in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb + +let create_with_scrollbar parent = + let frame = Frame.create parent in + let tw = Text.create frame in + frame, tw, add_scrollbar tw + +let goto_tag tw ~tag = + let index = (`Tagfirst tag, []) in + try Text.see tw ~index; + Text.mark_set tw ~index ~mark:"insert" + with Protocol.TkError _ -> () + +let search_string tw = + let tl = Jg_toplevel.titled "Search" in + Wm.transient_set tl ~master:(Winfo.toplevel tw); + let fi = Frame.create tl + and fd = Frame.create tl + and fm = Frame.create tl + and buttons = Frame.create tl + and direction = Textvariable.create ~on:tl () + and mode = Textvariable.create ~on:tl () + and count = Textvariable.create ~on:tl () + in + let label = Label.create fi ~text:"Pattern:" + and text = Entry.create fi ~width:20 + and back = Radiobutton.create fd ~variable:direction + ~text:"Backwards" ~value:"backward" + and forw = Radiobutton.create fd ~variable:direction + ~text:"Forwards" ~value:"forward" + and exact = Radiobutton.create fm ~variable:mode + ~text:"Exact" ~value:"exact" + and nocase = Radiobutton.create fm ~variable:mode + ~text:"No case" ~value:"nocase" + and regexp = Radiobutton.create fm ~variable:mode + ~text:"Regexp" ~value:"regexp" + in + let search = Button.create buttons ~text:"Search" ~command: + begin fun () -> + try + let pattern = Entry.get text in + let dir, ofs = match Textvariable.get direction with + "forward" -> `Forwards, 1 + | "backward" -> `Backwards, -1 + | _ -> assert false + and mode = match Textvariable.get mode with "exact" -> [`Exact] + | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> [] + in + let ndx = + Text.search tw ~pattern ~switches:([dir;`Count count] @ mode) + ~start:(`Mark "insert", [`Char ofs]) + in + tag_and_see tw ~tag:"sel" ~start:(ndx,[]) + ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))]) + with Invalid_argument _ -> () + end + and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in + + Focus.set text; + Jg_bind.return_invoke text ~button:search; + Jg_bind.escape_destroy tl; + Textvariable.set direction "forward"; + Textvariable.set mode "nocase"; + pack [label] ~side:`Left; + pack [text] ~side:`Right ~fill:`X ~expand:true; + pack [back; forw] ~side:`Left; + pack [exact; nocase; regexp] ~side:`Left; + pack [search; ok] ~side:`Left ~fill:`X ~expand:true; + pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.mli b/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.mli new file mode 100644 index 0000000000..e8646dd9d1 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_text.mli @@ -0,0 +1,28 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val get_all : text widget -> string +val tag_and_see : + text widget -> + tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit +val output : text widget -> buf:string -> pos:int -> len:int -> unit +val add_scrollbar : text widget -> scrollbar widget +val create_with_scrollbar : + 'a widget -> frame widget * text widget * scrollbar widget +val goto_tag : text widget -> tag:string -> unit +val search_string : text widget -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_tk.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_tk.ml new file mode 100644 index 0000000000..7fc77f096a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_tk.ml @@ -0,0 +1,24 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi +and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi +let tstart : textIndex = `Linechar (1,0), [] +and tend : textIndex = `End, [] + +let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jg_toplevel.ml b/ocaml-binary-annot/otherlibs/labltk/browser/jg_toplevel.ml new file mode 100644 index 0000000000..64b6f54d76 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jg_toplevel.ml @@ -0,0 +1,25 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Tk + +let titled ?iconname title = + let iconname = match iconname with None -> title | Some s -> s in + let tl = Toplevel.create Widget.default_toplevel in + Wm.title_set tl title; + Wm.iconname_set tl iconname; + Wm.group_set tl ~leader: Widget.default_toplevel; + tl diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/jglib.mllib b/ocaml-binary-annot/otherlibs/labltk/browser/jglib.mllib new file mode 100644 index 0000000000..5c254ff552 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/jglib.mllib @@ -0,0 +1,13 @@ +Jg_tk +Jg_config +Jg_bind +Jg_completion +Jg_box +Jg_button +Jg_toplevel +Jg_text +Jg_message +Jg_menu +Jg_entry +Jg_multibox +Jg_memo diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/lexical.ml b/ocaml-binary-annot/otherlibs/labltk/browser/lexical.ml new file mode 100644 index 0000000000..72f1957ec0 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/lexical.ml @@ -0,0 +1,145 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk +open Jg_tk +open Parser + +let tags = + ["control"; "define"; "structure"; "char"; + "infix"; "label"; "uident"] +and colors = + ["blue"; "forestgreen"; "purple"; "gray40"; + "indianred4"; "saddlebrown"; "midnightblue"] + +let init_tags tw = + List.iter2 tags colors ~f: + begin fun tag col -> + Text.tag_configure tw ~tag ~foreground:(`Color col) + end; + Text.tag_configure tw ~tag:"error" ~foreground:`Red; + Text.tag_configure tw ~tag:"error" ~relief:`Raised; + Text.tag_raise tw ~tag:"error" + +let tag ?(start=tstart) ?(stop=tend) tw = + let tpos c = (Text.index tw ~index:start, [`Char c]) in + let text = Text.get tw ~start ~stop in + let buffer = Lexing.from_string text in + Location.init buffer ""; + Location.input_name := ""; + List.iter tags + ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag); + let last = ref (EOF, 0, 0) in + try + while true do + let token = Lexer.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer in + let tag = + match token with + AMPERAMPER + | AMPERSAND + | BARBAR + | DO | DONE + | DOWNTO + | ELSE + | FOR + | IF + | LAZY + | MATCH + | OR + | THEN + | TO + | TRY + | WHEN + | WHILE + | WITH + -> "control" + | AND + | AS + | BAR + | CLASS + | CONSTRAINT + | EXCEPTION + | EXTERNAL + | FUN + | FUNCTION + | FUNCTOR + | IN + | INHERIT + | INITIALIZER + | LET + | METHOD + | MODULE + | MUTABLE + | NEW + | OF + | PRIVATE + | REC + | TYPE + | VAL + | VIRTUAL + -> "define" + | BEGIN + | END + | INCLUDE + | OBJECT + | OPEN + | SIG + | STRUCT + -> "structure" + | CHAR _ + | STRING _ + -> "char" + | BACKQUOTE + | INFIXOP1 _ + | INFIXOP2 _ + | INFIXOP3 _ + | INFIXOP4 _ + | PREFIXOP _ + | SHARP + -> "infix" + | LABEL _ + | OPTLABEL _ + | QUESTION + | TILDE + -> "label" + | UIDENT _ -> "uident" + | LIDENT _ -> + begin match !last with + (QUESTION | TILDE), _, _ -> "label" + | _ -> "" + end + | COLON -> + begin match !last with + LIDENT _, lstart, lstop -> + if lstop = start then + Text.tag_add tw ~tag:"label" + ~start:(tpos lstart) ~stop:(tpos stop); + "" + | _ -> "" + end + | EOF -> raise End_of_file + | _ -> "" + in + if tag <> "" then + Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop); + last := (token, start, stop) + done + with + End_of_file -> () + | Lexer.Error (err, loc) -> () diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/lexical.mli b/ocaml-binary-annot/otherlibs/labltk/browser/lexical.mli new file mode 100644 index 0000000000..3be04d3246 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/lexical.mli @@ -0,0 +1,20 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val init_tags : text widget -> unit +val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/list2.ml b/ocaml-binary-annot/otherlibs/labltk/browser/list2.ml new file mode 100644 index 0000000000..87b88f496a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/list2.ml @@ -0,0 +1,23 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels + +let exclude x l = List.filter l ~f:((<>) x) + +let rec flat_map ~f = function + [] -> [] + | x :: l -> f x @ flat_map ~f l diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/main.ml b/ocaml-binary-annot/otherlibs/labltk/browser/main.ml new file mode 100644 index 0000000000..181506960a --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/main.ml @@ -0,0 +1,132 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +module Unix = UnixLabels +open Tk + +let fatal_error text = + let top = openTk ~clas:"OCamlBrowser" () in + let mw = Message.create top ~text ~padx:20 ~pady:10 + ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W + and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in + pack [mw] ~side:`Top ~fill:`Both; + pack [b] ~side:`Bottom; + mainLoop (); + exit 0 + +let rec get_incr key = function + [] -> raise Not_found + | (k, c, d) :: rem -> + if k = key then + match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true + else get_incr key rem + +let check ~spec argv = + let i = ref 1 in + while !i < Array.length argv do + try + let a = get_incr argv.(!i) spec in + incr i; if a then incr i + with Not_found -> + i := Array.length argv + 1 + done; + !i = Array.length argv + +open Printf + +let print_version () = + printf "The Objective Caml browser, version %s\n" Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + printf "%s\n" Sys.ocaml_version; + exit 0; +;; + +let usage ~spec errmsg = + let b = Buffer.create 1024 in + bprintf b "%s\n" errmsg; + List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec; + Buffer.contents b + +let _ = + let is_win32 = Sys.os_type = "Win32" in + if is_win32 then + Format.pp_set_formatter_output_functions Format.err_formatter + (fun _ _ _ -> ()) (fun _ -> ()); + + let path = ref [] in + let st = ref true in + let spec = + [ "-I", Arg.String (fun s -> path := s :: !path), + "<dir> Add <dir> to the list of include directories"; + "-labels", Arg.Clear Clflags.classic, " <obsolete>"; + "-nolabels", Arg.Set Clflags.classic, + " Ignore non-optional labels in types"; + "-oldui", Arg.Clear st, " Revert back to old UI"; + "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), + "<command> Pipe sources through preprocessor <command>"; + "-rectypes", Arg.Set Clflags.recursive_types, + " Allow arbitrary recursive types"; + "-version", Arg.Unit print_version, + " Print version and exit"; + "-vnum", Arg.Unit print_version_num, " Print version number and exit"; + "-w", Arg.String (fun s -> Shell.warnings := s), + "<flags> Enable or disable warnings according to <flags>"; ] + and errmsg = "Command line: ocamlbrowser <options>" in + if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg); + Arg.parse spec + (fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) + errmsg; + Config.load_path := + Sys.getcwd () + :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path + @ [Config.standard_library]; + Warnings.parse_options false !Shell.warnings; + Unix.putenv "TERM" "noterminal"; + begin + try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial + with _ -> + fatal_error + (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'" + "Couldn't initialize environment." + (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB") + "points to the Objective Caml library." + Config.standard_library) + end; + + Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); + Searchpos.editor_ref := Editor.f; + + let top = openTk ~clas:"OCamlBrowser" () in + Jg_config.init (); + + (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) + at_exit Shell.kill_all; + + + if !st then Viewer.st_viewer ~on:top () + else Viewer.f ~on:top (); + + while true do + try + if is_win32 then mainLoop () + else Printexc.print mainLoop () + with Protocol.TkError _ -> + if not is_win32 then flush stderr + done diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/mytypes.mli b/ocaml-binary-annot/otherlibs/labltk/browser/mytypes.mli new file mode 100644 index 0000000000..6db120adcc --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/mytypes.mli @@ -0,0 +1,29 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +type edit_window = + { mutable name: string; + tw: text widget; + frame: frame widget; + modified: Textvariable.textVariable; + mutable shell: (string * Shell.shell) option; + mutable structure: Typedtree.structure; + mutable type_info: Stypes.annotation list; + mutable signature: Types.signature; + mutable psignature: Parsetree.signature; + number: string } diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/searchid.ml b/ocaml-binary-annot/otherlibs/labltk/browser/searchid.ml new file mode 100644 index 0000000000..6742039c11 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/searchid.ml @@ -0,0 +1,533 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Location +open Longident +open Path +open Types +open Typedtree +open Env +open Btype +open Ctype + +(* only initial here, but replaced by Pervasives later *) +let start_env = ref initial +let module_list = ref [] + +type pkind = + Pvalue + | Ptype + | Plabel + | Pconstructor + | Pmodule + | Pmodtype + | Pclass + | Pcltype + +let string_of_kind = function + Pvalue -> "v" + | Ptype -> "t" + | Plabel -> "l" + | Pconstructor -> "cn" + | Pmodule -> "m" + | Pmodtype -> "s" + | Pclass -> "c" + | Pcltype -> "ct" + +let rec longident_of_path = function + Pident id -> Lident (Ident.name id) + | Pdot (path, s, _) -> Ldot (longident_of_path path, s) + | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2) + +let rec remove_prefix lid ~prefix = + let rec remove_hd lid ~name = + match lid with + Ldot (Lident s1, s2) when s1 = name -> Lident s2 + | Ldot (l, s) -> Ldot (remove_hd ~name l, s) + | _ -> raise Not_found + in + match prefix with + [] -> lid + | name :: prefix -> + try remove_prefix ~prefix (remove_hd ~name lid) + with Not_found -> lid + +let rec permutations l = match l with + [] | [_] -> [l] + | [a;b] -> [l; [b;a]] + | _ -> + let _, perms = + List.fold_left l ~init:(l,[]) ~f: + begin fun (l, perms) a -> + let l = List.tl l in + l @ [a], + List.map (permutations l) ~f:(fun l -> a :: l) @ perms + end + in perms + +let rec choose n ~card:l = + let len = List.length l in + if n = len then [l] else + if n = 1 then List.map l ~f:(fun x -> [x]) else + if n = 0 then [[]] else + if n > len then [] else + match l with [] -> [] + | a :: l -> + List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) + @ choose n ~card:l + +let rec arr p ~card:n = + if p = 0 then 1 else n * arr (p-1) ~card:(n-1) + +let rec all_args ty = + let ty = repr ty in + match ty.desc with + Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) + | _ -> ([], ty) + +let rec equal ~prefix t1 t2 = + match (repr t1).desc, (repr t2).desc with + Tvar, Tvar -> true + | Tvariant row1, Tvariant row2 -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let fields1 = filter_row_fields false row1.row_fields + and fields2 = filter_row_fields false row1.row_fields + in + let r1, r2, pairs = merge_row_fields fields1 fields2 in + row1.row_closed = row2.row_closed && r1 = [] && r2 = [] && + List.for_all pairs ~f: + begin fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None -> true + | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix + | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> + c1 = c2 && List.length tl1 = List.length tl2 && + List.for_all2 tl1 tl2 ~f:(equal ~prefix) + | _ -> false + end + | Tarrow _, Tarrow _ -> + let l1, t1 = all_args t1 and l2, t2 = all_args t2 in + equal t1 t2 ~prefix && + List.length l1 = List.length l2 && + List.exists (permutations l1) ~f: + begin fun l1 -> + List.for_all2 l1 l2 ~f: + begin fun (p1,t1) (p2,t2) -> + (p1 = "" || p1 = p2) && equal t1 t2 ~prefix + end + end + | Ttuple l1, Ttuple l2 -> + List.length l1 = List.length l2 && + List.for_all2 l1 l2 ~f:(equal ~prefix) + | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> + remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) + && List.length l1 = List.length l2 + && List.for_all2 l1 l2 ~f:(equal ~prefix) + | _ -> false + +let is_opt s = s <> "" && s.[0] = '?' +let get_options = List.filter ~f:is_opt + +let rec included ~prefix t1 t2 = + match (repr t1).desc, (repr t2).desc with + Tvar, _ -> true + | Tvariant row1, Tvariant row2 -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let fields1 = filter_row_fields false row1.row_fields + and fields2 = filter_row_fields false row2.row_fields + in + let r1, r2, pairs = merge_row_fields fields1 fields2 in + r1 = [] && + List.for_all pairs ~f: + begin fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None -> true + | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix + | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> + c1 = c2 && List.length tl1 = List.length tl2 && + List.for_all2 tl1 tl2 ~f:(included ~prefix) + | _ -> false + end + | Tarrow _, Tarrow _ -> + let l1, t1 = all_args t1 and l2, t2 = all_args t2 in + included t1 t2 ~prefix && + let len1 = List.length l1 and len2 = List.length l2 in + let l2 = if arr len1 ~card:len2 < 100 then l2 else + let ll1 = get_options (fst (List.split l1)) in + List.filter l2 + ~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1) + in + len1 <= len2 && + List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: + begin fun l2 -> + List.for_all2 l1 l2 ~f: + begin fun (p1,t1) (p2,t2) -> + (p1 = "" || p1 = p2) && included t1 t2 ~prefix + end + end + | Ttuple l1, Ttuple l2 -> + let len1 = List.length l1 in + len1 <= List.length l2 && + List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: + begin fun l2 -> + List.for_all2 l1 l2 ~f:(included ~prefix) + end + | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix + | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> + remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) + && List.length l1 = List.length l2 + && List.for_all2 l1 l2 ~f:(included ~prefix) + | _ -> false + +let mklid = function + [] -> raise (Invalid_argument "Searchid.mklid") + | x :: l -> + List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x)) + +let mkpath = function + [] -> raise (Invalid_argument "Searchid.mklid") + | x :: l -> + List.fold_left l ~init:(Pident (Ident.create x)) + ~f:(fun acc x -> Pdot (acc, x, 0)) + +let get_fields ~prefix ~sign self = + let env = open_signature (mkpath prefix) sign initial in + match (expand_head env self).desc with + Tobject (ty_obj, _) -> + let l,_ = flatten_fields ty_obj in l + | _ -> [] + +let rec search_type_in_signature t ~sign ~prefix ~mode = + let matches = match mode with + `Included -> included t ~prefix + | `Exact -> equal t ~prefix + and lid_of_id id = mklid (prefix @ [Ident.name id]) in + List2.flat_map sign ~f: + begin fun item -> match item with + Tsig_value (id, vd) -> + if matches vd.val_type then [lid_of_id id, Pvalue] else [] + | Tsig_type (id, td, _) -> + if + begin match td.type_manifest with + None -> false + | Some t -> matches t + end || + begin match td.type_kind with + Type_abstract -> false + | Type_variant l -> + List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) + | Type_record(l, rep) -> + List.exists l ~f:(fun (_, _, t) -> matches t) + end + then [lid_of_id id, Ptype] else [] + | Tsig_exception (id, l) -> + if List.exists l ~f:matches + then [lid_of_id id, Pconstructor] + else [] + | Tsig_module (id, Tmty_signature sign, _) -> + search_type_in_signature t ~sign ~mode + ~prefix:(prefix @ [Ident.name id]) + | Tsig_module _ -> [] + | Tsig_modtype _ -> [] + | Tsig_class (id, cl, _) -> + let self = self_type cl.cty_type in + if matches self + || (match cl.cty_new with None -> false | Some ty -> matches ty) + (* || List.exists (get_fields ~prefix ~sign self) + ~f:(fun (_,_,ty_field) -> matches ty_field) *) + then [lid_of_id id, Pclass] else [] + | Tsig_cltype (id, cl, _) -> + let self = self_type cl.clty_type in + if matches self + (* || List.exists (get_fields ~prefix ~sign self) + ~f:(fun (_,_,ty_field) -> matches ty_field) *) + then [lid_of_id id, Pclass] else [] + end + +let search_all_types t ~mode = + let tl = match mode, t.desc with + `Exact, _ -> [t] + | `Included, Tarrow _ -> [t] + | `Included, _ -> + [t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))] + in List2.flat_map !module_list ~f: + begin fun modname -> + let mlid = Lident modname in + try match lookup_module mlid initial with + _, Tmty_signature sign -> + List2.flat_map tl + ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) + | _ -> [] + with Not_found | Env.Error _ -> [] + end + +exception Error of int * int + +let search_string_type text ~mode = + try + let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in + let sign = + try Typemod.transl_signature !start_env sexp with _ -> + let env = List.fold_left !module_list ~init:initial ~f: + begin fun acc m -> + try open_pers_signature m acc with Env.Error _ -> acc + end in + try Typemod.transl_signature env sexp + with Env.Error err -> [] + | Typemod.Error (l,_) -> + let start_c = l.loc_start.Lexing.pos_cnum in + let end_c = l.loc_end.Lexing.pos_cnum in + raise (Error (start_c - 8, end_c - 8)) + | Typetexp.Error (l,_) -> + let start_c = l.loc_start.Lexing.pos_cnum in + let end_c = l.loc_end.Lexing.pos_cnum in + raise (Error (start_c - 8, end_c - 8)) + in match sign with + [Tsig_value (_, vd)] -> + search_all_types vd.val_type ~mode + | _ -> [] + with + Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> + let start_c = l.loc_start.Lexing.pos_cnum in + let end_c = l.loc_end.Lexing.pos_cnum in + raise (Error (start_c - 8, end_c - 8)) + | Syntaxerr.Error(Syntaxerr.Other l) -> + let start_c = l.loc_start.Lexing.pos_cnum in + let end_c = l.loc_end.Lexing.pos_cnum in + raise (Error (start_c - 8, end_c - 8)) + | Lexer.Error (_, l) -> + let start_c = l.loc_start.Lexing.pos_cnum in + let end_c = l.loc_end.Lexing.pos_cnum in + raise (Error (start_c - 8, end_c - 8)) + +let longident_of_string text = + let exploded = ref [] and l = ref 0 in + for i = 0 to String.length text - 2 do + if text.[i] ='.' then + (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1) + done; + let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in + let rec mklid = function + [s] -> Lident s + | s :: l -> Ldot (mklid l, s) + | [] -> assert false in + sym, fun l -> mklid (sym :: !exploded @ l) + + +let explode s = + let l = ref [] in + for i = String.length s - 1 downto 0 do + l := s.[i] :: !l + done; !l + +let rec check_match ~pattern s = + match pattern, s with + [], [] -> true + | '*'::l, l' -> check_match ~pattern:l l' + || check_match ~pattern:('?'::'*'::l) l' + | '?'::l, _::l' -> check_match ~pattern:l l' + | x::l, y::l' when x == y -> check_match ~pattern:l l' + | _ -> false + +let search_pattern_symbol text = + if text = "" then [] else + let pattern = explode text in + let check i = check_match ~pattern (explode (Ident.name i)) in + let l = List.map !module_list ~f: + begin fun modname -> Lident modname, + try match lookup_module (Lident modname) initial with + _, Tmty_signature sign -> + List2.flat_map sign ~f: + begin function + Tsig_value (i, _) when check i -> [i, Pvalue] + | Tsig_type (i, _, _) when check i -> [i, Ptype] + | Tsig_exception (i, _) when check i -> [i, Pconstructor] + | Tsig_module (i, _, _) when check i -> [i, Pmodule] + | Tsig_modtype (i, _) when check i -> [i, Pmodtype] + | Tsig_class (i, cl, _) when check i + || List.exists + (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) + ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) + -> [i, Pclass] + | Tsig_cltype (i, cl, _) when check i + || List.exists + (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) + ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) + -> [i, Pcltype] + | _ -> [] + end + | _ -> [] + with Env.Error _ -> [] + end + in + List2.flat_map l ~f: + begin fun (m, l) -> + List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p) + end + +(* +let is_pattern s = + try for i = 0 to String.length s -1 do + if s.[i] = '?' || s.[i] = '*' then raise Exit + done; false + with Exit -> true +*) + +let search_string_symbol text = + if text = "" then [] else + let lid = snd (longident_of_string text) [] in + let try_lookup f k = + try let _ = f lid Env.initial in [lid, k] + with Not_found | Env.Error _ -> [] + in + try_lookup lookup_constructor Pconstructor @ + try_lookup lookup_module Pmodule @ + try_lookup lookup_modtype Pmodtype @ + try_lookup lookup_value Pvalue @ + try_lookup lookup_type Ptype @ + try_lookup lookup_label Plabel @ + try_lookup lookup_class Pclass + +open Parsetree + +let rec bound_variables pat = + match pat.ppat_desc with + Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> [] + | Ppat_var s -> [s] + | Ppat_alias (pat,s) -> s :: bound_variables pat + | Ppat_tuple l -> List2.flat_map l ~f:bound_variables + | Ppat_construct (_,None,_) -> [] + | Ppat_construct (_,Some pat,_) -> bound_variables pat + | Ppat_variant (_,None) -> [] + | Ppat_variant (_,Some pat) -> bound_variables pat + | Ppat_record (l, _) -> + List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat) + | Ppat_array l -> + List2.flat_map l ~f:bound_variables + | Ppat_or (pat1,pat2) -> + bound_variables pat1 @ bound_variables pat2 + | Ppat_constraint (pat,_) -> bound_variables pat + | Ppat_lazy pat -> bound_variables pat + +let search_structure str ~name ~kind ~prefix = + let loc = ref 0 in + let rec search_module str ~prefix = + match prefix with [] -> str + | modu::prefix -> + let str = + List.fold_left ~init:[] str ~f: + begin fun acc item -> + match item.pstr_desc with + Pstr_module (s, mexp) when s = modu -> + loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum; + begin match mexp.pmod_desc with + Pmod_structure str -> str + | _ -> [] + end + | _ -> acc + end + in search_module str ~prefix + in + List.iter (search_module str ~prefix) ~f: + begin fun item -> + if match item.pstr_desc with + Pstr_value (_, l) when kind = Pvalue -> + List.iter l ~f: + begin fun (pat,_) -> + if List.mem name (bound_variables pat) + then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum + end; + false + | Pstr_primitive (s, _) when kind = Pvalue -> name = s + | Pstr_type l when kind = Ptype -> + List.iter l ~f: + begin fun (s, td) -> + if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum + end; + false + | Pstr_exception (s, _) when kind = Pconstructor -> name = s + | Pstr_module (s, _) when kind = Pmodule -> name = s + | Pstr_modtype (s, _) when kind = Pmodtype -> name = s + | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> + List.iter l ~f: + begin fun c -> + if c.pci_name = name + then loc := c.pci_loc.loc_start.Lexing.pos_cnum + end; + false + | Pstr_class_type l when kind = Pcltype || kind = Ptype -> + List.iter l ~f: + begin fun c -> + if c.pci_name = name + then loc := c.pci_loc.loc_start.Lexing.pos_cnum + end; + false + | _ -> false + then loc := item.pstr_loc.loc_start.Lexing.pos_cnum + end; + !loc + +let search_signature sign ~name ~kind ~prefix = + let loc = ref 0 in + let rec search_module_type sign ~prefix = + match prefix with [] -> sign + | modu::prefix -> + let sign = + List.fold_left ~init:[] sign ~f: + begin fun acc item -> + match item.psig_desc with + Psig_module (s, mtyp) when s = modu -> + loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum; + begin match mtyp.pmty_desc with + Pmty_signature sign -> sign + | _ -> [] + end + | _ -> acc + end + in search_module_type sign ~prefix + in + List.iter (search_module_type sign ~prefix) ~f: + begin fun item -> + if match item.psig_desc with + Psig_value (s, _) when kind = Pvalue -> name = s + | Psig_type l when kind = Ptype -> + List.iter l ~f: + begin fun (s, td) -> + if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum + end; + false + | Psig_exception (s, _) when kind = Pconstructor -> name = s + | Psig_module (s, _) when kind = Pmodule -> name = s + | Psig_modtype (s, _) when kind = Pmodtype -> name = s + | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> + List.iter l ~f: + begin fun c -> + if c.pci_name = name + then loc := c.pci_loc.loc_start.Lexing.pos_cnum + end; + false + | Psig_class_type l when kind = Ptype || kind = Pcltype -> + List.iter l ~f: + begin fun c -> + if c.pci_name = name + then loc := c.pci_loc.loc_start.Lexing.pos_cnum + end; + false + | _ -> false + then loc := item.psig_loc.loc_start.Lexing.pos_cnum + end; + !loc diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/searchid.mli b/ocaml-binary-annot/otherlibs/labltk/browser/searchid.mli new file mode 100644 index 0000000000..980c141d08 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/searchid.mli @@ -0,0 +1,45 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +val start_env : Env.t ref +val module_list : string list ref +val longident_of_path : Path.t ->Longident.t + +type pkind = + Pvalue + | Ptype + | Plabel + | Pconstructor + | Pmodule + | Pmodtype + | Pclass + | Pcltype + +val string_of_kind : pkind -> string + +exception Error of int * int + +val search_string_type : + string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list +val search_pattern_symbol : string -> (Longident.t * pkind) list +val search_string_symbol : string -> (Longident.t * pkind) list + +val search_structure : + Parsetree.structure -> + name:string -> kind:pkind -> prefix:string list -> int +val search_signature : + Parsetree.signature -> + name:string -> kind:pkind -> prefix:string list -> int diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.ml b/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.ml new file mode 100644 index 0000000000..8cae995930 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.ml @@ -0,0 +1,890 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Support +open Tk +open Jg_tk +open Parsetree +open Types +open Typedtree +open Location +open Longident +open Path +open Env +open Searchid + +(* auxiliary functions *) + +let (~!) = Jg_memo.fast ~f:Str.regexp + +let lines_to_chars n ~text:s = + let l = String.length s in + let rec ltc n ~pos = + if n = 1 || pos >= l then pos else + if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1) + in ltc n ~pos:0 + +let in_loc loc ~pos = + loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum + && pos < loc.loc_end.Lexing.pos_cnum + +let le_loc loc1 loc2 = + loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum + && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum + +let add_found ~found sol ~env ~loc = + if loc.loc_ghost then () else + if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then () + else found := (sol, env, loc) :: + List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc)) + +let observe ~ref ?init f x = + let old = !ref in + begin match init with None -> () | Some x -> ref := x end; + try (f x : unit); let v = !ref in ref := old; v + with exn -> ref := old; raise exn + +let rec string_of_longident = function + Lident s -> s + | Ldot (id,s) -> string_of_longident id ^ "." ^ s + | Lapply (id1, id2) -> + string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")" + +let string_of_path p = string_of_longident (Searchid.longident_of_path p) + +let parent_path = function + Pdot (path, _, _) -> Some path + | Pident _ | Papply _ -> None + +let ident_of_path ~default = function + Pident i -> i + | Pdot (_, s, _) -> Ident.create s + | Papply _ -> Ident.create default + +let rec head_id = function + Pident id -> id + | Pdot (path,_,_) -> head_id path + | Papply (path,_) -> head_id path (* wrong, but ... *) + +let rec list_of_path = function + Pident id -> [Ident.name id] + | Pdot (path, s, _) -> list_of_path path @ [s] + | Papply (path, _) -> list_of_path path (* wrong, but ... *) + +(* a simple wrapper *) + +class buffer ~size = object + val buffer = Buffer.create size + method out buf = Buffer.add_substring buffer buf + method get = Buffer.contents buffer +end + +(* Search in a signature *) + +type skind = [`Type|`Class|`Module|`Modtype] + +let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list) +let add_found_sig = add_found ~found:found_sig + +let rec search_pos_type t ~pos ~env = + if in_loc ~pos t.ptyp_loc then + begin match t.ptyp_desc with + Ptyp_any + | Ptyp_var _ -> () + | Ptyp_variant(tl, _, _) -> + List.iter tl ~f: + begin function + Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env) + | Rinherit st -> search_pos_type ~pos ~env st + end + | Ptyp_arrow (_, t1, t2) -> + search_pos_type t1 ~pos ~env; + search_pos_type t2 ~pos ~env + | Ptyp_tuple tl -> + List.iter tl ~f:(search_pos_type ~pos ~env) + | Ptyp_constr (lid, tl) -> + List.iter tl ~f:(search_pos_type ~pos ~env); + add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc + | Ptyp_object fl -> + List.iter fl ~f: + begin function + | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env + | _ -> () + end + | Ptyp_class (lid, tl, _) -> + List.iter tl ~f:(search_pos_type ~pos ~env); + add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc + | Ptyp_alias (t, _) + | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t + | Ptyp_package (_, stl) -> + List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env) + end + +let rec search_pos_class_type cl ~pos ~env = + if in_loc cl.pcty_loc ~pos then + begin match cl.pcty_desc with + Pcty_constr (lid, _) -> + add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc + | Pcty_signature (_, cfl) -> + List.iter cfl ~f: + begin function + Pctf_inher cty -> search_pos_class_type cty ~pos ~env + | Pctf_val (_, _, _, ty, loc) -> + if in_loc loc ~pos then search_pos_type ty ~pos ~env + | Pctf_virt (_, _, ty, loc) -> + if in_loc loc ~pos then search_pos_type ty ~pos ~env + | Pctf_meth (_, _, ty, loc) -> + if in_loc loc ~pos then search_pos_type ty ~pos ~env + | Pctf_cstr (ty1, ty2, loc) -> + if in_loc loc ~pos then begin + search_pos_type ty1 ~pos ~env; + search_pos_type ty2 ~pos ~env + end + end + | Pcty_fun (_, ty, cty) -> + search_pos_type ty ~pos ~env; + search_pos_class_type cty ~pos ~env + end + +let search_pos_type_decl td ~pos ~env = + if in_loc ~pos td.ptype_loc then begin + begin match td.ptype_manifest with + Some t -> search_pos_type t ~pos ~env + | None -> () + end; + let rec search_tkind = function + Ptype_abstract -> () + | Ptype_variant dl -> + List.iter dl + ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) + | Ptype_record dl -> + List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in + search_tkind td.ptype_kind; + List.iter td.ptype_cstrs ~f: + begin fun (t1, t2, _) -> + search_pos_type t1 ~pos ~env; + search_pos_type t2 ~pos ~env + end + end + +let rec search_pos_signature l ~pos ~env = + ignore ( + List.fold_left l ~init:env ~f: + begin fun env pt -> + let env = match pt.psig_desc with + Psig_open id -> + let path, mt = lookup_module id env in + begin match mt with + Tmty_signature sign -> open_signature path sign env + | _ -> env + end + | sign_item -> + try add_signature (Typemod.transl_signature env [pt]) env + with Typemod.Error _ | Typeclass.Error _ + | Typetexp.Error _ | Typedecl.Error _ -> env + in + if in_loc ~pos pt.psig_loc then + begin match pt.psig_desc with + Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env + | Psig_type l -> + List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env) + | Psig_exception (_, l) -> + List.iter l ~f:(search_pos_type ~pos ~env); + add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc + | Psig_module (_, t) -> + search_pos_module t ~pos ~env + | Psig_recmodule decls -> + List.iter decls ~f:(fun (_, t) -> search_pos_module t ~pos ~env) + | Psig_modtype (_, Pmodtype_manifest t) -> + search_pos_module t ~pos ~env + | Psig_modtype _ -> () + | Psig_class l -> + List.iter l + ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) + | Psig_class_type l -> + List.iter l + ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) + (* The last cases should not happen in generated interfaces *) + | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc + | Psig_include t -> search_pos_module t ~pos ~env + end; + env + end) + +and search_pos_module m ~pos ~env = + if in_loc m.pmty_loc ~pos then begin + begin match m.pmty_desc with + Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc + | Pmty_signature sg -> search_pos_signature sg ~pos ~env + | Pmty_functor (_ , m1, m2) -> + search_pos_module m1 ~pos ~env; + search_pos_module m2 ~pos ~env + | Pmty_with (m, l) -> + search_pos_module m ~pos ~env; + List.iter l ~f: + begin function + _, Pwith_type t -> search_pos_type_decl t ~pos ~env + | _ -> () + end + | Pmty_typeof md -> + () (* TODO? *) + end + end + +let search_pos_signature l ~pos ~env = + observe ~ref:found_sig (search_pos_signature ~pos ~env) l + +(* the module display machinery *) + +type module_widgets = + { mw_frame: Widget.frame Widget.widget; + mw_title: Widget.label Widget.widget option; + mw_detach: Widget.button Widget.widget; + mw_edit: Widget.button Widget.widget; + mw_intf: Widget.button Widget.widget } + +let shown_modules = Hashtbl.create 17 +let default_frame = ref None +let set_path = ref (fun _ ~sign -> assert false) +let filter_modules () = + Hashtbl.iter + (fun key data -> + if not (Winfo.exists data.mw_frame) then + Hashtbl.remove shown_modules key) + shown_modules +let add_shown_module path ~widgets = + Hashtbl.add shown_modules path widgets +let find_shown_module path = + try + filter_modules (); + Hashtbl.find shown_modules path + with Not_found -> + match !default_frame with + None -> raise Not_found + | Some mw -> mw + +let is_shown_module path = + !default_frame <> None || + (filter_modules (); Hashtbl.mem shown_modules path) + +(* Viewing a signature *) + +(* Forward definitions of Viewer.view_defined and Editor.editor *) +let view_defined_ref = ref (fun lid ~env -> ()) +let editor_ref = ref (fun ?file ?pos ?opendialog () -> ()) + +let edit_source ~file ~path ~sign = + match sign with + [item] -> + let id, kind = + match item with + Tsig_value (id, _) -> id, Pvalue + | Tsig_type (id, _, _) -> id, Ptype + | Tsig_exception (id, _) -> id, Pconstructor + | Tsig_module (id, _, _) -> id, Pmodule + | Tsig_modtype (id, _) -> id, Pmodtype + | Tsig_class (id, _, _) -> id, Pclass + | Tsig_cltype (id, _, _) -> id, Pcltype + in + let prefix = List.tl (list_of_path path) and name = Ident.name id in + let pos = + try + let chan = open_in file in + if Filename.check_suffix file ".ml" then + let parsed = Parse.implementation (Lexing.from_channel chan) in + close_in chan; + Searchid.search_structure parsed ~name ~kind ~prefix + else + let parsed = Parse.interface (Lexing.from_channel chan) in + close_in chan; + Searchid.search_signature parsed ~name ~kind ~prefix + with _ -> 0 + in !editor_ref ~file ~pos () + | _ -> !editor_ref ~file () + +(* List of windows to destroy by Close All *) +let top_widgets = ref [] + +let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract) + +let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = + let env = + match path with None -> env + | Some path -> Env.open_signature path sign env in + let title = + match title, path with Some title, _ -> title + | None, Some path -> string_of_path path + | None, None -> "Signature" + in + let tl, tw, finish = + try match path, !default_frame with + None, Some ({mw_title=Some label} as mw) when not detach -> + Button.configure mw.mw_detach + ~command:(fun () -> view_signature sign ~title ~env ~detach:true); + pack [mw.mw_detach] ~side:`Left; + Pack.forget [mw.mw_edit; mw.mw_intf]; + List.iter ~f:destroy (Winfo.children mw.mw_frame); + Label.configure label ~text:title; + pack [label] ~fill:`X ~side:`Bottom; + Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () + | None, _ -> raise Not_found + | Some path, _ -> + let mw = + try find_shown_module path + with Not_found -> + view_module path ~env; + find_shown_module path + in + (try !set_path path ~sign with _ -> ()); + begin match mw.mw_title with None -> () + | Some label -> + Label.configure label ~text:title; + pack [label] ~fill:`X ~side:`Bottom + end; + Button.configure mw.mw_detach + ~command:(fun () -> view_signature sign ~title ~env ~detach:true); + pack [mw.mw_detach] ~side:`Left; + let repack = ref false in + List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f: + begin fun button ext -> + try + let id = head_id path in + let file = + Misc.find_in_path_uncap !Config.load_path + ((Ident.name id) ^ ext) in + Button.configure button + ~command:(fun () -> edit_source ~file ~path ~sign); + if !repack then Pack.forget [button] else + if not (Winfo.viewable button) then repack := true; + pack [button] ~side:`Left + with Not_found -> + Pack.forget [button] + end; + let top = Winfo.toplevel mw.mw_frame in + if not (Winfo.ismapped top) then Wm.deiconify top; + List.iter ~f:destroy (Winfo.children mw.mw_frame); + Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () + with Not_found -> + let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in + top_widgets := tl :: !top_widgets; + tl, tw, finish + in + Format.set_max_boxes 100; + Printtyp.signature Format.std_formatter sign; + finish (); + Lexical.init_tags tw; + Lexical.tag tw; + Text.configure tw ~state:`Disabled; + let text = Jg_text.get_all tw in + let pt = + try Parse.interface (Lexing.from_string text) + with Syntaxerr.Error e -> + let l = + match e with + Syntaxerr.Unclosed(l,_,_,_) -> l + | Syntaxerr.Applicative_path l -> l + | Syntaxerr.Other l -> l + in + Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) + ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; [] + | Lexer.Error (_, l) -> + let s = l.loc_start.Lexing.pos_cnum in + let e = l.loc_end.Lexing.pos_cnum in + Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; [] + in + Jg_bind.enter_focus tw; + bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")] + ~action:(fun _ -> Jg_text.search_string tw); + bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~fields:[`MouseX;`MouseY] ~breakable:true + ~action:(fun ev -> + let `Linechar (l, c) = + Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in + try + match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env + with [] -> break () + | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env + with Not_found | Env.Error _ -> ()); + bind tw ~events:[`ButtonPressDetail 3] ~breakable:true + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let x = ev.ev_MouseX and y = ev.ev_MouseY in + let `Linechar (l, c) = + Text.index tw ~index:(`Atxy(x,y), []) in + try + match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env + with [] -> break () + | ((kind, lid), env, loc) :: _ -> + let menu = view_decl_menu lid ~kind ~env ~parent:tw in + let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in + Menu.popup menu ~x ~y + with Not_found -> ()) + +and view_signature_item sign ~path ~env = + view_signature sign ~title:(string_of_path path) + ?path:(parent_path path) ~env + +and view_module path ~env = + match find_module path env with + Tmty_signature sign -> + !view_defined_ref (Searchid.longident_of_path path) ~env + | modtype -> + let id = ident_of_path path ~default:"M" in + view_signature_item [Tsig_module (id, modtype, Trec_not)] ~path ~env + +and view_module_id id ~env = + let path, _ = lookup_module id env in + view_module path ~env + +and view_type_decl path ~env = + let td = find_type path env in + try match td.type_manifest with None -> raise Not_found + | Some ty -> match Ctype.repr ty with + {desc = Tobject _} -> + let clt = find_cltype path env in + view_signature_item ~path ~env + [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + dummy_item; dummy_item] + | _ -> raise Not_found + with Not_found -> + view_signature_item ~path ~env + [Tsig_type(ident_of_path path ~default:"t", td, Trec_first)] + +and view_type_id li ~env = + let path, decl = lookup_type li env in + view_type_decl path ~env + +and view_class_id li ~env = + let path, cl = lookup_class li env in + view_signature_item ~path ~env + [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first); + dummy_item; dummy_item; dummy_item] + +and view_cltype_id li ~env = + let path, clt = lookup_cltype li env in + view_signature_item ~path ~env + [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + dummy_item; dummy_item] + +and view_modtype_id li ~env = + let path, td = lookup_modtype li env in + view_signature_item ~path ~env + [Tsig_modtype(ident_of_path path ~default:"S", td)] + +and view_expr_type ?title ?path ?env ?(name="noname") t = + let title = + match title, path with Some title, _ -> title + | None, Some path -> string_of_path path + | None, None -> "Expression type" + and path, id = + match path with None -> None, Ident.create name + | Some path -> parent_path path, ident_of_path path ~default:name + in + view_signature ~title ?path ?env + [Tsig_value (id, {val_type = t; val_kind = Val_reg})] + +and view_decl lid ~kind ~env = + match kind with + `Type -> view_type_id lid ~env + | `Class -> view_class_id lid ~env + | `Module -> view_module_id lid ~env + | `Modtype -> view_modtype_id lid ~env + +and view_decl_menu lid ~kind ~env ~parent = + let path, kname = + try match kind with + `Type -> fst (lookup_type lid env), "Type" + | `Class -> fst (lookup_class lid env), "Class" + | `Module -> fst (lookup_module lid env), "Module" + | `Modtype -> fst (lookup_modtype lid env), "Module type" + with Env.Error _ -> raise Not_found + in + let menu = Menu.create parent ~tearoff:false in + let label = kname ^ " " ^ string_of_path path in + begin match path with + Pident _ -> + Menu.add_command menu ~label ~state:`Disabled + | _ -> + Menu.add_command menu ~label + ~command:(fun () -> view_decl lid ~kind ~env); + end; + if kind = `Type || kind = `Modtype then begin + let buf = new buffer ~size:60 in + let (fo,ff) = Format.get_formatter_output_functions () + and margin = Format.get_margin () in + Format.set_formatter_output_functions buf#out (fun () -> ()); + Format.set_margin 60; + Format.open_hbox (); + if kind = `Type then + Printtyp.type_declaration + (ident_of_path path ~default:"t") + Format.std_formatter + (find_type path env) + else + Printtyp.modtype_declaration + (ident_of_path path ~default:"S") + Format.std_formatter + (find_modtype path env); + Format.close_box (); Format.print_flush (); + Format.set_formatter_output_functions fo ff; + Format.set_margin margin; + let l = Str.split ~!"\n" buf#get in + let font = + let font = + Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in + if font = "" then "7x14" else font + in + (* Menu.add_separator menu; *) + List.iter l + ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled) + end; + menu + +(* search and view in a structure *) + +type fkind = [ + `Exp of + [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] + * Types.type_expr + | `Class of Path.t * Types.class_type + | `Module of Path.t * Types.module_type +] + +let view_type kind ~env = + match kind with + `Exp (k, ty) -> + begin match k with + `Expr -> view_expr_type ty ~title:"Expression type" ~env + | `Pat -> view_expr_type ty ~title:"Pattern type" ~env + | `Const -> view_expr_type ty ~title:"Constant type" ~env + | `Val path -> + begin try + let vd = find_value path env in + view_signature_item ~path ~env + [Tsig_value(ident_of_path path ~default:"v", vd)] + with Not_found -> + view_expr_type ty ~path ~env + end + | `Var path -> + let vd = find_value path env in + view_expr_type vd.val_type ~env ~path ~title:"Variable type" + | `New path -> + let cl = find_class path env in + view_signature_item ~path ~env + [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)] + end + | `Class (path, cty) -> + let cld = { cty_params = []; cty_variance = []; cty_type = cty; + cty_path = path; cty_new = None } in + view_signature_item ~path ~env + [Tsig_class(ident_of_path path ~default:"c", cld, Trec_first)] + | `Module (path, mty) -> + match mty with + Tmty_signature sign -> view_signature sign ~path ~env + | modtype -> + view_signature_item ~path ~env + [Tsig_module(ident_of_path path ~default:"M", mty, Trec_not)] + +let view_type_menu kind ~env ~parent = + let title = + match kind with + `Exp (`Expr,_) -> "Expression :" + | `Exp (`Pat, _) -> "Pattern :" + | `Exp (`Const, _) -> "Constant :" + | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :" + | `Exp (`Var path, _) -> + "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :" + | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :" + | `Class (path, _) -> "Class " ^ string_of_path path ^ " :" + | `Module (path,_) -> "Module " ^ string_of_path path in + let menu = Menu.create parent ~tearoff:false in + begin match kind with + `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) -> + Menu.add_command menu ~label:title ~state:`Disabled + | `Exp _ | `Class _ | `Module _ -> + Menu.add_command menu ~label:title + ~command:(fun () -> view_type kind ~env) + end; + begin match kind with `Module _ | `Class _ -> () + | `Exp(_, ty) -> + let buf = new buffer ~size:60 in + let (fo,ff) = Format.get_formatter_output_functions () + and margin = Format.get_margin () in + Format.set_formatter_output_functions buf#out ignore; + Format.set_margin 60; + Format.open_hbox (); + Printtyp.reset (); + Printtyp.mark_loops ty; + Printtyp.type_expr Format.std_formatter ty; + Format.close_box (); Format.print_flush (); + Format.set_formatter_output_functions fo ff; + Format.set_margin margin; + let l = Str.split ~!"\n" buf#get in + let font = + let font = + Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in + if font = "" then "7x14" else font + in + (* Menu.add_separator menu; *) + List.iter l ~f: + begin fun label -> match (Ctype.repr ty).desc with + Tconstr (path,_,_) -> + Menu.add_command menu ~label ~font + ~command:(fun () -> view_type_decl path ~env) + | Tvariant {row_name = Some (path, _)} -> + Menu.add_command menu ~label ~font + ~command:(fun () -> view_type_decl path ~env) + | _ -> + Menu.add_command menu ~label ~font ~state:`Disabled + end + end; + menu + +let found_str = ref ([] : (fkind * Env.t * Location.t) list) +let add_found_str = add_found ~found:found_str + +let rec search_pos_structure ~pos str = + List.iter str ~f: + begin function + Tstr_eval exp -> search_pos_expr exp ~pos + | Tstr_value (rec_flag, l) -> + List.iter l ~f: + begin fun (pat, exp) -> + let env = + if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in + search_pos_pat pat ~pos ~env; + search_pos_expr exp ~pos + end + | Tstr_primitive (_, vd) ->() + | Tstr_type _ -> () + | Tstr_exception _ -> () + | Tstr_exn_rebind(_, _) -> () + | Tstr_module (_, m) -> search_pos_module_expr m ~pos + | Tstr_recmodule bindings -> + List.iter bindings ~f:(fun (_, m) -> search_pos_module_expr m ~pos) + | Tstr_modtype _ -> () + | Tstr_open _ -> () + | Tstr_class l -> + List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos) + | Tstr_cltype _ -> () + | Tstr_include (m, _) -> search_pos_module_expr m ~pos + end + +and search_pos_class_structure ~pos cls = + List.iter cls.cl_field ~f: + begin function + Cf_inher (cl, _, _) -> + search_pos_class_expr cl ~pos + | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos + | Cf_val _ -> () + | Cf_meth (_, exp) -> search_pos_expr exp ~pos + | Cf_let (_, pel, iel) -> + List.iter pel ~f: + begin fun (pat, exp) -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos + end; + List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos) + | Cf_init exp -> search_pos_expr exp ~pos + end + +and search_pos_class_expr ~pos cl = + if in_loc cl.cl_loc ~pos then begin + begin match cl.cl_desc with + Tclass_ident path -> + add_found_str (`Class (path, cl.cl_type)) + ~env:!start_env ~loc:cl.cl_loc + | Tclass_structure cls -> + search_pos_class_structure ~pos cls + | Tclass_fun (pat, iel, cl, _) -> + search_pos_pat pat ~pos ~env:pat.pat_env; + List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + search_pos_class_expr cl ~pos + | Tclass_apply (cl, el) -> + search_pos_class_expr cl ~pos; + List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x) + | Tclass_let (_, pel, iel, cl) -> + List.iter pel ~f: + begin fun (pat, exp) -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos + end; + List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + search_pos_class_expr cl ~pos + | Tclass_constraint (cl, _, _, _) -> + search_pos_class_expr cl ~pos + end; + add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type)) + ~env:!start_env ~loc:cl.cl_loc + end + +and search_pos_expr ~pos exp = + if in_loc exp.exp_loc ~pos then begin + begin match exp.exp_desc with + Texp_ident (path, _) -> + add_found_str (`Exp(`Val path, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc + | Texp_constant v -> + add_found_str (`Exp(`Const, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc + | Texp_let (_, expl, exp) -> + List.iter expl ~f: + begin fun (pat, exp') -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp' ~pos + end; + search_pos_expr exp ~pos + | Texp_function (l, _) -> + List.iter l ~f: + begin fun (pat, exp) -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos + end + | Texp_apply (exp, l) -> + List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x); + search_pos_expr exp ~pos + | Texp_match (exp, l, _) -> + search_pos_expr exp ~pos; + List.iter l ~f: + begin fun (pat, exp) -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos + end + | Texp_try (exp, l) -> + search_pos_expr exp ~pos; + List.iter l ~f: + begin fun (pat, exp) -> + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos + end + | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) + | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos) + | Texp_variant (_, None) -> () + | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos + | Texp_record (l, opt) -> + List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos); + (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) + | Texp_field (exp, _) -> search_pos_expr exp ~pos + | Texp_setfield (a, _, b) -> + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) + | Texp_ifthenelse (a, b, c) -> + search_pos_expr a ~pos; search_pos_expr b ~pos; + begin match c with None -> () + | Some exp -> search_pos_expr exp ~pos + end + | Texp_sequence (a,b) -> + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_while (a,b) -> + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_for (_, a, b, _, c) -> + List.iter [a;b;c] ~f:(search_pos_expr ~pos) + | Texp_when (a, b) -> + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_send (exp, _) -> search_pos_expr exp ~pos + | Texp_new (path, _) -> + add_found_str (`Exp(`New path, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc + | Texp_instvar (_,path) -> + add_found_str (`Exp(`Var path, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc + | Texp_setinstvar (_, path, exp) -> + search_pos_expr exp ~pos; + add_found_str (`Exp(`Var path, exp.exp_type)) + ~env:exp.exp_env ~loc:exp.exp_loc + | Texp_override (_, l) -> + List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos) + | Texp_letmodule (id, modexp, exp) -> + search_pos_module_expr modexp ~pos; + search_pos_expr exp ~pos + | Texp_assertfalse -> () + | Texp_assert exp -> + search_pos_expr exp ~pos + | Texp_lazy exp -> + search_pos_expr exp ~pos + | Texp_object (cls, _, _) -> + search_pos_class_structure ~pos cls + | Texp_pack modexp -> + search_pos_module_expr modexp ~pos + end; + add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc + end + +and search_pos_pat ~pos ~env pat = + if in_loc pat.pat_loc ~pos then begin + begin match pat.pat_desc with + Tpat_any -> () + | Tpat_var id -> + add_found_str (`Exp(`Val (Pident id), pat.pat_type)) + ~env ~loc:pat.pat_loc + | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env + | Tpat_lazy pat -> search_pos_pat pat ~pos ~env + | Tpat_constant _ -> + add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc + | Tpat_tuple l -> + List.iter l ~f:(search_pos_pat ~pos ~env) + | Tpat_construct (_, l) -> + List.iter l ~f:(search_pos_pat ~pos ~env) + | Tpat_variant (_, None, _) -> () + | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env + | Tpat_record l -> + List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env) + | Tpat_array l -> + List.iter l ~f:(search_pos_pat ~pos ~env) + | Tpat_or (a, b, None) -> + search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env + | Tpat_or (_, _, Some _) -> + () + end; + add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc + end + +and search_pos_module_expr ~pos m = + if in_loc m.mod_loc ~pos then begin + begin match m.mod_desc with + Tmod_ident path -> + add_found_str (`Module (path, m.mod_type)) + ~env:m.mod_env ~loc:m.mod_loc + | Tmod_structure str -> search_pos_structure str ~pos + | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos + | Tmod_apply (a, b, _) -> + search_pos_module_expr a ~pos; search_pos_module_expr b ~pos + | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos + | Tmod_unpack (e, _) -> search_pos_expr e ~pos + end; + add_found_str (`Module (Pident (Ident.create "M"), m.mod_type)) + ~env:m.mod_env ~loc:m.mod_loc + end + +let search_pos_structure ~pos str = + observe ~ref:found_str (search_pos_structure ~pos) str + +open Stypes + +let search_pos_ti ~pos = function + Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p + | Ti_expr e -> search_pos_expr ~pos e + | Ti_class c -> search_pos_class_expr ~pos c + | Ti_mod m -> search_pos_module_expr ~pos m + | _ -> () + +let rec search_pos_info ~pos = function + [] -> [] + | ti :: l -> + if in_loc ~pos (get_location ti) + then observe ~ref:found_str (search_pos_ti ~pos) ti + else search_pos_info ~pos l diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.mli b/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.mli new file mode 100644 index 0000000000..b2f89cd81c --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/searchpos.mli @@ -0,0 +1,77 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val top_widgets : any widget list ref + +type module_widgets = + { mw_frame: frame widget; + mw_title: label widget option; + mw_detach: button widget; + mw_edit: button widget; + mw_intf: button widget } + +val add_shown_module : Path.t -> widgets:module_widgets -> unit +val find_shown_module : Path.t -> module_widgets +val is_shown_module : Path.t -> bool +val default_frame : module_widgets option ref +val set_path : (Path.t -> sign:Types.signature -> unit) ref + +val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref +val editor_ref : + (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref + +val view_signature : + ?title:string -> + ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit +val view_signature_item : + Types.signature -> path:Path.t -> env:Env.t -> unit +val view_module_id : Longident.t -> env:Env.t -> unit +val view_type_id : Longident.t -> env:Env.t -> unit +val view_class_id : Longident.t -> env:Env.t -> unit +val view_cltype_id : Longident.t -> env:Env.t -> unit +val view_modtype_id : Longident.t -> env:Env.t -> unit +val view_type_decl : Path.t -> env:Env.t -> unit + +type skind = [`Type|`Class|`Module|`Modtype] +val search_pos_signature : + Parsetree.signature -> pos:int -> env:Env.t -> + ((skind * Longident.t) * Env.t * Location.t) list +val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit +val view_decl_menu : + Longident.t -> + kind:skind -> env:Env.t -> parent:text widget -> menu widget + +type fkind = [ + `Exp of + [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] + * Types.type_expr + | `Class of Path.t * Types.class_type + | `Module of Path.t * Types.module_type +] +val search_pos_structure : + pos:int -> Typedtree.structure_item list -> + (fkind * Env.t * Location.t) list +val search_pos_info : + pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list +val view_type : fkind -> env:Env.t -> unit +val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget + +val parent_path : Path.t -> Path.t option +val string_of_path : Path.t -> string +val string_of_longident : Longident.t -> string +val lines_to_chars : int -> text:string -> int diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/setpath.ml b/ocaml-binary-annot/otherlibs/labltk/browser/setpath.ml new file mode 100644 index 0000000000..1a41b573b5 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/setpath.ml @@ -0,0 +1,162 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk + +(* Listboxes *) + +let update_hooks = ref [] + +let add_update_hook f = update_hooks := f :: !update_hooks + +let exec_update_hooks () = + update_hooks := List.filter !update_hooks ~f: + begin fun f -> + try f (); true + with Protocol.TkError _ -> false + end + +let set_load_path l = + Config.load_path := l; + exec_update_hooks () + +let get_load_path () = !Config.load_path + +let renew_dirs box ~var ~dir = + Textvariable.set var dir; + Listbox.delete box ~first:(`Num 0) ~last:`End; + Listbox.insert box ~index:`End + ~texts:(Useunix.get_directories_in_files ~path:dir + (Useunix.get_files_in_directory dir)); + Jg_box.recenter box ~index:(`Num 0) + +let renew_path box = + Listbox.delete box ~first:(`Num 0) ~last:`End; + Listbox.insert box ~index:`End ~texts:!Config.load_path; + Jg_box.recenter box ~index:(`Num 0) + +let add_to_path ~dirs ?(base="") box = + let dirs = + if base = "" then dirs else + if dirs = [] then [base] else + List.map dirs ~f: + begin function + "." -> base + | ".." -> Filename.dirname base + | x -> Filename.concat base x + end + in + set_load_path + (dirs @ List.fold_left dirs ~init:(get_load_path ()) + ~f:(fun acc x -> List2.exclude x acc)) + +let remove_path box ~dirs = + set_load_path + (List.fold_left dirs ~init:(get_load_path ()) + ~f:(fun acc x -> List2.exclude x acc)) + +(* main function *) + +let f ~dir = + let current_dir = ref dir in + let tl = Jg_toplevel.titled "Edit Load Path" in + Jg_bind.escape_destroy tl; + let var_dir = Textvariable.create ~on:tl () in + let caplab = Label.create tl ~text:"Path" + and dir_name = Entry.create tl ~textvariable:var_dir + and browse = Frame.create tl in + let dirs = Frame.create browse + and path = Frame.create browse in + let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs + and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path + in + add_update_hook (fun () -> renew_path pathbox); + Listbox.configure pathbox ~width:40 ~selectmode:`Multiple; + Listbox.configure dirbox ~selectmode:`Multiple; + Jg_box.add_completion dirbox ~action: + begin fun index -> + begin match Listbox.get dirbox ~index with + "." -> () + | ".." -> current_dir := Filename.dirname !current_dir + | x -> current_dir := !current_dir ^ "/" ^ x + end; + renew_dirs dirbox ~var:var_dir ~dir:!current_dir; + Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End + end; + Jg_box.add_completion pathbox ~action: + begin fun index -> + current_dir := Listbox.get pathbox ~index; + renew_dirs dirbox ~var:var_dir ~dir:!current_dir + end; + + bind dir_name ~events:[`KeyPressDetail"Return"] + ~action:(fun _ -> + let dir = Textvariable.get var_dir in + if Useunix.is_directory dir then begin + current_dir := dir; + renew_dirs dirbox ~var:var_dir ~dir + end); + + (* Avoid space being used by the completion mechanism *) + let bind_space_toggle lb = + bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in + bind_space_toggle dirbox; + bind_space_toggle pathbox; + + let add_paths _ = + add_to_path pathbox ~base:!current_dir + ~dirs:(List.map (Listbox.curselection dirbox) + ~f:(fun x -> Listbox.get dirbox ~index:x)); + Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End + and remove_paths _ = + remove_path pathbox + ~dirs:(List.map (Listbox.curselection pathbox) + ~f:(fun x -> Listbox.get pathbox ~index:x)) + in + bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; + bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; + + let dirlab = Label.create dirs ~text:"Directories" + and pathlab = Label.create path ~text:"Load path" + and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths + and pathbuttons = Frame.create path in + let removebutton = + Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths + and ok = + Jg_button.create_destroyer tl ~parent:pathbuttons + in + renew_dirs dirbox ~var:var_dir ~dir:!current_dir; + renew_path pathbox; + pack [dirsb] ~side:`Right ~fill:`Y; + pack [dirbox] ~side:`Left ~fill:`Y ~expand:true; + pack [pathsb] ~side:`Right ~fill:`Y; + pack [pathbox] ~side:`Left ~fill:`Both ~expand:true; + pack [dirlab] ~side:`Top ~anchor:`W ~padx:10; + pack [addbutton] ~side:`Bottom ~fill:`X; + pack [dirframe] ~fill:`Y ~expand:true; + pack [pathlab] ~side:`Top ~anchor:`W ~padx:10; + pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true; + pack [pathbuttons] ~fill:`X ~side:`Bottom; + pack [pathframe] ~fill:`Both ~expand:true; + pack [dirs] ~side:`Left ~fill:`Y; + pack [path] ~side:`Right ~fill:`Both ~expand:true; + pack [caplab] ~side:`Top ~anchor:`W ~padx:10; + pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X; + pack [browse] ~side:`Bottom ~expand:true ~fill:`Both; + tl + +let set ~dir = ignore (f ~dir);; diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/setpath.mli b/ocaml-binary-annot/otherlibs/labltk/browser/setpath.mli new file mode 100644 index 0000000000..22bf5dc583 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/setpath.mli @@ -0,0 +1,25 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget + +val add_update_hook : (unit -> unit) -> unit +val exec_update_hooks : unit -> unit + (* things to do when Config.load_path changes *) + +val set : dir:string -> unit +val f : dir:string -> toplevel widget + (* edit the load path *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/shell.ml b/ocaml-binary-annot/otherlibs/labltk/browser/shell.ml new file mode 100644 index 0000000000..be93ef5fda --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/shell.ml @@ -0,0 +1,365 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +module Unix = UnixLabels +open Tk +open Jg_tk +open Dummy + +(* Here again, memoize regexps *) + +let (~!) = Jg_memo.fast ~f:Str.regexp + +(* Nice history class. May reuse *) + +class ['a] history () = object + val mutable history = ([] : 'a list) + val mutable count = 0 + method empty = history = [] + method add s = count <- 0; history <- s :: history + method previous = + let s = List.nth history count in + count <- (count + 1) mod List.length history; + s + method next = + let l = List.length history in + count <- (l + count - 1) mod l; + List.nth history ((l + count - 1) mod l) +end + +let dump_handle (h : Unix.file_descr) = + let obj = Obj.repr h in + if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then + invalid_arg "Shell.dump_handle"; + Nativeint.format "%x" (Obj.obj obj) + +(* The shell class. Now encapsulated *) + +let protect f x = try f x with _ -> () + +let is_win32 = Sys.os_type = "Win32" +let use_threads = is_win32 +let use_sigpipe = is_win32 + +class shell ~textw ~prog ~args ~env ~history = + let (in2,out1) = Unix.pipe () + and (in1,out2) = Unix.pipe () + and (err1,err2) = Unix.pipe () + and (sig2,sig1) = Unix.pipe () in +object (self) + val pid = + let env = + if use_sigpipe then + let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in + Array.append env [|sigdef|] + else env + in + Unix.create_process_env ~prog ~args ~env + ~stdin:in2 ~stdout:out2 ~stderr:err2 + val out = Unix.out_channel_of_descr out1 + val h : _ history = history + val mutable alive = true + val mutable reading = false + val ibuffer = Buffer.create 1024 + val imutex = Mutex.create () + val mutable ithreads = [] + method alive = alive + method kill = + if Winfo.exists textw then Text.configure textw ~state:`Disabled; + if alive then begin + alive <- false; + protect close_out out; + try + if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1); + List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2]; + if not use_threads then begin + Fileevent.remove_fileinput ~fd:in1; + Fileevent.remove_fileinput ~fd:err1; + end; + if not use_sigpipe then begin + Unix.kill ~pid ~signal:Sys.sigkill; + ignore (Unix.waitpid ~mode:[] pid) + end + with _ -> () + end + method interrupt = + if alive then try + reading <- false; + if use_sigpipe then begin + ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1); + self#send " " + end else + Unix.kill ~pid ~signal:Sys.sigint + with Unix.Unix_error _ -> () + method send s = + if alive then try + output_string out s; + flush out + with Sys_error _ -> () + method private read ~fd ~len = + begin try + let buf = String.create len in + let len = Unix.read fd ~buf ~pos:0 ~len in + if len > 0 then begin + self#insert (String.sub buf ~pos:0 ~len); + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) + end; + len + with Unix.Unix_error _ -> 0 + end; + method history (dir : [`Next|`Previous]) = + if not h#empty then begin + if reading then begin + Text.delete textw ~start:(`Mark"input",[`Char 1]) + ~stop:(`Mark"insert",[]) + end else begin + reading <- true; + Text.mark_set textw ~mark:"input" + ~index:(`Mark"insert",[`Char(-1)]) + end; + self#insert (if dir = `Previous then h#previous else h#next) + end + method private lex ?(start = `Mark"insert",[`Linestart]) + ?(stop = `Mark"insert",[`Lineend]) () = + Lexical.tag textw ~start ~stop + method insert text = + let idx = Text.index textw + ~index:(`Mark"insert",[`Char(-1);`Linestart]) in + Text.insert textw ~text ~index:(`Mark"insert",[]); + self#lex ~start:(idx,[`Linestart]) (); + Text.see textw ~index:(`Mark"insert",[]) + method private keypress c = + if not reading && c > " " then begin + reading <- true; + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) + end + method private keyrelease c = if c <> "" then self#lex () + method private return = + if reading then reading <- false + else Text.mark_set textw ~mark:"input" + ~index:(`Mark"insert",[`Linestart;`Char 1]); + Text.mark_set textw ~mark:"insert" ~index:(`Mark"insert",[`Lineend]); + self#lex ~start:(`Mark"input",[`Linestart]) (); + let s = + (* input is one character before real input *) + Text.get textw ~start:(`Mark"input",[`Char 1]) + ~stop:(`Mark"insert",[]) in + h#add s; + Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n"; + Text.yview_index textw ~index:(`Mark"insert",[]); + self#send s; + self#send "\n" + method private paste ev = + if not reading then begin + reading <- true; + Text.mark_set textw ~mark:"input" + ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) + end + initializer + Lexical.init_tags textw; + let rec bindings = + [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char); + ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char); + (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *) + ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste); + ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous); + ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next); + ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous); + ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next); + ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); + ([], `Destroy, [], fun _ -> self#kill) ] + in + List.iter bindings ~f: + begin fun (modif,event,fields,action) -> + bind textw ~events:[`Modified(modif,event)] ~fields ~action + end; + bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true + ~action:(fun _ -> self#return; break()); + List.iter ~f:Unix.close [in2;out2;err2]; + if use_threads then begin + let fileinput_thread fd = + let buf = String.create 1024 in + let len = ref 0 in + try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do + Mutex.lock imutex; + Buffer.add_substring ibuffer buf 0 !len; + Mutex.unlock imutex + done with Unix.Unix_error _ -> () + in + ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread); + let rec read_buffer () = + Mutex.lock imutex; + if Buffer.length ibuffer > 0 then begin + self#insert (Str.global_replace ~!"\r\n" "\n" + (Buffer.contents ibuffer)); + Buffer.reset ibuffer; + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) + end; + Mutex.unlock imutex; + Timer.set ~ms:100 ~callback:read_buffer + in + read_buffer () + end else begin + try + List.iter [in1;err1] ~f: + begin fun fd -> + Fileevent.add_fileinput ~fd + ~callback:(fun () -> ignore (self#read ~fd ~len:1024)) + end + with _ -> () + end +end + +(* Specific use of shell, for OCamlBrowser *) + +let shells : (string * shell) list ref = ref [] + +(* Called before exiting *) +let kill_all () = + List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill); + shells := [] + +let get_all () = + let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in + shells := all; + all + +let may_exec_unix prog = + try Unix.access prog ~perm:[Unix.X_OK]; prog + with Unix.Unix_error _ -> "" + +let may_exec_win prog = + let has_ext = + List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in + if has_ext then may_exec_unix prog else + List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:"" + ~f:(fun res prog -> if res = "" then may_exec_unix prog else res) + +let may_exec = + if is_win32 then may_exec_win else may_exec_unix + +let path_sep = if is_win32 then ";" else ":" + +let warnings = ref "Al" + +let program_not_found prog = + Jg_message.info ~title:"Error" + ("Program \"" ^ prog ^ "\"\nwas not found in path") + +let protect_arg s = + if String.contains s ' ' then "\"" ^ s ^ "\"" else s + +let f ~prog ~title = + let progargs = + List.filter ~f:((<>) "") (Str.split ~!" " prog) in + if progargs = [] then () else + let prog = List.hd progargs in + let path = + try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in + let exec_path = Str.split ~!path_sep path in + let exec_path = if is_win32 then "."::exec_path else exec_path in + let progpath = + if not (Filename.is_implicit prog) then may_exec prog else + List.fold_left exec_path ~init:"" ~f: + (fun res dir -> + if res = "" then may_exec (Filename.concat dir prog) else res) in + if progpath = "" then program_not_found prog else + let tl = Jg_toplevel.titled title in + let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in + Toplevel.configure tl ~menu:menus; + let file_menu = new Jg_menu.c "File" ~parent:menus + and history_menu = new Jg_menu.c "History" ~parent:menus + and signal_menu = new Jg_menu.c "Signal" ~parent:menus in + let frame, tw, sb = Jg_text.create_with_scrollbar tl in + Text.configure tw ~background:`White; + pack [sb] ~fill:`Y ~side:`Right; + pack [tw] ~fill:`Both ~expand:true ~side:`Left; + pack [frame] ~fill:`Both ~expand:true; + let env = Array.map (Unix.environment ()) ~f: + begin fun s -> + if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s + end in + let load_path = + List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in + let load_path = + if is_win32 then List.map ~f:protect_arg load_path else load_path in + let labels = if !Clflags.classic then ["-nolabels"] else [] in + let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in + let warnings = + if List.mem "-w" progargs || !warnings = "Al" then [] + else ["-w"; !warnings] + in + let args = + Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in + let history = new history () in + let start_shell () = + let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in + shells := (title, sh) :: !shells; + sh + in + let sh = ref (start_shell ()) in + let current_dir = ref (Unix.getcwd ()) in + file_menu#add_command "Restart" ~command: + begin fun () -> + (!sh)#kill; + Text.configure tw ~state:`Normal; + Text.insert tw ~index:(`End,[]) ~text:"\n"; + Text.see tw ~index:(`End,[]); + Text.mark_set tw ~mark:"insert" ~index:(`End,[]); + sh := start_shell (); + end; + file_menu#add_command "Use..." ~command: + begin fun () -> + Fileselect.f ~title:"Use File" ~filter:"*.ml" + ~sync:true ~dir:!current_dir () + ~action:(fun l -> + if l = [] then () else + let name = Fileselect.caml_dir (List.hd l) in + current_dir := Filename.dirname name; + if Filename.check_suffix name ".ml" + then + let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in + (!sh)#insert cmd; (!sh)#send cmd) + end; + file_menu#add_command "Load..." ~command: + begin fun () -> + Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true () + ~dir:!current_dir + ~action:(fun l -> + if l = [] then () else + let name = Fileselect.caml_dir (List.hd l) in + current_dir := Filename.dirname name; + if Filename.check_suffix name ".cmo" || + Filename.check_suffix name ".cma" + then + let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in + (!sh)#insert cmd; (!sh)#send cmd) + end; + file_menu#add_command "Import path" ~command: + begin fun () -> + List.iter (List.rev !Config.load_path) ~f: + (fun dir -> + (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n")) + end; + file_menu#add_command "Close" ~command:(fun () -> destroy tl); + history_menu#add_command "Previous " ~accelerator:"M-p" + ~command:(fun () -> (!sh)#history `Previous); + history_menu#add_command "Next" ~accelerator:"M-n" + ~command:(fun () -> (!sh)#history `Next); + signal_menu#add_command "Interrupt " ~accelerator:"C-c" + ~command:(fun () -> (!sh)#interrupt); + signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/shell.mli b/ocaml-binary-annot/otherlibs/labltk/browser/shell.mli new file mode 100644 index 0000000000..ac94f43d7c --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/shell.mli @@ -0,0 +1,46 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +class ['a] history : + unit -> + object + val mutable count : int + val mutable history : 'a list + method add : 'a -> unit + method empty : bool + method next : 'a + method previous : 'a + end + +(* toplevel shell *) + +class shell : + textw:Widget.text Widget.widget -> prog:string -> + args:string array -> env:string array -> history:string history -> + object + method alive : bool + method kill : unit + method interrupt : unit + method insert : string -> unit + method send : string -> unit + method history : [`Next|`Previous] -> unit + end + +val kill_all : unit -> unit +val get_all : unit -> (string * shell) list +val warnings : string ref + +val f : prog:string -> title:string -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.ml b/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.ml new file mode 100644 index 0000000000..d5347ef53b --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.ml @@ -0,0 +1,188 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open Tk +open Parsetree +open Location +open Jg_tk +open Mytypes + +(* Optionally preprocess a source file *) + +let preprocess ~pp ~ext text = + let sourcefile = Filename.temp_file "caml" ext in + begin try + let oc = open_out_bin sourcefile in + output_string oc text; + flush oc; + close_out oc + with _ -> + failwith "Preprocessing error" + end; + let tmpfile = Filename.temp_file "camlpp" ext in + let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in + if Ccomp.command comm <> 0 then begin + Sys.remove sourcefile; + Sys.remove tmpfile; + failwith "Preprocessing error" + end; + Sys.remove sourcefile; + tmpfile + +exception Outdated_version + +let parse_pp ~parse ~wrap ~ext text = + Location.input_name := ""; + match !Clflags.preprocessor with + None -> + let buffer = Lexing.from_string text in + Location.init buffer ""; + parse buffer + | Some pp -> + let tmpfile = preprocess ~pp ~ext text in + let ast_magic = + if ext = ".ml" then Config.ast_impl_magic_number + else Config.ast_intf_magic_number in + let ic = open_in_bin tmpfile in + let ast = + try + let buffer = String.create (String.length ast_magic) in + really_input ic buffer 0 (String.length ast_magic); + if buffer = ast_magic then begin + ignore (input_value ic); + wrap (input_value ic) + end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then + raise Outdated_version + else + raise Exit + with + Outdated_version -> + close_in ic; + Sys.remove tmpfile; + failwith "Ocaml and preprocessor have incompatible versions" + | _ -> + seek_in ic 0; + let buffer = Lexing.from_channel ic in + Location.init buffer ""; + parse buffer + in + close_in ic; + Sys.remove tmpfile; + ast + +let nowarnings = ref false + +let f txt = + let error_messages = ref [] in + let text = Jg_text.get_all txt.tw + and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in + let tl, ew, end_message = + Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in + Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend; + txt.structure <- []; + txt.type_info <- []; + txt.signature <- []; + txt.psignature <- []; + ignore (Stypes.get_info ()); + Clflags.annotations := true; + + begin try + + if Filename.check_suffix txt.name ".mli" then + let psign = parse_pp text ~ext:".mli" + ~parse:Parse.interface ~wrap:(fun x -> x) in + txt.psignature <- psign; + txt.signature <- Typemod.transl_signature !env psign + + else (* others are interpreted as .ml *) + + let psl = parse_pp text ~ext:".ml" + ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in + List.iter psl ~f: + begin function + Ptop_def pstr -> + let str, sign, env' = Typemod.type_structure !env pstr Location.none in + txt.structure <- txt.structure @ str; + txt.signature <- txt.signature @ sign; + env := env' + | Ptop_dir _ -> () + end; + txt.type_info <- Stypes.get_info (); + + with + Lexer.Error _ | Syntaxerr.Error _ + | Typecore.Error _ | Typemod.Error _ + | Typeclass.Error _ | Typedecl.Error _ + | Typetexp.Error _ | Includemod.Error _ + | Env.Error _ | Ctype.Tags _ | Failure _ as exn -> + txt.type_info <- Stypes.get_info (); + let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in + error_messages := et :: !error_messages; + let range = match exn with + Lexer.Error (err, l) -> + Lexer.report_error Format.std_formatter err; l + | Syntaxerr.Error err -> + Syntaxerr.report_error Format.std_formatter err; + begin match err with + Syntaxerr.Unclosed(l,_,_,_) -> l + | Syntaxerr.Applicative_path l -> l + | Syntaxerr.Other l -> l + end + | Typecore.Error (l,err) -> + Typecore.report_error Format.std_formatter err; l + | Typeclass.Error (l,err) -> + Typeclass.report_error Format.std_formatter err; l + | Typedecl.Error (l, err) -> + Typedecl.report_error Format.std_formatter err; l + | Typemod.Error (l,err) -> + Typemod.report_error Format.std_formatter err; l + | Typetexp.Error (l,err) -> + Typetexp.report_error Format.std_formatter err; l + | Includemod.Error errl -> + Includemod.report_error Format.std_formatter errl; Location.none + | Env.Error err -> + Env.report_error Format.std_formatter err; Location.none + | Ctype.Tags(l, l') -> + Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; + Location.none + | Failure s -> + Format.printf "%s.@." s; Location.none + | _ -> assert false + in + end_message (); + let s = range.loc_start.Lexing.pos_cnum in + let e = range.loc_end.Lexing.pos_cnum in + if s < e then + Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error" + end; + end_message (); + if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0) + then destroy tl + else begin + error_messages := tl :: !error_messages; + Text.configure ew ~state:`Disabled; + bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)] + ~action:(fun _ -> + try + let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in + let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in + let n = int_of_string s in + Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert"; + Text.see txt.tw ~index:(`Mark "insert", []) + with _ -> ()) + end; + !error_messages diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.mli b/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.mli new file mode 100644 index 0000000000..d61fce62e3 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/typecheck.mli @@ -0,0 +1,23 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open Widget +open Mytypes + +val nowarnings : bool ref + +val f : edit_window -> any widget list + (* Typechecks the window as much as possible *) diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/useunix.ml b/ocaml-binary-annot/otherlibs/labltk/browser/useunix.ml new file mode 100644 index 0000000000..666f866f02 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/useunix.ml @@ -0,0 +1,69 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +open StdLabels +open UnixLabels + +let get_files_in_directory dir = + let len = String.length dir in + let dir = + if len > 0 && Sys.os_type = "Win32" && + (dir.[len-1] = '/' || dir.[len-1] = '\\') + then String.sub dir ~pos:0 ~len:(len-1) + else dir + in match + try Some(opendir dir) with Unix_error _ -> None + with + None -> [] + | Some dirh -> + let rec get_them l = + match + try Some(readdir dirh) with _ -> None + with + | Some x -> + get_them (x::l) + | None -> + closedir dirh; l + in + List.sort ~cmp:compare (get_them []) + +let is_directory name = + try + (stat name).st_kind = S_DIR + with _ -> false + +let concat dir name = + let len = String.length dir in + if len = 0 then name else + if dir.[len-1] = '/' then dir ^ name + else dir ^ "/" ^ name + +let get_directories_in_files ~path = + List.filter ~f:(fun x -> is_directory (concat path x)) + +(************************************************** Subshell call *) +let subshell ~cmd = + let rc = open_process_in cmd in + let rec it l = + match + try Some(input_line rc) with _ -> None + with + Some x -> it (x::l) + | None -> List.rev l + in + let answer = it [] in + ignore (close_process_in rc); + answer diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/useunix.mli b/ocaml-binary-annot/otherlibs/labltk/browser/useunix.mli new file mode 100644 index 0000000000..2850c0d2da --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/useunix.mli @@ -0,0 +1,23 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +(* Unix utilities *) + +val get_files_in_directory : string -> string list +val is_directory : string -> bool +val concat : string -> string -> string +val get_directories_in_files : path:string -> string list -> string list +val subshell : cmd:string -> string list diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/viewer.ml b/ocaml-binary-annot/otherlibs/labltk/browser/viewer.ml new file mode 100644 index 0000000000..fef3cbe104 --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/viewer.ml @@ -0,0 +1,631 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +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 [Tsig_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 + [Tsig_exception (Ident.create name, 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 + Tsig_value (id, _) -> Lident (Ident.name id), Pvalue + | Tsig_type (id, _, _) -> Lident (Ident.name id), Ptype + | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor + | Tsig_module (id, _, _) -> Lident (Ident.name id), Pmodule + | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype + | Tsig_class (id, _, _) -> Lident (Ident.name id), Pclass + | Tsig_cltype (id, _, _) -> Lident (Ident.name id), Pcltype + +let view_defined ~env ?(show_all=false) modlid = + try match lookup_module modlid env with path, Tmty_signature sign -> + let rec iter_sign sign idents = + match sign with + [] -> List.rev idents + | decl :: rem -> + let rem = match decl, rem with + Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem + | Tsig_cltype _, 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 () + + +(* 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 diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/viewer.mli b/ocaml-binary-annot/otherlibs/labltk/browser/viewer.mli new file mode 100644 index 0000000000..d8bec671df --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/viewer.mli @@ -0,0 +1,31 @@ +(*************************************************************************) +(* *) +(* Objective Caml 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$ *) + +(* Module viewer *) +open Widget + +val search_symbol : unit -> unit + (* search a symbol in all modules in the path *) + +val f : ?dir:string -> ?on:toplevel widget -> unit -> unit + (* open then module viewer *) +val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit + (* one-box viewer *) + +val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit + (* displays a signature, found in environment *) + +val close_all_views : unit -> unit diff --git a/ocaml-binary-annot/otherlibs/labltk/browser/winmain.c b/ocaml-binary-annot/otherlibs/labltk/browser/winmain.c new file mode 100644 index 0000000000..dd9146fcce --- /dev/null +++ b/ocaml-binary-annot/otherlibs/labltk/browser/winmain.c @@ -0,0 +1,26 @@ +/* $Id$ */ + +#include <windows.h> +#include <mlvalues.h> +#include <callback.h> +#include <sys.h> + +/*CAMLextern int __argc; */ +/* CAMLextern char **__argv; */ +/* CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); */ +/* extern void caml_main (char **); */ + +int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, + LPSTR lpCmdLine, int nCmdShow) +{ + char exe_name[1024]; + char * argv[2]; + + GetModuleFileName(NULL, exe_name, sizeof(exe_name) - 1); + exe_name[sizeof(exe_name) - 1] = '0'; + argv[0] = exe_name; + argv[1] = NULL; + caml_main(argv); + sys_exit(Val_int(0)); + return 0; +} |