diff options
Diffstat (limited to 'otherlibs/labltk/browser')
45 files changed, 0 insertions, 4108 deletions
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile deleted file mode 100644 index 94b11d80c..000000000 --- a/otherlibs/labltk/browser/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -include ../Makefile.config - -LINKER=labltklink -LABLTKLIB=-I $(INSTALLDIR) -INCLUDES=$(LABLTKLIB) $(OLABLINCLUDES) -OLABLINCLUDES=-I $(OCAMLDIR)/parsing -I $(OCAMLDIR)/utils -I $(OCAMLDIR)/typing - -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: jglib.cma $(OBJ) - $(LINKER) -o lablbrowser $(LABLTKLIB) toplevellib.cma \ - unix.cma str.cma tk41.cma jglib.cma $(OBJ) \ - -cclib -lstr -cclib -lunix $(SYSLIBS) - -jglib.cma: $(JG) - $(LABLCOMP) -a -o jglib.cma $(JG) - -install: - if test -f lablbrowser; then : ; cp lablbrowser $(INSTALLBINDIR); 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 deleted file mode 100644 index ca28b5132..000000000 --- a/otherlibs/labltk/browser/README +++ /dev/null @@ -1,155 +0,0 @@ - - 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 deleted file mode 100644 index c5c662f01..000000000 --- a/otherlibs/labltk/browser/editor.ml +++ /dev/null @@ -1,543 +0,0 @@ -(* $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 parent: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 parent:tl () in - let ok = Button.create parent: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 parent:tl () in - let fl = Frame.create parent:ef () - and fi = Frame.create parent:ef () in - let ll = Label.create parent:fl text:"Line number:" () - and il = Entry.create parent:fi width:10 () - and lc = Label.create parent:fl text:"Col number:" () - and ic = Entry.create parent: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 parent:tl () in - let ok = Button.create parent: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 parent:tl text:"Send to:" () - and box = Listbox.create parent:tl () - and frame = Frame.create parent:tl () in - Jg_bind.enter_focus box; - let cancel = Jg_button.create_destroyer tl parent:frame text:"Cancel" - and ok = Button.create parent: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 parent: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 parent: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 parent: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 parent: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 deleted file mode 100644 index d186e4874..000000000 --- a/otherlibs/labltk/browser/editor.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* $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 deleted file mode 100644 index e0d0e7c33..000000000 --- a/otherlibs/labltk/browser/fileselect.ml +++ /dev/null @@ -1,282 +0,0 @@ -(* $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 parent:tl borderwidth:(`Pix 1) relief:`Raised () in - let df = Frame.create parent:frm () in - let dfl = Frame.create parent:df () in - let dfll = Label.create parent:dfl text:"Directories" () in - let dflf, directory_listbox, directory_scrollbar = - Jg_box.create_with_scrollbar parent:dfl () in - let dfr = Frame.create parent:df () in - let dfrl = Label.create parent:dfr text:"Files" () in - let dfrf, filter_listbox, filter_scrollbar = - Jg_box.create_with_scrollbar parent:dfr () in - let cfrm = Frame.create parent: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 parent:frm text:"Filter" () in - let sl = Label.create parent:frm text:"Selection" () in - let filter_entry = Jg_entry.create parent:frm textvariable:filter_var () - command:(fun filter -> configure :filter) in - let selection_entry = Jg_entry.create parent:frm textvariable:selection_var - command:(fun file -> activate [file]) () in - - (* and buttons *) - let set_path = Button.create parent: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 parent: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 parent: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 parent:cfrm text:"Filter" () - command:(fun () -> configure filter:(Textvariable.get filter_var)) - and ccb = Button.create parent: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 deleted file mode 100644 index 789cd17e2..000000000 --- a/otherlibs/labltk/browser/fileselect.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* $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 deleted file mode 100644 index 9d30f5793..000000000 --- a/otherlibs/labltk/browser/jg_bind.ml +++ /dev/null @@ -1,15 +0,0 @@ -(* $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 deleted file mode 100644 index 3889f20fd..000000000 --- a/otherlibs/labltk/browser/jg_bind.mli +++ /dev/null @@ -1,7 +0,0 @@ -(* $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 deleted file mode 100644 index f71bd0e7f..000000000 --- a/otherlibs/labltk/browser/jg_box.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* $Id$ *) - -open Tk - -let add_scrollbar lb = - let sb = - Scrollbar.create parent:(Winfo.parent lb) command:(Listbox.yview lb) () in - Listbox.configure lb yscrollcommand:(Scrollbar.set sb); sb - -let create_with_scrollbar :parent ?:selectmode () = - let frame = Frame.create :parent () in - let lb = Listbox.create parent: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 deleted file mode 100644 index db56374aa..000000000 --- a/otherlibs/labltk/browser/jg_button.ml +++ /dev/null @@ -1,11 +0,0 @@ -(* $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 deleted file mode 100644 index 8836af09f..000000000 --- a/otherlibs/labltk/browser/jg_completion.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* $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 deleted file mode 100644 index 427e74455..000000000 --- a/otherlibs/labltk/browser/jg_completion.mli +++ /dev/null @@ -1,9 +0,0 @@ -(* $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 deleted file mode 100644 index 330efa7e5..000000000 --- a/otherlibs/labltk/browser/jg_config.ml +++ /dev/null @@ -1,18 +0,0 @@ -(* $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 ("*" ^ cl ^ ".font") value:font); - Option.add "*Button.padY" value:"0" priority:`StartupFile; - Option.add "*Text.highlightThickness" value:"0" priority:`StartupFile; - Option.add "*interface.background" value:"gray85" priority:`StartupFile; - let foreground = - Option.get Widget.default_toplevel - name:"disabledForeground" class:"Foreground" in - if foreground = "" then - Option.add "*disabledForeground" value:"black" diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli deleted file mode 100644 index 183035108..000000000 --- a/otherlibs/labltk/browser/jg_config.mli +++ /dev/null @@ -1,3 +0,0 @@ -(* $Id$ *) - -val init: unit -> unit diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml deleted file mode 100644 index d9109d83a..000000000 --- a/otherlibs/labltk/browser/jg_entry.ml +++ /dev/null @@ -1,13 +0,0 @@ -(* $Id$ *) - -open Tk - -let create :parent ?:command ?:width ?:textvariable () = - 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 deleted file mode 100644 index 43a5eb15b..000000000 --- a/otherlibs/labltk/browser/jg_memo.ml +++ /dev/null @@ -1,17 +0,0 @@ -(* $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 deleted file mode 100644 index 8d08111b1..000000000 --- a/otherlibs/labltk/browser/jg_memo.mli +++ /dev/null @@ -1,8 +0,0 @@ -(* $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 deleted file mode 100644 index 21295f3d6..000000000 --- a/otherlibs/labltk/browser/jg_menu.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* $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 parent: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 deleted file mode 100644 index 9385f37d0..000000000 --- a/otherlibs/labltk/browser/jg_message.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* $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 parent:tl () in - pack [frame] side:`Top fill:`Both expand:true; - coe tl, frame - in - let tw = Text.create parent: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 parent:tl :text padx:(`Pix 20) pady:(`Pix 10) - width:(`Pix 250) justify:`Left aspect:400 anchor:`W () - and fw = Frame.create parent:tl () - and sync = Textvariable.create on:tl () - and r = ref (`cancel : [`yes|`no|`cancel]) in - let accept = Button.create parent:fw text:"Yes" () - command:(fun () -> r := `yes; destroy tl) - and refuse = Button.create parent: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 deleted file mode 100644 index 8862702c6..000000000 --- a/otherlibs/labltk/browser/jg_message.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* $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 deleted file mode 100644 index 161e21534..000000000 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* $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 :parent :cols :texts ?:maxheight ?:width () = 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 parent:(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 deleted file mode 100644 index fbd1ab13a..000000000 --- a/otherlibs/labltk/browser/jg_multibox.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* $Id$ *) - -class c : - parent:'a Widget.widget -> cols:int -> - texts:string list -> ?maxheight:int -> ?width:int -> unit -> -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 deleted file mode 100644 index 2477e9acc..000000000 --- a/otherlibs/labltk/browser/jg_text.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* $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 parent:(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 parent: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 parent:tl () - and fd = Frame.create parent:tl () - and fm = Frame.create parent:tl () - and buttons = Frame.create parent:tl () - and direction = Textvariable.create on:tl () - and mode = Textvariable.create on:tl () - and count = Textvariable.create on:tl () - in - let label = Label.create parent:fi text:"Pattern:" () - and text = Entry.create parent:fi width:20 () - and back = Radiobutton.create parent:fd variable:direction - text:"Backwards" value:"backward" () - and forw = Radiobutton.create parent:fd variable:direction - text:"Forwards" value:"forward" () - and exact = Radiobutton.create parent:fm variable:mode - text:"Exact" value:"exact" () - and nocase = Radiobutton.create parent:fm variable:mode - text:"No case" value:"nocase" () - and regexp = Radiobutton.create parent:fm variable:mode - text:"Regexp" value:"regexp" () - in - let search = Button.create parent: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 deleted file mode 100644 index 8b3880eef..000000000 --- a/otherlibs/labltk/browser/jg_text.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* $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 : - parent:'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 deleted file mode 100644 index da5f4930c..000000000 --- a/otherlibs/labltk/browser/jg_tk.ml +++ /dev/null @@ -1,8 +0,0 @@ -(* $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 deleted file mode 100644 index c36a215ef..000000000 --- a/otherlibs/labltk/browser/jg_toplevel.ml +++ /dev/null @@ -1,10 +0,0 @@ -(* $Id$ *) - -open Tk - -let titled ?:iconname title = - let iconname = match iconname with None -> title | Some s -> s in - let tl = Toplevel.create parent: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 deleted file mode 100644 index e98096c2e..000000000 --- a/otherlibs/labltk/browser/lexical.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* $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 _ - | QUESTION3 - | 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 deleted file mode 100644 index d9711f5fc..000000000 --- a/otherlibs/labltk/browser/lexical.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* $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 deleted file mode 100644 index 6ab8b7863..000000000 --- a/otherlibs/labltk/browser/list2.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* $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 deleted file mode 100644 index 681342cff..000000000 --- a/otherlibs/labltk/browser/main.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* $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 deleted file mode 100644 index 582295c39..000000000 --- a/otherlibs/labltk/browser/mytypes.mli +++ /dev/null @@ -1,14 +0,0 @@ -(* $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 deleted file mode 100644 index a43085752..000000000 --- a/otherlibs/labltk/browser/searchid.ml +++ /dev/null @@ -1,497 +0,0 @@ -(* $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 deleted file mode 100644 index 0d7458e70..000000000 --- a/otherlibs/labltk/browser/searchid.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* $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 deleted file mode 100644 index 9883ea50c..000000000 --- a/otherlibs/labltk/browser/searchpos.ml +++ /dev/null @@ -1,760 +0,0 @@ -(* $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 deleted file mode 100644 index eeae7f32c..000000000 --- a/otherlibs/labltk/browser/searchpos.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* $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 deleted file mode 100644 index 99c045d97..000000000 --- a/otherlibs/labltk/browser/setpath.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* $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 parent:tl text:"Path" () - and dir_name = - Entry.create parent:tl textvariable:var_dir () - and browse = Frame.create parent:tl () in - let dirs = Frame.create parent:browse () - and path = Frame.create parent:browse () in - let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar parent:dirs () - and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar parent: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 parent:dirs text:"Directories" () - and pathlab = Label.create parent:path text:"Load path" () - and addbutton = - Button.create parent:dirs text:"Add to path" command:add_paths () - and pathbuttons = Frame.create parent:path () in - let removebutton = - Button.create parent: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 deleted file mode 100644 index 9801f83e7..000000000 --- a/otherlibs/labltk/browser/setpath.mli +++ /dev/null @@ -1,10 +0,0 @@ -(* $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 deleted file mode 100644 index 5af22d1b4..000000000 --- a/otherlibs/labltk/browser/shell.ml +++ /dev/null @@ -1,237 +0,0 @@ -(* $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 parent: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 parent: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 deleted file mode 100644 index adea44551..000000000 --- a/otherlibs/labltk/browser/shell.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* $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 deleted file mode 100644 index 8c1e29deb..000000000 --- a/otherlibs/labltk/browser/typecheck.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* $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 deleted file mode 100644 index fd9970495..000000000 --- a/otherlibs/labltk/browser/typecheck.mli +++ /dev/null @@ -1,9 +0,0 @@ -(* $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 deleted file mode 100644 index 33dd20f2b..000000000 --- a/otherlibs/labltk/browser/useunix.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* $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 deleted file mode 100644 index 23699155a..000000000 --- a/otherlibs/labltk/browser/useunix.mli +++ /dev/null @@ -1,8 +0,0 @@ -(* $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 deleted file mode 100644 index bc9d7228b..000000000 --- a/otherlibs/labltk/browser/viewer.ml +++ /dev/null @@ -1,323 +0,0 @@ -(* $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 parent:tl () in - let all = Button.create parent:buttons text:"Show all" padx:(`Pix 20) () - and ok = Jg_button.create_destroyer tl parent:buttons - and detach = Button.create parent:buttons text:"Detach" () - and edit = Button.create parent:buttons text:"Impl" () - and intf = Button.create parent: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 parent:tl () in - let box = - new Jg_multibox.c parent: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 parent: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 parent:tl width:30 () in - let choice = Frame.create parent:tl () - and which = Textvariable.create on:tl () in - let itself = Radiobutton.create parent:choice text:"Itself" - variable:which value:"itself" () - and extype = Radiobutton.create parent:choice text:"Exact type" - variable:which value:"exact" () - and iotype = Radiobutton.create parent:choice text:"Included type" - variable:which value:"iotype" () - and buttons = Frame.create parent:tl () in - let search = Button.create parent: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 parent:tl () - and buttons = Frame.create parent:tl () in - let ok = Button.create parent:buttons text:"Ok" () - and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel" - and labels = Frame.create parent:input () - and entries = Frame.create parent:input () in - let l1 = Label.create parent:labels text:"Command:" () - and l2 = Label.create parent:labels text:"Title:" () - and e1 = - Jg_entry.create parent:entries command:(fun _ -> Button.invoke ok) () - and e2 = - Jg_entry.create parent: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 parent:top () in - pack [tl] expand:true fill:`Both; - coe tl - in - let menus = Frame.create parent: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 parent: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 parent:tl () in - let buttons = Frame.create parent:tl () in - let search = Button.create parent: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 parent: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 deleted file mode 100644 index 798afeb08..000000000 --- a/otherlibs/labltk/browser/viewer.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* $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 |