diff options
Diffstat (limited to 'otherlibs/labltk/browser')
27 files changed, 1201 insertions, 1183 deletions
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml index 6725f5dab..acc514d77 100644 --- a/otherlibs/labltk/browser/editor.ml +++ b/otherlibs/labltk/browser/editor.ml @@ -24,18 +24,18 @@ 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 :invert = - let variable = Textvariable.create on:tl () in + Wm.transient_set tl ~master:Widget.default_toplevel; + let mk_chkbutton ~text ~ref ~invert = + let variable = Textvariable.create ~on:tl () in if (if invert then not !ref else !ref) then Textvariable.set variable "1"; - Checkbutton.create tl :text :variable, + Checkbutton.create tl ~text ~variable, (fun () -> ref := Textvariable.get variable = (if invert then "0" else "1")) in let chkbuttons, setflags = List.split (List.map - f:(fun (text, ref, invert) -> mk_chkbutton :text :ref :invert) + ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert) [ "No pervasives", Clflags.nopervasives, false; "No warnings", Typecheck.nowarnings, false; "Modern", Clflags.classic, true; @@ -43,16 +43,16 @@ let compiler_preferences () = "Type on load", type_on_load, false ]) in let buttons = Frame.create tl in - let ok = Button.create buttons text:"Ok" padx:20 command: + let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command: begin fun () -> - List.iter f:(fun f -> f ()) setflags; + List.iter ~f:(fun f -> f ()) setflags; destroy tl end - and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel" + 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 + pack chkbuttons ~side:`Top ~anchor:`W; + pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; + pack [buttons] ~side:`Bottom ~fill:`X let rec exclude txt = function [] -> [] @@ -60,75 +60,75 @@ let rec exclude txt = function let goto_line tw = let tl = Jg_toplevel.titled "Go to" in - Wm.transient_set tl master:Widget.default_toplevel; + Wm.transient_set tl ~master:Widget.default_toplevel; Jg_bind.escape_destroy tl; let ef = Frame.create tl in let fl = Frame.create ef and fi = Frame.create ef in - let ll = Label.create fl text:"Line number:" - and il = Entry.create fi width:10 - and lc = Label.create fl text:"Col number:" - and ic = Entry.create fi width:10 + let ll = Label.create fl ~text:"Line ~number:" + and il = Entry.create fi ~width:10 + and lc = Label.create fl ~text:"Col ~number:" + and ic = Entry.create fi ~width:10 and get_int ew = try int_of_string (Entry.get ew) with Failure "int_of_string" -> 0 in let buttons = Frame.create tl in - let ok = Button.create buttons text:"Ok" command: + let ok = Button.create buttons ~text:"Ok" ~command: begin fun () -> let l = get_int il and c = get_int ic in - Text.mark_set tw mark:"insert" index:(`Linechar (l,0), [`Char c]); - Text.see tw index:(`Mark "insert", []); + 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 + and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set il; - List.iter [il; ic] f: + List.iter [il; ic] ~f: begin fun w -> Jg_bind.enter_focus w; - Jg_bind.return_invoke w button:ok + 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 + 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 shells = Sort.list shells ~order:(fun (x,_) (y,_) -> x <= y) in let tl = Jg_toplevel.titled "Select Shell" in Jg_bind.escape_destroy tl; - Wm.transient_set tl master:(Winfo.toplevel txt.tw); - let label = Label.create tl text:"Send to:" + Wm.transient_set tl ~master:(Winfo.toplevel txt.tw); + let label = Label.create tl ~text:"Send ~to:" and box = Listbox.create tl and frame = Frame.create tl in Jg_bind.enter_focus box; - let cancel = Jg_button.create_destroyer tl parent:frame text:"Cancel" - and ok = Button.create frame text:"Ok" command: + let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel" + and ok = Button.create frame ~text:"Ok" ~command: begin fun () -> try - let name = Listbox.get box index:`Active in + let name = Listbox.get box ~index:`Active in txt.shell <- Some (name, List.assoc name shells); destroy tl with Not_found -> txt.shell <- None; destroy tl end in - Listbox.insert box index:`End texts:(List.map f:fst shells); - Listbox.configure box height:(List.length shells); - bind box events:[`KeyPressDetail"Return"] breakable:true - action:(fun _ -> Button.invoke ok; break ()); - bind box events:[`Modified([`Double],`ButtonPressDetail 1)] breakable:true - fields:[`MouseX;`MouseY] - action:(fun ev -> - Listbox.activate box index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); + Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells); + Listbox.configure box ~height:(List.length shells); + bind box ~events:[`KeyPressDetail"Return"] ~breakable:true + ~action:(fun _ -> Button.invoke ok; break ()); + bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); Button.invoke ok; break ()); - pack [label] side:`Top anchor:`W; - pack [box] side:`Top fill:`Both; - pack [frame] side:`Bottom fill:`X expand:true; - pack [ok;cancel] side:`Left fill:`X expand:true + pack [label] ~side:`Top ~anchor:`W; + pack [box] ~side:`Top ~fill:`Both; + pack [frame] ~side:`Bottom ~fill:`X ~expand:true; + pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true open Parser @@ -141,13 +141,13 @@ let send_phrase txt = match txt.shell with None -> () | Some (_,sh) -> try - let i1,i2 = Text.tag_nextrange txt.tw tag:"sel" start:tstart in - let phrase = Text.get txt.tw start:(i1,[]) end:(i2,[]) in + let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in + let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in sh#send phrase; - if Str.string_match phrase pat:(Str.regexp ";;") pos:0 + if Str.string_match phrase ~pat:(Str.regexp ";;") ~pos:0 then sh#send "\n" else sh#send ";;\n" with Not_found | Protocol.TkError _ -> - let text = Text.get txt.tw start:tstart end:tend in + let text = Text.get txt.tw ~start:tstart ~stop:tend in let buffer = Lexing.from_string text in let start = ref 0 and block_start = ref [] @@ -161,12 +161,12 @@ let send_phrase txt = in let bol = (pos = 0) || text.[pos-1] = '\n' in if not !after && - Text.compare txt.tw index:(tpos pos) op:(if bol then `Gt else `Ge) - index:(`Mark"insert",[]) + Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge) + ~index:(`Mark"insert",[]) then begin after := true; let anon, real = - List.partition !block_start f:(fun x -> x = -1) in + List.partition !block_start ~f:(fun x -> x = -1) in block_start := anon; if real <> [] then start := List.hd real; end; @@ -194,46 +194,46 @@ let send_phrase txt = | _ -> () done; - let phrase = String.sub text pos:!start len:(!pend - !start) in + let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in sh#send phrase; sh#send ";;\n" -let search_pos_window txt :x :y = +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 `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 + let pos = Searchpos.lines_to_chars l ~text + c in try if txt.structure <> [] then - try Searchpos.search_pos_structure txt.structure :pos + try Searchpos.search_pos_structure txt.structure ~pos with Searchpos.Found_str (kind, env) -> - Searchpos.view_type kind :env + Searchpos.view_type kind ~env else try Searchpos.search_pos_signature - txt.psignature :pos env:!Searchid.start_env; + txt.psignature ~pos ~env:!Searchid.start_env; () with Searchpos.Found_sig (kind, lid, env) -> - Searchpos.view_decl lid :kind :env + Searchpos.view_decl lid ~kind ~env with Not_found -> () -let search_pos_menu txt :x :y = +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 `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 + let pos = Searchpos.lines_to_chars l ~text + c in try if txt.structure <> [] then - try Searchpos.search_pos_structure txt.structure :pos + 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 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 + Menu.popup menu ~x ~y else try Searchpos.search_pos_signature - txt.psignature :pos env:!Searchid.start_env; + 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 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 + Menu.popup menu ~x ~y with Not_found -> () let string_width s = @@ -247,54 +247,54 @@ let string_width s = 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,[`Lineend]) in - ignore (Str.string_match pat:reg line pos:0); + let `Linechar(l,c) = Text.index tw ~index:(ins,[]) + and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in + ignore (Str.string_match ~pat:reg line ~pos:0); let len = Str.match_end () in - if len < c then Text.insert tw index:(ins,[]) text:"\t" else + if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else let width = string_width (Str.matched_string line) in - Text.mark_set tw mark:"insert" index:(ins,[`Linestart;`Char len]); + Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]); let indent = if l <= 1 then 2 else let previous = - Text.get tw start:(ins,[`Line(-1);`Linestart]) - end:(ins,[`Line(-1);`Lineend]) in - ignore (Str.string_match pat:reg previous pos:0); + Text.get tw ~start:(ins,[`Line(-1);`Linestart]) + ~stop:(ins,[`Line(-1);`Lineend]) in + ignore (Str.string_match ~pat:reg previous ~pos:0); let previous = Str.matched_string previous in let width_previous = string_width previous in if width_previous <= width then 2 else width_previous - width in - Text.insert tw index:(ins,[]) text:(String.make indent ' ') + Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ') (* The editor class *) -class editor :top :menus = object (self) - val file_menu = new Jg_menu.c "File" parent:menus - val edit_menu = new Jg_menu.c "Edit" parent:menus - val compiler_menu = new Jg_menu.c "Compiler" parent:menus - val module_menu = new Jg_menu.c "Modules" parent:menus - val window_menu = new Jg_menu.c "Windows" parent:menus +class editor ~top ~menus = object (self) + val file_menu = new Jg_menu.c "File" ~parent:menus + val edit_menu = new Jg_menu.c "Edit" ~parent:menus + val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus + val module_menu = new Jg_menu.c "Modules" ~parent:menus + val window_menu = new Jg_menu.c "Windows" ~parent:menus val label = - Checkbutton.create menus state:`Disabled - onvalue:"modified" offvalue:"unchanged" + Checkbutton.create menus ~state:`Disabled + ~onvalue:"modified" ~offvalue:"unchanged" val mutable current_dir = Unix.getcwd () val mutable error_messages = [] val mutable windows = [] val mutable current_tw = Text.create top - val vwindow = Textvariable.create on:top () + val vwindow = Textvariable.create ~on:top () val mutable window_counter = 0 method reset_window_menu = - Menu.delete window_menu#menu first:(`Num 0) last:`End; + Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End; List.iter - (Sort.list windows order: + (Sort.list windows ~order: (fun w1 w2 -> Filename.basename w1.name < Filename.basename w2.name)) - f: + ~f: begin fun txt -> Menu.add_radiobutton window_menu#menu - label:(Filename.basename txt.name) - variable:vwindow value:txt.number - command:(fun () -> self#set_edit txt) + ~label:(Filename.basename txt.name) + ~variable:vwindow ~value:txt.number + ~command:(fun () -> self#set_edit txt) end method set_edit txt = @@ -303,74 +303,74 @@ class editor :top :menus = object (self) windows <- txt :: exclude txt windows; self#reset_window_menu; current_tw <- txt.tw; - Checkbutton.configure label text:(Filename.basename txt.name) - variable:txt.modified; + Checkbutton.configure label ~text:(Filename.basename txt.name) + ~variable:txt.modified; Textvariable.set vwindow txt.number; - Text.yview txt.tw scroll:(`Page 0); - pack [txt.frame] fill:`Both expand:true side:`Bottom + Text.yview txt.tw ~scroll:(`Page 0); + pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom method new_window name = let tl, tw, sb = Jg_text.create_with_scrollbar top in - Text.configure tw background:`White; + 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 (); + modified = Textvariable.create ~on:tw (); shell = None; structure = []; signature = []; psignature = [] } in let control c = Char.chr (Char.code c - 96) in - bind tw events:[`Modified([`Alt], `KeyPress)] action:ignore; - bind tw events:[`KeyPress] fields:[`Char] - action:(fun ev -> + bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore; + bind tw ~events:[`KeyPress] ~fields:[`Char] + ~action:(fun ev -> if ev.ev_Char <> "" & (ev.ev_Char.[0] >= ' ' or List.mem ev.ev_Char.[0] - (List.map f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) + (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) then Textvariable.set txt.modified "modified"); - bind tw events:[`KeyPressDetail"Tab"] breakable:true - action:(fun _ -> + bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true + ~action:(fun _ -> indent_line tw; Textvariable.set txt.modified "modified"; break ()); - bind tw events:[`Modified([`Control],`KeyPressDetail"k")] - action:(fun _ -> + bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")] + ~action:(fun _ -> let text = - Text.get tw start:(`Mark"insert",[]) end:(`Mark"insert",[`Lineend]) - in ignore (Str.string_match pat:(Str.regexp "[ \t]*") text pos:0); + Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend]) + in ignore (Str.string_match ~pat:(Str.regexp "[ \t]*") text ~pos:0); if Str.match_end () <> String.length text then begin Clipboard.clear (); - Clipboard.append data:text () + Clipboard.append ~data:text () end); - bind tw events:[`KeyRelease] fields:[`Char] - action:(fun ev -> + bind tw ~events:[`KeyRelease] ~fields:[`Char] + ~action:(fun ev -> if ev.ev_Char <> "" then - Lexical.tag tw start:(`Mark"insert", [`Linestart]) - end:(`Mark"insert", [`Lineend])); - bind tw events:[`Motion] action:(fun _ -> Focus.set tw); - bind tw events:[`ButtonPressDetail 2] - action:(fun _ -> + Lexical.tag tw ~start:(`Mark"insert", [`Linestart]) + ~stop:(`Mark"insert", [`Lineend])); + bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw); + bind tw ~events:[`ButtonPressDetail 2] + ~action:(fun _ -> Textvariable.set txt.modified "modified"; - Lexical.tag txt.tw start:(`Mark"insert", [`Linestart]) - end:(`Mark"insert", [`Lineend])); - bind tw events:[`Modified([`Double], `ButtonPressDetail 1)] - fields:[`MouseX;`MouseY] - action:(fun ev -> search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY); - bind tw events:[`ButtonPressDetail 3] fields:[`MouseX;`MouseY] - action:(fun ev -> search_pos_menu txt x:ev.ev_MouseX y:ev.ev_MouseY); - - pack [sb] fill:`Y side:`Right; - pack [tw] fill:`Both expand:true side:`Left; + Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart]) + ~stop:(`Mark"insert", [`Lineend])); + bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); + bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); + + pack [sb] ~fill:`Y ~side:`Right; + pack [tw] ~fill:`Both ~expand:true ~side:`Left; self#set_edit txt; Checkbutton.deselect label; Lexical.init_tags txt.tw method clear_errors () = - Text.tag_remove current_tw tag:"error" start:tstart end:tend; + Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; List.iter error_messages - f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); + ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); error_messages <- [] method typecheck () = @@ -378,7 +378,7 @@ class editor :top :menus = object (self) error_messages <- Typecheck.f (List.hd windows) method lex () = - Text.tag_remove current_tw tag:"error" start:tstart end:tend; + Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; Lexical.tag current_tw method save_text ?name:l txt = @@ -389,17 +389,17 @@ class editor :top :menus = object (self) try if Sys.file_exists name then if txt.name = name then - Sys.rename old:name new:(name ^ "~") + Sys.rename ~src:name ~dst:(name ^ "~") else begin match - Jg_message.ask master:top title:"Save" + 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 + let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in output_string file text; close_out file; - Checkbutton.configure label text:(Filename.basename name); + Checkbutton.configure label ~text:(Filename.basename name); Checkbutton.deselect label; txt.name <- name with @@ -411,17 +411,17 @@ class editor :top :menus = object (self) try let index = try - self#set_edit (List.find windows f:(fun x -> x.name = name)); + self#set_edit (List.find windows ~f:(fun x -> x.name = name)); let txt = List.hd windows in if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask master:top title:"Open" + 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", []), []) + (Text.index current_tw ~index:(`Mark"insert", []), []) with Not_found -> self#new_window name; tstart in current_dir <- Filename.dirname name; @@ -429,16 +429,16 @@ class editor :top :menus = object (self) and tw = current_tw and len = ref 0 and buf = String.create 4096 in - Text.delete tw start:tstart end:tend; + Text.delete tw ~start:tstart ~stop:tend; while - len := input file :buf pos:0 len:4096; + len := input file ~buf ~pos:0 ~len:4096; !len > 0 do - Jg_text.output tw :buf pos:0 len:!len + Jg_text.output tw ~buf ~pos:0 ~len:!len done; close_in file; - Text.mark_set tw mark:"insert" :index; - Text.see tw :index; + Text.mark_set tw ~mark:"insert" ~index; + Text.see tw ~index; if Filename.check_suffix name ".ml" or Filename.check_suffix name ".mli" then begin @@ -451,7 +451,7 @@ class editor :top :menus = object (self) method close_window txt = try if Textvariable.get txt.modified = "modified" then - begin match Jg_message.ask master:top title:"Close" + begin match Jg_message.ask ~master:top ~title:"Close" ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") with `yes -> self#save_text txt | `no -> () @@ -465,8 +465,8 @@ class editor :top :menus = object (self) with Exit -> () method open_file () = - Fileselect.f title:"Open File" action:self#load_text - dir:current_dir filter:("*.{ml,mli}") sync:true () + 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) @@ -474,27 +474,27 @@ class editor :top :menus = object (self) method quit () = try - List.iter windows f: + List.iter windows ~f: begin fun txt -> if Textvariable.get txt.modified = "modified" then - match Jg_message.ask master:top title:"Quit" + 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 end; - bind top events:[`Destroy]; + bind top ~events:[`Destroy]; destroy top; break () with Exit -> break () - method reopen :file :pos = + 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.mark_set current_tw ~mark:"insert" ~index:(tpos pos); Text.yview_index current_tw - index:(`Linechar(1,0),[`Char pos; `Line (-2)]) + ~index:(`Linechar(1,0),[`Char pos; `Line (-2)]) initializer (* Create a first window *) @@ -508,60 +508,60 @@ class editor :top :menus = object (self) [`Alt], "x", (fun () -> send_phrase (List.hd windows)); [`Alt], "l", self#lex; [`Alt], "t", self#typecheck ] - f:begin fun (modi,key,act) -> - bind top events:[`Modified(modi, `KeyPressDetail key)] breakable:true - action:(fun _ -> act (); break ()) + ~f:begin fun (modi,key,act) -> + bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true + ~action:(fun _ -> act (); break ()) end; - bind top events:[`Destroy] breakable:true fields:[`Widget] action: + bind top ~events:[`Destroy] ~breakable:true ~fields:[`Widget] ~action: begin fun ev -> if Widget.name ev.ev_Widget = Widget.name top then self#quit () end; (* File menu *) - file_menu#add_command "Open File..." command:self#open_file; + file_menu#add_command "Open File..." ~command:self#open_file; file_menu#add_command "Reopen" - command:(fun () -> self#load_text [(List.hd windows).name]); - file_menu#add_command "Save File" command:self#save_file accelerator:"M-s"; - file_menu#add_command "Save As..." underline:5 command: + ~command:(fun () -> self#load_text [(List.hd windows).name]); + file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s"; + file_menu#add_command "Save As..." ~underline:5 ~command: begin fun () -> let txt = List.hd windows in - Fileselect.f title:"Save as File" - action:(fun name -> self#save_text txt :name) - dir:(Filename.dirname txt.name) - filter:"*.{ml,mli}" - file:(Filename.basename txt.name) - sync:true usepath:false () + 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; + 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: + edit_menu#add_command "Paste selection" ~command: begin fun () -> - Text.insert current_tw index:(`Mark"insert",[]) - text:(Selection.get displayof:top ()) + Text.insert current_tw ~index:(`Mark"insert",[]) + ~text:(Selection.get ~displayof:top ()) end; - edit_menu#add_command "Goto..." accelerator:"C-g" - command:(fun () -> goto_line current_tw); - edit_menu#add_command "Search..." accelerator:"C-s" - command:(fun () -> Jg_text.search_string current_tw); - edit_menu#add_command "To shell" accelerator:"M-x" - command:(fun () -> send_phrase (List.hd windows)); + edit_menu#add_command "Goto..." ~accelerator:"C-g" + ~command:(fun () -> goto_line current_tw); + edit_menu#add_command "Search..." ~accelerator:"C-s" + ~command:(fun () -> Jg_text.search_string current_tw); + edit_menu#add_command "To shell" ~accelerator:"M-x" + ~command:(fun () -> send_phrase (List.hd windows)); edit_menu#add_command "Select shell..." - command:(fun () -> select_shell (List.hd windows)); + ~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; + ~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: + ~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 @@ -571,47 +571,47 @@ class editor :top :menus = object (self) Env.add_module (Ident.create modname) (Types.Tmty_signature txt.signature) Env.initial - in Viewer.view_defined (Longident.Lident modname) :env + in Viewer.view_defined (Longident.Lident modname) ~env end; (* Modules *) module_menu#add_command "Path editor..." - command:(fun () -> Setpath.set dir:current_dir); + ~command:(fun () -> Setpath.set ~dir:current_dir); module_menu#add_command "Reset cache" - command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); + ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); module_menu#add_command "Search symbol..." - command:Viewer.search_symbol; + ~command:Viewer.search_symbol; module_menu#add_command "Close all" - command:Viewer.close_all_views; + ~command:Viewer.close_all_views; (* pack everything *) - pack (List.map f:(fun m -> coe m#button) + pack (List.map ~f:(fun m -> coe m#button) [file_menu; edit_menu; compiler_menu; module_menu; window_menu] @ [coe label]) - side:`Left ipadx:5 anchor:`W; - pack [menus] before:(List.hd windows).frame side:`Top fill:`X + ~side:`Left ~ipadx: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) () = +let editor ?file ?(pos=0) () = if match !already_open with None -> false | Some ed -> - try ed#reopen :file :pos; true + try ed#reopen ~file ~pos; true with Protocol.TkError _ -> already_open := None; false then () else let top = Jg_toplevel.titled "Editor" in - let menus = Frame.create top name:"menubar" in - let ed = new editor :top :menus in + let menus = Frame.create top ~name:"menubar" in + let ed = new editor ~top ~menus in already_open := Some ed; - if file <> None then ed#reopen :file :pos + if file <> None then ed#reopen ~file ~pos -let f ?:file ?:pos ?(:opendialog=false) () = +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 () + 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/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml index 2553591a0..df95db012 100644 --- a/otherlibs/labltk/browser/fileselect.ml +++ b/otherlibs/labltk/browser/fileselect.ml @@ -23,66 +23,66 @@ open Tk (**** Memoized rexgexp *) -let (~) = Jg_memo.fast f:Str.regexp +let (~!) = Jg_memo.fast ~f:Str.regexp (************************************************************ Path name *) let parse_filter src = (* replace // by / *) - let s = global_replace pat:~"/+" templ:"/" src in + let s = global_replace ~pat:~!"/+" ~templ:"/" src in (* replace /./ by / *) - let s = global_replace pat:~"/\./" templ:"/" s in + let s = global_replace ~pat:~!"/\./" ~templ:"/" s in (* replace hoge/../ by "" *) let s = global_replace s - pat:~"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./" templ:"" in + ~pat:~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./" ~templ:"" in (* replace hoge/..$ by *) let s = global_replace s - pat:~"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$" templ:"" in + ~pat:~!"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$" ~templ:"" in (* replace ^/../../ by / *) - let s = global_replace pat:~"^\(/\.\.\)+/" templ:"/" s in - if string_match s pat:~"^\([^\*?[]*/\)\(.*\)" pos:0 then + let s = global_replace ~pat:~!"^\(/\.\.\)+/" ~templ:"/" s in + if string_match s ~pat:~!"^\([^\*?[]*/\)\(.*\)" ~pos:0 then let dirs = matched_group 1 s and ptrn = matched_group 2 s in dirs, ptrn else "", s -let rec fixpoint :f v = +let rec fixpoint ~f v = let v' = f v in - if v = v' then v else fixpoint :f v' + if v = v' then v else fixpoint ~f v' let unix_regexp s = - let s = Str.global_replace pat:~"[$^.+]" templ:"\\\\\\0" s in - let s = Str.global_replace pat:~"\\*" templ:".*" s in - let s = Str.global_replace pat:~"\\?" templ:".?" s in + let s = Str.global_replace ~pat:~!"[$^.+]" ~templ:"\\\\\\0" s in + let s = Str.global_replace ~pat:~!"\\*" ~templ:".*" s in + let s = Str.global_replace ~pat:~!"\\?" ~templ:".?" s in let s = fixpoint s - f:(Str.replace_first pat:~"\\({.*\\),\\(.*}\\)" templ:"\\1\\|\\2") in + ~f:(Str.replace_first ~pat:~!"\\({.*\\),\\(.*}\\)" ~templ:"\\1\\|\\2") in let s = - Str.global_replace pat:~"{\\(.*\\)}" templ:"\\(\\1\\)" s in + Str.global_replace ~pat:~!"{\\(.*\\)}" ~templ:"\\(\\1\\)" s in Str.regexp s -let exact_match s :pat = - Str.string_match :pat s pos:0 & Str.match_end () = String.length s +let exact_match s ~pat = + Str.string_match ~pat s ~pos:0 & Str.match_end () = String.length s -let ls :dir :pattern = +let ls ~dir ~pattern = let files = get_files_in_directory dir in let regexp = unix_regexp pattern in - List.filter files f:(exact_match pat:regexp) + List.filter files ~f:(exact_match ~pat:regexp) (* -let ls :dir :pattern = - subshell cmd:("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") +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 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 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 @@ -90,27 +90,27 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) let tl = Jg_toplevel.titled title in Focus.set tl; - let new_var () = Textvariable.create on:tl () in + let new_var () = Textvariable.create ~on:tl () in let filter_var = new_var () and selection_var = new_var () and sync_var = new_var () in Textvariable.set filter_var deffilter; - let frm = Frame.create tl borderwidth:1 relief:`Raised in + let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in let df = Frame.create frm in let dfl = Frame.create df in - let dfll = Label.create dfl text:"Directories" in + let dfll = Label.create dfl ~text:"Directories" in let dflf, directory_listbox, directory_scrollbar = Jg_box.create_with_scrollbar dfl in let dfr = Frame.create df in - let dfrl = Label.create dfr text:"Files" in + let dfrl = Label.create dfr ~text:"Files" in let dfrf, filter_listbox, filter_scrollbar = Jg_box.create_with_scrollbar dfr in - let cfrm = Frame.create tl borderwidth:1 relief:`Raised in + let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in - let configure :filter = + let configure ~filter = let filter = - if string_match pat:~"^/.*" filter pos:0 + if string_match ~pat:~!"^/.*" filter ~pos:0 then filter else !current_dir ^ "/" ^ filter in @@ -121,34 +121,34 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) current_pattern := pattern; let filter = if !load_in_path & usepath then pattern else dir ^ pattern in - let directories = get_directories_in_files path:dir + let directories = get_directories_in_files ~path:dir (get_files_in_directory dir) in let matched_files = (* get matched file by subshell call. *) if !load_in_path & usepath then - List.fold_left !Config.load_path init:[] f: + List.fold_left !Config.load_path ~init:[] ~f: begin fun acc dir -> - let files = ls :dir :pattern in - Sort.merge order:(<) files - (List.fold_left files init:acc - f:(fun acc name -> List2.exclude name acc)) + let files = ls ~dir ~pattern in + Sort.merge ~order:(<) files + (List.fold_left files ~init:acc + ~f:(fun acc name -> List2.exclude name acc)) end else - List.fold_left directories init:(ls :dir :pattern) - f:(fun acc dir -> List2.exclude dir acc) + List.fold_left directories ~init:(ls ~dir ~pattern) + ~f:(fun acc dir -> List2.exclude dir acc) in Textvariable.set filter_var filter; Textvariable.set selection_var (dir ^ deffile); - Listbox.delete filter_listbox first:(`Num 0) last:`End; - Listbox.insert filter_listbox index:`End texts:matched_files; - Jg_box.recenter filter_listbox index:(`Num 0); + 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 + 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) + 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 @@ -158,13 +158,13 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) destroy tl; let l = if !load_in_path & usepath then - List.fold_right l init:[] f: + List.fold_right l ~init:[] ~f: begin fun name acc -> if name <> "" & name.[0] = '/' then name :: acc else - try search_in_path :name :: acc with Not_found -> acc + try search_in_path ~name :: acc with Not_found -> acc end else - List.map l f: + List.map l ~f: begin fun x -> if x <> "" & x.[0] = '/' then x else !current_dir ^ "/" ^ x @@ -179,106 +179,106 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) in (* entries *) - let fl = Label.create frm text:"Filter" in - let sl = Label.create frm text:"Selection" in - let filter_entry = Jg_entry.create frm textvariable:filter_var - command:(fun filter -> configure :filter) in - let selection_entry = Jg_entry.create frm textvariable:selection_var - command:(fun file -> activate [file]) in + let fl = Label.create frm ~text:"Filter" in + let sl = Label.create frm ~text:"Selection" in + let filter_entry = Jg_entry.create frm ~textvariable:filter_var + ~command:(fun filter -> configure ~filter) in + let selection_entry = Jg_entry.create frm ~textvariable:selection_var + ~command:(fun file -> activate [file]) in (* and buttons *) - let set_path = Button.create dfl text:"Path editor" command: + let set_path = Button.create dfl ~text:"Path editor" ~command: begin fun () -> - Setpath.add_update_hook (fun () -> configure filter:!current_pattern); - let w = Setpath.f dir:!current_dir in + Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern); + let w = Setpath.f ~dir:!current_dir in Grab.set w; - bind w events:[`Destroy] extend:true action:(fun _ -> Grab.set tl) + bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl) end in - let toggle_in_path = Checkbutton.create dfl text:"Use load path" - command: + let toggle_in_path = Checkbutton.create dfl ~text:"Use load path" + ~command: begin fun () -> load_in_path := not !load_in_path; if !load_in_path then - pack [set_path] side:`Bottom fill:`X expand:true + pack [set_path] ~side:`Bottom ~fill:`X ~expand:true else Pack.forget [set_path]; - configure filter:(Textvariable.get filter_var) + configure ~filter:(Textvariable.get filter_var) end - and okb = Button.create cfrm text:"Ok" command: + and okb = Button.create cfrm ~text:"Ok" ~command: begin fun () -> let files = - List.map (Listbox.curselection filter_listbox) f: + List.map (Listbox.curselection filter_listbox) ~f: begin fun x -> - !current_dir ^ Listbox.get filter_listbox index:x + !current_dir ^ Listbox.get filter_listbox ~index:x end in let files = if files = [] then [Textvariable.get selection_var] else files in activate [Textvariable.get selection_var] end - and flb = Button.create cfrm text:"Filter" - command:(fun () -> configure filter:(Textvariable.get filter_var)) - and ccb = Button.create cfrm text:"Cancel" - command:(fun () -> activate []) in + and flb = Button.create cfrm ~text:"Filter" + ~command:(fun () -> configure ~filter:(Textvariable.get filter_var)) + and ccb = Button.create cfrm ~text:"Cancel" + ~command:(fun () -> activate []) in (* binding *) - bind tl events:[`KeyPressDetail "Escape"] action:(fun _ -> activate []); + bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []); Jg_box.add_completion filter_listbox - action:(fun index -> activate [Listbox.get filter_listbox :index]); - if multi then Listbox.configure filter_listbox selectmode:`Multiple else - bind filter_listbox events:[`ButtonPressDetail 1] fields:[`MouseY] - action:(fun ev -> + ~action:(fun index -> activate [Listbox.get filter_listbox ~index]); + if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else + bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY] + ~action:(fun ev -> let name = Listbox.get filter_listbox - index:(Listbox.nearest filter_listbox y:ev.ev_MouseY) in + ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in if !load_in_path & usepath then - try Textvariable.set selection_var (search_in_path :name) + try Textvariable.set selection_var (search_in_path ~name) with Not_found -> () else Textvariable.set selection_var (!current_dir ^ "/" ^ name)); - Jg_box.add_completion directory_listbox action: + Jg_box.add_completion directory_listbox ~action: begin fun index -> let filter = !current_dir ^ "/" ^ - (Listbox.get directory_listbox :index) ^ + (Listbox.get directory_listbox ~index) ^ "/" ^ !current_pattern - in configure :filter + in configure ~filter end; - pack [frm] fill:`Both expand:true; + pack [frm] ~fill:`Both ~expand:true; (* filter *) - pack [fl] side:`Top anchor:`W; - pack [filter_entry] side:`Top fill:`X; + pack [fl] ~side:`Top ~anchor:`W; + pack [filter_entry] ~side:`Top ~fill:`X; (* directory + files *) - pack [df] side:`Top fill:`Both expand:true; + 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; + 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; + 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; + 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; + 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; + else configure ~filter:deffilter; Tkwait.visibility tl; Grab.set tl; diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml index 91eb610c6..958401add 100644 --- a/otherlibs/labltk/browser/jg_bind.ml +++ b/otherlibs/labltk/browser/jg_bind.ml @@ -16,12 +16,12 @@ open Tk let enter_focus w = - bind w events:[`Enter] action:(fun _ -> Focus.set w) + bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) let escape_destroy ?destroy:tl w = let tl = match tl with Some w -> w | None -> w in - bind w events:[`KeyPressDetail "Escape"] action:(fun _ -> destroy tl) + bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl) -let return_invoke w :button = - bind w events:[`KeyPressDetail "Return"] - action:(fun _ -> Button.invoke button) +let return_invoke w ~button = + bind w ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> Button.invoke button) diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml index 1194c8ab8..1b9643ffa 100644 --- a/otherlibs/labltk/browser/jg_box.ml +++ b/otherlibs/labltk/browser/jg_box.ml @@ -17,56 +17,56 @@ open Tk let add_scrollbar lb = let sb = - Scrollbar.create (Winfo.parent lb) command:(Listbox.yview lb) in - Listbox.configure lb yscrollcommand:(Scrollbar.set sb); sb + Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in + Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb -let create_with_scrollbar ?:selectmode parent = +let create_with_scrollbar ?selectmode parent = let frame = Frame.create parent in - let lb = Listbox.create frame ?:selectmode in + let lb = Listbox.create frame ?selectmode in frame, lb, add_scrollbar lb (* from frx_listbox,adapted *) -let recenter lb :index = - Listbox.selection_clear lb first:(`Num 0) last:`End; +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 + Listbox.activate lb ~index; + Listbox.selection_anchor lb ~index; + Listbox.yview_index lb ~index -class timed ?:wait ?:nocase get_texts = object +class timed ?wait ?nocase get_texts = object val get_texts = get_texts - inherit Jg_completion.timed [] ?:wait ?:nocase as super + inherit Jg_completion.timed [] ?wait ?nocase as super method reset = texts <- get_texts (); super#reset end -let add_completion ?:action ?:wait ?:nocase lb = +let add_completion ?action ?wait ?nocase lb = let comp = - new timed ?:wait ?:nocase - (fun () -> Listbox.get_range lb first:(`Num 0) last:`End) in + new timed ?wait ?nocase + (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in Jg_bind.enter_focus lb; - bind lb events:[`KeyPress] fields:[`Char] action: + bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: begin fun ev -> (* consider only keys producing characters. The callback is called even if you press Shift. *) if ev.ev_Char <> "" then - recenter lb index:(`Num (comp#add ev.ev_Char)) + recenter lb ~index:(`Num (comp#add ev.ev_Char)) end; begin match action with Some action -> - bind lb events:[`KeyPressDetail "Return"] - action:(fun _ -> action `Active); - bind lb events:[`Modified([`Double], `ButtonPressDetail 1)] - breakable:true fields:[`MouseY] - action:(fun ev -> - action (Listbox.nearest lb y:ev.ev_MouseY); break ()) + bind lb ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> action `Active); + bind lb ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~breakable:true ~fields:[`MouseY] + ~action:(fun ev -> + action (Listbox.nearest lb ~y:ev.ev_MouseY); break ()) | None -> () end; - recenter lb index:(`Num 0) (* so that first item is active *) + 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 index 0461eece6..5a0a733d8 100644 --- a/otherlibs/labltk/browser/jg_button.ml +++ b/otherlibs/labltk/browser/jg_button.ml @@ -15,10 +15,10 @@ open Tk -let create_destroyer :parent ?(:text="Ok") tl = - Button.create parent :text command:(fun () -> destroy tl) +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; +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 index 130c56919..9217fcf45 100644 --- a/otherlibs/labltk/browser/jg_completion.ml +++ b/otherlibs/labltk/browser/jg_completion.ml @@ -13,10 +13,10 @@ (* $Id$ *) -let lt_string ?(:nocase=false) s1 s2 = +let lt_string ?(nocase=false) s1 s2 = if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2 -class completion ?:nocase texts = object +class completion ?nocase texts = object val mutable texts = texts val nocase = nocase val mutable prefix = "" @@ -24,7 +24,7 @@ class completion ?:nocase texts = object method add c = prefix <- prefix ^ c; while current < List.length texts - 1 & - lt_string (List.nth texts current) prefix ?:nocase + lt_string (List.nth texts current) prefix ?nocase do current <- current + 1 done; @@ -36,8 +36,8 @@ class completion ?:nocase texts = object current <- 0 end -class timed ?:nocase ?:wait texts = object (self) - inherit completion texts ?:nocase as super +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 = @@ -45,7 +45,7 @@ class timed ?:nocase ?:wait texts = object (self) None -> self#reset | Some t -> Timer.remove t end; - timer <- Some (Timer.add ms:wait callback:(fun () -> self#reset)); + timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); super#add c method reset = timer <- None; super#reset diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml index 610f850f8..a65d6b6e4 100644 --- a/otherlibs/labltk/browser/jg_config.ml +++ b/otherlibs/labltk/browser/jg_config.ml @@ -19,20 +19,20 @@ let variable = if Sys.os_type = "Win32" then "Arial 9" else "variable" let init () = - if Sys.os_type = "Win32" then Option.add path:"*font" fixed; + if Sys.os_type = "Win32" then Option.add ~path:"*font" fixed; let font = let font = - Option.get Widget.default_toplevel name:"variableFont" class:"Font" in + Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in if font = "" then variable else font in List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] - f:(fun cl -> Option.add path:("*" ^ cl ^ ".font") font); - Option.add path:"*Menu.tearOff" "0" priority:`StartupFile; - Option.add path:"*Button.padY" "0" priority:`StartupFile; - Option.add path:"*Text.highlightThickness" "0" priority:`StartupFile; - Option.add path:"*interface.background" "gray85" priority:`StartupFile; + ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font); + Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile; + Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile; + Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile; + Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile; let foreground = Option.get Widget.default_toplevel - name:"disabledForeground" class:"Foreground" in + ~name:"disabledForeground" ~clas:"Foreground" in if foreground = "" then - Option.add path:"*disabledForeground" "black" + Option.add ~path:"*disabledForeground" "black" diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml index 04cd454bd..c662bed85 100644 --- a/otherlibs/labltk/browser/jg_entry.ml +++ b/otherlibs/labltk/browser/jg_entry.ml @@ -15,12 +15,12 @@ open Tk -let create ?:command ?:width ?:textvariable parent = - let ew = Entry.create parent ?:width ?:textvariable in +let create ?command ?width ?textvariable parent = + let ew = Entry.create parent ?width ?textvariable in Jg_bind.enter_focus ew; begin match command with Some command -> - bind ew events:[`KeyPressDetail "Return"] - action:(fun _ -> command (Entry.get ew)) + bind ew ~events:[`KeyPressDetail "Return"] + ~action:(fun _ -> command (Entry.get ew)) | None -> () end; ew diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml index f6f6e773b..70c6da2d1 100644 --- a/otherlibs/labltk/browser/jg_memo.ml +++ b/otherlibs/labltk/browser/jg_memo.ml @@ -22,7 +22,7 @@ let rec assq key = function | Cons (a, b, l) -> if key == a then b else assq key l -let fast :f = +let fast ~f = let memo = ref Nil in fun key -> try assq key !memo diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml index ca60e685f..e92b7e889 100644 --- a/otherlibs/labltk/browser/jg_menu.ml +++ b/otherlibs/labltk/browser/jg_menu.ml @@ -15,12 +15,12 @@ open Tk -class c :parent ?(underline:n=0) text = object (self) +class c ~parent ?underline:(n=0) text = object (self) val pair = let button = - Menubutton.create parent :text underline:n in + Menubutton.create parent ~text ~underline:n in let menu = Menu.create button in - Menubutton.configure button :menu; + Menubutton.configure button ~menu; button, menu method button = fst pair method menu = snd pair @@ -32,10 +32,10 @@ class c :parent ?(underline:n=0) text = object (self) ?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 + 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 index f36cda643..0de81640f 100644 --- a/otherlibs/labltk/browser/jg_message.ml +++ b/otherlibs/labltk/browser/jg_message.ml @@ -17,32 +17,32 @@ open Tk open Jg_tk (* -class formatted :parent :width :maxheight :minheight = +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 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; + 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 () -> ()) + 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)); + 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 + pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y end *) -let formatted :title ?:on ?(:ppf = Format.std_formatter) - ?(:width=60) ?(:maxheight=10) ?(:minheight=0) () = +let formatted ~title ?on ?(ppf = Format.std_formatter) + ?(width=60) ?(maxheight=10) ?(minheight=0) () = let tl, frame = match on with Some frame -> coe frame, frame @@ -50,47 +50,47 @@ let formatted :title ?:on ?(:ppf = Format.std_formatter) let tl = Jg_toplevel.titled title in Jg_bind.escape_destroy tl; let frame = Frame.create tl in - pack [frame] side:`Top fill:`Both expand:true; + pack [frame] ~side:`Top ~fill:`Both ~expand:true; coe tl, frame in - let tw = Text.create frame :width wrap:`Word in - pack [tw] side:`Left fill:`Both expand:true; + let tw = Text.create frame ~width ~wrap:`Word in + pack [tw] ~side:`Left ~fill:`Both ~expand:true; Format.pp_print_flush ppf (); Format.pp_set_margin ppf (width - 2); let fof,fff = Format.pp_get_formatter_output_functions ppf () in Format.pp_set_formatter_output_functions ppf - out:(Jg_text.output tw) flush:(fun () -> ()); + ~out:(Jg_text.output tw) ~flush:(fun () -> ()); tl, tw, begin fun () -> Format.pp_print_flush ppf (); - Format.pp_set_formatter_output_functions ppf out:fof flush:fff; - let `Linechar (l, _) = Text.index tw index:(tposend 1) in - Text.configure tw height:(max minheight (min l maxheight)); + Format.pp_set_formatter_output_functions ppf ~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 + pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y end -let ask :title ?:master text = +let ask ~title ?master text = let tl = Jg_toplevel.titled title in begin match master with None -> () - | Some master -> Wm.transient_set tl :master + | Some master -> Wm.transient_set tl ~master end; - let mw = Message.create tl :text padx:20 pady:10 - width:250 justify:`Left aspect:400 anchor:`W + let mw = Message.create tl ~text ~padx:20 ~pady:10 + ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W and fw = Frame.create tl - and sync = Textvariable.create on:tl () + and sync = Textvariable.create ~on:tl () and r = ref (`cancel : [`yes|`no|`cancel]) in - let accept = Button.create fw text:"Yes" - command:(fun () -> r := `yes; destroy tl) - and refuse = Button.create fw text:"No" - command:(fun () -> r := `no; destroy tl) - and cancel = Jg_button.create_destroyer tl parent:fw text:"Cancel" + let accept = Button.create fw ~text:"Yes" + ~command:(fun () -> r := `yes; destroy tl) + and refuse = Button.create fw ~text:"No" + ~command:(fun () -> r := `no; destroy tl) + and cancel = Jg_button.create_destroyer tl ~parent:fw ~text:"Cancel" in - bind tl events:[`Destroy] extend:true - action:(fun _ -> Textvariable.set sync "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; + bind tl ~events:[`Destroy] ~extend:true + ~action:(fun _ -> Textvariable.set sync "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_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml index bdf5143c3..5fb90b494 100644 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -13,14 +13,14 @@ (* $Id$ *) -let rec gen_list f:f :len = - if len = 0 then [] else f () :: gen_list f:f len:(len - 1) +let rec gen_list ~f:f ~len = + if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1) -let rec make_list :len :fill = - if len = 0 then [] else fill :: make_list len:(len - 1) :fill +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 = +let rec firsts ~len l = if len = 0 then ([],l) else match l with a::l -> @@ -29,37 +29,37 @@ let rec firsts :len l = | [] -> (l,[]) -let rec split :len = function +let rec split ~len = function [] -> [] | l -> - let (f,r) = firsts l :len in - let ret = split :len r in + let (f,r) = firsts l ~len in + let ret = split ~len r in f :: ret -let extend l :len :fill = +let extend l ~len ~fill = if List.length l >= len then l - else l @ make_list :fill len:(len - List.length l) + else l @ make_list ~fill len:(len - List.length l) *) (* By row version *) -let rec first l :len = +let rec first l ~len = if len = 0 then [], l else match l with - [] -> make_list :len fill:"", [] + [] -> make_list ~len ~fill:"", [] | a::l -> - let (l',r) = first len:(len - 1) l in a::l',r + let (l',r) = first ~len:(len - 1) l in a::l',r -let rec split l :len = - if l = [] then make_list :len fill:[] else - let (cars,r) = first l :len in - let cdrs = split r :len in - List.map2 cars cdrs f:(fun a l -> a::l) +let rec split l ~len = + if l = [] then make_list ~len ~fill:[] else + let (cars,r) = first l ~len in + let cdrs = split r ~len in + List.map2 cars cdrs ~f:(fun a l -> a::l) open Tk -class c :cols :texts ?:maxheight ?:width parent = object (self) +class c ~cols ~texts ?maxheight ?width parent = object (self) val parent' = coe parent val length = List.length texts val boxes = @@ -68,11 +68,11 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) match maxheight with None -> height | Some max -> min max height in - gen_list len:cols f: + gen_list ~len:cols ~f: begin fun () -> - Listbox.create parent :height ?:width - highlightthickness:0 - borderwidth:1 + Listbox.create parent ~height ?width + ~highlightthickness:0 + ~borderwidth:1 end val mutable current = 0 method cols = cols @@ -80,7 +80,7 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) method parent = parent' method boxes = boxes method current = current - method recenter ?(:aligntop=false) n = + method recenter ?(aligntop=false) n = current <- if n < 0 then 0 else if n < length then n else length - 1; @@ -88,27 +88,27 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) You have to be in Extended or Browse mode *) let box = List.nth boxes (current mod cols) and index = `Num (current / cols) in - List.iter boxes f: + List.iter boxes ~f: begin fun box -> - Listbox.selection_clear box first:(`Num 0) last:`End; - Listbox.selection_anchor box :index; - Listbox.activate box :index + 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; + if aligntop then Listbox.yview_index box ~index + else Listbox.see box ~index; let (first,last) = Listbox.yview_get box in - List.iter boxes f:(Listbox.yview scroll:(`Moveto first)) + List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first)) method init = - let textl = split len:cols texts in - List.iter2 boxes textl f: + let textl = split ~len:cols texts in + List.iter2 boxes textl ~f: begin fun box texts -> Jg_bind.enter_focus box; - Listbox.insert box :texts index:`End + 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 ()); + 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)) @@ -123,31 +123,31 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) "Next", (fun n -> n + current_height () * cols); "Home", (fun _ -> 0); "End", (fun _ -> List.length texts) ] - f:begin fun (key,f) -> - self#bind_kbd events:[`KeyPressDetail key] - action:(fun _ index:n -> self#recenter (f n); break ()) + ~f:begin fun (key,f) -> + self#bind_kbd ~events:[`KeyPressDetail key] + ~action:(fun _ ~index:n -> self#recenter (f n); break ()) end; self#recenter 0 - method bind_mouse :events :action = + method bind_mouse ~events ~action = let i = ref 0 in - List.iter boxes f: + List.iter boxes ~f: begin fun box -> let b = !i in - bind box :events breakable:true fields:[`MouseX;`MouseY] - action:(fun ev -> - let `Num n = Listbox.nearest box y:ev.ev_MouseY - in action ev index:(n * cols + b)); + bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY] + ~action:(fun ev -> + let `Num n = Listbox.nearest box ~y:ev.ev_MouseY + in action ev ~index:(n * cols + b)); incr i end - method bind_kbd :events :action = + method bind_kbd ~events ~action = let i = ref 0 in - List.iter boxes f: + List.iter boxes ~f: begin fun box -> let b = !i in - bind box :events breakable:true fields:[`Char] - action:(fun ev -> - let `Num n = Listbox.index box index:`Active in - action ev index:(n * cols + b)); + bind box ~events ~breakable:true ~fields:[`Char] + ~action:(fun ev -> + let `Num n = Listbox.index box ~index:`Active in + action ev ~index:(n * cols + b)); incr i end end @@ -156,27 +156,27 @@ let add_scrollbar (box : c) = let boxes = box#boxes in let sb = Scrollbar.create (box#parent) - command:(fun :scroll -> List.iter boxes f:(Listbox.yview :scroll)) in + ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in List.iter boxes - f:(fun lb -> Listbox.configure lb yscrollcommand:(Scrollbar.set sb)); - pack [sb] before:(List.hd boxes) side:`Right fill:`Y; + ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb)); + pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y; sb -let add_completion ?:action ?:wait (box : c) = - let comp = new Jg_completion.timed (box#texts) ?:wait in - box#bind_kbd events:[`KeyPress] - action:(fun ev :index -> +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); + 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#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_text.ml b/otherlibs/labltk/browser/jg_text.ml index 910cd518d..97e071a6e 100644 --- a/otherlibs/labltk/browser/jg_text.ml +++ b/otherlibs/labltk/browser/jg_text.ml @@ -16,59 +16,59 @@ open Tk open Jg_tk -let get_all tw = Text.get tw start:tstart end:(tposend 1) +let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1) -let tag_and_see tw :tag :start :end = - Text.tag_remove tw start:(tpos 0) end:tend :tag; - Text.tag_add tw :start :end :tag; +let tag_and_see tw ~tag ~start ~stop = + Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag; + Text.tag_add tw ~start ~stop ~tag; try - Text.see tw index:(`Tagfirst tag, []); - Text.mark_set tw mark:"insert" index:(`Tagfirst tag, []) + Text.see tw ~index:(`Tagfirst tag, []); + Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, []) with Protocol.TkError _ -> () -let output tw :buf :pos :len = - Text.insert tw index:tend text:(String.sub buf :pos :len) +let output tw ~buf ~pos ~len = + Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len) let add_scrollbar tw = - let sb = Scrollbar.create (Winfo.parent tw) command:(Text.yview tw) - in Text.configure tw yscrollcommand:(Scrollbar.set sb); sb + let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw) + in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb let create_with_scrollbar parent = let frame = Frame.create parent in let tw = Text.create frame in frame, tw, add_scrollbar tw -let goto_tag tw :tag = +let goto_tag tw ~tag = let index = (`Tagfirst tag, []) in - try Text.see tw :index; - Text.mark_set tw :index mark:"insert" + 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; + Wm.transient_set tl ~master:Widget.default_toplevel; let fi = Frame.create tl and fd = Frame.create tl and fm = Frame.create tl and buttons = Frame.create tl - and direction = Textvariable.create on:tl () - and mode = Textvariable.create on:tl () - and count = Textvariable.create on:tl () + and direction = Textvariable.create ~on:tl () + and mode = Textvariable.create ~on:tl () + and count = Textvariable.create ~on:tl () in - let label = Label.create fi text:"Pattern:" - and text = Entry.create fi width:20 - and back = Radiobutton.create fd variable:direction - text:"Backwards" value:"backward" - and forw = Radiobutton.create fd variable:direction - text:"Forwards" value:"forward" - and exact = Radiobutton.create fm variable:mode - text:"Exact" value:"exact" - and nocase = Radiobutton.create fm variable:mode - text:"No case" value:"nocase" - and regexp = Radiobutton.create fm variable:mode - text:"Regexp" value:"regexp" + let label = Label.create fi ~text:"Pattern:" + and text = Entry.create fi ~width:20 + and back = Radiobutton.create fd ~variable:direction + ~text:"Backwards" ~value:"backward" + and forw = Radiobutton.create fd ~variable:direction + ~text:"Forwards" ~value:"forward" + and exact = Radiobutton.create fm ~variable:mode + ~text:"Exact" ~value:"exact" + and nocase = Radiobutton.create fm ~variable:mode + ~text:"No case" ~value:"nocase" + and regexp = Radiobutton.create fm ~variable:mode + ~text:"Regexp" ~value:"regexp" in - let search = Button.create buttons text:"Search" command: + let search = Button.create buttons ~text:"Search" ~command: begin fun () -> try let pattern = Entry.get text in @@ -80,23 +80,23 @@ let search_string tw = | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> [] in let ndx = - Text.search tw :pattern switches:([dir;`Count count] @ mode) - start:(`Mark "insert", [`Char ofs]) + 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))]) + tag_and_see tw ~tag:"sel" ~start:(ndx,[]) + ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))]) with Invalid_argument _ -> () end - and ok = Jg_button.create_destroyer tl parent:buttons text:"Cancel" in + and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set text; - Jg_bind.return_invoke text button:search; + Jg_bind.return_invoke text ~button:search; Jg_bind.escape_destroy tl; Textvariable.set direction "forward"; Textvariable.set mode "nocase"; - pack [label] side:`Left; - pack [text] side:`Right fill:`X expand:true; - pack [back; forw] side:`Left; - pack [exact; nocase; regexp] side:`Left; - pack [search; ok] side:`Left fill:`X expand:true; - pack [fi; fd; fm; buttons] side:`Top fill:`X + 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 index fc7fc1a2f..4889f7076 100644 --- a/otherlibs/labltk/browser/jg_text.mli +++ b/otherlibs/labltk/browser/jg_text.mli @@ -18,7 +18,7 @@ open Widget val get_all : text widget -> string val tag_and_see : text widget -> - tag:Tk.textTag -> start:Tk.textIndex -> end:Tk.textIndex -> unit + tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit val output : text widget -> buf:string -> pos:int -> len:int -> unit val add_scrollbar : text widget -> scrollbar widget val create_with_scrollbar : diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml index fbae706ad..8b4fb1778 100644 --- a/otherlibs/labltk/browser/jg_toplevel.ml +++ b/otherlibs/labltk/browser/jg_toplevel.ml @@ -15,10 +15,10 @@ open Tk -let titled ?:iconname title = +let titled ?iconname title = let iconname = match iconname with None -> title | Some s -> s in let tl = Toplevel.create Widget.default_toplevel in - Wm.title_set tl :title; - Wm.iconname_set tl name:iconname; - Wm.group_set tl leader: Widget.default_toplevel; + Wm.title_set tl ~title; + Wm.iconname_set tl ~name:iconname; + Wm.group_set tl ~leader: Widget.default_toplevel; tl diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml index 655c3cc18..38dcb8f81 100644 --- a/otherlibs/labltk/browser/lexical.ml +++ b/otherlibs/labltk/browser/lexical.ml @@ -25,24 +25,28 @@ and colors = "indianred4"; "saddlebrown"; "midnightblue"] let init_tags tw = - List.iter2 tags colors f: + List.iter2 tags colors ~f: begin fun tag col -> - Text.tag_configure tw :tag foreground:(`Color 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" + 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=tend) tw = - let tpos c = (Text.index tw index:start, [`Char c]) in - let text = Text.get tw :start :end in +let tag ?(start=tstart) ?(stop=tend) tw = + let tpos c = (Text.index tw ~index:start, [`Char c]) in + let text = Text.get tw ~start ~stop in let buffer = Lexing.from_string text in List.iter tags - f:(fun tag -> Text.tag_remove tw :start :end :tag); + ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag); + let last = ref (EOF, 0, 0) in try while true do + let token = Lexer.token buffer + and start = Lexing.lexeme_start buffer + and stop = Lexing.lexeme_end buffer in let tag = - match Lexer.token buffer with + match token with AMPERAMPER | AMPERSAND | BARBAR @@ -108,17 +112,31 @@ let tag ?(:start=tstart) ?(:end=tend) tw = | SHARP -> "infix" | LABEL _ - | LABELID _ + | OPTLABEL _ | QUESTION + | TILDE -> "label" | UIDENT _ -> "uident" + | LIDENT _ -> + begin match !last with + (QUESTION | TILDE), _, _ -> "label" + | _ -> "" + end + | COLON -> + begin match !last with + LIDENT _, lstart, lstop -> + if lstop = start then + Text.tag_add tw ~tag:"label" + ~start:(tpos lstart) ~stop:(tpos stop); + "" + | _ -> "" + end | EOF -> raise End_of_file | _ -> "" in if tag <> "" then - Text.tag_add tw :tag - start:(tpos (Lexing.lexeme_start buffer)) - end:(tpos (Lexing.lexeme_end buffer)) + Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop); + last := (token, start, stop) done with End_of_file -> () diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli index 53a6c95f6..fa308b946 100644 --- a/otherlibs/labltk/browser/lexical.mli +++ b/otherlibs/labltk/browser/lexical.mli @@ -16,4 +16,4 @@ open Widget val init_tags : text widget -> unit -val tag : ?start:Tk.textIndex -> ?end:Tk.textIndex -> text widget -> unit +val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml index 80cac04ef..8ba876f25 100644 --- a/otherlibs/labltk/browser/list2.ml +++ b/otherlibs/labltk/browser/list2.ml @@ -13,8 +13,8 @@ (* $Id$ *) -let exclude x l = List.filter l f:((<>) x) +let exclude x l = List.filter l ~f:((<>) x) -let rec flat_map :f = function +let rec flat_map ~f = function [] -> [] - | x :: l -> f x @ flat_map :f l + | x :: l -> f x @ flat_map ~f l diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml index 994231268..0f6db0564 100644 --- a/otherlibs/labltk/browser/main.ml +++ b/otherlibs/labltk/browser/main.ml @@ -18,7 +18,7 @@ open Tk let _ = let path = ref [] in Arg.parse - keywords:[ "-I", Arg.String (fun s -> path := s :: !path), + ~keywords:["-I", Arg.String (fun s -> path := s :: !path), "<dir> Add <dir> to the list of include directories"; "-label", Arg.Unit (fun () -> Clflags.classic := false), "Use strict label syntax"; @@ -35,9 +35,9 @@ let _ = \032 U/u enable/disable unused match case\n\ \032 V/v enable/disable hidden instance variable\n\ \032 X/x enable/disable all other warnings\n\ - \032 default setting is A (all warnings enabled)" ] - others:(fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) - errmsg:"ocamlbrowser :"; + \032 default setting is A (all warnings enabled)"] + ~others:(fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) + ~errmsg:"ocamlbrowser :"; Config.load_path := List.rev !path @ [Config.standard_library]; Warnings.parse_options !Shell.warnings; Unix.putenv "TERM" "noterminal"; @@ -49,14 +49,14 @@ let _ = Searchpos.view_defined_ref := Viewer.view_defined; Searchpos.editor_ref.contents <- Editor.f; - let top = openTk class:"OCamlBrowser" () in + let top = openTk ~clas:"OCamlBrowser" () in Jg_config.init (); - bind top events:[`Destroy] action:(fun _ -> exit 0); + bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); at_exit Shell.kill_all; - Viewer.f on:top (); + Viewer.f ~on:top (); while true do try diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index c892992e2..2ce0d1674 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -51,17 +51,17 @@ let rec longident_of_path = function | 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 = +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) + | 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) + try remove_prefix ~prefix (remove_hd ~name lid) with Not_found -> lid let rec permutations l = match l with @@ -69,27 +69,27 @@ let rec permutations l = match l with | [a;b] -> [l; [b;a]] | _ -> let _, perms = - List.fold_left l init:(l,[]) f: + List.fold_left l ~init:(l,[]) ~f: begin fun (l, perms) a -> let l = List.tl l in l @ [a], - List.map (permutations l) f:(fun l -> a :: l) @ perms + List.map (permutations l) ~f:(fun l -> a :: l) @ perms end in perms -let rec choose n in:l = +let rec choose n ~card:l = let len = List.length l in if n = len then [l] else - if n = 1 then List.map l f:(fun x -> [x]) else + if n = 1 then List.map l ~f:(fun x -> [x]) else if n = 0 then [[]] else if n > len then [] else match l with [] -> [] | a :: l -> - List.map (choose (n-1) in:l) f:(fun l -> a :: l) - @ choose n in:l + List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) + @ choose n ~card:l -let rec arr p in:n = - if p = 0 then 1 else n * arr (p-1) in:(n-1) +let rec arr p ~card:n = + if p = 0 then 1 else n * arr (p-1) ~card:(n-1) let rec all_args ty = let ty = repr ty in @@ -97,7 +97,7 @@ let rec all_args ty = Tarrow(l, ty1, ty2) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) | _ -> ([], ty) -let rec equal :prefix t1 t2 = +let rec equal ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with Tvar, Tvar -> true | Tvariant row1, Tvariant row2 -> @@ -107,40 +107,40 @@ let rec equal :prefix t1 t2 = in let r1, r2, pairs = merge_row_fields fields1 fields2 in row1.row_closed = row2.row_closed & r1 = [] & r2 = [] & - List.for_all pairs f: + List.for_all pairs ~f: begin fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 :prefix + | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix | Reither(c1, tl1, _), Reither(c2, tl2, _) -> c1 = c2 & List.length tl1 = List.length tl2 & - List.for_all2 tl1 tl2 f:(equal :prefix) + List.for_all2 tl1 tl2 ~f:(equal ~prefix) | _ -> false end | Tarrow _, Tarrow _ -> let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - equal t1 t2 :prefix & + equal t1 t2 ~prefix & List.length l1 = List.length l2 & - List.exists (permutations l1) f: + List.exists (permutations l1) ~f: begin fun l1 -> - List.for_all2 l1 l2 f: + List.for_all2 l1 l2 ~f: begin fun (p1,t1) (p2,t2) -> - (p1 = "" or p1 = p2) & equal t1 t2 :prefix + (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 f:(equal :prefix) + List.for_all2 l1 l2 ~f:(equal ~prefix) | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix :prefix (longident_of_path p1) = (longident_of_path p2) + remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) & List.length l1 = List.length l2 - & List.for_all2 l1 l2 f:(equal :prefix) + & List.for_all2 l1 l2 ~f:(equal ~prefix) | _ -> false let is_opt s = s <> "" & s.[0] = '?' -let get_options = List.filter f:is_opt +let get_options = List.filter ~f:is_opt -let rec included :prefix t1 t2 = +let rec included ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with Tvar, _ -> true | Tvariant row1, Tvariant row2 -> @@ -150,71 +150,71 @@ let rec included :prefix t1 t2 = in let r1, r2, pairs = merge_row_fields fields1 fields2 in r1 = [] & - List.for_all pairs f: + List.for_all pairs ~f: begin fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None -> true - | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 :prefix + | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix | Reither(c1, tl1, _), Reither(c2, tl2, _) -> c1 = c2 & List.length tl1 = List.length tl2 & - List.for_all2 tl1 tl2 f:(included :prefix) + List.for_all2 tl1 tl2 ~f:(included ~prefix) | _ -> false end | Tarrow _, Tarrow _ -> let l1, t1 = all_args t1 and l2, t2 = all_args t2 in - included t1 t2 :prefix & + 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 l2 = if arr len1 ~card:len2 < 100 then l2 else let ll1 = get_options (fst (List.split l1)) in List.filter l2 - f:(fun (l,_) -> not (is_opt l) or List.mem l ll1) + ~f:(fun (l,_) -> not (is_opt l) or List.mem l ll1) in len1 <= len2 & - List.exists (List2.flat_map f:permutations (choose len1 in:l2)) f: + List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: begin fun l2 -> - List.for_all2 l1 l2 f: + List.for_all2 l1 l2 ~f: begin fun (p1,t1) (p2,t2) -> - (p1 = "" or p1 = p2) & included t1 t2 :prefix + (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 f:permutations (choose len1 in:l2)) f: + List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: begin fun l2 -> - List.for_all2 l1 l2 f:(included :prefix) + List.for_all2 l1 l2 ~f:(included ~prefix) end - | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 :prefix + | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> - remove_prefix :prefix (longident_of_path p1) = (longident_of_path p2) + remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) & List.length l1 = List.length l2 - & List.for_all2 l1 l2 f:(included :prefix) + & List.for_all2 l1 l2 ~f:(included ~prefix) | _ -> false let mklid = function [] -> raise (Invalid_argument "Searchid.mklid") | x :: l -> - List.fold_left l init:(Lident x) f:(fun acc x -> Ldot (acc, x)) + List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x)) let mkpath = function [] -> raise (Invalid_argument "Searchid.mklid") | x :: l -> - List.fold_left l init:(Pident (Ident.create x)) - f:(fun acc x -> Pdot (acc, x, 0)) + List.fold_left l ~init:(Pident (Ident.create x)) + ~f:(fun acc x -> Pdot (acc, x, 0)) -let get_fields :prefix :sign self = +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 rec search_type_in_signature t ~sign ~prefix ~mode = let matches = match mode with - `included -> included t :prefix - | `exact -> equal t :prefix + `included -> included t ~prefix + | `exact -> equal t ~prefix and lid_of_id id = mklid (prefix @ [Ident.name id]) in - List2.flat_map sign f: + List2.flat_map sign ~f: begin fun item -> match item with Tsig_value (id, vd) -> if matches vd.val_type then [lid_of_id id, Pvalue] else [] @@ -227,60 +227,60 @@ let rec search_type_in_signature t in:sign :prefix :mode = begin match td.type_kind with Type_abstract -> false | Type_variant l -> - List.exists l f:(fun (_, l) -> List.exists l f:matches) + List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) | Type_record(l, rep) -> - List.exists l f:(fun (_, _, t) -> matches t) + List.exists l ~f:(fun (_, _, t) -> matches t) end then [lid_of_id id, Ptype] else [] | Tsig_exception (id, l) -> - if List.exists l f:matches + if List.exists l ~f: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]) + search_type_in_signature t ~sign ~mode + ~prefix:(prefix @ [Ident.name id]) | Tsig_module _ -> [] | Tsig_modtype _ -> [] | Tsig_class (id, cl) -> let self = self_type cl.cty_type in if matches self or (match cl.cty_new with None -> false | Some ty -> matches ty) - (* or List.exists (get_fields :prefix :sign self) - f:(fun (_,_,ty_field) -> matches ty_field) *) + (* or List.exists (get_fields ~prefix ~sign self) + ~f:(fun (_,_,ty_field) -> matches ty_field) *) then [lid_of_id id, Pclass] else [] | Tsig_cltype (id, cl) -> let self = self_type cl.clty_type in if matches self - (* or List.exists (get_fields :prefix :sign self) - f:(fun (_,_,ty_field) -> matches ty_field) *) + (* or List.exists (get_fields ~prefix ~sign self) + ~f:(fun (_,_,ty_field) -> matches ty_field) *) then [lid_of_id id, Pclass] else [] end -let search_all_types t :mode = +let 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 f: + in List2.flat_map !module_list ~f: begin fun modname -> let mlid = Lident modname in try match lookup_module mlid initial with _, Tmty_signature sign -> List2.flat_map tl - f:(search_type_in_signature in:sign prefix:[modname] :mode) + ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) | _ -> [] with Not_found | Env.Error _ -> [] end exception Error of int * int -let search_string_type text :mode = +let search_string_type text ~mode = try let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in let sign = try Typemod.transl_signature !start_env sexp with _ -> - let env = List.fold_left !module_list init:initial f: + let env = List.fold_left !module_list ~init:initial ~f: begin fun acc m -> try open_pers_signature m acc with Env.Error _ -> acc end in @@ -290,7 +290,7 @@ let search_string_type text :mode = | 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 + search_all_types vd.val_type ~mode | _ -> [] with Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> @@ -303,9 +303,9 @@ 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) + (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 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) @@ -319,24 +319,24 @@ let explode s = l := s.[i] :: !l done; !l -let rec check_match :pattern s = +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' + | '*'::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 f: + let check i = check_match ~pattern (explode (Ident.name i)) in + let l = List.map !module_list ~f: begin fun modname -> Lident modname, try match lookup_module (Lident modname) initial with _, Tmty_signature sign -> - List2.flat_map sign f: + List2.flat_map sign ~f: begin function Tsig_value (i, _) when check i -> [i, Pvalue] | Tsig_type (i, _) when check i -> [i, Ptype] @@ -345,13 +345,13 @@ let search_pattern_symbol text = | 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)) - f:(fun (name,_,_) -> check_match :pattern (explode name)) + (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) + ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) -> [i, Pclass] | Tsig_cltype (i, cl) when check i or List.exists - (get_fields prefix:[modname] :sign (self_type cl.clty_type)) - f:(fun (name,_,_) -> check_match :pattern (explode name)) + (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) + ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) -> [i, Pcltype] | _ -> [] end @@ -359,9 +359,9 @@ let search_pattern_symbol text = with Env.Error _ -> [] end in - List2.flat_map l f: + List2.flat_map l ~f: begin fun (m, l) -> - List.map l f:(fun (i, p) -> Ldot (m, Ident.name i), p) + List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p) end (* @@ -394,26 +394,26 @@ let rec bound_variables pat = Ppat_any | Ppat_constant _ | Ppat_type _ -> [] | Ppat_var s -> [s] | Ppat_alias (pat,s) -> s :: bound_variables pat - | Ppat_tuple l -> List2.flat_map l f:bound_variables + | Ppat_tuple l -> List2.flat_map l ~f:bound_variables | Ppat_construct (_,None,_) -> [] | Ppat_construct (_,Some pat,_) -> bound_variables pat | Ppat_variant (_,None) -> [] | Ppat_variant (_,Some pat) -> bound_variables pat | Ppat_record l -> - List2.flat_map l f:(fun (_,pat) -> bound_variables pat) + List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat) | Ppat_array l -> - List2.flat_map l f:bound_variables + List2.flat_map l ~f: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 search_structure str ~name ~kind ~prefix = let loc = ref 0 in - let rec search_module str :prefix = + let rec search_module str ~prefix = match prefix with [] -> str | modu::prefix -> let str = - List.fold_left init:[] str f: + List.fold_left ~init:[] str ~f: begin fun acc item -> match item.pstr_desc with Pstr_module (s, mexp) when s = modu -> @@ -424,13 +424,13 @@ let search_structure str :name :kind :prefix = end | _ -> acc end - in search_module str :prefix + in search_module str ~prefix in - List.iter (search_module str :prefix) f: + List.iter (search_module str ~prefix) ~f: begin fun item -> if match item.pstr_desc with Pstr_value (_, l) when kind = Pvalue -> - List.iter l f: + List.iter l ~f: begin fun (pat,_) -> if List.mem name (bound_variables pat) then loc := pat.ppat_loc.loc_start @@ -438,7 +438,7 @@ let search_structure str :name :kind :prefix = false | Pstr_primitive (s, _) when kind = Pvalue -> name = s | Pstr_type l when kind = Ptype -> - List.iter l f: + List.iter l ~f: begin fun (s, td) -> if s = name then loc := td.ptype_loc.loc_start end; @@ -447,13 +447,13 @@ let search_structure str :name :kind :prefix = | 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 f: + List.iter l ~f: 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 f: + List.iter l ~f: begin fun c -> if c.pci_name = name then loc := c.pci_loc.loc_start end; @@ -463,13 +463,13 @@ let search_structure str :name :kind :prefix = end; !loc -let search_signature sign :name :kind :prefix = +let search_signature sign ~name ~kind ~prefix = let loc = ref 0 in - let rec search_module_type sign :prefix = + let rec search_module_type sign ~prefix = match prefix with [] -> sign | modu::prefix -> let sign = - List.fold_left init:[] sign f: + List.fold_left ~init:[] sign ~f: begin fun acc item -> match item.psig_desc with Psig_module (s, mtyp) when s = modu -> @@ -480,14 +480,14 @@ let search_signature sign :name :kind :prefix = end | _ -> acc end - in search_module_type sign :prefix + in search_module_type sign ~prefix in - List.iter (search_module_type sign :prefix) f: + List.iter (search_module_type sign ~prefix) ~f: begin fun item -> if match item.psig_desc with Psig_value (s, _) when kind = Pvalue -> name = s | Psig_type l when kind = Ptype -> - List.iter l f: + List.iter l ~f: begin fun (s, td) -> if s = name then loc := td.ptype_loc.loc_start end; @@ -496,13 +496,13 @@ let search_signature sign :name :kind :prefix = | 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 f: + List.iter l ~f: 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 f: + List.iter l ~f: begin fun c -> if c.pci_name = name then loc := c.pci_loc.loc_start end; diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 4b7560f9d..201e2b8b9 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -26,16 +26,16 @@ open Searchid (* auxiliary functions *) -let (~) = Jg_memo.fast f:Str.regexp +let (~!) = Jg_memo.fast ~f:Str.regexp -let lines_to_chars n in:s = +let lines_to_chars n ~text:s = let l = String.length s in - let rec ltc n :pos = + 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 + 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 = +let in_loc loc ~pos = pos >= loc.loc_start & pos < loc.loc_end let rec string_of_longident = function @@ -50,7 +50,7 @@ let parent_path = function Pdot (path, _, _) -> Some path | Pident _ | Papply _ -> None -let ident_of_path :default = function +let ident_of_path ~default = function Pident i -> i | Pdot (_, s, _) -> Ident.create s | Papply _ -> Ident.create default @@ -67,9 +67,9 @@ let rec list_of_path = function (* a simple wrapper *) -class buffer :size = object +class buffer ~size = object val buffer = Buffer.create size - method out :buf = Buffer.add_substring buffer buf + method out ~buf = Buffer.add_substring buffer buf method get = Buffer.contents buffer end @@ -79,84 +79,84 @@ 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 +let rec search_pos_type t ~pos ~env = + if in_loc ~pos t.ptyp_loc then begin (match t.ptyp_desc with Ptyp_any | Ptyp_var _ -> () | Ptyp_variant(tl, _, _) -> List.iter tl - f:(fun (_,_,tl) -> List.iter tl f:(search_pos_type :pos :env)) + ~f:(fun (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)) | Ptyp_arrow (_, t1, t2) -> - search_pos_type t1 :pos :env; - search_pos_type t2 :pos :env + search_pos_type t1 ~pos ~env; + search_pos_type t2 ~pos ~env | Ptyp_tuple tl -> - List.iter tl f:(search_pos_type :pos :env) + List.iter tl ~f:(search_pos_type ~pos ~env) | Ptyp_constr (lid, tl) -> - List.iter tl f:(search_pos_type :pos :env); + List.iter tl ~f:(search_pos_type ~pos ~env); raise (Found_sig (`Type, lid, env)) | Ptyp_object fl -> - List.iter fl f: + List.iter fl ~f: begin function - | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty :pos :env + | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env | _ -> () end | Ptyp_class (lid, tl, _) -> - List.iter tl f:(search_pos_type :pos :env); + List.iter tl ~f:(search_pos_type ~pos ~env); raise (Found_sig (`Type, lid, env)) - | Ptyp_alias (t, _) -> search_pos_type :pos :env t); + | 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 +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 f: + List.iter cfl ~f: begin function - Pctf_inher cty -> search_pos_class_type cty :pos :env + 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 + 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 + 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 + 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 + 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 + 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 +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 + Some t -> search_pos_type t ~pos ~env | None -> () end; begin match td.ptype_kind with Ptype_abstract -> () | Ptype_variant dl -> List.iter dl - f:(fun (_, tl) -> List.iter tl f:(search_pos_type :pos :env)) + ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)) | Ptype_record dl -> - List.iter dl f:(fun (_, _, t) -> search_pos_type t :pos :env) + List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) end; raise Not_found end -let rec search_pos_signature l :pos :env = +let rec search_pos_signature l ~pos ~env = ignore ( - List.fold_left l init:env f: + List.fold_left l ~init:env ~f: begin fun env pt -> let env = match pt.psig_desc with Psig_open id -> @@ -170,47 +170,47 @@ let rec search_pos_signature l :pos :env = with Typemod.Error _ | Typeclass.Error _ | Typetexp.Error _ | Typedecl.Error _ -> env in - if in_loc :pos pt.psig_loc then begin + 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_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env | Psig_type l -> - List.iter l f:(fun (_,desc) -> search_pos_type_decl :pos desc :env) + List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env) | Psig_exception (_, l) -> - List.iter l f:(search_pos_type :pos :env); + List.iter l ~f:(search_pos_type ~pos ~env); raise (Found_sig (`Type, Lident "exn", env)) | Psig_module (_, t) -> - search_pos_module t :pos :env + search_pos_module t ~pos ~env | Psig_modtype (_, Pmodtype_manifest t) -> - search_pos_module t :pos :env + search_pos_module t ~pos ~env | Psig_modtype _ -> () | Psig_class l -> List.iter l - f:(fun ci -> search_pos_class_type ci.pci_expr :pos :env) + ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) | Psig_class_type l -> List.iter l - f:(fun ci -> search_pos_class_type ci.pci_expr :pos :env) + ~f:(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 + | 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 +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 -> search_pos_signature sg :pos :env + | Pmty_signature sg -> search_pos_signature sg ~pos ~env | Pmty_functor (_ , m1, m2) -> - search_pos_module m1 :pos :env; - search_pos_module m2 :pos :env + search_pos_module m1 ~pos ~env; + search_pos_module m2 ~pos ~env | Pmty_with (m, l) -> - search_pos_module m :pos :env; - List.iter l f: + search_pos_module m ~pos ~env; + List.iter l ~f: begin function - _, Pwith_type t -> search_pos_type_decl t :pos :env + _, Pwith_type t -> search_pos_type_decl t ~pos ~env | _ -> () end end; @@ -227,13 +227,13 @@ type module_widgets = let shown_modules = Hashtbl.create 17 let filter_modules () = - Hashtbl.iter shown_modules f: - begin fun :key :data -> + Hashtbl.iter shown_modules ~f: + begin fun ~key ~data -> if not (Winfo.exists data.mw_frame) then Hashtbl.remove shown_modules key end -let add_shown_module path :widgets = - Hashtbl.add shown_modules key:path data:widgets +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 path @@ -245,10 +245,10 @@ let is_shown_module 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 view_defined_ref = ref (fun lid ~env -> ()) +let editor_ref = ref (fun ?file ?pos ?opendialog () -> ()) -let edit_source :file :path :sign = +let edit_source ~file ~path ~sign = match sign with [item] -> let id, kind = @@ -268,19 +268,19 @@ let edit_source :file :path :sign = if Filename.check_suffix file ".ml" then let parsed = Parse.implementation (Lexing.from_channel chan) in close_in chan; - Searchid.search_structure parsed :name :kind :prefix + 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 + Searchid.search_signature parsed ~name ~kind ~prefix with _ -> 0 - in !editor_ref :file :pos () - | _ -> !editor_ref :file () + 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 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 @@ -296,14 +296,14 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = let widgets = try find_shown_module path with Not_found -> - view_module path :env; + 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; + ~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"] f: + List.iter2 [widgets.mw_edit; widgets.mw_intf] [".ml"; ".mli"] ~f: begin fun button ext -> try let id = head_id path in @@ -311,17 +311,17 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = 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 + ~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 f:destroy (Winfo.children widgets.mw_frame); - Jg_message.formatted :title on:widgets.mw_frame maxheight:15 () + List.iter ~f: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 + let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in top_widgets := tl :: !top_widgets; tl, tw, finish in @@ -330,7 +330,7 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = finish (); Lexical.init_tags tw; Lexical.tag tw; - Text.configure tw state:`Disabled; + Text.configure tw ~state:`Disabled; let text = Jg_text.get_all tw in let pt = try Parse.interface (Lexing.from_string text) @@ -340,105 +340,106 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = 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"; [] + Jg_text.tag_and_see tw ~start:(tpos l.loc_start) + ~stop:(tpos l.loc_end) ~tag:"error"; [] | Lexer.Error (_, s, e) -> - Jg_text.tag_and_see tw start:(tpos s) end:(tpos e) tag:"error"; [] + Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; [] in Jg_bind.enter_focus tw; - bind tw events:[`Modified([`Control], `KeyPressDetail"s")] - action:(fun _ -> Jg_text.search_string tw); - bind tw events:[`Modified([`Double], `ButtonPressDetail 1)] - fields:[`MouseX;`MouseY] breakable:true - action:(fun ev -> + bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")] + ~action:(fun _ -> Jg_text.search_string tw); + bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~fields:[`MouseX;`MouseY] ~breakable:true + ~action:(fun ev -> let `Linechar (l, c) = - Text.index tw index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in + 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; + search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env; break () - with Found_sig (kind, lid, env) -> view_decl lid :kind :env + with Found_sig (kind, lid, env) -> view_decl lid ~kind ~env with Not_found | Env.Error _ -> ()); - bind tw events:[`ButtonPressDetail 3] fields:[`MouseX;`MouseY] breakable:true - action:(fun ev -> + bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] ~breakable:true + ~action:(fun ev -> let x = ev.ev_MouseX and y = ev.ev_MouseY in let `Linechar (l, c) = - Text.index tw index:(`Atxy(x,y), []) in + Text.index tw ~index:(`Atxy(x,y), []) in try try - search_pos_signature pt pos:(lines_to_chars l in:text + c) :env; + search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env; break () with Found_sig (kind, lid, env) -> - let menu = view_decl_menu lid :kind :env parent:tw in + 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 + 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_signature_item sign ~path ~env = + view_signature sign ~title:(string_of_path path) + ?path:(parent_path path) ~env -and view_module 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 + !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 + let id = ident_of_path path ~default:"M" in + view_signature_item [Tsig_module (id, modtype)] ~path ~env -and view_module_id id :env = +and view_module_id id ~env = let path, _ = lookup_module id env in - view_module path :env + view_module path ~env -and view_type_decl 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)] + 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)] + view_signature_item ~path ~env + [Tsig_type(ident_of_path path ~default:"t", td)] -and view_type_id li :env = +and view_type_id li ~env = let path, decl = lookup_type li env in - view_type_decl path :env + view_type_decl path ~env -and view_class_id li :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)] + view_signature_item ~path ~env + [Tsig_class(ident_of_path path ~default:"c", cl)] -and view_cltype_id li :env = +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)] + view_signature_item ~path ~env + [Tsig_cltype(ident_of_path path ~default:"ct", clt)] -and view_modtype_id li :env = +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)] + view_signature_item ~path ~env + [Tsig_modtype(ident_of_path path ~default:"S", td)] -and view_expr_type ?:title ?:path ?:env ?(:name="noname") t = +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 + | Some path -> parent_path path, ident_of_path path ~default:name in - view_signature :title ?:path ?:env + view_signature ~title ?path ?env [Tsig_value (id, {val_type = t; val_kind = Val_reg})] -and view_decl lid :kind :env = +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 + `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 = +and view_decl_menu lid ~kind ~env ~parent = let path, kname = try match kind with `Type -> fst (lookup_type lid env), "Type" @@ -447,44 +448,44 @@ and view_decl_menu lid :kind :env :parent = | `Modtype -> fst (lookup_modtype lid env), "Module type" with Env.Error _ -> raise Not_found in - let menu = Menu.create parent tearoff:false 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 ~state:`Disabled | _ -> - Menu.add_command menu :label - command:(fun () -> view_decl lid :kind :env); + 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 size:60 in + let buf = new buffer ~size:60 in let (fo,ff) = Format.get_formatter_output_functions () and margin = Format.get_margin () in - Format.set_formatter_output_functions out:buf#out flush:(fun () -> ()); + 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") + (ident_of_path path ~default:"t") Format.std_formatter (find_type path env) else Printtyp.modtype_declaration - (ident_of_path path default:"S") + (ident_of_path path ~default:"S") Format.std_formatter (find_modtype path env); Format.close_box (); Format.print_flush (); - Format.set_formatter_output_functions out:fo flush:ff; + Format.set_formatter_output_functions ~out:fo ~flush:ff; Format.set_margin margin; - let l = Str.split sep:~"\n" buf#get in + let l = Str.split ~sep:~!"\n" buf#get in let font = let font = - Option.get Widget.default_toplevel name:"font" class:"Font" in + Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in if font = "" then "7x14" else font in (* Menu.add_separator menu; *) List.iter l - f:(fun label -> Menu.add_command menu :label :font state:`Disabled) + ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled) end; menu @@ -499,42 +500,42 @@ type fkind = [ ] exception Found_str of fkind * Env.t -let view_type kind :env = +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 + `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)] + view_signature_item ~path ~env + [Tsig_value(ident_of_path path ~default:"v", vd)] with Not_found -> - view_expr_type ty :path :env + 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" + 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)] + 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)] + 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 + Tmty_signature sign -> view_signature sign ~path ~env | modtype -> - view_signature_item :path :env - [Tsig_module(ident_of_path path default:"M", mty)] + view_signature_item ~path ~env + [Tsig_module(ident_of_path path ~default:"M", mty)] -let view_type_menu kind :env :parent = +let view_type_menu kind ~env ~parent = let title = match kind with `Exp (`Expr,_) -> "Expression :" @@ -542,234 +543,234 @@ let view_type_menu kind :env :parent = | `Exp (`Const, _) -> "Constant :" | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :" | `Exp (`Var path, _) -> - "Variable " ^ Ident.name (ident_of_path path default:"noname") ^ " :" + "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 + 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 + Menu.add_command menu ~label:title ~state:`Disabled | `Exp _ | `Class _ | `Module _ -> - Menu.add_command menu label:title - command:(fun () -> view_type kind :env) + Menu.add_command menu ~label:title + ~command:(fun () -> view_type kind ~env) end; begin match kind with `Module _ | `Class _ -> () | `Exp(_, ty) -> - let buf = new buffer size:60 in + let buf = new buffer ~size:60 in let (fo,ff) = Format.get_formatter_output_functions () and margin = Format.get_margin () in - Format.set_formatter_output_functions out:buf#out flush:(fun () -> ()); + 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 Format.std_formatter ty; Format.close_box (); Format.print_flush (); - Format.set_formatter_output_functions out:fo flush:ff; + Format.set_formatter_output_functions ~out:fo ~flush:ff; Format.set_margin margin; - let l = Str.split sep:~"\n" buf#get in + let l = Str.split ~sep:~!"\n" buf#get in let font = let font = - Option.get Widget.default_toplevel name:"font" class:"Font" in + Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in if font = "" then "7x14" else font in (* Menu.add_separator menu; *) - List.iter l f: + List.iter l ~f: begin fun label -> match (Ctype.repr ty).desc with Tconstr (path,_,_) -> - Menu.add_command menu :label :font - command:(fun () -> view_type_decl path :env) + 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 + ~command:(fun () -> view_type_decl path ~env) | _ -> - Menu.add_command menu :label :font state:`Disabled + Menu.add_command menu ~label ~font ~state:`Disabled end end; menu -let rec search_pos_structure :pos str = - List.iter str f: +let rec search_pos_structure ~pos str = + List.iter str ~f: begin function - Tstr_eval exp -> search_pos_expr exp :pos + Tstr_eval exp -> search_pos_expr exp ~pos | Tstr_value (rec_flag, l) -> - List.iter l f: + List.iter l ~f: begin fun (pat, exp) -> let env = if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in - search_pos_pat pat :pos :env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env; + search_pos_expr exp ~pos end | Tstr_primitive (_, vd) ->() | Tstr_type _ -> () | Tstr_exception _ -> () | Tstr_exn_rebind(_, _) -> () - | Tstr_module (_, m) -> search_pos_module_expr m :pos + | Tstr_module (_, m) -> search_pos_module_expr m ~pos | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> - List.iter l f:(fun (id, _, _, cl) -> search_pos_class_expr cl :pos) + List.iter l ~f:(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 +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 f: + List.iter cls.cl_field ~f: 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 + 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 f: + List.iter pel ~f: begin fun (pat, exp) -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos end; - List.iter iel f:(fun (_,exp) -> search_pos_expr exp :pos) - | Cf_init exp -> search_pos_expr exp :pos + List.iter iel ~f:(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 f:(fun (_,exp) -> search_pos_expr exp :pos); - search_pos_class_expr cl :pos + search_pos_pat pat ~pos ~env:pat.pat_env; + List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + search_pos_class_expr cl ~pos | Tclass_apply (cl, el) -> - search_pos_class_expr cl :pos; - List.iter el f:(Misc.may (search_pos_expr :pos)) + search_pos_class_expr cl ~pos; + List.iter el ~f:(Misc.may (search_pos_expr ~pos)) | Tclass_let (_, pel, iel, cl) -> - List.iter pel f: + List.iter pel ~f: begin fun (pat, exp) -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos end; - List.iter iel f:(fun (_,exp) -> search_pos_expr exp :pos); - search_pos_class_expr cl :pos + List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + search_pos_class_expr cl ~pos | Tclass_constraint (cl, _, _, _) -> - search_pos_class_expr cl :pos + 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 +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 f: + List.iter expl ~f: begin fun (pat, exp') -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp' :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp' ~pos end; - search_pos_expr exp :pos + search_pos_expr exp ~pos | Texp_function (l, _) -> - List.iter l f: + List.iter l ~f: begin fun (pat, exp) -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos end | Texp_apply (exp, l) -> - List.iter l f:(Misc.may (search_pos_expr :pos)); - search_pos_expr exp :pos + List.iter l ~f:(Misc.may (search_pos_expr ~pos)); + search_pos_expr exp ~pos | Texp_match (exp, l, _) -> - search_pos_expr exp :pos; - List.iter l f: + search_pos_expr exp ~pos; + List.iter l ~f: begin fun (pat, exp) -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos end | Texp_try (exp, l) -> - search_pos_expr exp :pos; - List.iter l f: + search_pos_expr exp ~pos; + List.iter l ~f: begin fun (pat, exp) -> - search_pos_pat pat :pos env:exp.exp_env; - search_pos_expr exp :pos + search_pos_pat pat ~pos ~env:exp.exp_env; + search_pos_expr exp ~pos end - | Texp_tuple l -> List.iter l f:(search_pos_expr :pos) - | Texp_construct (_, l) -> List.iter l f:(search_pos_expr :pos) + | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) + | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos) | Texp_variant (_, None) -> () - | Texp_variant (_, Some exp) -> search_pos_expr exp :pos + | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos | Texp_record (l, opt) -> - List.iter l f:(fun (_, exp) -> search_pos_expr exp :pos); - (match opt with None -> () | Some exp -> search_pos_expr exp :pos) - | Texp_field (exp, _) -> search_pos_expr exp :pos + List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos); + (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) + | Texp_field (exp, _) -> search_pos_expr exp ~pos | Texp_setfield (a, _, b) -> - search_pos_expr a :pos; search_pos_expr b :pos - | Texp_array l -> List.iter l f:(search_pos_expr :pos) + search_pos_expr a ~pos; search_pos_expr b ~pos + | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) | Texp_ifthenelse (a, b, c) -> - search_pos_expr a :pos; search_pos_expr b :pos; + search_pos_expr a ~pos; search_pos_expr b ~pos; begin match c with None -> () - | Some exp -> search_pos_expr exp :pos + | Some exp -> search_pos_expr exp ~pos end | Texp_sequence (a,b) -> - search_pos_expr a :pos; search_pos_expr b :pos + search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_while (a,b) -> - search_pos_expr a :pos; search_pos_expr b :pos + search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_for (_, a, b, _, c) -> - List.iter [a;b;c] f:(search_pos_expr :pos) + List.iter [a;b;c] ~f:(search_pos_expr ~pos) | Texp_when (a, b) -> - search_pos_expr a :pos; search_pos_expr b :pos - | Texp_send (exp, _) -> search_pos_expr exp :pos + 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; + search_pos_expr exp ~pos; raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env)) | Texp_override (_, l) -> - List.iter l f:(fun (_, exp) -> search_pos_expr exp :pos) + List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos) | Texp_letmodule (id, modexp, exp) -> - search_pos_module_expr modexp :pos; - search_pos_expr exp :pos + 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 +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_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 f:(search_pos_pat :pos :env) + List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_construct (_, l) -> - List.iter l f:(search_pos_pat :pos :env) + List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_variant (_, None, _) -> () - | Tpat_variant (_, Some pat, _) -> search_pos_pat pat :pos :env + | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env | Tpat_record l -> - List.iter l f:(fun (_, pat) -> search_pos_pat pat :pos :env) + List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env) | Tpat_array l -> - List.iter l f:(search_pos_pat :pos :env) + List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_or (a, b) -> - search_pos_pat a :pos :env; search_pos_pat b :pos :env + 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 +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_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 + 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)) diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli index 14e431cbf..15fe48d34 100644 --- a/otherlibs/labltk/browser/searchpos.mli +++ b/otherlibs/labltk/browser/searchpos.mli @@ -69,5 +69,5 @@ 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 +val lines_to_chars : int -> text:string -> int diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml index 85f77eec2..a69c8fdc8 100644 --- a/otherlibs/labltk/browser/setpath.ml +++ b/otherlibs/labltk/browser/setpath.ml @@ -22,7 +22,7 @@ let update_hooks = ref [] let add_update_hook f = update_hooks := f :: !update_hooks let exec_update_hooks () = - update_hooks := List.filter !update_hooks f: + update_hooks := List.filter !update_hooks ~f: begin fun f -> try f (); true with Protocol.TkError _ -> false @@ -34,24 +34,24 @@ let set_load_path l = let get_load_path () = !Config.load_path -let renew_dirs box :var :dir = +let renew_dirs box ~var ~dir = Textvariable.set var dir; - Listbox.delete box first:(`Num 0) last:`End; - Listbox.insert box index:`End - texts:(Useunix.get_directories_in_files path:dir + 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) + 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) + 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 add_to_path ~dirs ?(base="") box = let dirs = if base = "" then dirs else if dirs = [] then [base] else - List.map dirs f: + List.map dirs ~f: begin function "." -> base | ".." -> Filename.dirname base @@ -59,23 +59,23 @@ let add_to_path :dirs ?(:base="") box = end in set_load_path - (dirs @ List.fold_left dirs init:(get_load_path ()) - f:(fun acc x -> List2.exclude x acc)) + (dirs @ List.fold_left dirs ~init:(get_load_path ()) + ~f:(fun acc x -> List2.exclude x acc)) -let remove_path box :dirs = +let remove_path box ~dirs = set_load_path - (List.fold_left dirs init:(get_load_path ()) - f:(fun acc x -> List2.exclude x acc)) + (List.fold_left dirs ~init:(get_load_path ()) + ~f:(fun acc x -> List2.exclude x acc)) (* main function *) -let f :dir = +let f ~dir = let current_dir = ref dir in let tl = Jg_toplevel.titled "Edit Load Path" in Jg_bind.escape_destroy tl; - let var_dir = Textvariable.create on:tl () in - let caplab = Label.create tl text:"Path" - and dir_name = Entry.create tl textvariable:var_dir + let var_dir = Textvariable.create ~on:tl () in + let caplab = Label.create tl ~text:"Path" + and dir_name = Entry.create tl ~textvariable:var_dir and browse = Frame.create tl in let dirs = Frame.create browse and path = Frame.create browse in @@ -83,78 +83,78 @@ let f :dir = and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path in add_update_hook (fun () -> renew_path pathbox); - Listbox.configure pathbox width:40 selectmode:`Multiple; - Listbox.configure dirbox selectmode:`Multiple; - Jg_box.add_completion dirbox action: + 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 + 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 + 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: + Jg_box.add_completion pathbox ~action: begin fun index -> - current_dir := Listbox.get pathbox :index; - renew_dirs dirbox var:var_dir dir:!current_dir + current_dir := Listbox.get pathbox ~index; + renew_dirs dirbox ~var:var_dir ~dir:!current_dir end; - bind dir_name events:[`KeyPressDetail"Return"] - action:(fun _ -> + bind dir_name ~events:[`KeyPressDetail"Return"] + ~action:(fun _ -> let dir = Textvariable.get var_dir in if Useunix.is_directory dir then begin current_dir := dir; - renew_dirs dirbox var:var_dir :dir + renew_dirs dirbox ~var:var_dir ~dir end); (* Avoid space being used by the completion mechanism *) let bind_space_toggle lb = - bind lb events:[`KeyPressDetail "space"] extend:true action:ignore in + bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in bind_space_toggle dirbox; bind_space_toggle pathbox; let add_paths _ = - add_to_path pathbox base:!current_dir - dirs:(List.map (Listbox.curselection dirbox) - f:(fun x -> Listbox.get dirbox index:x)); - Listbox.selection_clear dirbox first:(`Num 0) last:`End + add_to_path pathbox ~base:!current_dir + ~dirs:(List.map (Listbox.curselection dirbox) + ~f:(fun x -> Listbox.get dirbox ~index:x)); + Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End and remove_paths _ = remove_path pathbox - dirs:(List.map (Listbox.curselection pathbox) - f:(fun x -> Listbox.get pathbox index:x)) + ~dirs:(List.map (Listbox.curselection pathbox) + ~f:(fun x -> Listbox.get pathbox ~index:x)) in - bind dirbox events:[`KeyPressDetail "Insert"] action:add_paths; - bind pathbox events:[`KeyPressDetail "Delete"] action:remove_paths; + bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; + bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; - let dirlab = Label.create dirs text:"Directories" - and pathlab = Label.create path text:"Load path" - and addbutton = Button.create dirs text:"Add to path" command:add_paths + let dirlab = Label.create dirs ~text:"Directories" + and pathlab = Label.create path ~text:"Load path" + and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths and pathbuttons = Frame.create path in let removebutton = - Button.create pathbuttons text:"Remove from path" command:remove_paths + Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths and ok = - Jg_button.create_destroyer tl parent:pathbuttons + Jg_button.create_destroyer tl ~parent:pathbuttons in - renew_dirs dirbox var:var_dir dir:!current_dir; + renew_dirs dirbox ~var:var_dir ~dir:!current_dir; renew_path pathbox; - pack [dirsb] side:`Right fill:`Y; - pack [dirbox] side:`Left fill:`Y expand:true; - pack [pathsb] side:`Right fill:`Y; - pack [pathbox] side:`Left fill:`Both expand:true; - pack [dirlab] side:`Top anchor:`W padx:10; - pack [addbutton] side:`Bottom fill:`X; - pack [dirframe] fill:`Y expand:true; - pack [pathlab] side:`Top anchor:`W padx:10; - pack [removebutton; ok] side:`Left fill:`X expand:true; - pack [pathbuttons] fill:`X side:`Bottom; - pack [pathframe] fill:`Both expand:true; - pack [dirs] side:`Left fill:`Y; - pack [path] side:`Right fill:`Both expand:true; - pack [caplab] side:`Top anchor:`W padx:10; - pack [dir_name] side:`Top anchor:`W fill:`X; - pack [browse] side:`Bottom expand:true fill:`Both; + pack [dirsb] ~side:`Right ~fill:`Y; + pack [dirbox] ~side:`Left ~fill:`Y ~expand:true; + pack [pathsb] ~side:`Right ~fill:`Y; + pack [pathbox] ~side:`Left ~fill:`Both ~expand:true; + pack [dirlab] ~side:`Top ~anchor:`W ~padx:10; + pack [addbutton] ~side:`Bottom ~fill:`X; + pack [dirframe] ~fill:`Y ~expand:true; + pack [pathlab] ~side:`Top ~anchor:`W ~padx:10; + pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true; + pack [pathbuttons] ~fill:`X ~side:`Bottom; + pack [pathframe] ~fill:`Both ~expand:true; + pack [dirs] ~side:`Left ~fill:`Y; + pack [path] ~side:`Right ~fill:`Both ~expand:true; + pack [caplab] ~side:`Top ~anchor:`W ~padx:10; + pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X; + pack [browse] ~side:`Bottom ~expand:true ~fill:`Both; tl -let set :dir = ignore (f :dir);; +let set ~dir = ignore (f ~dir);; diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml index 7e8b479bd..5a82116d5 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -19,7 +19,7 @@ open Dummy (* Here again, memoize regexps *) -let (~) = Jg_memo.fast f:Str.regexp +let (~!) = Jg_memo.fast ~f:Str.regexp (* Nice history class. May reuse *) @@ -38,7 +38,7 @@ class ['a] history () = object List.nth history ((l + count - 1) mod l) end -let dump_mem ?(:pos = 0) ?:len obj = +let dump_mem ?(pos = 0) ?len obj = if not (Obj.is_block obj) then invalid_arg "Shell.dump_mem"; let len = match len with @@ -55,7 +55,7 @@ let dump_mem ?(:pos = 0) ?:len obj = let protect f x = try f x with _ -> () -class shell :textw :prog :args :env = +class shell ~textw ~prog ~args ~env = let (in2,out1) = Unix.pipe () and (in1,out2) = Unix.pipe () and (err1,err2) = Unix.pipe () @@ -68,8 +68,8 @@ object (self) Array.append env [|sigdef|] else env in - Unix.create_process_env :prog :args :env - stdin:in2 stdout:out2 stderr:err2 + Unix.create_process_env ~prog ~args ~env + ~stdin:in2 ~stdout:out2 ~stderr:err2 val out = Unix.out_channel_of_descr out1 val h = new history () val mutable alive = true @@ -79,20 +79,20 @@ object (self) val mutable ithreads = [] method alive = alive method kill = - if Winfo.exists textw then Text.configure textw state:`Disabled; + if Winfo.exists textw then Text.configure textw ~state:`Disabled; if alive then begin alive <- false; protect close_out out; try if Sys.os_type = "Win32" then begin - ignore (Unix.write sig1 buf:"T" pos:0 len:1); - List.iter f:(protect Unix.close) [sig1; sig2] + ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1); + List.iter ~f:(protect Unix.close) [sig1; sig2] end else begin - List.iter f:(protect Unix.close) [in1; err1; sig1; sig2]; - Fileevent.remove_fileinput fd:in1; - Fileevent.remove_fileinput fd:err1; - Unix.kill :pid signal:Sys.sigkill; - ignore (Unix.waitpid mode:[] pid) + List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2]; + Fileevent.remove_fileinput ~fd:in1; + Fileevent.remove_fileinput ~fd:err1; + Unix.kill ~pid ~signal:Sys.sigkill; + ignore (Unix.waitpid ~mode:[] pid) end with _ -> () end @@ -100,23 +100,23 @@ object (self) if alive then try reading <- false; if Sys.os_type = "Win32" then begin - ignore (Unix.write sig1 buf:"C" pos:0 len:1); + ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1); self#send " " end else - Unix.kill :pid signal:Sys.sigint + Unix.kill ~pid ~signal:Sys.sigint with Unix.Unix_error _ -> () method send s = if alive then try output_string out s; flush out with Sys_error _ -> () - method private read :fd :len = + method private read ~fd ~len = begin try let buf = String.create len in - let len = Unix.read fd :buf pos:0 :len in + let len = Unix.read fd ~buf ~pos:0 ~len in if len > 0 then begin - self#insert (String.sub buf pos:0 :len); - Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)]) + self#insert (String.sub buf ~pos:0 ~len); + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end; len with Unix.Unix_error _ -> 0 @@ -124,50 +124,50 @@ object (self) 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",[]) + Text.delete textw ~start:(`Mark"input",[`Char 1]) + ~stop:(`Mark"insert",[]) end else begin reading <- true; - Text.mark_set textw mark:"input" - index:(`Mark"insert",[`Char(-1)]) + 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 = `Mark"insert",[`Lineend]) () = - Lexical.tag textw :start :end + method private lex ?(start = `Mark"insert",[`Linestart]) + ?(stop = `Mark"insert",[`Lineend]) () = + Lexical.tag textw ~start ~stop method insert text = let idx = Text.index textw - index:(`Mark"insert",[`Char(-1);`Linestart]) in - Text.insert textw :text index:(`Mark"insert",[]); - self#lex start:(idx,[`Linestart]) (); - Text.see textw index:(`Mark"insert",[]) + ~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)]) + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end method private keyrelease c = if c <> "" then self#lex () method private return = if reading then reading <- false - else Text.mark_set textw mark:"input" - index:(`Mark"insert",[`Linestart;`Char 1]); - Text.mark_set textw mark:"insert"index:(`Mark"insert",[`Line 1]); - self#lex start:(`Mark"input",[`Linestart]) (); + else Text.mark_set textw ~mark:"input" + ~index:(`Mark"insert",[`Linestart;`Char 1]); + Text.mark_set textw ~mark:"insert"~index:(`Mark"insert",[`Line 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 + Text.get textw ~start:(`Mark"input",[`Char 1]) + ~stop:(`Mark"insert",[]) in h#add s; - Text.insert textw index:(`Mark"insert",[]) text:"\n"; - Text.yview_index textw index:(`Mark"insert",[]); + Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n"; + Text.yview_index textw ~index:(`Mark"insert",[]); self#send s; self#send "\n" method private paste ev = if not reading then begin reading <- true; - Text.mark_set textw mark:"input" - index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) + Text.mark_set textw ~mark:"input" + ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) end initializer Lexical.init_tags textw; @@ -183,42 +183,42 @@ object (self) ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); ([], `Destroy, [], fun _ -> self#kill) ] in - List.iter bindings f: + List.iter bindings ~f: begin fun (modif,event,fields,action) -> - bind textw events:[`Modified(modif,event)] :fields :action + bind textw ~events:[`Modified(modif,event)] ~fields ~action end; - bind textw events:[`KeyPressDetail"Return"] breakable:true - action:(fun _ -> self#return; break()); - List.iter f:Unix.close [in2;out2;err2]; + bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true + ~action:(fun _ -> self#return; break()); + List.iter ~f:Unix.close [in2;out2;err2]; if Sys.os_type = "Win32" then begin let fileinput_thread fd = let buf = String.create 1024 in let len = ref 0 in - try while len := ThreadUnix.read fd :buf pos:0 len:1024; !len > 0 do + try while len := ThreadUnix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do Mutex.lock imutex; - Buffer.add_substring ibuffer buf pos:0 len:!len; + Buffer.add_substring ibuffer buf ~pos:0 ~len:!len; Mutex.unlock imutex done with Unix.Unix_error _ -> () in - ithreads <- List.map [in1; err1] f:(Thread.create fileinput_thread); + ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread); let rec read_buffer () = Mutex.lock imutex; if Buffer.length ibuffer > 0 then begin - self#insert (Str.global_replace pat:~"\r\n" templ:"\n" + self#insert (Str.global_replace ~pat:~!"\r\n" ~templ:"\n" (Buffer.contents ibuffer)); Buffer.reset ibuffer; - Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)]) + Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end; Mutex.unlock imutex; - Timer.set ms:100 callback:read_buffer + Timer.set ~ms:100 ~callback:read_buffer in read_buffer () end else begin try - List.iter [in1;err1] f: + List.iter [in1;err1] ~f: begin fun fd -> - Fileevent.add_fileinput :fd - callback:(fun () -> ignore (self#read :fd len:1024)) + Fileevent.add_fileinput ~fd + ~callback:(fun () -> ignore (self#read ~fd ~len:1024)) end with _ -> () end @@ -230,20 +230,20 @@ let shells : (string * shell) list ref = ref [] (* Called before exiting *) let kill_all () = - List.iter !shells f:(fun (_,sh) -> if sh#alive then sh#kill); + List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill); shells := [] let get_all () = - let all = List.filter !shells f:(fun (_,sh) -> sh#alive) in + let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in shells := all; all let may_exec_unix prog = - try Unix.access file:prog perm:[Unix.X_OK]; true + try Unix.access ~file:prog ~perm:[Unix.X_OK]; true with Unix.Unix_error _ -> false let may_exec_win prog = - List.exists f:may_exec_unix [prog; prog^".exe"; prog^".cmo"; prog^".bat"] + List.exists ~f:may_exec_unix [prog; prog^".exe"; prog^".cmo"; prog^".bat"] let may_exec = if Sys.os_type = "Win32" then may_exec_win else may_exec_unix @@ -252,50 +252,50 @@ let path_sep = if Sys.os_type = "Win32" then ";" else ":" let warnings = ref "A" -let f :prog :title = +let f ~prog ~title = let progargs = - List.filter f:((<>) "") (Str.split sep:~" " prog) in + List.filter ~f:((<>) "") (Str.split ~sep:~!" " prog) in if progargs = [] then () else let prog = List.hd progargs in let path = try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in - let exec_path = Str.split sep:~path_sep path in + let exec_path = Str.split ~sep:~!path_sep path in let exists = if not (Filename.is_implicit prog) then may_exec prog else List.exists exec_path - f:(fun dir -> may_exec (Filename.concat dir prog)) in + ~f:(fun dir -> may_exec (Filename.concat dir prog)) in if not exists then () else let tl = Jg_toplevel.titled title in - let menus = Frame.create tl name:"menubar" in - let file_menu = new Jg_menu.c "File" parent:menus - and history_menu = new Jg_menu.c "History" parent:menus - and signal_menu = new Jg_menu.c "Signal" parent:menus in - pack [menus] side:`Top fill:`X; + let menus = Frame.create tl ~name:"menubar" in + let file_menu = new Jg_menu.c "File" ~parent:menus + and history_menu = new Jg_menu.c "History" ~parent:menus + and signal_menu = new Jg_menu.c "Signal" ~parent:menus in + pack [menus] ~side:`Top ~fill:`X; pack [file_menu#button; history_menu#button; signal_menu#button] - side:`Left ipadx:5 anchor:`W; + ~side:`Left ~ipadx:5 ~anchor:`W; let frame, tw, sb = Jg_text.create_with_scrollbar tl in - Text.configure tw background:`White; - pack [sb] fill:`Y side:`Right; - pack [tw] fill:`Both expand:true side:`Left; - pack [frame] fill:`Both expand:true; - let env = Array.map (Unix.environment ()) f: + Text.configure tw ~background:`White; + pack [sb] ~fill:`Y ~side:`Right; + pack [tw] ~fill:`Both ~expand:true ~side:`Left; + pack [frame] ~fill:`Both ~expand:true; + let env = Array.map (Unix.environment ()) ~f: begin fun s -> - if Str.string_match pat:~"TERM=" s pos:0 then "TERM=dumb" else s + if Str.string_match ~pat:~!"TERM=" s ~pos:0 then "TERM=dumb" else s end in let load_path = - List2.flat_map !Config.load_path f:(fun dir -> ["-I"; dir]) in + List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in let modern = if !Clflags.classic then [] else ["-label"] in let warnings = if List.mem "-w" progargs || !warnings = "A" then [] else ["-w"; !warnings] in let args = Array.of_list (progargs @ modern @ warnings @ load_path) in - let sh = new shell textw:tw :prog :env :args in + let sh = new shell ~textw:tw ~prog ~env ~args in let current_dir = ref (Unix.getcwd ()) in - file_menu#add_command "Use..." command: + file_menu#add_command "Use..." ~command: begin fun () -> - Fileselect.f title:"Use File" filter:"*.ml" sync:true dir:!current_dir () - action:(fun l -> + 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; @@ -304,11 +304,11 @@ let f :prog :title = let cmd = "#use \"" ^ name ^ "\";;\n" in sh#insert cmd; sh#send cmd) end; - file_menu#add_command "Load..." command: + file_menu#add_command "Load..." ~command: begin fun () -> - Fileselect.f title:"Load File" filter:"*.cm[oa]" sync:true () - dir:!current_dir - action:(fun l -> + 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; @@ -318,17 +318,17 @@ let f :prog :title = let cmd = "#load \"" ^ name ^ "\";;\n" in sh#insert cmd; sh#send cmd) end; - file_menu#add_command "Import path" command: + file_menu#add_command "Import path" ~command: begin fun () -> List.iter (List.rev !Config.load_path) - f:(fun dir -> sh#send ("#directory \"" ^ dir ^ "\";;\n")) + ~f:(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); + 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/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index 2cdf33bb7..8e1f62018 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -26,8 +26,8 @@ let f txt = let text = Jg_text.get_all txt.tw and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in let tl, ew, end_message = - Jg_message.formatted title:"Warnings" ppf:Format.err_formatter () in - Text.tag_remove txt.tw tag:"error" start:tstart end:tend; + Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in + Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend; begin txt.structure <- []; txt.signature <- []; @@ -42,7 +42,7 @@ let f txt = else (* others are interpreted as .ml *) let psl = Parse.use_file (Lexing.from_string text) in - List.iter psl f: + List.iter psl ~f: begin function Ptop_def pstr -> let str, sign, env' = Typemod.type_structure !env pstr in @@ -58,7 +58,7 @@ let f txt = | 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 + 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) -> @@ -93,23 +93,22 @@ let f txt = in end_message (); if s < e then - Jg_text.tag_and_see txt.tw start:(tpos s) end:(tpos e) tag:"error" + Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error" end; end_message (); - if !nowarnings or Text.index ew index:tend = `Linechar (2,0) + 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:[`Modified([`Double], `ButtonPressDetail 1)] - action:(fun _ -> - let s = - Text.get ew start:(`Mark "insert", [`Wordstart]) - end:(`Mark "insert", [`Wordend]) in + Text.configure ew ~state:`Disabled; + bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)] + ~action:(fun _ -> try + let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in + let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in let n = int_of_string s in - Text.mark_set txt.tw index:(tpos n) mark:"insert"; - Text.see txt.tw index:(`Mark "insert", []) - with Failure "int_of_string" -> ()) + Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert"; + Text.see txt.tw ~index:(`Mark "insert", []) + with _ -> ()) end; !error_messages diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml index 056bd6709..b17911091 100644 --- a/otherlibs/labltk/browser/useunix.ml +++ b/otherlibs/labltk/browser/useunix.ml @@ -30,18 +30,18 @@ let get_files_in_directory dir = | None -> closedir dirh; l in - Sort.list order:(<=) (get_them []) + Sort.list ~order:(<=) (get_them []) let is_directory name = try (stat name).st_kind = S_DIR with _ -> false -let get_directories_in_files :path = - List.filter f:(fun x -> is_directory (path ^ "/" ^ x)) +let get_directories_in_files ~path = + List.filter ~f:(fun x -> is_directory (path ^ "/" ^ x)) (************************************************** Subshell call *) -let subshell :cmd = +let subshell ~cmd = let rc = open_process_in cmd in let rec it l = match diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 1711ee112..7ec4aad9e 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -23,28 +23,28 @@ open Env open Searchpos open Searchid -let list_modules :path = - List.fold_left path init:[] f: +let list_modules ~path = + List.fold_left path ~init:[] ~f: begin fun modules dir -> let l = List.filter (Useunix.get_files_in_directory dir) - f:(fun x -> Filename.check_suffix x ".cmi") in - let l = List.map l f: + ~f:(fun x -> Filename.check_suffix x ".cmi") in + let l = List.map l ~f: begin fun x -> String.capitalize (Filename.chop_suffix x ".cmi") end in - List.fold_left l init:modules - f:(fun modules item -> + List.fold_left l ~init:modules + ~f:(fun modules item -> if List.mem item modules then modules else item :: modules) end let reset_modules box = - Listbox.delete box first:(`Num 0) last:`End; - module_list := Sort.list order:(<) (list_modules path:!Config.load_path); - Listbox.insert box index:`End texts:!module_list; - Jg_box.recenter box index:(`Num 0) + 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 view_symbol ~kind ~env ?path id = let name = match id with Lident x -> x | Ldot (_, x) -> x @@ -53,11 +53,11 @@ let view_symbol :kind :env ?:path id = 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 + 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 + Tconstr (path, _, _) -> view_type_decl path ~env | _ -> () end | Pconstructor -> @@ -65,18 +65,18 @@ let view_symbol :kind :env ?:path id = 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 + view_signature ~title:(string_of_longident id) ~env ?path [Tsig_exception (Ident.create name, cd.cstr_args)] else - view_type_decl cpath :env + 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 + | 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 = +let choose_symbol ~title ~env ?signature ?path l = if match path with None -> false | Some path -> is_shown_module path @@ -85,27 +85,27 @@ let choose_symbol :title :env ?:signature ?:path l = Jg_bind.escape_destroy tl; top_widgets := coe tl :: !top_widgets; let buttons = Frame.create tl in - let all = Button.create buttons text:"Show all" padx:20 - and ok = Jg_button.create_destroyer tl parent:buttons - and detach = Button.create buttons text:"Detach" - and edit = Button.create buttons text:"Impl" - and intf = Button.create buttons text:"Intf" in - let l = Sort.list l order: + let all = Button.create buttons ~text:"Show all" ~padx:20 + and ok = Jg_button.create_destroyer tl ~parent:buttons + and detach = Button.create buttons ~text:"Detach" + and edit = Button.create buttons ~text:"Impl" + and intf = Button.create buttons ~text:"Intf" in + let l = Sort.list l ~order: (fun (li1, _) (li2,_) -> string_of_longident li1 < string_of_longident li2) in - let nl = List.map l f: + let nl = List.map l ~f: begin fun (li, k) -> string_of_longident li ^ " (" ^ string_of_kind k ^ ")" end in let fb = Frame.create tl in let box = - new Jg_multibox.c fb cols:3 texts:nl maxheight:3 width:21 in + new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in box#init; - box#bind_kbd events:[`KeyPressDetail"Escape"] - action:(fun _ :index -> destroy tl; break ()); + box#bind_kbd ~events:[`KeyPressDetail"Escape"] + ~action:(fun _ ~index -> destroy tl; break ()); if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box); - Jg_multibox.add_completion box action: + Jg_multibox.add_completion box ~action: begin fun pos -> let li, k = List.nth l pos in let path = @@ -116,25 +116,25 @@ let choose_symbol :title :env ?:signature ?:path l = with Not_found -> None end | _ -> path - in view_symbol li kind:k :env ?:path + in view_symbol li ~kind:k ~env ?path end; - pack [buttons] side:`Bottom fill:`X; - pack [fb] side:`Top fill:`Both expand:true; + 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 + None -> pack [ok] ~fill:`X ~expand:true | Some signature -> - Button.configure all command: + Button.configure all ~command: begin fun () -> - view_signature signature :title :env ?:path + view_signature signature ~title ~env ?path end; - pack [ok; all] side:`Right fill:`X expand:true + pack [ok; all] ~side:`Right ~fill:`X ~expand:true end; begin match path with None -> () | Some path -> let frame = Frame.create tl in - pack [frame] side:`Bottom fill:`X; + pack [frame] ~side:`Bottom ~fill:`X; add_shown_module path - widgets:{ mw_frame = frame; mw_detach = detach; + ~widgets:{ mw_frame = frame; mw_detach = detach; mw_edit = edit; mw_intf = intf } end @@ -142,20 +142,20 @@ let search_which = ref "itself" let search_symbol () = if !module_list = [] then - module_list := Sort.list order:(<) (list_modules path:!Config.load_path); + module_list := Sort.list ~order:(<) (list_modules ~path:!Config.load_path); let tl = Jg_toplevel.titled "Search symbol" in Jg_bind.escape_destroy tl; - let ew = Entry.create tl width:30 in + let ew = Entry.create tl ~width:30 in let choice = Frame.create tl - and which = Textvariable.create on:tl () in - let itself = Radiobutton.create choice text:"Itself" - variable:which value:"itself" - and extype = Radiobutton.create choice text:"Exact type" - variable:which value:"exact" - and iotype = Radiobutton.create choice text:"Included type" - variable:which value:"iotype" + and which = Textvariable.create ~on:tl () in + let itself = Radiobutton.create choice ~text:"Itself" + ~variable:which ~value:"itself" + and extype = Radiobutton.create choice ~text:"Exact type" + ~variable:which ~value:"exact" + and iotype = Radiobutton.create choice ~text:"Included type" + ~variable:which ~value:"iotype" and buttons = Frame.create tl in - let search = Button.create buttons text:"Search" command: + let search = Button.create buttons ~text:"Search" ~command: begin fun () -> search_which := Textvariable.get which; let text = Entry.get ew in @@ -163,28 +163,28 @@ let search_symbol () = 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 + | "iotype" -> search_string_type text ~mode:`included + | "exact" -> search_string_type text ~mode:`exact | _ -> assert false in if l <> [] then - choose_symbol title:"Choose symbol" env:!start_env l + 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) + Entry.selection_range ew ~start:(`Num s) ~stop:(`Num e); + Entry.xview_index ew ~index:(`Num s) end - and ok = Jg_button.create_destroyer tl parent:buttons text:"Cancel" in + and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set ew; - Jg_bind.return_invoke ew button:search; + Jg_bind.return_invoke ew ~button:search; Textvariable.set which !search_which; - pack [itself; extype; iotype] side:`Left anchor:`W; - pack [search; ok] side:`Left fill:`X expand:true; + pack [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 + ~side:`Top ~fill:`X ~expand:true -let view_defined modlid :env = +let view_defined modlid ~env = try match lookup_module modlid env with path, Tmty_signature sign -> let ident_of_decl = function @@ -207,18 +207,18 @@ let view_defined modlid :env = 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 + 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 + let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in Env.report_error Format.std_formatter err; finish () let close_all_views () = List.iter !top_widgets - f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); + ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); top_widgets := [] @@ -227,64 +227,64 @@ 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; + Wm.transient_set tl ~master:Widget.default_toplevel; let input = Frame.create tl and buttons = Frame.create tl in - let ok = Button.create buttons text:"Ok" - and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel" + let ok = Button.create buttons ~text:"Ok" + and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" and labels = Frame.create input and entries = Frame.create input in - let l1 = Label.create labels text:"Command:" - and l2 = Label.create labels text:"Title:" + let l1 = Label.create labels ~text:"Command:" + and l2 = Label.create labels ~text:"Title:" and e1 = - Jg_entry.create entries command:(fun _ -> Button.invoke ok) + Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) and e2 = - Jg_entry.create entries command:(fun _ -> Button.invoke ok) - and names = List.map f:fst (Shell.get_all ()) in - Entry.insert e1 index:`End text:!default_shell; + Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) + and names = List.map ~f:fst (Shell.get_all ()) in + Entry.insert e1 ~index:`End ~text:!default_shell; let shell_name () = "Shell #" ^ string_of_int !shell_counter in while List.mem (shell_name ()) names do incr shell_counter done; - Entry.insert e2 index:`End text:(shell_name ()); - Button.configure ok command:(fun () -> + Entry.insert e2 ~index:`End ~text:(shell_name ()); + Button.configure ok ~command:(fun () -> if not (List.mem (Entry.get e2) names) then begin default_shell := Entry.get e1; - Shell.f prog:!default_shell title:(Entry.get e2); + 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 + 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 f ?(dir=Unix.getcwd()) ?on () = let tl = match on with None -> let tl = Jg_toplevel.titled "Module viewer" in ignore (Jg_bind.escape_destroy tl); coe tl | Some top -> - Wm.title_set top title:"OCamlBrowser"; - Wm.iconname_set top name:"OCamlBrowser"; + Wm.title_set top ~title:"OCamlBrowser"; + Wm.iconname_set top ~name:"OCamlBrowser"; let tl = Frame.create top in - pack [tl] expand:true fill:`Both; + pack [tl] ~expand:true ~fill:`Both; coe tl in - let menus = Frame.create tl name:"menubar" in - let filemenu = new Jg_menu.c "File" parent:menus - and modmenu = new Jg_menu.c "Modules" parent:menus in + let menus = Frame.create tl ~name:"menubar" in + let filemenu = new Jg_menu.c "File" ~parent:menus + and modmenu = new Jg_menu.c "Modules" ~parent:menus in let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in - Jg_box.add_completion mbox nocase:true action: + Jg_box.add_completion mbox ~nocase:true ~action: begin fun index -> - view_defined (Lident (Listbox.get mbox :index)) env:!start_env + view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env end; Setpath.add_update_hook (fun () -> reset_modules mbox); let ew = Entry.create tl in let buttons = Frame.create tl in - let search = Button.create buttons text:"Search" pady:1 command: + let search = Button.create buttons ~text:"Search" ~pady:1 ~command: begin fun () -> let s = Entry.get ew in let is_type = ref false and is_long = ref false in @@ -294,45 +294,45 @@ let f ?(:dir=Unix.getcwd()) ?:on () = done; let l = if !is_type then try - search_string_type mode:`included s + search_string_type ~mode:`included s with Searchid.Error (start,stop) -> - Entry.icursor ew index:(`Num start); [] + 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 + | [lid,kind] when !is_long -> view_symbol lid ~kind ~env:!start_env + | _ -> choose_symbol ~title:"Choose symbol" ~env:!start_env l end and close = - Button.create buttons text:"Close all" pady:1 command:close_all_views + Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views in (* bindings *) Jg_bind.enter_focus ew; - Jg_bind.return_invoke ew button:search; - bind close events:[`Modified([`Double], `ButtonPressDetail 1)] - action:(fun _ -> destroy tl); + Jg_bind.return_invoke ew ~button:search; + bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] + ~action:(fun _ -> destroy tl); (* File menu *) filemenu#add_command "Open..." - command:(fun () -> !editor_ref opendialog:true ()); - filemenu#add_command "Editor..." command:(fun () -> !editor_ref ()); - filemenu#add_command "Shell..." command:start_shell; - filemenu#add_command "Quit" command:(fun () -> destroy tl); + ~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.set :dir); + ~command:(fun () -> Setpath.set ~dir); modmenu#add_command "Reset cache" - command:(fun () -> reset_modules mbox; Env.reset_cache ()); - modmenu#add_command "Search symbol..." command:search_symbol; + ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); + modmenu#add_command "Search symbol..." ~command:search_symbol; - pack [filemenu#button; modmenu#button] side:`Left ipadx: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; + pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx: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 |