diff options
Diffstat (limited to 'otherlibs/labltk/browser')
45 files changed, 4107 insertions, 0 deletions
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile new file mode 100644 index 000000000..e739dda90 --- /dev/null +++ b/otherlibs/labltk/browser/Makefile @@ -0,0 +1,48 @@ +include ../Makefile.common + +LABLTKLIB=-I ../lib -I ../support +OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str +OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing +INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) +CLIBS=-L../support -llabltk41 -L$(OTHERS)/str -lstr -L$(OTHERS)/unix -lunix + +OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ + fileselect.cmo searchid.cmo searchpos.cmo shell.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 + +.ml.cmo: + $(LABLCOMP) $(INCLUDES) $< + +.mli.cmi: + $(LABLCOMP) $(INCLUDES) $< + +all: lablbrowser + +lablbrowser: $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) + $(LABLC) -custom -o lablbrowser $(INCLUDES) \ + $(TOPDIR)/toplevel/toplevellib.cma \ + unix.cma str.cma tk41.cma jglib.cma $(OBJ) \ + -cclib "$(CLIBS)" $(TKLINKOPT) + +jglib.cma: $(JG) + $(LABLCOMP) -a -o jglib.cma $(JG) + +install: + if test -f lablbrowser; then : ; cp lablbrowser $(BINDIR); fi + +clean: + rm -f *.cm? lablbrowser *~ *.orig + +depend: + $(LABLDEP) *.ml *.mli > .depend + +include .depend diff --git a/otherlibs/labltk/browser/README b/otherlibs/labltk/browser/README new file mode 100644 index 000000000..ca28b5132 --- /dev/null +++ b/otherlibs/labltk/browser/README @@ -0,0 +1,155 @@ + + Installing and Using LablBrowser + + +INSTALLATION + If you installed it with LablTk, nothing to do. + Otherwise, the source is in labltk41/browser. + After installing LablTk, simply do "make" and "make install". + The name of the command is `lablbrowser'. + +USE + LablBrowser 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 O'Labl + 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 OLABLDIR. You may also extend the + initial load path (only standard library by default) by using the + -I command line option. + +a) Viewer + It displays the list of modules in the load path. Click on one to + start your trip. + + The entry line at the bottom 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 + during your trip (every click creates one...) By double-clicking on + it you will quit the browser. + + File - Open and File - Editor give access to the editor. + + File - Shell opens an O'Labl shell. + + 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. + +b) Module walking + Each module is displayed in its own window. + + At the top, a scrollable list of the defined identifiers. If you + click on one, this will either create a new window (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. + * Show all displays the signature of the whole module. + * 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. + +c) 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. + +d) 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 LablBrowser 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 lablbrowser 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>
\ No newline at end of file diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml new file mode 100644 index 000000000..57354a22c --- /dev/null +++ b/otherlibs/labltk/browser/editor.ml @@ -0,0 +1,543 @@ +(* $Id$ *) + +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 () = + let tl = Jg_toplevel.titled "Compiler" in + Wm.transient_set tl master:Widget.default_toplevel; + let mk_chkbutton :text :ref = + let variable = Textvariable.create on:tl () in + if !ref then Textvariable.set variable to:"1"; + Checkbutton.create tl :text :variable, + (fun () -> ref := Textvariable.get variable = "1") + in + let chkbuttons, setflags = List.split + (List.map fun:(fun (text, ref) -> mk_chkbutton :text :ref) + ["No pervasives", Clflags.nopervasives; + "No warnings", Typecheck.nowarnings; + "Classic", Clflags.classic; + "Lex on load", lex_on_load; + "Type on load", type_on_load]) + in + let buttons = Frame.create tl in + let ok = Button.create buttons text:"Ok" padx:(`Pix 20) command: + begin fun () -> + List.iter fun:(fun f -> f ()) setflags; + destroy tl + end + and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel" + in + pack chkbuttons side:`Top anchor:`W; + pack [ok;cancel] side:`Left fill:`X expand:true; + pack [buttons] side:`Bottom fill:`X + +let rec exclude elt:txt = function + [] -> [] + | x :: l -> if txt.number = x.number then l else x :: exclude elt:txt l + +let goto_line tw = + let tl = Jg_toplevel.titled "Go to" in + Wm.transient_set tl master:Widget.default_toplevel; + 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] fun: + 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 = Sort.list shells order:(fun (x,_) (y,_) -> x <= y) 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 key:name shells); + destroy tl + with Not_found -> txt.shell <- None; destroy tl + end + in + Listbox.insert box index:`End texts:(List.map fun:fst shells); + Listbox.configure box height:(List.length shells); + bind box events:[[],`KeyPressDetail"Return"] + action:(`Setbreakable([], fun _ -> Button.invoke ok; break ())); + bind box events:[[`Double],`ButtonPressDetail 1] + action:(`Setbreakable([`MouseX;`MouseY], 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 + +let send_region 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 + sh#send (Text.get txt.tw start:(i1,[]) end:(i2,[])); + sh#send";;\n" + with _ -> () + +let search_pos_window txt :x :y = + if txt.structure = [] & 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 in:text + c in + try if txt.structure <> [] then + try Searchpos.search_pos_structure txt.structure :pos + with Searchpos.Found_str (kind, env) -> + Searchpos.view_type kind :env + else + try Searchpos.search_pos_signature + txt.psignature :pos env:!Searchid.start_env; + () + with Searchpos.Found_sig (kind, lid, env) -> + Searchpos.view_decl lid :kind :env + with Not_found -> () + +let search_pos_menu txt :x :y = + if txt.structure = [] & 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 in:text + c in + try if txt.structure <> [] then + try Searchpos.search_pos_structure txt.structure :pos + with Searchpos.Found_str (kind, env) -> + 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 + else + try Searchpos.search_pos_signature + txt.psignature :pos env:!Searchid.start_env; + () + with Searchpos.Found_sig (kind, lid, env) -> + 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 + 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]) end:(ins,[]) in + Str.string_match reg line pos:0; + if Str.match_end () < c then + Text.insert tw index:(ins,[]) text:"\t" + else let indent = + if l <= 1 then 2 else + let previous = + Text.get tw start:(ins,[`Line(-1);`Linestart]) + end:(ins,[`Line(-1);`Lineend]) in + Str.string_match reg previous pos:0; + let previous = Str.matched_string previous in + let width = string_width line + and 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 len: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 + val label = + Checkbutton.create 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 reset_window_menu = + Menu.delete window_menu#menu first:(`Num 0) last:`End; + List.iter + (Sort.list windows order: + (fun w1 w2 -> Filename.basename w1.name < Filename.basename w2.name)) + fun: + 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_edit txt = + if windows <> [] then + Pack.forget [(List.hd windows).frame]; + windows <- txt :: exclude elt:txt windows; + self#reset_window_menu; + current_tw <- txt.tw; + Checkbutton.configure label text:(Filename.basename txt.name) + variable:txt.modified; + Textvariable.set vwindow to: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 = []; signature = []; psignature = [] } + in + let control c = Char.chr (Char.code c - 96) in + bind tw events:[[`Alt], `KeyPress] action:(`Set ([], fun _ -> ())); + bind tw events:[[], `KeyPress] + action:(`Set ([`Char], fun ev -> + if ev.ev_Char <> "" & + (ev.ev_Char.[0] >= ' ' or + List.mem elt:ev.ev_Char.[0] + (List.map fun:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) + then Textvariable.set txt.modified to:"modified")); + bind tw events:[[],`KeyPressDetail"Tab"] + action:(`Setbreakable ([], fun _ -> + indent_line tw; + Textvariable.set txt.modified to:"modified"; + break ())); + bind tw events:[[`Control],`KeyPressDetail"k"] + action:(`Set ([], fun _ -> + let text = + Text.get tw start:(`Mark"insert",[]) end:(`Mark"insert",[`Lineend]) + in Str.string_match (Str.regexp "[ \t]*") text pos:0; + if Str.match_end () <> String.length text then begin + Clipboard.clear (); + Clipboard.append data:text () + end)); + bind tw events:[[], `KeyRelease] + action:(`Set ([`Char], fun ev -> + if ev.ev_Char <> "" then + Lexical.tag tw start:(`Mark"insert", [`Linestart]) + end:(`Mark"insert", [`Lineend]))); + bind tw events:[[], `Motion] action:(`Set ([], fun _ -> Focus.set tw)); + bind tw events:[[], `ButtonPressDetail 2] + action:(`Set ([], fun _ -> + Textvariable.set txt.modified to:"modified"; + Lexical.tag txt.tw start:(`Mark"insert", [`Linestart]) + end:(`Mark"insert", [`Lineend]))); + bind tw events:[[`Double], `ButtonPressDetail 1] + action:(`Set ([`MouseX;`MouseY], fun ev -> + search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY)); + bind tw events:[[], `ButtonPressDetail 3] + action:(`Set ([`MouseX;`MouseY], 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; + Checkbutton.deselect label; + Lexical.init_tags txt.tw + + method clear_errors () = + Text.tag_remove current_tw tag:"error" start:tstart end:tend; + List.iter error_messages + fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); + error_messages <- [] + + method typecheck () = + self#clear_errors (); + error_messages <- Typecheck.f (List.hd windows) + + method lex () = + Text.tag_remove current_tw tag:"error" start:tstart end:tend; + Lexical.tag current_tw + + 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 + Sys.rename old:name new:(name ^ "~") + else begin match + Jg_message.ask master:top title:"Save" + ("File `" ^ name ^ "' exists. Overwrite it?") + with `yes -> () | `no | `cancel -> raise Exit + end; + let file = open_out name in + let text = Text.get txt.tw start:tstart end:(tposend 1) in + output_string text to:file; + close_out file; + Checkbutton.configure label text:(Filename.basename name); + Checkbutton.deselect label; + txt.name <- name + with + Sys_error _ | 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 pred:(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; + Checkbutton.deselect label; + (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 buffer = String.create len:4096 in + Text.delete tw start:tstart end:tend; + while + len := input file :buffer pos:0 len:4096; + !len > 0 + do + Jg_text.output tw :buffer pos:0 len:!len + done; + close_in file; + Text.mark_set tw mark:"insert" :index; + Text.see tw :index; + if Filename.check_suffix name suff:".ml" or + Filename.check_suffix name suff:".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 elt: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 () = + try List.iter windows + fun:(fun txt -> + if Textvariable.get txt.modified = "modified" then + match Jg_message.ask master:top title:"Quit" + ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") + with `yes -> self#save_text txt + | `no -> () + | `cancel -> raise Exit); + bind top events:[[],`Destroy] action:`Remove; + destroy top; break () + with Exit -> break () + + 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); + Text.yview_index current_tw + index:(`Linechar(1,0),[`Char pos; `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], "x", (fun () -> send_region (List.hd windows)); + [`Alt], "l", self#lex; + [`Alt], "t", self#typecheck ] + fun:begin fun (modi,key,act) -> + bind top events:[modi, `KeyPressDetail key] + action:(`Setbreakable ([], fun _ -> act (); break ())) + end; + + bind top events:[[],`Destroy] + action:(`Setbreakable + ([`Widget], fun ev -> + if Widget.name ev.ev_Widget = Widget.name top + then self#quit ())); + + (* 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; + 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_region (List.hd windows)); + edit_menu#add_command "Select shell..." + command:(fun () -> select_shell (List.hd windows)); + + (* Compiler menu *) + compiler_menu#add_command "Preferences..." + command:compiler_preferences; + 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 + end; + + (* Modules *) + module_menu#add_command "Path editor..." + command:(fun () -> Setpath.f 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; + + (* pack everything *) + pack (List.map fun:(fun m -> coe m#button) + [file_menu; edit_menu; compiler_menu; module_menu; window_menu] + @ [coe label]) + side:`Left ipadx:(`Pix 5) anchor:`W; + pack [menus] before:(List.hd windows).frame side:`Top fill:`X +end + +(* The main function starts here ! *) + +let already_open : editor option ref = ref None + +let editor ?:file ?:pos{= 0} () = + + if match !already_open with None -> false + | Some ed -> + try ed#reopen :file :pos; true + with Protocol.TkError _ -> already_open := None; false + then () else + let top = Jg_toplevel.titled "Editor" in + let menus = Frame.create top name:"menubar" in + let ed = new editor :top :menus in + already_open := Some 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 () diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli new file mode 100644 index 000000000..3515dc148 --- /dev/null +++ b/otherlibs/labltk/browser/editor.mli @@ -0,0 +1,6 @@ +(* $Id$ *) + +open Widget + +val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit + (* open the file editor *) diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml new file mode 100644 index 000000000..f59140b2e --- /dev/null +++ b/otherlibs/labltk/browser/fileselect.ml @@ -0,0 +1,282 @@ +(* $Id$ *) + +(* file selection box *) + +open Useunix +open Str +open Filename + +open Tk + +(**** Memoized rexgexp *) + +let regexp = (new Jg_memo.c fun:Str.regexp)#get + +(************************************************************ Path name *) + +let parse_filter src = + (* replace // by / *) + let s = global_replace (regexp "/+") with:"/" src in + (* replace /./ by / *) + let s = global_replace (regexp "/\./") with:"/" s in + (* replace hoge/../ by "" *) + let s = global_replace + (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./") with:"" s in + (* replace hoge/..$ by *) + let s = global_replace + (regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$") with:"" s in + (* replace ^/../../ by / *) + let s = global_replace (regexp "^\(/\.\.\)+/") with:"/" s in + if string_match (regexp "^\([^\*?[]*/\)\(.*\)") s pos:0 then + let dirs = matched_group 1 s + and ptrn = matched_group 2 s + in + dirs, ptrn + else "", s + +let fixpoint fun:f v = + let v1 = ref v and v2 = ref (f v) in + while !v1 <> !v2 do v1 := !v2; v2 := f !v2 done; + !v1 + +let unix_regexp s = + let s = Str.global_replace (regexp "[$^.+]") with:"\\\\\\0" s in + let s = Str.global_replace (regexp "\\*") with:".*" s in + let s = Str.global_replace (regexp "\\?") with:".?" s in + let s = + fixpoint s fun:(fun s -> + Str.global_replace (regexp "\\({.*\\),\\(.*}\\)") s + with:"\\1\\|\\2") in + let s = + Str.global_replace (regexp "{\\(.*\\)}") with:"\\(\\1\\)" s in + Str.regexp s + +let exact_match s :regexp = + Str.string_match regexp s pos: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 pred:(exact_match :regexp) + +(* +let ls :dir :pattern = + subshell cmd:("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") +*) + +(********************************************* 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 dir 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 to:deffilter; + + let frm = Frame.create tl borderwidth:(`Pix 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:(`Pix 1) relief:`Raised in + + let configure :filter = + let filter = + if string_match (regexp "^/.*") filter pos:0 + then filter + else !current_dir ^ "/" ^ 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 acc:[] fun: + begin fun :acc dir -> + let files = ls :dir :pattern in + Sort.merge order:(<) files + (List.fold_left files :acc + fun:(fun :acc name -> List2.exclude elt:name acc)) + end + else + List.fold_left directories acc:(ls :dir :pattern) + fun:(fun :acc dir -> List2.exclude elt:dir acc) + in + Textvariable.set filter_var to:filter; + Textvariable.set selection_var to:(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 acc:[] fun: + begin fun name :acc -> + if name <> "" & name.[0] = '/' then name :: acc else + try search_in_path :name :: acc with Not_found -> acc + end + else + List.map l fun: + begin fun x -> + if x <> "" & x.[0] = '/' then x + else !current_dir ^ "/" ^ x + end + in + if sync then + begin + selected_files := l; + Textvariable.set sync_var to:"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] + action:(`Extend ([], 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) fun: + 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 [Textvariable.get selection_var] + 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:(`Set ([], 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] + action:(`Set ([`MouseY], 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 to:(search_in_path :name) + with Not_found -> () + else Textvariable.set selection_var to:(!current_dir ^ "/" ^ name))); + + Jg_box.add_completion directory_listbox action: + begin fun index -> + let filter = + !current_dir ^ "/" ^ + (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/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli new file mode 100644 index 000000000..789cd17e2 --- /dev/null +++ b/otherlibs/labltk/browser/fileselect.mli @@ -0,0 +1,22 @@ +(* $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 *) diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml new file mode 100644 index 000000000..df0bf80d9 --- /dev/null +++ b/otherlibs/labltk/browser/jg_bind.ml @@ -0,0 +1,15 @@ +(* $Id$ *) + +open Tk + +let enter_focus w = + bind w events:[[], `Enter] action:(`Set ([], 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:(`Set ([], fun _ -> destroy tl)) + +let return_invoke w :button = + bind w events:[[], `KeyPressDetail "Return"] + action:(`Set ([], fun _ -> Button.invoke button)) diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli new file mode 100644 index 000000000..3889f20fd --- /dev/null +++ b/otherlibs/labltk/browser/jg_bind.mli @@ -0,0 +1,7 @@ +(* $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/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml new file mode 100644 index 000000000..e7add1139 --- /dev/null +++ b/otherlibs/labltk/browser/jg_box.ml @@ -0,0 +1,57 @@ +(* $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 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] + action:(`Set([`Char], 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)))); + + begin match action with + Some action -> + bind lb events:[[], `KeyPressDetail "Return"] + action:(`Set ([], fun _ -> action `Active)); + bind lb events:[[`Double], `ButtonPressDetail 1] + action:(`Setbreakable ([`MouseY], fun ev -> + action (Listbox.nearest lb y:ev.ev_MouseY); break ())) + | None -> () + end; + + recenter lb index:(`Num 0) (* so that first item is active *) diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml new file mode 100644 index 000000000..64f7d6027 --- /dev/null +++ b/otherlibs/labltk/browser/jg_button.ml @@ -0,0 +1,11 @@ +(* $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/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml new file mode 100644 index 000000000..8836af09f --- /dev/null +++ b/otherlibs/labltk/browser/jg_completion.ml @@ -0,0 +1,39 @@ +(* $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 pos:current) prefix ?:nocase + do + current <- current + 1 + done; + current + method current = current + method get_current = List.nth texts pos: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/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli new file mode 100644 index 000000000..427e74455 --- /dev/null +++ b/otherlibs/labltk/browser/jg_completion.mli @@ -0,0 +1,9 @@ +(* $Id$ *) + +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/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml new file mode 100644 index 000000000..a5bef0c60 --- /dev/null +++ b/otherlibs/labltk/browser/jg_config.ml @@ -0,0 +1,18 @@ +(* $Id$ *) + +let init () = + let font = + let font = + Option.get Widget.default_toplevel name:"variableFont" class:"Font" in + if font = "" then "variable" else font + in + List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] + fun:(fun cl -> Option.add path:("*" ^ cl ^ ".font") font); + 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" class:"Foreground" in + if foreground = "" then + Option.add path:"*disabledForeground" "black" diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli new file mode 100644 index 000000000..183035108 --- /dev/null +++ b/otherlibs/labltk/browser/jg_config.mli @@ -0,0 +1,3 @@ +(* $Id$ *) + +val init: unit -> unit diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml new file mode 100644 index 000000000..b961d1a96 --- /dev/null +++ b/otherlibs/labltk/browser/jg_entry.ml @@ -0,0 +1,13 @@ +(* $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:(`Set ([], fun _ -> command (Entry.get ew))) + | None -> () + end; + ew diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml new file mode 100644 index 000000000..43a5eb15b --- /dev/null +++ b/otherlibs/labltk/browser/jg_memo.ml @@ -0,0 +1,17 @@ +(* $Id$ *) + +class ['a,'b] c fun:(f : 'a -> 'b) = object + val hash = Hashtbl.create 7 + method get key = + try Hashtbl.find hash :key + with Not_found -> + let data = f key in + Hashtbl.add hash :key :data; + data + method clear = Hashtbl.clear hash + method reget key = + Hashtbl.remove :key hash; + let data = f key in + Hashtbl.add hash :key :data; + data +end diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli new file mode 100644 index 000000000..8d08111b1 --- /dev/null +++ b/otherlibs/labltk/browser/jg_memo.mli @@ -0,0 +1,8 @@ +(* $Id$ *) + +class ['a, 'b] c : fun:('a -> 'b) -> object + val hash : ('a, 'b) Hashtbl.t + method clear : unit + method get : 'a -> 'b + method reget : 'a -> 'b +end diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml new file mode 100644 index 000000000..ef18c1f1f --- /dev/null +++ b/otherlibs/labltk/browser/jg_menu.ml @@ -0,0 +1,28 @@ +(* $Id$ *) + +open Tk + +class c :parent ?underline:n{=0} text = object (self) + val pair = + let button = + Menubutton.create parent :text underline:n in + let menu = Menu.create button in + Menubutton.configure button :menu; + button, menu + method button = fst pair + method menu = snd pair + 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:n{=0} ?:accelerator ?:activebackground + ?:activeforeground ?:background ?:bitmap ?:command ?:font ?:foreground + ?:image ?:state label = + Menu.add_command (self#menu) :label underline:n ?:accelerator + ?:activebackground ?:activeforeground ?:background ?:bitmap + ?:command ?:font ?:foreground ?:image ?:state +end diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml new file mode 100644 index 000000000..54548a72f --- /dev/null +++ b/otherlibs/labltk/browser/jg_message.ml @@ -0,0 +1,82 @@ +(* $Id$ *) + +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 ?:width{=60} ?:maxheight{=10} ?:minheight{=0} () = + let tl, frame = + match on with + Some frame -> 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.print_flush (); + Format.set_margin (width - 2); + let fof,fff = Format.get_formatter_output_functions () in + Format.set_formatter_output_functions + out:(Jg_text.output tw) flush:(fun () -> ()); + tl, tw, + begin fun () -> + Format.print_flush (); + Format.set_formatter_output_functions out:fof flush: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 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:(`Pix 20) pady:(`Pix 10) + width:(`Pix 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:"Yes" + command:(fun () -> r := `yes; destroy tl) + and refuse = Button.create fw text:"No" + command:(fun () -> r := `no; destroy tl) + and cancel = Jg_button.create_destroyer tl parent:fw text:"Cancel" + in + bind tl events:[[],`Destroy] + action:(`Extend([],fun _ -> Textvariable.set sync to:"1")); + pack [accept; refuse; cancel] 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 diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli new file mode 100644 index 000000000..8862702c6 --- /dev/null +++ b/otherlibs/labltk/browser/jg_message.mli @@ -0,0 +1,13 @@ +(* $Id$ *) + +val formatted : + title:string -> + ?on:Widget.frame Widget.widget -> + ?width:int -> + ?maxheight:int -> + ?minheight:int -> + unit -> Widget.any Widget.widget * Widget.text Widget.widget * (unit -> unit) + +val ask : + title:string -> ?master:Widget.toplevel Widget.widget -> + string -> [`cancel|`no|`yes] diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml new file mode 100644 index 000000000..f05524e11 --- /dev/null +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -0,0 +1,169 @@ +(* $Id$ *) + +let rec gen_list fun:f :len = + if len = 0 then [] else f () :: gen_list fun: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 fun:(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 fun: + begin fun () -> + Listbox.create parent :height ?:width + highlightthickness:(`Pix 0) + borderwidth:(`Pix 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 pos:(current mod cols) + and index = `Num (current / cols) in + List.iter boxes fun: + 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 fun:(Listbox.yview scroll:(`Moveto first)) + method init = + let textl = split len:cols texts in + List.iter2 boxes textl fun: + 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) ] + fun: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 fun: + begin fun box -> + let b = !i in + bind box :events + action:(`Setbreakable ([`MouseX;`MouseY], 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 fun: + begin fun box -> + let b = !i in + bind box :events + action:(`Setbreakable ([`Char], 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 fun:(Listbox.yview :scroll)) in + List.iter boxes + fun:(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/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli new file mode 100644 index 000000000..ea6539607 --- /dev/null +++ b/otherlibs/labltk/browser/jg_multibox.mli @@ -0,0 +1,23 @@ +(* $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.modifier list * Tk.xEvent) list -> + action:(Tk.eventInfo -> index:int -> unit) -> unit + method bind_kbd : + events:(Tk.modifier list * Tk.xEvent) 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/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml new file mode 100644 index 000000000..18e4b8318 --- /dev/null +++ b/otherlibs/labltk/browser/jg_text.ml @@ -0,0 +1,88 @@ +(* $Id$ *) + +open Tk +open Jg_tk + +let get_all tw = Text.get tw start:tstart end:(tposend 1) + +let tag_and_see tw :tag :start end:e = + Text.tag_remove tw start:(tpos 0) end:tend :tag; + Text.tag_add tw :start end:e :tag; + try + Text.see tw index:(`Tagfirst tag, []); + Text.mark_set tw mark:"insert" index:(`Tagfirst tag, []) + with Protocol.TkError _ -> () + +let output tw :buffer :pos :len = + Text.insert tw index:tend text:(String.sub buffer :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:Widget.default_toplevel; + 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 + 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,[]) + end:(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 to:"forward"; + Textvariable.set mode to:"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/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli new file mode 100644 index 000000000..6dd60e7ff --- /dev/null +++ b/otherlibs/labltk/browser/jg_text.mli @@ -0,0 +1,14 @@ +(* $Id$ *) + +open Widget + +val get_all : text widget -> string +val tag_and_see : + text widget -> + tag:Tk.textTag -> start:Tk.textIndex -> end:Tk.textIndex -> unit +val output : text widget -> buffer: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/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml new file mode 100644 index 000000000..da5f4930c --- /dev/null +++ b/otherlibs/labltk/browser/jg_tk.ml @@ -0,0 +1,8 @@ +(* $Id$ *) + +open Tk + +let tpos x : textIndex = `Linechar (1,0), [`Char x] +and tposend x : textIndex = `End, [`Char (-x)] +let tstart : textIndex = `Linechar (1,0), [] +and tend : textIndex = `End, [] diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml new file mode 100644 index 000000000..e3ee0a893 --- /dev/null +++ b/otherlibs/labltk/browser/jg_toplevel.ml @@ -0,0 +1,10 @@ +(* $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 name:iconname; + tl diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml new file mode 100644 index 000000000..7c10b37b9 --- /dev/null +++ b/otherlibs/labltk/browser/lexical.ml @@ -0,0 +1,111 @@ +(* $Id$ *) + +open Tk +open Jg_tk +open Parser + +let tags = + ["control"; "define"; "structure"; "char"; + "infix"; "label"; "uident"] +and colors = + ["blue"; "forestgreen"; "purple"; "gray40"; + "indianred4"; "brown"; "midnightblue"] + +let init_tags tw = + List.iter2 tags colors fun: + 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} ?end:pend{=tend} tw = + let tpos c = (Text.index tw index:start, [`Char c]) in + let text = Text.get tw :start end:pend in + let buffer = Lexing.from_string text in + List.iter tags + fun:(fun tag -> Text.tag_remove tw :start end:pend :tag); + try + while true do + let tag = + match Lexer.token buffer 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 + | PARSER + | PRIVATE + | REC + | TYPE + | VAL + | VIRTUAL + -> "define" + | BEGIN + | END + | INCLUDE + | OBJECT + | OPEN + | SIG + | STRUCT + -> "structure" + | CHAR _ + | STRING _ + -> "char" + | BACKQUOTE + | INFIXOP1 _ + | INFIXOP2 _ + | INFIXOP3 _ + | INFIXOP4 _ + | PREFIXOP _ + | QUESTION2 + | SHARP + -> "infix" + | LABEL _ + | QUESTION + -> "label" + | UIDENT _ -> "uident" + | EOF -> raise End_of_file + | _ -> "" + in + if tag <> "" then + Text.tag_add tw :tag + start:(tpos (Lexing.lexeme_start buffer)) + end:(tpos (Lexing.lexeme_end buffer)) + done + with + End_of_file -> () + | Lexer.Error (err, s, e) -> () diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli new file mode 100644 index 000000000..d9711f5fc --- /dev/null +++ b/otherlibs/labltk/browser/lexical.mli @@ -0,0 +1,6 @@ +(* $Id$ *) + +open Widget + +val init_tags : text widget -> unit +val tag : ?start:Tk.textIndex -> ?end:Tk.textIndex -> text widget -> unit diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml new file mode 100644 index 000000000..6ab8b7863 --- /dev/null +++ b/otherlibs/labltk/browser/list2.ml @@ -0,0 +1,7 @@ +(* $Id$ *) + +let exclude elt:x l = List.filter l pred:((<>) x) + +let rec flat_map fun:f = function + [] -> [] + | x :: l -> f x @ flat_map fun:f l diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml new file mode 100644 index 000000000..f38c8ff78 --- /dev/null +++ b/otherlibs/labltk/browser/main.ml @@ -0,0 +1,34 @@ +(* $Id$ *) + +open Tk + +let _ = + let path = ref [] in + Arg.parse + keywords:[ "-I", Arg.String (fun s -> path := s :: !path), + "<dir> Add <dir> to the list of include directories" ] + others:(fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) + errmsg:"lablbrowser :"; + Config.load_path := List.rev !path @ [Config.standard_library]; + begin + try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial + with Env.Error _ -> () + end; + + Searchpos.view_defined_ref := Viewer.view_defined; + Searchpos.editor_ref.contents <- Editor.f; + + let top = openTkClass "LablBrowser" in + Jg_config.init (); + + bind top events:[[], `Destroy] action:(`Set ([], fun _ -> exit 0)); + at_exit Shell.kill_all; + + + Viewer.f on:top (); + + while true do + try + Printexc.print mainLoop () + with Protocol.TkError _ -> () + done diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli new file mode 100644 index 000000000..582295c39 --- /dev/null +++ b/otherlibs/labltk/browser/mytypes.mli @@ -0,0 +1,14 @@ +(* $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 signature: Types.signature; + mutable psignature: Parsetree.signature; + number: string } diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml new file mode 100644 index 000000000..c5871cc93 --- /dev/null +++ b/otherlibs/labltk/browser/searchid.ml @@ -0,0 +1,497 @@ +(* $Id$ *) + +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 acc:(l,[]) fun: + begin fun acc:(l, perms) a -> + let l = List.tl l in + l @ [a], + List.map (permutations l) fun:(fun l -> a :: l) @ perms + end + in perms + +let rec choose n in:l = + let len = List.length l in + if n = len then [l] else + if n = 1 then List.map l fun:(fun x -> [x]) else + if n = 0 then [[]] else + if n > len then [] else + match l with [] -> [] + | a :: l -> + List.map (choose (n-1) in:l) fun:(fun l -> a :: l) + @ choose n in:l + +let rec arr p in:n = + if p = 0 then 1 else n * arr (p-1) in:(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 pred: + 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 pred:(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) pred: + begin fun l1 -> + List.for_all2 l1 l2 pred: + begin fun (p1,t1) (p2,t2) -> + (p1 = "" or p1 = p2) & equal t1 t2 :prefix + end + end + | Ttuple l1, Ttuple l2 -> + List.length l1 = List.length l2 & + List.for_all2 l1 l2 pred:(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 pred:(equal :prefix) + | _ -> false + +let is_opt s = s <> "" & s.[0] = '?' +let get_options = List.filter pred: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 row1.row_fields + in + let r1, r2, pairs = merge_row_fields fields1 fields2 in + r1 = [] & + List.for_all pairs pred: + 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 pred:(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 in:len2 < 100 then l2 else + let ll1 = get_options (fst (List.split l1)) in + List.filter l2 + pred:(fun (l,_) -> not (is_opt l) or List.mem elt:l ll1) + in + len1 <= len2 & + List.exists (List2.flat_map fun:permutations (choose len1 in:l2)) pred: + begin fun l2 -> + List.for_all2 l1 l2 pred: + begin fun (p1,t1) (p2,t2) -> + (p1 = "" or 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 fun:permutations (choose len1 in:l2)) pred: + begin fun l2 -> + List.for_all2 l1 l2 pred:(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 pred:(included :prefix) + | _ -> false + +let mklid = function + [] -> raise (Invalid_argument "Searchid.mklid") + | x :: l -> + List.fold_left l acc:(Lident x) fun:(fun :acc x -> Ldot (acc, x)) + +let mkpath = function + [] -> raise (Invalid_argument "Searchid.mklid") + | x :: l -> + List.fold_left l acc:(Pident (Ident.create x)) + fun:(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 in: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 fun: + 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 or + begin match td.type_kind with + Type_abstract -> false + | Type_variant l -> + List.exists l pred:(fun (_, l) -> List.exists l pred:matches) + | Type_record l -> + List.exists l pred:(fun (_, _, t) -> matches t) + end + then [lid_of_id id, Ptype] else [] + | Tsig_exception (id, l) -> + if List.exists l pred:matches + then [lid_of_id id, Pconstructor] + else [] + | Tsig_module (id, Tmty_signature sign) -> + search_type_in_signature t in: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 + or (match cl.cty_new with None -> false | Some ty -> matches ty) + (* or List.exists (get_fields :prefix :sign self) + pred:(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 + (* or List.exists (get_fields :prefix :sign self) + pred:(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())); newty(Tarrow("",newvar(),t))] + in List2.flat_map !module_list fun: + begin fun modname -> + let mlid = Lident modname in + try match lookup_module mlid initial with + _, Tmty_signature sign -> + List2.flat_map tl + fun:(search_type_in_signature in: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 acc:initial fun: + 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,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8)) + | Typetexp.Error (l,_) -> raise (Error (l.loc_start - 8, l.loc_end - 8)) + in match sign with + [Tsig_value (_, vd)] -> + search_all_types vd.val_type :mode + | _ -> [] + with + Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> + raise (Error (l.loc_start - 8, l.loc_end - 8)) + | Syntaxerr.Error(Syntaxerr.Other l) -> + raise (Error (l.loc_start - 8, l.loc_end - 8)) + | Lexer.Error (_, s, e) -> raise (Error (s - 8, e - 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) 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' + or 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 fun: + begin fun modname -> Lident modname, + try match lookup_module (Lident modname) initial with + _, Tmty_signature sign -> + List2.flat_map sign fun: + 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 + or List.exists + (get_fields prefix:[modname] :sign (self_type cl.cty_type)) + pred:(fun (name,_,_) -> check_match :pattern (explode name)) + -> [i, Pclass] + | Tsig_cltype (i, cl) when check i + or List.exists + (get_fields prefix:[modname] :sign (self_type cl.clty_type)) + pred:(fun (name,_,_) -> check_match :pattern (explode name)) + -> [i, Pcltype] + | _ -> [] + end + | _ -> [] + with Env.Error _ -> [] + end + in + List2.flat_map l fun: + begin fun (m, l) -> + List.map l fun:(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] = '?' or 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_var s -> [s] + | Ppat_alias (pat,s) -> s :: bound_variables pat + | Ppat_tuple l -> List2.flat_map l fun: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 fun:(fun (_,pat) -> bound_variables pat) + | Ppat_array l -> + List2.flat_map l fun:bound_variables + | Ppat_or (pat1,pat2) -> + bound_variables pat1 @ bound_variables pat2 + | Ppat_constraint (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 acc:[] str fun: + begin fun :acc item -> + match item.pstr_desc with + Pstr_module (s, mexp) when s = modu -> + loc := mexp.pmod_loc.loc_start; + 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) fun: + begin fun item -> + if match item.pstr_desc with + Pstr_value (_, l) when kind = Pvalue -> + List.iter l fun: + begin fun (pat,_) -> + if List.mem elt:name (bound_variables pat) + then loc := pat.ppat_loc.loc_start + end; + false + | Pstr_primitive (s, _) when kind = Pvalue -> name = s + | Pstr_type l when kind = Ptype -> + List.iter l fun: + begin fun (s, td) -> + if s = name then loc := td.ptype_loc.loc_start + 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 or kind = Ptype or kind = Pcltype -> + List.iter l fun: + begin fun c -> + if c.pci_name = name then loc := c.pci_loc.loc_start + end; + false + | Pstr_class_type l when kind = Pcltype or kind = Ptype -> + List.iter l fun: + begin fun c -> + if c.pci_name = name then loc := c.pci_loc.loc_start + end; + false + | _ -> false + then loc := item.pstr_loc.loc_start + 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 acc:[] sign fun: + begin fun :acc item -> + match item.psig_desc with + Psig_module (s, mtyp) when s = modu -> + loc := mtyp.pmty_loc.loc_start; + 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) fun: + 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 fun: + begin fun (s, td) -> + if s = name then loc := td.ptype_loc.loc_start + 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 or kind = Ptype or kind = Pcltype -> + List.iter l fun: + begin fun c -> + if c.pci_name = name then loc := c.pci_loc.loc_start + end; + false + | Psig_class_type l when kind = Ptype or kind = Pcltype -> + List.iter l fun: + begin fun c -> + if c.pci_name = name then loc := c.pci_loc.loc_start + end; + false + | _ -> false + then loc := item.psig_loc.loc_start + end; + !loc diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli new file mode 100644 index 000000000..0d7458e70 --- /dev/null +++ b/otherlibs/labltk/browser/searchid.mli @@ -0,0 +1,31 @@ +(* $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/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml new file mode 100644 index 000000000..ad36cdb0a --- /dev/null +++ b/otherlibs/labltk/browser/searchpos.ml @@ -0,0 +1,760 @@ +(* $Id$ *) + +open Tk +open Jg_tk +open Parsetree +open Types +open Typedtree +open Location +open Longident +open Path +open Env +open Searchid + +(* auxiliary functions *) + +let lines_to_chars n in:s = + let l = String.length s in + let rec ltc n :pos = + if n = 1 or 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 = + pos >= loc.loc_start & pos < loc.loc_end + +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 standard (diposable) buffer class *) + +class buffer :len = object + val mutable buffer = String.create :len + val mutable length = len + val mutable current = 0 + method out buffer:b :pos :len = + while len + current > length do + let newbuf = String.create len:(length * 2) in + String.blit buffer pos:0 len:current to:newbuf to_pos:0; + buffer <- newbuf; + length <- 2 * length + done; + String.blit b :pos to:buffer to_pos:current :len; + current <- current + len + method get = String.sub buffer pos:0 len:current +end + +(* Search in a signature *) + +type skind = [`Type|`Class|`Module|`Modtype] + +exception Found_sig of skind * Longident.t * Env.t + +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 + fun:(fun (_,_,tl) -> List.iter tl fun:(search_pos_type :pos :env)) + | Ptyp_arrow (_, t1, t2) -> + search_pos_type t1 :pos :env; + search_pos_type t2 :pos :env + | Ptyp_tuple tl -> + List.iter tl fun:(search_pos_type :pos :env) + | Ptyp_constr (lid, tl) -> + List.iter tl fun:(search_pos_type :pos :env); + raise (Found_sig (`Type, lid, env)) + | Ptyp_object fl -> + List.iter fl fun: + begin function + | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty :pos :env + | _ -> () + end + | Ptyp_class (lid, tl, _) -> + List.iter tl fun:(search_pos_type :pos :env); + raise (Found_sig (`Type, lid, env)) + | Ptyp_alias (t, _) -> search_pos_type :pos :env t); + raise Not_found + end + +let rec search_pos_class_type cl :pos :env = + if in_loc cl.pcty_loc :pos then begin + begin match cl.pcty_desc with + Pcty_constr (lid, _) -> + raise (Found_sig (`Class, lid, env)) + | Pcty_signature (_, cfl) -> + List.iter cfl fun: + begin function + Pctf_inher cty -> search_pos_class_type cty :pos :env + | Pctf_val (_, _, Some ty, loc) -> + if in_loc loc :pos then search_pos_type ty :pos :env + | Pctf_val _ -> () + | 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; + raise Not_found + 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; + begin match td.ptype_kind with + Ptype_abstract -> () + | Ptype_variant dl -> + List.iter dl + fun:(fun (_, tl) -> List.iter tl fun:(search_pos_type :pos :env)) + | Ptype_record dl -> + List.iter dl fun:(fun (_, _, t) -> search_pos_type t :pos :env) + end; + raise Not_found + end + +let rec search_pos_signature l :pos :env = + List.fold_left l acc:env fun: + begin fun acc: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 + begin match pt.psig_desc with + Psig_value (_, desc) -> search_pos_type desc.pval_type :pos :env + | Psig_type l -> + List.iter l fun:(fun (_,desc) -> search_pos_type_decl :pos desc :env) + | Psig_exception (_, l) -> + List.iter l fun:(search_pos_type :pos :env); + raise (Found_sig (`Type, Lident "exn", env)) + | Psig_module (_, 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 + fun:(fun ci -> search_pos_class_type ci.pci_expr :pos :env) + | Psig_class_type l -> + List.iter l + fun:(fun ci -> search_pos_class_type ci.pci_expr :pos :env) + (* The last cases should not happen in generated interfaces *) + | Psig_open lid -> raise (Found_sig (`Module, lid, env)) + | Psig_include t -> search_pos_module t :pos :env + end; + raise Not_found + 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 -> raise (Found_sig (`Modtype, lid, env)) + | Pmty_signature sg -> let _ = search_pos_signature sg :pos :env in () + | 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 fun: + begin function + _, Pwith_type t -> search_pos_type_decl t :pos :env + | _ -> () + end + end; + raise Not_found + end + +(* the module display machinery *) + +type module_widgets = + { mw_frame: Widget.frame Widget.widget; + 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 filter_modules () = + Hashtbl.iter shown_modules fun: + begin fun :key :data -> + if not (Winfo.exists data.mw_frame) then + Hashtbl.remove :key shown_modules + end +let add_shown_module path :widgets = + Hashtbl.add shown_modules key:path data:widgets +and find_shown_module path = + filter_modules (); + Hashtbl.find shown_modules key: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 suff:".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 rec view_signature ?:title ?:path ?:env{= !start_env} 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 with + None -> raise Not_found + | Some path -> + let widgets = + try find_shown_module path + with Not_found -> + view_module path :env; + find_shown_module path + in + Button.configure widgets.mw_detach + command:(fun () -> view_signature sign :title :env); + pack [widgets.mw_detach] side:`Left; + Pack.forget [widgets.mw_edit; widgets.mw_intf]; + List.iter2 [widgets.mw_edit; widgets.mw_intf] [".ml"; ".mli"] fun: + begin fun button ext -> + try + let id = head_id path in + let file = + Misc.find_in_path !Config.load_path + (String.uncapitalize (Ident.name id) ^ ext) in + Button.configure button + command:(fun () -> edit_source :file :path :sign); + pack [button] side:`Left + with Not_found -> () + end; + let top = Winfo.toplevel widgets.mw_frame in + if not (Winfo.ismapped top) then Wm.deiconify top; + Focus.set top; + List.iter fun:destroy (Winfo.children widgets.mw_frame); + Jg_message.formatted :title on:widgets.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 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.Other l -> l + in + Jg_text.tag_and_see tw start:(tpos l.loc_start) + end:(tpos l.loc_end) tag:"error"; [] + | Lexer.Error (_, s, e) -> + Jg_text.tag_and_see tw start:(tpos s) end:(tpos e) tag:"error"; [] + in + Jg_bind.enter_focus tw; + bind tw events:[[`Control], `KeyPressDetail"s"] + action:(`Set ([], fun _ -> Jg_text.search_string tw)); + bind tw events:[[`Double], `ButtonPressDetail 1] + action:(`Setbreakable ([`MouseX;`MouseY], fun ev -> + let `Linechar (l, c) = + Text.index tw index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in + try try + search_pos_signature pt pos:(lines_to_chars l in:text + c) :env; + break () + with Found_sig (kind, lid, env) -> view_decl lid :kind :env + with Not_found | Env.Error _ -> ())); + bind tw events:[[], `ButtonPressDetail 3] + action:(`Setbreakable ([`MouseX;`MouseY], 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 try + search_pos_signature pt pos:(lines_to_chars l in:text + c) :env; + break () + with Found_sig (kind, lid, env) -> + 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)] :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)] + | _ -> raise Not_found + with Not_found -> + view_signature_item :path :env + [Tsig_type(ident_of_path path default:"t", td)] + +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)] + +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)] + +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 or kind = `Modtype then begin + let buf = new buffer len:60 in + let (fo,ff) = Format.get_formatter_output_functions () + and margin = Format.get_margin () in + Format.set_formatter_output_functions out:buf#out flush:(fun () -> ()); + Format.set_margin 60; + Format.open_hbox (); + if kind = `Type then + Printtyp.type_declaration + (ident_of_path path default:"t") + (find_type path env) + else + Printtyp.modtype_declaration + (ident_of_path path default:"S") + (find_modtype path env); + Format.close_box (); Format.print_flush (); + Format.set_formatter_output_functions out:fo flush:ff; + Format.set_margin margin; + let l = Str.split sep:(Str.regexp "\n") buf#get in + let font = + let font = + Option.get Widget.default_toplevel name:"font" class:"Font" in + if font = "" then "7x14" else font + in + (* Menu.add_separator menu; *) + List.iter l + fun:(fun label -> Menu.add_command menu :label :font state:`Disabled) + end; + menu + +(* search and view in a structure *) + +type fkind = + [ `Exp [`Expr|`Pat|`Const|`Val Path.t|`Var Path.t|`New Path.t] + * Types.type_expr + | `Class Path.t * Types.class_type + | `Module Path.t * Types.module_type ] +exception Found_str of fkind * Env.t + +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)] + end + | `Class (path, cty) -> + let cld = { cty_params = []; cty_type = cty; + cty_path = path; cty_new = None } in + view_signature_item :path :env + [Tsig_class(ident_of_path path default:"c", cld)] + | `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)] + +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 len:60 in + let (fo,ff) = Format.get_formatter_output_functions () + and margin = Format.get_margin () in + Format.set_formatter_output_functions out:buf#out flush:(fun () -> ()); + Format.set_margin 60; + Format.open_hbox (); + Printtyp.reset (); + Printtyp.mark_loops ty; + Printtyp.type_expr ty; + Format.close_box (); Format.print_flush (); + Format.set_formatter_output_functions out:fo flush:ff; + Format.set_margin margin; + let l = Str.split sep:(Str.regexp "\n") buf#get in + let font = + let font = + Option.get Widget.default_toplevel name:"font" class:"Font" in + if font = "" then "7x14" else font + in + (* Menu.add_separator menu; *) + List.iter l fun: + 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 rec search_pos_structure :pos str = + List.iter str fun: + begin function + Tstr_eval exp -> search_pos_expr exp :pos + | Tstr_value (rec_flag, l) -> + List.iter l fun: + 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_module (_, m) -> search_pos_module_expr m :pos + | Tstr_modtype _ -> () + | Tstr_open _ -> () + | Tstr_class l -> + List.iter l fun:(fun (id, _, _, cl) -> search_pos_class_expr cl :pos) + | Tstr_cltype _ -> () + 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 -> + raise (Found_str (`Class (path, cl.cl_type), !start_env)) + | Tclass_structure cls -> + List.iter cls.cl_field fun: + begin function + Cf_inher (cl, _, _) -> + search_pos_class_expr cl :pos + | Cf_val (_, _, exp) -> search_pos_expr exp :pos + | Cf_meth (_, exp) -> search_pos_expr exp :pos + | Cf_let (_, pel, iel) -> + List.iter pel fun: + begin fun (pat, exp) -> + search_pos_pat pat :pos env:exp.exp_env; + search_pos_expr exp :pos + end; + List.iter iel fun:(fun (_,exp) -> search_pos_expr exp :pos) + | Cf_init exp -> search_pos_expr exp :pos + end + | Tclass_fun (pat, iel, cl, _) -> + search_pos_pat pat :pos env:pat.pat_env; + List.iter iel fun:(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 fun:(Misc.may (search_pos_expr :pos)) + | Tclass_let (_, pel, iel, cl) -> + List.iter pel fun: + begin fun (pat, exp) -> + search_pos_pat pat :pos env:exp.exp_env; + search_pos_expr exp :pos + end; + List.iter iel fun:(fun (_,exp) -> search_pos_expr exp :pos); + search_pos_class_expr cl :pos + | Tclass_constraint (cl, _, _, _) -> + search_pos_class_expr cl :pos + end; + raise (Found_str + (`Class (Pident (Ident.create "c"), cl.cl_type), !start_env)) + 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, _) -> + raise (Found_str (`Exp(`Val path, exp.exp_type), exp.exp_env)) + | Texp_constant v -> + raise (Found_str (`Exp(`Const, exp.exp_type), exp.exp_env)) + | Texp_let (_, expl, exp) -> + List.iter expl fun: + 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 fun: + 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 fun:(Misc.may (search_pos_expr :pos)); + search_pos_expr exp :pos + | Texp_match (exp, l, _) -> + search_pos_expr exp :pos; + List.iter l fun: + 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 fun: + 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 fun:(search_pos_expr :pos) + | Texp_construct (_, l) -> List.iter l fun:(search_pos_expr :pos) + | Texp_variant (_, None) -> () + | Texp_variant (_, Some exp) -> search_pos_expr exp :pos + | Texp_record (l, opt) -> + List.iter l fun:(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 fun:(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] fun:(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, _) -> + raise (Found_str (`Exp(`New path, exp.exp_type), exp.exp_env)) + | Texp_instvar (_,path) -> + raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env)) + | Texp_setinstvar (_, path, exp) -> + search_pos_expr exp :pos; + raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env)) + | Texp_override (_, l) -> + List.iter l fun:(fun (_, exp) -> search_pos_expr exp :pos) + | Texp_letmodule (id, modexp, exp) -> + search_pos_module_expr modexp :pos; + search_pos_expr exp :pos + end; + raise (Found_str (`Exp(`Expr, exp.exp_type), exp.exp_env)) + 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 -> + raise (Found_str (`Exp(`Val (Pident id), pat.pat_type), env)) + | Tpat_alias (pat, _) -> search_pos_pat pat :pos :env + | Tpat_constant _ -> + raise (Found_str (`Exp(`Const, pat.pat_type), env)) + | Tpat_tuple l -> + List.iter l fun:(search_pos_pat :pos :env) + | Tpat_construct (_, l) -> + List.iter l fun:(search_pos_pat :pos :env) + | Tpat_variant (_, None, _) -> () + | Tpat_variant (_, Some pat, _) -> search_pos_pat pat :pos :env + | Tpat_record l -> + List.iter l fun:(fun (_, pat) -> search_pos_pat pat :pos :env) + | Tpat_array l -> + List.iter l fun:(search_pos_pat :pos :env) + | Tpat_or (a, b) -> + search_pos_pat a :pos :env; search_pos_pat b :pos :env + end; + raise (Found_str (`Exp(`Pat, pat.pat_type), env)) + 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 -> + raise + (Found_str (`Module (path, m.mod_type), m.mod_env)) + | 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 + end; + raise (Found_str (`Module (Pident (Ident.create "M"), m.mod_type), + m.mod_env)) + end diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli new file mode 100644 index 000000000..a5ee29f48 --- /dev/null +++ b/otherlibs/labltk/browser/searchpos.mli @@ -0,0 +1,57 @@ +(* $Id$ *) + +open Widget + +val top_widgets : any widget list ref + +type module_widgets = + { mw_frame: frame widget; + 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 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 -> 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] +exception Found_sig of skind * Longident.t * Env.t +val search_pos_signature : + Parsetree.signature -> pos:int -> env:Env.t -> Env.t + (* raises Found_sig to return its result, or Not_found *) +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 [`Expr|`Pat|`Const|`Val Path.t|`Var Path.t|`New Path.t] + * Types.type_expr + | `Class Path.t * Types.class_type + | `Module Path.t * Types.module_type ] +exception Found_str of fkind * Env.t +val search_pos_structure : + pos:int -> Typedtree.structure_item list -> unit + (* raises Found_str to return its result *) +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 -> in:string -> int + diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml new file mode 100644 index 000000000..1c6ad22ef --- /dev/null +++ b/otherlibs/labltk/browser/setpath.ml @@ -0,0 +1,146 @@ +(* $Id$ *) + +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 pred: + 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 to: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 fun: + begin function + "." -> base + | ".." -> Filename.dirname base + | x -> base ^ "/" ^ x + end + in + set_load_path + (dirs @ List.fold_left dirs acc:(get_load_path ()) + fun:(fun :acc x -> List2.exclude elt:x acc)) + +let remove_path box :dirs = + set_load_path + (List.fold_left dirs acc:(get_load_path ()) + fun:(fun :acc x -> List2.exclude elt: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:(`Set([], 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)); + + let bind_space_toggle lb = + bind lb events:[[], `KeyPressDetail "space"] + action:(`Extend ([], fun _ -> ())) + 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) + fun:(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) + fun:(fun x -> Listbox.get pathbox index:x)) + in + bind dirbox events:[[], `KeyPressDetail "Insert"] + action:(`Set ([], add_paths)); + bind pathbox events:[[], `KeyPressDetail "Delete"] + action:(`Set ([], 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:(`Pix 10); + pack [addbutton] side:`Bottom fill:`X; + pack [dirframe] fill:`Y expand:true; + pack [pathlab] side:`Top anchor:`W padx:(`Pix 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:(`Pix 10); + pack [dir_name] side:`Top anchor:`W fill:`X; + pack [browse] side:`Bottom expand:true fill:`Both; + tl diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli new file mode 100644 index 000000000..9801f83e7 --- /dev/null +++ b/otherlibs/labltk/browser/setpath.mli @@ -0,0 +1,10 @@ +(* $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 f : dir:string -> toplevel widget + (* edit the load path *) diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml new file mode 100644 index 000000000..8f91c6a4f --- /dev/null +++ b/otherlibs/labltk/browser/shell.ml @@ -0,0 +1,237 @@ +(* $Id$ *) + +open Tk +open Jg_tk + +(* 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 pos:count history 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 pos:((l + count - 1) mod l) +end + +(* The shell class. Now encapsulated *) + +let protect f x = try f x with _ -> () + +class shell :textw :prog :args :env = + let (in2,out1) = Unix.pipe () + and (in1,out2) = Unix.pipe () + and (err1,err2) = Unix.pipe () in +object (self) + val pid = Unix.create_process_env :prog :args :env in:in2 out:out2 err:err2 + val out = Unix.out_channel_of_descr out1 + val h = new history () + val mutable alive = true + val mutable reading = false + 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; + List.iter fun:(protect Unix.close) [in1; err1; in2; out2; err2]; + try + Fileevent.remove_fileinput fd:in1; + Fileevent.remove_fileinput fd:err1; + Unix.kill :pid signal:Sys.sigkill; + Unix.waitpid flags:[] pid; () + with _ -> () + end + method interrupt = + if alive then try + reading <- false; + Unix.kill :pid signal:Sys.sigint + with Unix.Unix_error _ -> () + method send s = + if alive then try + output_string s to:out; + flush out + with Sys_error _ -> () + method private read :fd :len = + try + let buffer = String.create :len in + let len = Unix.read fd :buffer pos:0 :len in + self#insert (String.sub buffer pos:0 :len); + Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)]) + with Unix.Unix_error _ -> () + method history (dir : [`next|`previous]) = + if not h#empty then begin + if reading then begin + Text.delete textw start:(`Mark"input",[`Char 1]) + end:(`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]} + ?end:endx{= `Mark"insert",[`Lineend]} () = + Lexical.tag textw :start end:endx + 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]); + self#lex start:(`Mark"input",[`Linestart]) (); + let s = + (* input is one character before real input *) + Text.get textw start:(`Mark"input",[`Char 1]) + end:(`Mark"insert",[]) in + h#add s; + 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 + fun:(fun (events,fields,f) -> + bind textw :events action:(`Set(fields,f))); + begin try + List.iter [in1;err1] fun: + begin fun fd -> + Fileevent.add_fileinput :fd + callback:(fun () -> self#read :fd len:1024) + end + with _ -> () + end +end + +(* Specific use of shell, for LablBrowser *) + +let shells : (string * shell) list ref = ref [] + +(* Called before exiting *) +let kill_all () = + List.iter !shells fun:(fun (_,sh) -> if sh#alive then sh#kill); + shells := [] + +let get_all () = + let all = List.filter !shells pred:(fun (_,sh) -> sh#alive) in + shells := all; + all + +let may_exec prog = + try + let stats = Unix.stat prog in + stats.Unix.st_perm land 1 <> 0 or + stats.Unix.st_perm land 8 <> 0 + & List.mem elt:stats.Unix.st_gid (Array.to_list (Unix.getgroups ())) or + stats.Unix.st_perm land 64 <> 0 & stats.Unix.st_uid = Unix.getuid () + with Unix.Unix_error _ -> false + +let f :prog :title = + let progargs = + List.filter pred:((<>) "") (Str.split sep:(Str.regexp " ") prog) in + if progargs = [] then () else + let prog = List.hd progargs in + let path = try Sys.getenv "PATH" with Not_found -> "/bin:/usr/bin" in + let exec_path = Str.split sep:(Str.regexp":") path in + let exists = + if not (Filename.is_implicit prog) then may_exec prog else + List.exists exec_path + pred:(fun dir -> may_exec (Filename.concat dir prog)) in + if not exists then () else + let tl = Jg_toplevel.titled title in + let menus = Frame.create tl name:"menubar" in + 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 + pack [menus] side:`Top fill:`X; + pack [file_menu#button; history_menu#button; signal_menu#button] + side:`Left ipadx:(`Pix 5) anchor:`W; + 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 reg = Str.regexp "TERM=" in + let env = Array.map (Unix.environment ()) fun: + begin fun s -> + if Str.string_match reg s pos:0 then "TERM=dumb" else s + end in + let load_path = + List2.flat_map !Config.load_path fun:(fun dir -> ["-I"; dir]) in + let args = Array.of_list (progargs @ load_path) in + let sh = new shell textw:tw :prog :env :args in + let current_dir = ref (Unix.getcwd ()) in + 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 = List.hd l in + current_dir := Filename.dirname name; + if Filename.check_suffix name suff:".ml" + then + let cmd = "#use \"" ^ 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 = List.hd l in + current_dir := Filename.dirname name; + if Filename.check_suffix name suff:".cmo" or + Filename.check_suffix name suff:".cma" + then + let cmd = "#load \"" ^ 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) + fun:(fun dir -> sh#send ("#directory \"" ^ 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); + shells := (title, sh) :: !shells diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli new file mode 100644 index 000000000..adea44551 --- /dev/null +++ b/otherlibs/labltk/browser/shell.mli @@ -0,0 +1,20 @@ +(* $Id$ *) + +(* toplevel shell *) + +class shell : + textw:Widget.text Widget.widget -> prog:string -> + args:string array -> env:string array -> + 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 f : prog:string -> title:string -> unit diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml new file mode 100644 index 000000000..8d90681a2 --- /dev/null +++ b/otherlibs/labltk/browser/typecheck.ml @@ -0,0 +1,98 @@ +(* $Id$ *) + +open Tk +open Parsetree +open Location +open Jg_tk +open Mytypes + +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" () in + Text.tag_remove txt.tw tag:"error" start:tstart end:tend; + begin + txt.structure <- []; + txt.signature <- []; + txt.psignature <- []; + try + + if Filename.check_suffix txt.name suff:".mli" then + let psign = Parse.interface (Lexing.from_string text) in + txt.psignature <- psign; + txt.signature <- Typemod.transl_signature !env psign + + else (* others are interpreted as .ml *) + + let psl = Parse.use_file (Lexing.from_string text) in + List.iter psl fun: + begin function + Ptop_def pstr -> + let str, sign, env' = Typemod.type_structure !env pstr in + txt.structure <- txt.structure @ str; + txt.signature <- txt.signature @ sign; + env := env' + | Ptop_dir _ -> () + end + + with + Lexer.Error _ | Syntaxerr.Error _ + | Typecore.Error _ | Typemod.Error _ + | Typeclass.Error _ | Typedecl.Error _ + | Typetexp.Error _ | Includemod.Error _ + | Env.Error _ | Ctype.Tags _ as exn -> + let et, ew, end_message = Jg_message.formatted title:"Error !" () in + error_messages := et :: !error_messages; + let s, e = match exn with + Lexer.Error (err, s, e) -> + Lexer.report_error err; s,e + | Syntaxerr.Error err -> + Syntaxerr.report_error err; + let l = + match err with + Syntaxerr.Unclosed(l,_,_,_) -> l + | Syntaxerr.Other l -> l + in l.loc_start, l.loc_end + | Typecore.Error (l,err) -> + Typecore.report_error err; l.loc_start, l.loc_end + | Typeclass.Error (l,err) -> + Typeclass.report_error err; l.loc_start, l.loc_end + | Typedecl.Error (l, err) -> + Typedecl.report_error err; l.loc_start, l.loc_end + | Typemod.Error (l,err) -> + Typemod.report_error err; l.loc_start, l.loc_end + | Typetexp.Error (l,err) -> + Typetexp.report_error err; l.loc_start, l.loc_end + | Includemod.Error errl -> + Includemod.report_error errl; 0, 0 + | Env.Error err -> + Env.report_error err; 0, 0 + | Ctype.Tags(l, l') -> + Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value." l l'; 0, 0 + | _ -> assert false + in + end_message (); + if s < e then + Jg_text.tag_and_see txt.tw start:(tpos s) end:(tpos e) tag:"error" + end; + end_message (); + if !nowarnings or 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:[[`Double], `ButtonPressDetail 1] + action:(`Set ([], fun _ -> + let s = + Text.get ew start:(`Mark "insert", [`Wordstart]) + end:(`Mark "insert", [`Wordend]) in + try + 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 Failure "int_of_string" -> ())) + end; + !error_messages diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli new file mode 100644 index 000000000..80c4e3caf --- /dev/null +++ b/otherlibs/labltk/browser/typecheck.mli @@ -0,0 +1,9 @@ +(* $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/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml new file mode 100644 index 000000000..33dd20f2b --- /dev/null +++ b/otherlibs/labltk/browser/useunix.ml @@ -0,0 +1,36 @@ +(* $Id$ *) + +open Unix + +let get_files_in_directory dir = + try + let dirh = opendir dir in + let rec get_them () = + try + let x = readdir dirh in + x :: get_them () + with + _ -> closedir dirh; [] + in + Sort.list order:(<) (get_them ()) + with Unix_error _ -> [] + +let is_directory name = + try + (stat name).st_kind = S_DIR + with _ -> false + +let get_directories_in_files :path = + List.filter pred:(fun x -> is_directory (path ^ "/" ^ x)) + +(************************************************** Subshell call *) +let subshell :cmd = + let rc = open_process_in cmd in + let rec it () = + try + let x = input_line rc in x :: it () + with _ -> [] + in + let answer = it () in + ignore (close_process_in rc); + answer diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli new file mode 100644 index 000000000..23699155a --- /dev/null +++ b/otherlibs/labltk/browser/useunix.mli @@ -0,0 +1,8 @@ +(* $Id$ *) + +(* Unix utilities *) + +val get_files_in_directory : string -> string list +val is_directory : string -> bool +val get_directories_in_files : path:string -> string list -> string list +val subshell : cmd:string -> string list diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml new file mode 100644 index 000000000..6ca0a0a81 --- /dev/null +++ b/otherlibs/labltk/browser/viewer.ml @@ -0,0 +1,323 @@ +(* $Id$ *) + +open Tk +open Jg_tk +open Mytypes +open Longident +open Types +open Typedtree +open Env +open Searchpos +open Searchid + +let list_modules :path = + List.fold_left path acc:[] fun: + begin fun :acc dir -> + let l = + List.filter (Useunix.get_files_in_directory dir) + pred:(fun x -> Filename.check_suffix x suff:".cmi") in + let l = List.map l fun: + begin fun x -> + String.capitalize (Filename.chop_suffix x suff:".cmi") + end in + List.fold_left l :acc + fun:(fun :acc elt -> if List.mem acc :elt then acc else elt :: acc) + end + +let reset_modules box = + Listbox.delete box first:(`Num 0) last:`End; + module_list := Sort.list order:(<) (list_modules path:!Config.load_path); + Listbox.insert box index:`End texts:!module_list; + Jg_box.recenter box index:(`Num 0) + +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 + +let choose_symbol :title :env ?:signature ?:path l = + if match path with + None -> false + | Some path -> + try find_shown_module path; true with Not_found -> false + 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:(`Pix 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 = Sort.list l order: + (fun (li1, _) (li2,_) -> + string_of_longident li1 < string_of_longident li2) + in + let nl = List.map l fun: + 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 (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_detach = detach; + mw_edit = edit; mw_intf = intf } + end + +let search_which = ref "itself" + +let search_symbol () = + if !module_list = [] then + module_list := Sort.list order:(<) (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:"itself" + and extype = Radiobutton.create choice text:"Exact type" + variable:which value:"exact" + and iotype = Radiobutton.create choice text:"Included type" + variable:which value:"iotype" + and buttons = Frame.create tl in + let search = Button.create buttons text:"Search" command: + begin fun () -> + search_which := Textvariable.get which; + let text = Entry.get ew in + try if text = "" then () else + let l = match !search_which with + "itself" -> search_string_symbol text + | "iotype" -> search_string_type text mode:`included + | "exact" -> search_string_type text mode:`exact + in + if l <> [] then + choose_symbol title:"Choose symbol" env:!start_env l + with Searchid.Error (s,e) -> + Entry.selection_clear ew; + Entry.selection_range ew start:(`Num s) end:(`Num e); + Entry.xview_index ew index:(`Num s) + 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 to:!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 + +let view_defined modlid :env = + try match lookup_module modlid env with + path, Tmty_signature sign -> + let ident_of_decl = 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 + in + 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 decl :: idents) + in + let l = iter_sign sign [] in + choose_symbol l title:(string_of_path path) signature:sign + env:(open_signature path sign env) :path + | _ -> () + with Not_found -> () + | Env.Error err -> + let tl, tw, finish = Jg_message.formatted title:"Error!" () in + Env.report_error err; + finish () + +let close_all_views () = + List.iter !top_widgets + fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); + top_widgets := [] + + +let shell_counter = ref 1 +let default_shell = ref "ocaml" + +let start_shell () = + let tl = Jg_toplevel.titled "Start New Shell" in + Wm.transient_set tl master:Widget.default_toplevel; + 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 fun:fst (Shell.get_all ()) in + Entry.insert e1 index:`End text:!default_shell; + while List.mem names elt:("Shell #" ^ string_of_int !shell_counter) do + incr shell_counter + done; + Entry.insert e2 index:`End text:("Shell #" ^ string_of_int !shell_counter); + Button.configure ok command:(fun () -> + if not (List.mem names elt:(Entry.get e2)) 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 + +let f ?:dir{= Unix.getcwd()} ?:on () = + let tl = match on with + None -> + let tl = Jg_toplevel.titled "Module viewer" in + Jg_bind.escape_destroy tl; coe tl + | Some top -> + Wm.title_set top title:"LablBrowser"; + Wm.iconname_set top name:"LablBrowser"; + let tl = Frame.create top in + pack [tl] expand:true fill:`Both; + coe tl + in + let menus = Frame.create tl name:"menubar" 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:(`Pix 1) + command: + begin fun () -> + let s = Entry.get ew in + 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; + let l = + if !is_type then try + search_string_type mode:`included s + with Searchid.Error (start,stop) -> + Entry.icursor ew index:(`Num start); [] + else if !is_long then + search_string_symbol s + else + search_pattern_symbol s in + match l with [] -> () + | [lid,kind] when !is_long -> view_symbol lid :kind env:!start_env + | _ -> choose_symbol title:"Choose symbol" env:!start_env l + end + and close = + Button.create buttons text:"Close all" pady:(`Pix 1) + command:close_all_views + in + (* bindings *) + Jg_bind.enter_focus ew; + Jg_bind.return_invoke ew button:search; + bind close events:[[`Double], `ButtonPressDetail 1] + action:(`Set ([], 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:start_shell; + filemenu#add_command "Quit" command:(fun () -> destroy tl); + + (* modules menu *) + modmenu#add_command "Path editor..." command:(fun () -> Setpath.f :dir; ()); + modmenu#add_command "Reset cache" + command:(fun () -> reset_modules mbox; Env.reset_cache ()); + modmenu#add_command "Search symbol..." command:search_symbol; + + pack [filemenu#button; modmenu#button] side:`Left ipadx:(`Pix 5) anchor:`W; + pack [menus] side:`Top fill:`X; + 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 diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli new file mode 100644 index 000000000..2ddf38861 --- /dev/null +++ b/otherlibs/labltk/browser/viewer.mli @@ -0,0 +1,15 @@ +(* $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 view_defined : Longident.t -> env:Env.t -> unit + (* displays a signature, found in environment *) + +val close_all_views : unit -> unit |