Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

nouvelle syntaxe avec tilde 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3061 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2000-04-12 03:43:25 +00:00
parent 975d4dc752
commit 780b65fca6
70 changed files with 1773 additions and 1738 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
emacs/caml-font.el
View File

@ -43,9 +43,9 @@
"\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"")
'font-lock-string-face)
;labels (and open)
'("\\(\\<[A-Za-z][A-Za-z0-9_']*:\\)\\([^:=]\\|\\'\\|$\\)" 1
'("\\(\\([~?]\\|\\<\\)[a-z][a-z0-9_']*:\\)[^:=]" 1
font-lock-variable-name-face)
'("\\<\\(assert\\|open\\|include\\|:[A-Za-z][A-Za-z0-9_']*\\)\\>\\|?"
'("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-z0-9_']*"
. font-lock-variable-name-face)
;modules and constructors
'("\\(\\<\\|:\\)\\([A-Z][A-Za-z0-9_']*\\)\\>"

7
emacs/caml.el
View File

@ -15,8 +15,8 @@
(defvar caml-imenu-enable nil
"*Enable Imenu support.")
(defvar caml-olabl-disable nil
"*Disable O'Labl support")
(defvar caml-olabl-enable nil
"*Enable O'Labl support")
(defvar caml-mode-indentation 2
"*Used for \\[caml-unindent-command].")
@ -369,8 +369,7 @@ have caml-electric-indent on, which see.")
(modify-syntax-entry ?' "w" caml-mode-syntax-table)
(modify-syntax-entry ?_ "w" caml-mode-syntax-table)
; : is part of words (labels) in O'Labl
(if caml-olabl-disable nil
(modify-syntax-entry ?: "w" caml-mode-syntax-table))
(if caml-olabl-enable (modify-syntax-entry ?: "w" caml-mode-syntax-table))
; ISO-latin accented letters and EUC kanjis are part of words
(let ((i 160))
(while (< i 256)

34
otherlibs/labltk/Widgets.src
View File

@ -590,7 +590,7 @@ widget entry {
function () configure [widget(entry); "configure"; option(entry) list]
function (string) configure_get [widget(entry); "configure"]
function () delete_single [widget(entry); "delete"; index: Index(entry)]
function () delete_range [widget(entry); "delete"; start: Index(entry); end: Index(entry)]
function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)]
function (string) get [widget(entry); "get"]
function () icursor [widget(entry); "icursor"; index: Index(entry)]
function (int) index [widget(entry); "index"; index: Index(entry)]
@ -602,7 +602,7 @@ widget entry {
function () selection_clear [widget(entry); "selection"; "clear"]
function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)]
function (bool) selection_present [widget(entry); "selection"; "present"]
function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; end: Index(entry)]
function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)]
function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)]
function () xview [widget(entry); "xview"; scroll: ScrollValue]
@ -634,7 +634,7 @@ type Colormap {
# Visual classes are: directcolor, grayscale, greyscale, pseudocolor,
# staticcolor, staticgray, staticgrey, truecolor
type Visual {
ClassVisual (Class) [[string; int]]
ClassVisual (Clas) [[string; int]]
DefaultVisual ["default"]
WidgetVisual (Widget) [widget]
BestDepth (Bestdepth) [["best"; int]]
@ -653,7 +653,7 @@ widget frame {
# Widget specific options
option Background
option Class ["-class"; string]
option Clas ["-class"; string]
option Colormap ["-colormap"; Colormap]
option Height
option Visual ["-visual"; Visual]
@ -691,7 +691,7 @@ subtype option(rowcolumnconfigure) {
subtype option(grid) {
Column ["-column"; int]
ColumnSpan ["-columnspan"; int]
In ["-in"; widget]
Inside ["-in"; widget]
IPadX ["-ipadx"; int]
IPadY ["-ipady"; int]
PadX
@ -718,7 +718,7 @@ module Grid {
## TODO: check result values
function (int,int) location ["grid"; "location"; widget; x:int; y:int]
function (bool) propagate_get ["grid"; "propagate"; widget]
function () propagate_set ["grid"; "propagate"; widget; to: bool]
function () propagate_set ["grid"; "propagate"; widget; bool]
function () row_configure
["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list]
function (string) row_configure_get
@ -1074,7 +1074,7 @@ module Option {
unsafe function () add
["option"; "add"; path: string; string; ?priority:[OptionPriority]]
function () clear ["option"; "clear"]
function (string) get ["option"; "get"; widget; name: string; class: string]
function (string) get ["option"; "get"; widget; name: string; clas: string]
unsafe function () readfile
["option"; "readfile"; string; ?priority:[OptionPriority]]
}
@ -1120,7 +1120,7 @@ module Pack {
function () configure ["pack"; "configure"; widget list; option(pack) list]
function () forget ["pack"; "forget"; widget list]
function (bool) propagate_get ["pack"; "propagate"; widget]
function () propagate_set ["pack"; "propagate"; widget; to: bool]
function () propagate_set ["pack"; "propagate"; widget; bool]
function (widget list) slaves ["pack"; "slaves"; widget]
}
@ -1188,7 +1188,7 @@ module Imagephoto {
function () blank [ImagePhoto; "blank"]
function () configure [ImagePhoto; "configure"; option(photoimage) list]
function (string) configure_get [ImagePhoto; "configure"]
function () copy [ImagePhoto; "copy"; to: ImagePhoto; photo(copy) list]
function () copy [ImagePhoto; "copy"; dst: ImagePhoto; photo(copy) list]
function (int, int, int) get [ImagePhoto; "get"; x: int; y: int]
# can't express nested lists ?
# function () put [ImagePhoto; "put"; [[Color list] list]; photo(put) list]
@ -1340,7 +1340,7 @@ widget scale {
function (float) get [widget(scale); "get"]
function (float) get_xy [widget(scale); "get"; x: int; y: int]
function (ScaleElement) identify [widget(scale); x: int; y: int]
function () set [widget(scale); "set"; to: float]
function () set [widget(scale); "set"; float]
}
@ -1535,10 +1535,10 @@ widget text {
function () configure [widget(text); "configure"; option(text) list]
function (string) configure_get [widget(text); "configure"]
function () debug [widget(text); "debug"; switch: bool]
function () delete [widget(text); "delete"; start: TextIndex; end: TextIndex]
function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex]
function () delete_char [widget(text); "delete"; index: TextIndex]
function (int, int, int, int, int) dlineinfo [ widget(text); "dlineinfo"; index: TextIndex]
function (string) get [widget(text); "get"; start: TextIndex; end: TextIndex]
function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex]
function (string) get_char [widget(text); "get"; index: TextIndex]
function () image_configure
[widget(text); "image"; "configure"; name: string; option(embeddedi) list]
@ -1561,7 +1561,7 @@ widget text {
function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]]
function () see [widget(text); "see"; index: TextIndex]
# Tags
function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; end: TextIndex]
function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex]
function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; at: TextIndex]
external tag_bind "builtin/text_tag_bind"
function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list]
@ -1572,12 +1572,12 @@ widget text {
function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]]
# function (TextTag list) tag_allnames [widget(text); "tag"; "names"]
# function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; index: TextIndex]
function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?end: [TextIndex]]
function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]]
function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]]
# function () tag_raise_above [widget(text); "tag"; "raise"; tag: TextTag; above: TextTag]
# function () tag_raise_top [widget(text); "tag"; "raise"; tag: TextTag ]
function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag]
function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; end: TextIndex]
function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex]
function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; at: TextIndex]
function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list]
function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list]
@ -1642,7 +1642,7 @@ widget toplevel {
# Widget specific options
option Background
option Class
option Clas
option Colormap
option Height
option Screen ["-screen"; string]
@ -1809,7 +1809,7 @@ module Wm {
function () minsize_set ["wm"; "minsize"; widget; width: int; height: int]
function (int,int) minsize_get ["wm"; "minsize"; widget]
### Override
function () overrideredirect_set ["wm"; "overrideredirect"; widget; to: bool]
function () overrideredirect_set ["wm"; "overrideredirect"; widget; bool]
function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget]
### Position
function () positionfrom_clear ["wm"; "positionfrom"; widget; ""]

402
otherlibs/labltk/browser/editor.ml
View File

@ -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);
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;
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 ()

202
otherlibs/labltk/browser/fileselect.ml
View File

@ -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;

10
otherlibs/labltk/browser/jg_bind.ml
View File

@ -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)

46
otherlibs/labltk/browser/jg_box.ml
View File

@ -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 *)

10
otherlibs/labltk/browser/jg_button.ml
View File

@ -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

12
otherlibs/labltk/browser/jg_completion.ml
View File

@ -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

18
otherlibs/labltk/browser/jg_config.ml
View File

@ -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"

8
otherlibs/labltk/browser/jg_entry.ml
View File

@ -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

2
otherlibs/labltk/browser/jg_memo.ml
View File

@ -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

18
otherlibs/labltk/browser/jg_menu.ml
View File

@ -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

68
otherlibs/labltk/browser/jg_message.ml
View File

@ -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

132
otherlibs/labltk/browser/jg_multibox.ml
View File

@ -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 -> ()

84
otherlibs/labltk/browser/jg_text.ml
View File

@ -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

2
otherlibs/labltk/browser/jg_text.mli
View File

@ -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 :

8
otherlibs/labltk/browser/jg_toplevel.ml
View File

@ -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

46
otherlibs/labltk/browser/lexical.ml
View File

@ -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 -> ()

2
otherlibs/labltk/browser/lexical.mli
View File

@ -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

6
otherlibs/labltk/browser/list2.ml
View File

@ -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

14
otherlibs/labltk/browser/main.ml
View File

@ -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

196
otherlibs/labltk/browser/searchid.ml
View File

@ -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;

511
otherlibs/labltk/browser/searchpos.ml
View File

@ -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))

2
otherlibs/labltk/browser/searchpos.mli
View File

@ -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

128
otherlibs/labltk/browser/setpath.ml
View File

@ -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);;

188
otherlibs/labltk/browser/shell.ml
View File

@ -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

29
otherlibs/labltk/browser/typecheck.ml
View File

@ -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

8
otherlibs/labltk/browser/useunix.ml
View File

@ -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

230
otherlibs/labltk/browser/viewer.ml
View File

@ -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

11
otherlibs/labltk/builtin/builtin_bind.ml
View File

@ -178,11 +178,12 @@ let wrapeventInfo f (what : eventField list) =
ev_RootY = 0 } in
function args ->
let l = ref args in
List.iter f:(function field ->
match !l with
| [] -> ()
| v :: rest -> filleventInfo ev v field; l := rest)
what;
List.iter what ~f:
begin fun field ->
match !l with
| [] -> ()
| v :: rest -> filleventInfo ev v field; l := rest
end;
f ev

10
otherlibs/labltk/builtin/builtinf_bind.ml
View File

@ -1,5 +1,5 @@
let bind_class :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
?:action ?(on:widget) name =
let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = [])
?action ?on:widget name =
let widget = match widget with None -> Widget.dummy | Some w -> coe w in
tkCommand
[| TkToken "bind";
@ -8,7 +8,7 @@ let bind_class :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
begin match action with None -> TkToken ""
| Some f ->
let cbId =
register_callback widget callback: (wrapeventInfo f fields) in
register_callback widget ~callback: (wrapeventInfo f fields) in
let cb = if extend then "+camlcb " else "camlcb " in
let cb = cb ^ cbId ^ writeeventField fields in
let cb =
@ -20,8 +20,8 @@ let bind_class :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
end
|]
let bind :events ?:extend ?:breakable ?:fields ?:action widget =
bind_class :events ?:extend ?:breakable ?:fields ?:action on:widget
let bind ~events ?extend ?breakable ?fields ?action widget =
bind_class ~events ?extend ?breakable ?fields ?action ~on:widget
(Widget.name widget)
let bind_tag = bind_class

2
otherlibs/labltk/builtin/builtini_GetBitmap.ml
View File

@ -4,7 +4,7 @@ let cCAMLtoTKbitmap : bitmap -> tkArgs = function
let cTKtoCAMLbitmap s =
if String.get s 0 = '@'
then `File (String.sub s pos:1 len:(String.length s - 1))
then `File (String.sub s ~pos:1 ~len:(String.length s - 1))
else `Predefined s

2
otherlibs/labltk/builtin/builtini_GetPixel.ml
View File

@ -7,7 +7,7 @@ let cCAMLtoTKunits : units -> tkArgs = function
let cTKtoCAMLunits str =
let len = String.length str in
let num_part str = String.sub str pos:0 len:(len - 1) in
let num_part str = String.sub str ~pos:0 ~len:(len - 1) in
match String.get str (pred len) with
| 'c' -> `Cm (float_of_string (num_part str))
| 'i' -> `In (float_of_string (num_part str))

4
otherlibs/labltk/builtin/builtini_bind.ml
View File

@ -44,11 +44,11 @@ let cCAMLtoTKevent (ev : event) =
| `Unmap -> "Unmap"
| `Visibility -> "Visibility"
| `Modified(ml, ev) ->
String.concat sep:"" (List.map f:cCAMLtoTKmodifier ml)
String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml)
^ convert ev
in "<" ^ convert ev ^ ">"
let cCAMLtoTKeventSequence (l : event list) =
TkToken(String.concat sep:"" (List.map f:cCAMLtoTKevent l))
TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l))

6
otherlibs/labltk/builtin/builtini_index.ml
View File

@ -29,9 +29,9 @@ let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs)
let cTKtoCAMLtext_index s =
try
let p = String.index s '.' in
`Linechar (int_of_string (String.sub s pos:0 len:p),
int_of_string (String.sub s pos:(p + 1)
len:(String.length s - p - 1)))
`Linechar (int_of_string (String.sub s ~pos:0 ~len:p),
int_of_string (String.sub s ~pos:(p + 1)
~len:(String.length s - p - 1)))
with
Not_found ->
raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s))

2
otherlibs/labltk/builtin/builtini_text.ml
View File

@ -23,7 +23,7 @@ let cCAMLtoTKtextIndex (i : textIndex) =
let ppTextIndex (base, ml : textIndex) =
match cCAMLtoTKtext_index base with
TkToken ppbase ->
String.concat sep:"" (ppbase :: List.map f:ppTextModifier ml)
String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml)
| _ -> assert false
in
TkToken (ppTextIndex i)

8
otherlibs/labltk/builtin/canvas_bind.ml
View File

@ -1,6 +1,6 @@
let bind canvas:widget :events
?(:extend = false) ?(:breakable = false) ?(:fields = [])
?:action tag =
let bind ~canvas:widget ~events
?(extend = false) ?(breakable = false) ?(fields = [])
?action tag =
tkCommand
[| cCAMLtoTKwidget widget;
TkToken "bind";
@ -9,7 +9,7 @@ let bind canvas:widget :events
begin match action with None -> TkToken ""
| Some f ->
let cbId =
register_callback widget callback: (wrapeventInfo f fields) in
register_callback widget ~callback: (wrapeventInfo f fields) in
let cb = if extend then "+camlcb " else "camlcb " in
let cb = cb ^ cbId ^ writeeventField fields in
let cb =

8
otherlibs/labltk/builtin/dialog.ml
View File

@ -1,12 +1,12 @@
let create :parent :title :message :buttons ?:name
?(:bitmap = `Predefined "") ?(:default = -1) () =
let w = Widget.new_atom "toplevel" ?:name :parent in
let create ~parent ~title ~message ~buttons ?name
?(bitmap = `Predefined "") ?(default = -1) () =
let w = Widget.new_atom "toplevel" ?name ~parent in
let res = tkEval [|TkToken"tk_dialog";
cCAMLtoTKwidget w;
TkToken title;
TkToken message;
cCAMLtoTKbitmap bitmap;
TkToken (string_of_int default);
TkTokenList (List.map f:(fun x -> TkToken x) buttons)|]
TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|]
in
int_of_string res

8
otherlibs/labltk/builtin/optionmenu.ml
View File

@ -1,15 +1,15 @@
open Protocol
(* Implementation of the tk_optionMenu *)
let create :parent :variable ?:name values =
let w = Widget.new_atom "menubutton" :parent ?:name in
let mw = Widget.new_atom "menu" parent:w name:"menu" in
let create ~parent ~variable ?name values =
let w = Widget.new_atom "menubutton" ~parent ?name in
let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in
(* assumes .menu naming *)
let res =
tkEval [|TkToken "tk_optionMenu";
TkToken (Widget.name w);
cCAMLtoTKtextVariable variable;
TkTokenList (List.map f:(fun x -> TkToken x) values)|] in
TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in
if res <> Widget.name mw then
raise (TkError "internal error in Optionmenu.create")
else

13
otherlibs/labltk/builtin/selection_handle_set.ml
View File

@ -1,13 +1,16 @@
(* The function *must* use tkreturn *)
let handle_set command: cmd =
let handle_set ~command =
selection_handle_icccm_optionals (fun opts w ->
tkCommand [|TkToken"selection";
TkToken"handle";
TkTokenList opts;
cCAMLtoTKwidget w;
let id = register_callback w callback:(function args ->
let a1 = int_of_string (List.hd args) in
let a2 = int_of_string (List.nth args 1) in
tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb " ^ id)
let id = register_callback w ~callback:
begin fun args ->
let pos = int_of_string (List.hd args) in
let len = int_of_string (List.nth args 1) in
tkreturn (command ~pos ~len)
end
in TkToken ("camlcb " ^ id)
|])

2
otherlibs/labltk/builtin/selection_handle_set.mli
View File

@ -1,4 +1,4 @@
val handle_set :
command: (pos:int -> len:int -> string) ->
?format: string -> ?selection:string -> ?type: string -> 'a widget -> unit
?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit
(* tk invocation: selection handle <icccm list> <widget> <command> *)

4
otherlibs/labltk/builtin/selection_own_set.ml
View File

@ -1,6 +1,6 @@
(* builtin to handle callback association to widget *)
let own_set ?:command =
selection_ownset_icccm_optionals ?:command (fun opts w ->
let own_set ?command =
selection_ownset_icccm_optionals ?command (fun opts w ->
tkCommand [|TkToken"selection";
TkToken"own";
TkTokenList opts;

6
otherlibs/labltk/builtin/text_tag_bind.ml
View File

@ -1,5 +1,5 @@
let tag_bind :tag :events ?(:extend = false) ?(:breakable = false)
?(:fields = []) ?:action widget =
let tag_bind ~tag ~events ?(extend = false) ?(breakable = false)
?(fields = []) ?action widget =
tkCommand
[| cCAMLtoTKwidget widget;
TkToken "tag";
@ -10,7 +10,7 @@ let tag_bind :tag :events ?(:extend = false) ?(:breakable = false)
| None -> TkToken ""
| Some f ->
let cbId =
register_callback widget callback: (wrapeventInfo f fields) in
register_callback widget ~callback: (wrapeventInfo f fields) in
let cb = if extend then "+camlcb " else "camlcb " in
let cb = cb ^ cbId ^ writeeventField fields in
let cb =

4
otherlibs/labltk/builtin/winfo_contained.ml
View File

@ -1,2 +1,2 @@
let contained :x :y w =
forget_type w = containing :x :y ()
let contained ~x ~y w =
forget_type w = containing ~x ~y ()

345
otherlibs/labltk/compiler/compile.ml
View File

@ -21,57 +21,55 @@ open Tables
(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
let safetype = true
let labeloff :at l = match l with
let labeloff ~at l = match l with
"", t -> t
| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at))
let labelstring l = match l with
"" -> ""
| _ -> l ^ ":"
let labelstring l =
if l = "" then l else
if l.[0] = '?' then l ^ ":" else
"~" ^ l ^ ":"
let labelprint :w l = w (labelstring l)
let typelabel l =
if l = "" then l else l ^ ":"
let small s =
let sout = ref "" in
for i=0 to String.length s - 1 do
let c =
if s.[i] >= 'A' && s.[i] <= 'Z' then
Char.chr(Char.code(s.[i]) - (Char.code 'A' - Char.code 'a'))
else s.[i]
in
sout := !sout ^ (String.make 1 c)
done;
!sout
let nicknames =
[ "class", "clas";
"type", "typ";
"in", "inside";
"from", "src";
"to", "dst" ]
let small_ident s =
let idents = ["to"; "raise"; "in"; "class"; "new"]
in
let s = small s in
if List.mem s idents then (String.make 1 s.[0]) ^ s
else s
let small = String.lowercase
let gettklabel fc =
match fc.template with
ListArg( StringArg s :: _ ) ->
if (try s.[0] = '-' with _ -> false) then
String.sub s pos:1 len:(String.length s - 1)
else
if s = "" then small fc.ml_name else small s
let s = small s in
if s = "" then s else
let s =
if s.[0] = '-'
then String.sub s ~pos:1 ~len:(String.length s - 1)
else s
in begin
try List.assoc s nicknames
with Not_found -> s
end
| _ -> raise (Failure "gettklabel")
let count item:x l =
let count ~item:x l =
let count = ref 0 in
List.iter f:(fun y -> if x = y then incr count) l;
List.iter ~f:(fun y -> if x = y then incr count) l;
!count
(* Extract all types from a template *)
let rec types_of_template = function
StringArg _ -> []
| TypeArg (l, t) -> [l, t]
| ListArg l -> List.flatten (List.map f:types_of_template l)
| ListArg l -> List.flatten (List.map ~f:types_of_template l)
| OptionalArgs (l, tl, _) ->
begin
match List.flatten (List.map f:types_of_template tl) with
match List.flatten (List.map ~f:types_of_template tl) with
["", t] -> ["?" ^ l, t]
| [_, _] -> raise (Failure "0 label required")
| _ -> raise (Failure "0 or more than 1 args in for optionals")
@ -81,7 +79,7 @@ let rec types_of_template = function
* Pretty print a type
* used to write ML type definitions
*)
let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
let rec ppMLtype =
function
Unit -> "unit"
@ -99,32 +97,32 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
try
let typdef = Hashtbl.find types_table sup in
let fcl = List.assoc sub typdef.subtypes in
let tklabels = List.map f:gettklabel fcl in
let l = List.map fcl f:
let tklabels = List.map ~f:gettklabel fcl in
let l = List.map fcl ~f:
begin fun fc ->
"?" ^ begin let p = gettklabel fc in
if count item:p tklabels > 1 then small fc.ml_name else p
if count ~item:p tklabels > 1 then small fc.ml_name else p
end
^ ":" ^
let l = types_of_template fc.template in
match l with
[] -> "unit"
| [lt] -> ppMLtype (labeloff lt at:"ppMLtype")
| [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype")
| l ->
"(" ^ String.concat sep:"*"
"(" ^ String.concat ~sep:"*"
(List.map l
f:(fun lt -> ppMLtype (labeloff lt at:"ppMLtype")))
~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype")))
^ ")"
end in
String.concat sep:" ->\n" l
String.concat ~sep:" ->\n" l
with
Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
end
| List ty -> (ppMLtype ty) ^ " list"
| Product tyl -> String.concat sep:" * " (List.map f:ppMLtype tyl)
| Product tyl -> String.concat ~sep:" * " (List.map ~f:ppMLtype tyl)
| Record tyl ->
String.concat sep:" * "
(List.map tyl f:(fun (l, t) -> labelstring l ^ ppMLtype t))
String.concat ~sep:" * "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
| Subtype ("widget", sub) -> sub ^ " widget"
| UserDefined "widget" ->
if any then "any widget" else
@ -140,15 +138,15 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
if typdef.variant then
if return then try
"[>" ^
String.concat sep:"|"
(List.map typdef.constructors f:
String.concat ~sep:"|"
(List.map typdef.constructors ~f:
begin
fun c ->
"`" ^ c.var_name ^
(match types_of_template c.template with
[] -> ""
| l -> " of " ^ ppMLtype (Product (List.map l
f:(labeloff at:"ppMLtype UserDefined"))))
~f:(labeloff ~at:"ppMLtype UserDefined"))))
end) ^ "]"
with
Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
@ -162,8 +160,8 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
| Function (Product tyl) ->
raise (Failure "Function (Product tyl) ? ppMLtype")
| Function (Record tyl) ->
"(" ^ String.concat sep:" -> "
(List.map tyl f:(fun (l, t) -> labelstring l ^ ppMLtype t))
"(" ^ String.concat ~sep:" -> "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
^ " -> unit)"
| Function ty ->
"(" ^ (ppMLtype ty) ^ " -> unit)"
@ -175,13 +173,13 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
let rec ppTemplate = function
StringArg s -> s
| TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">"
| ListArg l -> "{" ^ String.concat sep:" " (List.map f:ppTemplate l) ^ "}"
| ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}"
| OptionalArgs (l, tl, d) ->
"?" ^ l ^ "{" ^ String.concat sep:" " (List.map f:ppTemplate tl)
^ "}[<" ^ String.concat sep:" " (List.map f:ppTemplate d) ^ ">]"
"?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl)
^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]"
let doc_of_template = function
ListArg l -> String.concat sep:" " (List.map f:ppTemplate l)
ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l)
| t -> ppTemplate t
(*
@ -189,56 +187,56 @@ let doc_of_template = function
*)
(* Write an ML constructor *)
let write_constructor :w {ml_name = mlconstr; template = t} =
let write_constructor ~w {ml_name = mlconstr; template = t} =
w mlconstr;
begin match types_of_template t with
[] -> ()
| l -> w " of ";
w (ppMLtype any:true (Product (List.map l
f:(labeloff at:"write_constructor"))))
w (ppMLtype ~any:true (Product (List.map l
~f:(labeloff ~at:"write_constructor"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
(* Write a rhs type decl *)
let write_constructors :w = function
let write_constructors ~w = function
[] -> fatal_error "empty type"
| x :: l ->
write_constructor :w x;
List.iter l f:
write_constructor ~w x;
List.iter l ~f:
begin fun x ->
w "\n | ";
write_constructor :w x
write_constructor ~w x
end
(* Write an ML variant *)
let write_variant :w {ml_name = mlconstr; var_name = varname; template = t} =
let write_variant ~w {ml_name = mlconstr; var_name = varname; template = t} =
w "`";
w varname;
begin match types_of_template t with
[] -> ()
| l ->
w " of ";
w (ppMLtype any:true def:true
(Product (List.map l f:(labeloff at:"write_variant"))))
w (ppMLtype ~any:true ~def:true
(Product (List.map l ~f:(labeloff ~at:"write_variant"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
let write_variants :w = function
let write_variants ~w = function
[] -> fatal_error "empty variants"
| l ->
List.iter l f:
List.iter l ~f:
begin fun x ->
w "\n | ";
write_variant :w x
write_variant ~w x
end
(* Definition of a type *)
let write_type intf:w impl:w' name def:typdef =
let write_type ~intf:w ~impl:w' name ~def:typdef =
(* Only needed if no subtypes, otherwise use optionals *)
if typdef.subtypes = [] then begin
w "(* Variant type *)\n";
w ("type " ^ name ^ " = [");
write_variants :w (sort_components typdef.constructors);
write_variants ~w (sort_components typdef.constructors);
w "\n]\n\n"
end
@ -246,39 +244,41 @@ let write_type intf:w impl:w' name def:typdef =
(* Converters *)
(************************************************************)
let rec converterTKtoCAML argname as:ty =
match ty with
| Int -> "int_of_string " ^ argname
| Float -> "float_of_string " ^ argname
| Bool -> "(match " ^ argname ^ " with
let rec converterTKtoCAML ~arg = function
| Int -> "int_of_string " ^ arg
| Float -> "float_of_string " ^ arg
| Bool -> "(match " ^ arg ^ " with
| \"1\" -> true
| \"0\" -> false
| s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
| Char -> "String.get " ^ argname ^ " 0"
| String -> argname
| UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ argname
| Char -> "String.get " ^ arg ^ " 0"
| String -> arg
| UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg
| Subtype ("widget", s') ->
"(Obj.magic (cTKtoCAMLwidget " ^ argname ^ ") : " ^ s' ^ " widget)"
| Subtype (s, s') -> "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ argname
String.concat ~sep:" "
["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
| Subtype (s, s') -> "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
| List ty ->
begin match type_parser_arity ty with
OneToken ->
"(List.map (function x -> " ^ (converterTKtoCAML "x) " as:ty)
^ argname ^ ")"
OneToken ->
String.concat ~sep:" "
["(List.map (function x ->";
converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
| MultipleToken ->
"iterate_converter (function x -> " ^
(converterTKtoCAML "x) " as:ty) ^ argname ^ ")"
String.concat ~sep:" "
["iterate_converter (function x ->";
converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
end
| As (ty, _) -> converterTKtoCAML argname as:ty
| As (ty, _) -> converterTKtoCAML ~arg ty
| t ->
prerr_endline ("ERROR with " ^ argname ^ " " ^ ppMLtype t);
prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t);
fatal_error "converterTKtoCAML"
(*******************************)
(* Wrappers *)
(*******************************)
let varnames :prefix n =
let varnames ~prefix n =
let rec var i =
if i > n then []
else (prefix ^ string_of_int i) :: var (succ i)
@ -292,47 +292,47 @@ let varnames :prefix n =
* TODO: remove arg_ stuff and process lists directly ?
*)
let rec wrapper_code fname of:ty =
let rec wrapper_code ~name ty =
match ty with
Unit -> "(function _ -> " ^ fname ^ " ())"
| As (ty, _) -> wrapper_code fname of:ty
Unit -> "(fun _ -> " ^ name ^ " ())"
| As (ty, _) -> wrapper_code ~name ty
| ty ->
"(function args ->\n " ^
"(fun args ->\n " ^
begin match ty with
Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl ->
(* variables for each component of the product *)
let vnames = varnames prefix:"a" (List.length tyl) in
let vnames = varnames ~prefix:"a" (List.length tyl) in
(* getting the arguments *)
let readarg =
List.map2 vnames tyl f:
List.map2 vnames tyl ~f:
begin fun v (l, ty) ->
match type_parser_arity ty with
OneToken ->
"let (" ^ v ^ ", args) = " ^
converterTKtoCAML "(List.hd args)" as:ty ^
converterTKtoCAML ~arg:"(List.hd args)" ty ^
", List.tl args in\n "
| MultipleToken ->
"let (" ^ v ^ ", args) = " ^
converterTKtoCAML "args" as:ty ^
converterTKtoCAML ~arg:"args" ty ^
" in\n "
end in
String.concat sep:"" readarg ^ fname ^ " " ^
String.concat sep:" "
(List.map2 f:(fun v (l, _) -> labelstring l ^ v) vnames tyl)
String.concat ~sep:"" readarg ^ name ^ " " ^
String.concat ~sep:" "
(List.map2 ~f:(fun v (l, _) -> labelstring l ^ v) vnames tyl)
(* all other types are read in one operation *)
| List ty ->
fname ^ "(" ^ converterTKtoCAML "args" as:ty ^ ")"
name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")"
| String ->
fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| ty ->
begin match type_parser_arity ty with
OneToken ->
fname ^ "(" ^ converterTKtoCAML "(List.hd args)" as:ty ^ ")"
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| MultipleToken ->
"let (v, _) = " ^ converterTKtoCAML "args" as:ty ^
" in\n " ^ fname ^ " v"
"let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^
" in\n " ^ name ^ " v"
end
end ^ ")"
@ -359,7 +359,7 @@ type mini_parser =
let can_generate_parser constructors =
let pp = {zeroary = []; intpar = []; stringpar = []} in
if List.for_all constructors f:
if List.for_all constructors ~f:
begin fun c ->
match c.template with
ListArg [StringArg s] ->
@ -379,12 +379,12 @@ let can_generate_parser constructors =
(* We can generate parsers only for simple types *)
(* we should avoid multiple walks *)
let write_TKtoCAML :w name def:typdef =
let write_TKtoCAML ~w name ~def:typdef =
if typdef.parser_arity = MultipleToken then
prerr_string ("You must write cTKtoCAML" ^ name ^
" : string list ->" ^ name ^ " * string list\n")
else
let write :consts :name =
let write ~consts ~name =
match can_generate_parser consts with
NoParser ->
prerr_string
@ -398,7 +398,7 @@ let write_TKtoCAML :w name def:typdef =
w (" with _ ->\n")
end;
w (" match n with\n");
List.iter pp.zeroary f:
List.iter pp.zeroary ~f:
begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> "; w ml; w "\n"
end;
@ -412,9 +412,9 @@ let write_TKtoCAML :w name def:typdef =
w "\n\n"
in
begin
write :name consts:typdef.constructors;
List.iter typdef.subtypes f: begin
fun (subname, consts) -> write name:(subname ^ "_" ^ name) :consts
write ~name ~consts:typdef.constructors;
List.iter typdef.subtypes ~f: begin
fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
end
end
@ -424,14 +424,14 @@ let write_TKtoCAML :w name def:typdef =
(* Produce an in-lined converter Caml -> Tk for simple types *)
(* the converter is a function of type: <type> -> string *)
let rec converterCAMLtoTK :context_widget argname as:ty =
let rec converterCAMLtoTK ~context_widget argname ty =
match ty with
Int -> "TkToken (string_of_int " ^ argname ^ ")"
| Float -> "TkToken (string_of_float " ^ argname ^ ")"
| Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\""
| Char -> "TkToken (Char.escaped " ^ argname ^ ")"
| String -> "TkToken " ^ argname
| As (ty, _) -> converterCAMLtoTK :context_widget argname as:ty
| As (ty, _) -> converterCAMLtoTK ~context_widget argname ty
| UserDefined s ->
let name = "cCAMLtoTK" ^ s ^ " " in
let args = argname in
@ -465,7 +465,7 @@ let rec converterCAMLtoTK :context_widget argname as:ty =
*
*)
let code_of_template :context_widget ?(func:funtemplate=false) template =
let code_of_template ~context_widget ?func:(funtemplate=false) template =
let catch_opts = ref ("", "") in (* class name and first option *)
let variables = ref [] in
let variables2 = ref [] in
@ -496,22 +496,22 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
newvar := newvar2;
"TkTokenList opts"
| TypeArg (l, List ty) ->
"TkTokenList (List.map f:(function x -> "
^ converterCAMLtoTK :context_widget "x" as:ty
"TkTokenList (List.map ~f:(function x -> "
^ converterCAMLtoTK ~context_widget "x" ty
^ ") " ^ !newvar l ^ ")"
| TypeArg (l, Function tyarg) ->
"let id = register_callback " ^ context_widget
^ " callback: " ^ wrapper_code (!newvar l) of:tyarg
^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg
^ " in TkToken (\"camlcb \" ^ id)"
| TypeArg (l, ty) -> converterCAMLtoTK :context_widget (!newvar l) as:ty
| TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty
| ListArg l ->
"TkQuote (TkTokenList ["
^ String.concat sep:";\n " (List.map f:coderec l) ^ "])"
^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
| OptionalArgs (l, tl, d) ->
let nv = !newvar ("?" ^ l) in
optionvar := Some nv; (* Store *)
let argstr = String.concat sep:"; " (List.map f:coderec tl) in
let defstr = String.concat sep:"; " (List.map f:coderec d) in
let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in
"TkTokenList (match " ^ nv ^ " with\n"
^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
^ " | None -> [" ^ defstr ^ "])"
@ -520,14 +520,14 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
if funtemplate then
match template with
ListArg l ->
"[|" ^ String.concat sep:";\n " (List.map f:coderec l) ^ "|]"
"[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]"
| _ -> "[|" ^ coderec template ^ "|]"
else
match template with
ListArg [x] -> coderec x
| ListArg l ->
"TkTokenList [" ^
String.concat sep:";\n " (List.map f:coderec l) ^
String.concat ~sep:";\n " (List.map ~f:coderec l) ^
"]"
| _ -> coderec template
in
@ -538,29 +538,29 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
*)
(* For each case of a concrete type *)
let write_clause :w :context_widget comp =
let write_clause ~w ~context_widget comp =
let warrow () = w " -> " in
w "`";
w comp.var_name;
let code, variables, variables2, (co, _) =
code_of_template :context_widget comp.template in
code_of_template ~context_widget comp.template in
(* no subtype I think ... *)
if co <> "" then raise (Failure "write_clause subtype ?");
begin match variables with
| [] -> warrow()
| [x] -> w " "; w (labeloff x at:"write_clause"); warrow()
| [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
| l ->
w " ( ";
w (String.concat sep:", " (List.map f:(labeloff at:"write_clause") l));
w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
w ")";
warrow()
end;
w code
(* The full converter *)
let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name =
let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
let write_one name constrs =
w ("let cCAMLtoTK" ^ name);
let context_widget =
@ -576,7 +576,7 @@ let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name =
end;
w (" = function");
List.iter constrs
f:(fun c -> w "\n | "; write_clause :w :context_widget c);
~f:(fun c -> w "\n | "; write_clause ~w ~context_widget c);
w "\n\n\n"
in
@ -585,52 +585,52 @@ let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name =
if typdef.subtypes == [] then
write_one name constrs
else
List.iter constrs f:
List.iter constrs ~f:
begin fun fc ->
let code, vars, _, (co, _) =
code_of_template context_widget:"dummy" fc.template in
code_of_template ~context_widget:"dummy" fc.template in
if co <> "" then fatal_error "optionals in optionals";
let vars = List.map f:snd vars in
let vars = List.map ~f:snd vars in
w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name);
w " ("; w (String.concat sep:", " vars); w ") =\n ";
w " ("; w (String.concat ~sep:", " vars); w ") =\n ";
w code; w "\n\n"
end
(* Tcl does not really return "lists". It returns sp separated tokens *)
let rec write_result_parsing :w = function
let rec write_result_parsing ~w = function
List String ->
w "(splitlist res)"
| List ty ->
w (" List.map f: " ^ converterTKtoCAML "(splitlist res)" as:ty)
w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
| Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl -> (* of course all the labels are "" *)
let rnames = varnames prefix:"r" (List.length tyl) in
let rnames = varnames ~prefix:"r" (List.length tyl) in
w " let l = splitlist res in";
w ("\n if List.length l <> " ^ string_of_int (List.length tyl));
w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
w ("\n else ");
List.iter2 rnames tyl f:
List.iter2 rnames tyl ~f:
begin fun r (l, ty) ->
if l <> "" then raise (Failure "lables in return type!!!");
w (" let " ^ r ^ ", l = ");
begin match type_parser_arity ty with
OneToken ->
w (converterTKtoCAML "(List.hd l)" as:ty); w (", List.tl l")
w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l")
| MultipleToken ->
w (converterTKtoCAML "l" as:ty)
w (converterTKtoCAML ~arg:"l" ty)
end;
w (" in\n")
end;
w (String.concat sep:", " rnames)
w (String.concat ~sep:", " rnames)
| String ->
w (converterTKtoCAML "res" as:String)
| As (ty, _) -> write_result_parsing :w ty
w (converterTKtoCAML ~arg:"res" String)
| As (ty, _) -> write_result_parsing ~w ty
| ty ->
match type_parser_arity ty with
OneToken -> w (converterTKtoCAML "res" as:ty)
| MultipleToken -> w (converterTKtoCAML "(splitlist res)" as:ty)
OneToken -> w (converterTKtoCAML ~arg:"res" ty)
| MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty)
let write_function :w def =
let write_function ~w def =
w ("let " ^ def.ml_name);
(* a bit approximative *)
let context_widget = match def.template with
@ -639,21 +639,21 @@ let write_function :w def =
| _ -> "dummy" in
let code, variables, variables2, (co, lbl) =
code_of_template func:true :context_widget def.template in
code_of_template ~func:true ~context_widget def.template in
(* Arguments *)
let uv, lv, ov =
let rec replace_args :u :l :o = function
let rec replace_args ~u ~l ~o = function
[] -> u, l, o
| ("", x) :: ls ->
replace_args u:(x :: u) :l :o ls
replace_args ~u:(x :: u) ~l ~o ls
| (p, _ as x) :: ls when p.[0] = '?' ->
replace_args :u :l o:(x :: o) ls
replace_args ~u ~l ~o:(x :: o) ls
| x :: ls ->
replace_args :u l:(x :: l) :o ls
replace_args ~u ~l:(x :: l) ~o ls
in
replace_args u:[] l:[] o:[] (List.rev (variables @ variables2))
replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2))
in
List.iter (lv@ov) f:(fun (l, v) -> w " "; w (labelstring l); w v);
List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
if co <> "" then begin
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " =\n";
@ -661,10 +661,10 @@ let write_function :w def =
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " (fun opts";
if uv = [] then w " ()"
else List.iter uv f:(fun x -> w " "; w x);
else List.iter uv ~f:(fun x -> w " "; w x);
w " ->\n"
end else begin
List.iter uv f:(fun x -> w " "; w x);
List.iter uv ~f:(fun x -> w " "; w x);
if (ov <> [] || lv = []) && uv = [] then w " ()";
w " =\n"
end;
@ -672,15 +672,15 @@ let write_function :w def =
| Unit | As (Unit, _) -> w "tkCommand "; w code
| ty ->
w "let res = tkEval "; w code ; w " in \n";
write_result_parsing :w ty
write_result_parsing ~w ty
end;
if co <> "" then w ")";
w "\n\n"
let write_create :w clas =
(w "let create ?:name =\n" : unit);
let write_create ~w clas =
(w "let create ?name =\n" : unit);
w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n");
w (" let w = new_atom \"" ^ clas ^ "\" :parent ?:name in\n");
w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
w " tkCommand [|";
w ("TkToken \"" ^ clas ^ "\";\n");
w (" TkToken (Widget.name w);\n");
@ -705,7 +705,7 @@ let find_in_path path name =
(* builtin-code: the file (without suffix) is in .template... *)
(* not efficient, but hell *)
let write_external :w def =
let write_external ~w def =
match def.template with
| StringArg fname ->
begin try
@ -725,45 +725,34 @@ let write_external :w def =
end
| _ -> raise (Compiler_Error "invalid external definition")
let write_catch_optionals :w clas def:typdef =
let write_catch_optionals ~w clas ~def:typdef =
if typdef.subtypes = [] then () else
List.iter typdef.subtypes f:
List.iter typdef.subtypes ~f:
begin fun (subclass, classdefs) ->
w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n");
let tklabels = List.map f:gettklabel classdefs in
let tklabels = List.map ~f:gettklabel classdefs in
let l =
List.map classdefs f:
List.map classdefs ~f:
begin fun fc ->
(*
let code, vars, _, (co, _) =
code_of_template context_widget:"dummy" fc.template in
code_of_template ~context_widget:"dummy" fc.template in
if co <> "" then fatal_error "optionals in optionals";
*)
let p = gettklabel fc in
(if count item:p tklabels > 1 then small fc.ml_name else p),
small_ident fc.ml_name (* used as labels *),
(if count ~item:p tklabels > 1 then small fc.ml_name else p),
small fc.ml_name
end in
let p =
List.map l f:
begin fun (s, si, _) ->
if s = si then " ?:" ^ s
else " ?" ^ s ^ ":" ^ si
end in
let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in
let v =
List.map l f:
begin fun (_, si, s) ->
(*
let vars = List.map f:snd vars in
let vars = String.concat sep:"," vars in
"(maycons (fun (" ^ vars ^ ") -> " ^ code ^ ") " ^ si
*)
"(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si
end in
w (String.concat sep:"\n" p);
List.map l ~f:
begin fun (si, s) ->
"(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si
end in
w (String.concat ~sep:"\n" p);
w " ->\n";
w " f ";
w (String.concat sep:"\n " v);
w (String.concat ~sep:"\n " v);
w "\n []";
w (String.make (List.length v) ')');
w "\n\n"

45
otherlibs/labltk/compiler/intf.ml
View File

@ -20,28 +20,29 @@
open Tables
open Compile
let write_create_p :w wname =
let write_create_p ~w wname =
w "val create :\n ?name:string ->\n";
begin
try
let option = Hashtbl.find types_table "options" in
let classdefs = List.assoc wname option.subtypes in
let tklabels = List.map f:gettklabel classdefs in
let l = List.map classdefs f:
let tklabels = List.map ~f:gettklabel classdefs in
let l = List.map classdefs ~f:
begin fun fc ->
begin let p = gettklabel fc in
if count item:p tklabels > 1 then small fc.ml_name else p
end, fc.template
if count ~item:p tklabels > 1 then small fc.ml_name else p
end,
fc.template
end in
w (String.concat sep:" ->\n"
(List.map l f:
w (String.concat ~sep:" ->\n"
(List.map l ~f:
begin fun (s, t) ->
" ?" ^ s ^ ":"
^(ppMLtype
(match types_of_template t with
| [t] -> labeloff t at:"write_create_p"
| [t] -> labeloff t ~at:"write_create_p"
| [] -> fatal_error "multiple"
| l -> Product (List.map f:(labeloff at:"write_create_p") l)))
| l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l)))
end))
with Not_found -> fatal_error "in write_create_p"
end;
@ -52,35 +53,39 @@ let write_create_p :w wname =
w " and checked dynamically. *)\n"
(* Unsafe: write special comment *)
let write_function_type :w def =
let write_function_type ~w def =
if not def.safe then w "(* unsafe *)\n";
w "val "; w def.ml_name; w " : ";
let us, ls, os =
let tys = types_of_template def.template in
let rec replace_args :u :l :o = function
let rec replace_args ~u ~l ~o = function
[] -> u, l, o
| (_, List(Subtype _) as x)::ls ->
replace_args :u :l o:(x::o) ls
replace_args ~u ~l ~o:(x::o) ls
| ("", _ as x)::ls ->
replace_args u:(x::u) :l :o ls
replace_args ~u:(x::u) ~l ~o ls
| (p, _ as x)::ls when p.[0] = '?' ->
replace_args :u :l o:(x::o) ls
replace_args ~u ~l ~o:(x::o) ls
| x::ls ->
replace_args :u l:(x::l) :o ls
replace_args ~u ~l:(x::l) ~o ls
in
replace_args u:[] l:[] o:[] (List.rev tys)
replace_args ~u:[] ~l:[] ~o:[] (List.rev tys)
in
let counter = ref 0 in
List.iter (ls @ os @ us)
f:(fun (l, t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
List.iter (ls @ os @ us) ~f:
begin fun (l, t) ->
if l <> "" then w (l ^ ":");
w (ppMLtype t ~counter);
w " -> "
end;
if (os <> [] || ls = []) && us = [] then w "unit -> ";
w (ppMLtype any:true return:true def.result); (* RETURN TYPE !!! *)
w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
w " \n";
(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
let write_external_type :w def =
let write_external_type ~w def =
match def.template with
| StringArg fname ->
begin try

8
otherlibs/labltk/compiler/lexer.mll
View File

@ -28,7 +28,7 @@ let current_line = ref 1
let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
let _ = List.iter
f:(fun (str,tok) -> Hashtbl.add keyword_table key:str data:tok)
~f:(fun (str,tok) -> Hashtbl.add keyword_table ~key:str ~data:tok)
[
"int", TYINT;
"float", TYFLOAT;
@ -64,15 +64,15 @@ let reset_string_buffer () =
let store_string_char c =
if !string_index >= String.length (!string_buff) then begin
let new_buff = String.create (String.length (!string_buff) * 2) in
String.blit src:(!string_buff) src_pos:0 dst:new_buff dst_pos:0
len:(String.length (!string_buff));
String.blit ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0
~len:(String.length (!string_buff));
string_buff := new_buff
end;
String.set (!string_buff) (!string_index) c;
incr string_index
let get_stored_string () =
let s = String.sub (!string_buff) pos:0 len:(!string_index) in
let s = String.sub (!string_buff) ~pos:0 ~len:(!string_index) in
string_buff := initial_string_buffer;
s
(* To translate escape sequences *)

64
otherlibs/labltk/compiler/maincompile.ml
View File

@ -84,7 +84,7 @@ let parse_file filename =
in an hash table. *)
let elements t =
let elems = ref [] in
Hashtbl.iter f:(fun key:_ data:d -> elems := d :: !elems) t;
Hashtbl.iter ~f:(fun ~key:_ ~data:d -> elems := d :: !elems) t;
!elems;;
(* Verifies that duplicated clauses are semantically equivalent and
@ -96,9 +96,9 @@ let uniq_clauses = function
if constr1.template <> constr2.template then
begin
let code1, vars11, vars12, opts1 =
code_of_template context_widget:"dummy" constr1.template in
code_of_template ~context_widget:"dummy" constr1.template in
let code2, vars12, vars22, opts2 =
code_of_template context_widget:"dummy" constr2.template in
code_of_template ~context_widget:"dummy" constr2.template in
let err =
Printf.sprintf
"uncompatible redondant clauses for variant %s:\n %s\n and\n %s"
@ -113,11 +113,11 @@ let uniq_clauses = function
end in
let t = Hashtbl.create 11 in
List.iter l
f:(fun constr ->
~f:(fun constr ->
let c = constr.var_name in
if Hashtbl.mem t c
then (check_constr constr (Hashtbl.find t c))
else Hashtbl.add t key:c data:constr);
else Hashtbl.add t ~key:c ~data:constr);
elements t;;
let option_hack oc =
@ -128,7 +128,7 @@ let option_hack oc =
constructors =
begin
let constrs =
List.map typdef.constructors f:
List.map typdef.constructors ~f:
begin fun c ->
{ component = Constructor;
ml_name = c.ml_name;
@ -148,7 +148,7 @@ let option_hack oc =
variant = false }
in
write_CAMLtoTK
w:(output_string oc) def:hack safetype:false "options_constrs"
~w:(output_string oc) ~def:hack ~safetype:false "options_constrs"
let compile () =
verbose_endline "Creating tkgen.ml ...";
@ -157,22 +157,22 @@ let compile () =
let oc'' = open_out_bin (destfile "tkfgen.ml") in
let sorted_types = Tsort.sort types_order in
verbose_endline " writing types ...";
List.iter sorted_types f:
List.iter sorted_types ~f:
begin fun typname ->
verbose_string (" " ^ typname ^ " ");
try
let typdef = Hashtbl.find types_table typname in
verbose_string "type ";
write_type intf:(output_string oc)
impl:(output_string oc')
typname def:typdef;
write_type ~intf:(output_string oc)
~impl:(output_string oc')
typname ~def:typdef;
verbose_string "C2T ";
write_CAMLtoTK w:(output_string oc') typname def:typdef;
write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef;
verbose_string "T2C ";
if List.mem typname !types_returned then
write_TKtoCAML w:(output_string oc') typname def:typdef;
write_TKtoCAML ~w:(output_string oc') typname ~def:typdef;
verbose_string "CO ";
write_catch_optionals w:(output_string oc') typname def:typdef;
write_catch_optionals ~w:(output_string oc') typname ~def:typdef;
verbose_endline "."
with Not_found ->
if not (List.mem_assoc typname !types_external) then
@ -186,7 +186,7 @@ let compile () =
verbose_endline " option hacking ...";
option_hack oc';
verbose_endline " writing functions ...";
List.iter f:(write_function w:(output_string oc'')) !function_table;
List.iter ~f:(write_function ~w:(output_string oc'')) !function_table;
close_out oc;
close_out oc';
close_out oc'';
@ -195,11 +195,11 @@ let compile () =
verbose_endline "Creating tkgen.mli ...";
let oc = open_out_bin (destfile "tkgen.mli") in
List.iter (sort_components !function_table)
f:(write_function_type w:(output_string oc));
~f:(write_function_type ~w:(output_string oc));
close_out oc;
verbose_endline "Creating other ml, mli ...";
Hashtbl.iter module_table f:
begin fun key:wname data:wdef ->
Hashtbl.iter module_table ~f:
begin fun ~key:wname ~data:wdef ->
verbose_endline (" "^wname);
let modname = wname in
let oc = open_out_bin (destfile (modname ^ ".ml"))
@ -209,7 +209,7 @@ let compile () =
| Family -> output_string oc' ("(* The "^wname^" commands *)\n")
end;
output_string oc "open Protocol\n";
List.iter f:(fun s -> output_string oc s; output_string oc' s)
List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
[ "open Tk\n";
"open Tkintf\n";
"open Widget\n";
@ -217,17 +217,17 @@ let compile () =
];
begin match wdef.module_type with
Widget ->
write_create w:(output_string oc) wname;
write_create_p w:(output_string oc') wname
write_create ~w:(output_string oc) wname;
write_create_p ~w:(output_string oc') wname
| Family -> ()
end;
List.iter f:(write_function w:(output_string oc))
List.iter ~f:(write_function ~w:(output_string oc))
(sort_components wdef.commands);
List.iter f:(write_function_type w:(output_string oc'))
List.iter ~f:(write_function_type ~w:(output_string oc'))
(sort_components wdef.commands);
List.iter f:(write_external w:(output_string oc))
List.iter ~f:(write_external ~w:(output_string oc))
(sort_components wdef.externals);
List.iter f:(write_external_type w:(output_string oc'))
List.iter ~f:(write_external_type ~w:(output_string oc'))
(sort_components wdef.externals);
close_out oc;
close_out oc'
@ -237,17 +237,17 @@ let compile () =
let oc = open_out_bin (destfile "modules") in
output_string oc "WIDGETOBJS=";
Hashtbl.iter module_table
f:(fun key:name data:_ ->
~f:(fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".cmo ");
output_string oc "\n";
Hashtbl.iter module_table
f:(fun key:name data:_ ->
~f:(fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".ml ");
output_string oc ": tkgen.ml\n\n";
Hashtbl.iter module_table f:
begin fun key:name data:_ ->
Hashtbl.iter module_table ~f:
begin fun ~key:name ~data:_ ->
output_string oc name;
output_string oc ".cmo : ";
output_string oc name;
@ -261,10 +261,10 @@ let compile () =
let main () =
Arg.parse
keywords:[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
~keywords:[ "-verbose", Arg.Unit (fun () -> flag_verbose := true),
"Make output verbose" ]
others:(fun filename -> input_name := filename)
errmsg:"Usage: tkcompiler <source file>" ;
~others:(fun filename -> input_name := filename)
~errmsg:"Usage: tkcompiler <source file>" ;
try
verbose_string "Parsing... ";
parse_file !input_name;

5
otherlibs/labltk/compiler/parser.mly
View File

@ -95,13 +95,14 @@ Labeled_type2 :
{ $1, $3 }
;
/* products */
/* products
Type_list :
Type2 COMMA Type_list
{ $1 :: $3 }
| Type2
{ [$1] }
;
*/
/* records */
Type_record :
@ -287,7 +288,7 @@ entry :
TYPE ParserArity TypeName LBRACE Constructors RBRACE
{ enter_type $3 $2 $5 }
| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE
{ enter_type $4 $3 $6 variant: true }
{ enter_type $4 $3 $6 ~variant: true }
| TYPE ParserArity TypeName EXTERNAL
{ enter_external_type $3 $2 }
| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE

58
otherlibs/labltk/compiler/tables.ml
View File

@ -60,7 +60,7 @@ type fullcomponent = {
}
let sort_components =
Sort.list order:(fun c1 c2 -> c1.ml_name < c2.ml_name)
Sort.list ~order:(fun c1 c2 -> c1.ml_name < c2.ml_name)
(* components are given either in full or abbreviated *)
@ -116,8 +116,8 @@ let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
let rec getvarname ml_name temp =
let offhypben s =
let s = String.copy s in
if (try String.sub s pos:0 len:1 with _ -> "") = "-" then
String.sub s pos:1 len:(String.length s - 1)
if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then
String.sub s ~pos:1 ~len:(String.length s - 1)
else s
and makecapital s =
begin
@ -153,7 +153,7 @@ let new_type typname arity =
subtypes = [];
requires_widget_context = false;
variant = false} in
Hashtbl.add types_table key:typname data:typdef;
Hashtbl.add types_table ~key:typname ~data:typdef;
typdef
@ -210,8 +210,8 @@ let enter_external_type s v =
let rec enter_argtype = function
Unit | Int | Float | Bool | Char | String -> ()
| List ty -> enter_argtype ty
| Product tyl -> List.iter f:enter_argtype tyl
| Record tyl -> List.iter tyl f:(fun (l,t) -> enter_argtype t)
| Product tyl -> List.iter ~f:enter_argtype tyl
| Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t)
| UserDefined s -> Tsort.add_element types_order s
| Subtype (s,_) -> Tsort.add_element types_order s
| Function ty -> enter_argtype ty
@ -220,14 +220,14 @@ let rec enter_argtype = function
let rec enter_template_types = function
StringArg _ -> ()
| TypeArg (l,t) -> enter_argtype t
| ListArg l -> List.iter f:enter_template_types l
| OptionalArgs (_,tl,_) -> List.iter f:enter_template_types tl
| ListArg l -> List.iter ~f:enter_template_types l
| OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl
(* Find type dependancies on s *)
let rec add_dependancies s =
function
List ty -> add_dependancies s ty
| Product tyl -> List.iter f:(add_dependancies s) tyl
| Product tyl -> List.iter ~f:(add_dependancies s) tyl
| Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s)
| UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s)
| Function ty -> add_dependancies s ty
@ -237,16 +237,16 @@ let rec add_dependancies s =
let rec add_template_dependancies s = function
StringArg _ -> ()
| TypeArg (l,t) -> add_dependancies s t
| ListArg l -> List.iter f:(add_template_dependancies s) l
| OptionalArgs (_,tl,_) -> List.iter f:(add_template_dependancies s) tl
| ListArg l -> List.iter ~f:(add_template_dependancies s) l
| OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl
(* Assumes functions are not nested in products, which is reasonable due to syntax*)
let rec has_callback = function
StringArg _ -> false
| TypeArg (l,Function _ ) -> true
| TypeArg _ -> false
| ListArg l -> List.exists f:has_callback l
| OptionalArgs (_,tl,_) -> List.exists f:has_callback tl
| ListArg l -> List.exists ~f:has_callback l
| OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl
(*** Returned types ***)
let really_add ty =
@ -261,8 +261,8 @@ let rec add_return_type = function
| Char -> ()
| String -> ()
| List ty -> add_return_type ty
| Product tyl -> List.iter f:add_return_type tyl
| Record tyl -> List.iter tyl f:(fun (l,t) -> add_return_type t)
| Product tyl -> List.iter ~f:add_return_type tyl
| Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
| UserDefined s -> really_add s
| Subtype (s,_) -> really_add s
| Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
@ -298,12 +298,12 @@ let rec find_constructor cname = function
else find_constructor cname l
(* Enter a type, must not be previously defined *)
let enter_type typname ?(:variant = false) arity constructors =
let enter_type typname ?(variant = false) arity constructors =
if Hashtbl.mem types_table typname then
raise (Duplicate_Definition ("type", typname)) else
let typdef = new_type typname arity in
if variant then typdef.variant <- true;
List.iter constructors f:
List.iter constructors ~f:
begin fun c ->
if not (check_duplicate_constr false c typdef.constructors)
then begin
@ -327,7 +327,7 @@ let enter_subtype typ arity subtyp constructors =
then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
else begin
let real_constructors =
List.map constructors f:
List.map constructors ~f:
begin function
Full c ->
if not (check_duplicate_constr true c typdef.constructors)
@ -345,7 +345,7 @@ let enter_subtype typ arity subtyp constructors =
(* TODO: duplicate def in subtype are not checked *)
typdef.subtypes <-
(subtyp , Sort.list real_constructors
order:(fun c1 c2 -> c1.var_name <= c2.var_name)) ::
~order:(fun c1 c2 -> c1.var_name <= c2.var_name)) ::
typdef.subtypes
end
@ -369,19 +369,19 @@ let rec add_sort l obj =
else
(s',l)::(add_sort rest obj)
let separate_components = List.fold_left f:add_sort init:[]
let separate_components = List.fold_left ~f:add_sort ~init:[]
let enter_widget name components =
if Hashtbl.mem module_table name then
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
List.iter sorted_components f:
List.iter sorted_components ~f:
begin function
Constructor, l ->
enter_subtype "options" MultipleToken
name (List.map f:(fun c -> Full c) l)
name (List.map ~f:(fun c -> Full c) l)
| Command, l ->
List.iter f:enter_component_types l
List.iter ~f:enter_component_types l
| External, _ -> ()
end;
let commands =
@ -391,8 +391,8 @@ let enter_widget name components =
try List.assoc External sorted_components
with Not_found -> []
in
Hashtbl.add module_table key:name
data:{module_type = Widget; commands = commands; externals = externals}
Hashtbl.add module_table ~key:name
~data:{module_type = Widget; commands = commands; externals = externals}
(******************** Functions ********************)
let enter_function comp =
@ -405,10 +405,10 @@ let enter_module name components =
if Hashtbl.mem module_table name then
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
List.iter sorted_components f:
List.iter sorted_components ~f:
begin function
Constructor, l -> fatal_error "unexpected Constructor"
| Command, l -> List.iter f:enter_component_types l
| Command, l -> List.iter ~f:enter_component_types l
| External, _ -> ()
end;
let commands =
@ -418,6 +418,6 @@ let enter_module name components =
try List.assoc External sorted_components
with Not_found -> []
in
Hashtbl.add module_table key:name
data:{module_type = Family; commands = commands; externals = externals}
Hashtbl.add module_table ~key:name
~data:{module_type = Family; commands = commands; externals = externals}

6
otherlibs/labltk/compiler/tsort.ml
View File

@ -62,13 +62,13 @@ let sort order =
let q = Queue.create ()
and result = ref [] in
List.iter !order
f:(function {pred_count = n} as node ->
~f:(function {pred_count = n} as node ->
if n = 0 then Queue.add node q);
begin try
while true do
let t = Queue.take q in
result := t.node :: !result;
List.iter t.successors f:
List.iter t.successors ~f:
begin fun s ->
let n = s.pred_count - 1 in
s.pred_count <- n;
@ -78,7 +78,7 @@ let sort order =
with
Queue.Empty ->
List.iter !order
f:(fun node -> if node.pred_count <> 0
~f:(fun node -> if node.pred_count <> 0
then raise Cyclic)
end;
!result

30
otherlibs/labltk/jpf/balloon.ml
View File

@ -34,7 +34,7 @@ let configure_cursor w cursor =
TkToken "-cursor";
TkToken cursor |]
let put on: w ms: millisec mesg =
let put ~on: w ~ms: millisec mesg =
let t = ref None in
let cursor = ref "" in
@ -52,15 +52,15 @@ let put on: w ms: millisec mesg =
end
and set ev =
if !flag then
t := Some (Timer.add ms: millisec callback: (fun () ->
t := Some (Timer.add ~ms: millisec ~callback: (fun () ->
t := None;
if !debug then
prerr_endline ("Balloon: " ^ Widget.name w);
update_idletasks();
Message.configure !popupw text: mesg;
Message.configure !popupw ~text: mesg;
raise_window !topw;
Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *)
geometry: ("+"^(string_of_int (ev.ev_RootX + 9))^
~geometry: ("+"^(string_of_int (ev.ev_RootX + 9))^
"+"^(string_of_int (ev.ev_RootY + 8)));
Wm.deiconify !topw;
cursor := cget w `Cursor;
@ -69,11 +69,11 @@ let put on: w ms: millisec mesg =
List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy];
[`KeyPress]; [`KeyRelease]]
f:(fun events -> bind w :events extend:true action:(fun _ -> reset ()));
List.iter [[`Enter]; [`Motion]] f:
~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ()));
List.iter [[`Enter]; [`Motion]] ~f:
begin fun events ->
bind w :events extend:true fields:[`RootX; `RootY]
action:(fun ev -> reset (); set ev)
bind w ~events ~extend:true ~fields:[`RootX; `RootY]
~action:(fun ev -> reset (); set ev)
end
let init () =
@ -81,16 +81,16 @@ let init () =
Protocol.add_destroy_hook (fun w ->
Hashtbl.remove t w);
topw := Toplevel.create default_toplevel;
Wm.overrideredirect_set !topw to: true;
Wm.overrideredirect_set !topw true;
Wm.withdraw !topw;
popupw := Message.create !topw name: "balloon"
background: (`Color "yellow") aspect: 300;
popupw := Message.create !topw ~name: "balloon"
~background: (`Color "yellow") ~aspect: 300;
pack [!popupw];
bind_class "all" events: [`Enter] extend:true fields:[`Widget] action:
bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action:
begin fun w ->
try Hashtbl.find t w.ev_Widget
with Not_found ->
Hashtbl.add t key:w.ev_Widget data: ();
let x = Option.get w.ev_Widget name: "balloon" class: "Balloon" in
if x <> "" then put on: w.ev_Widget ms: 1000 x
Hashtbl.add t ~key:w.ev_Widget ~data: ();
let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
end

178
otherlibs/labltk/jpf/fileselect.ml
View File

@ -32,15 +32,15 @@ let global_dir = ref (getcwd ())
(* from frx_listbox.ml *)
let scroll_link sb lb =
Listbox.configure lb yscrollcommand: (Scrollbar.set sb);
Scrollbar.configure sb command: (Listbox.yview lb)
Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb);
Scrollbar.configure sb ~command: (Listbox.yview lb)
(* focus when enter binding *)
let bind_enter_focus w =
bind w events:[`Enter] action:(fun _ -> Focus.set w);;
bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);;
let myentry_create p :variable =
let w = Entry.create p relief: `Sunken textvariable: variable in
let myentry_create p ~variable =
let w = Entry.create p ~relief: `Sunken ~textvariable: variable in
bind_enter_focus w; w
(************************************************************* Subshell call *)
@ -48,8 +48,8 @@ let myentry_create p :variable =
let subshell cmd =
let r,w = pipe () in
match fork () with
0 -> close r; dup2 src:w dst:stdout;
execv prog:"/bin/sh" args:[| "/bin/sh"; "-c"; cmd |];
0 -> close r; dup2 ~src:w ~dst:stdout;
execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |];
exit 127
| id ->
close w;
@ -63,7 +63,7 @@ let subshell cmd =
in
let answer = it [] in
close_in rc; (* because of finalize_channel *)
let p, st = waitpid mode:[] id in answer
let p, st = waitpid ~mode:[] id in answer
(***************************************************************** Path name *)
@ -72,20 +72,20 @@ let dirget = regexp "^\([^\*?[]*/\)\(.*\)"
let parse_filter src =
(* replace // by / *)
let s = global_replace pat:(regexp "/+") templ:"/" src in
let s = global_replace ~pat:(regexp "/+") ~templ:"/" src in
(* replace /./ by / *)
let s = global_replace pat:(regexp "/\./") templ:"/" s in
let s = global_replace ~pat:(regexp "/\./") ~templ:"/" s in
(* replace ????/../ by "" *)
let s = global_replace s
pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./")
templ:"" in
~pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./")
~templ:"" in
(* replace ????/..$ by "" *)
let s = global_replace s
pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$")
templ:"" in
~pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$")
~templ:"" in
(* replace ^/../../ by / *)
let s = global_replace pat:(regexp "^\(/\.\.\)+/") templ:"/" s in
if string_match pat:dirget s pos:0 then
let s = global_replace ~pat:(regexp "^\(/\.\.\)+/") ~templ:"/" s in
if string_match ~pat:dirget s ~pos:0 then
let dirs = matched_group 1 s
and ptrn = matched_group 2 s
in
@ -108,15 +108,15 @@ let get_files_in_directory dir =
| Some x ->
get_them (x::l)
in
Sort.list order:(<=) (get_them [])
Sort.list ~order:(<=) (get_them [])
let rec get_directories_in_files path =
List.filter
f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
let remove_directories path =
List.filter
f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
(************************* a nice interface to listbox - from frx_listbox.ml *)
@ -127,20 +127,20 @@ let add_completion lb action =
and lastevent = ref 0 in
let rec move_forward () =
if Listbox.get lb index:(`Num !current) < !prefx then
if Listbox.get lb ~index:(`Num !current) < !prefx then
if !current < !maxi then begin incr current; move_forward() end
and recenter () =
let element = `Num !current in
(* Clean the selection *)
Listbox.selection_clear lb first:(`Num 0) last:`End;
Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
(* Set it to our unique element *)
Listbox.selection_set lb first:element last:element;
Listbox.selection_set lb ~first:element ~last:element;
(* Activate it, to keep consistent with Up/Down.
You have to be in Extended or Browse mode *)
Listbox.activate lb index:element;
Listbox.selection_anchor lb index:element;
Listbox.see lb index:element in
Listbox.activate lb ~index:element;
Listbox.selection_anchor lb ~index:element;
Listbox.see lb ~index:element in
let complete time s =
if time - !lastevent < 500 then (* sorry, hard coded limit *)
@ -154,12 +154,12 @@ let add_completion lb action =
recenter() in
bind lb events:[`KeyPress] fields:[`Char; `Time]
bind lb ~events:[`KeyPress] ~fields:[`Char; `Time]
(* consider only keys producing characters. The callback is called
if you press Shift. *)
action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char);
~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char);
(* Key specific bindings override KeyPress *)
bind lb events:[`KeyPressDetail "Return"] :action;
bind lb ~events:[`KeyPressDetail "Return"] ~action;
(* Finally, we have to set focus, otherwise events dont get through *)
Focus.set lb;
recenter() (* so that first item is selected *);
@ -171,7 +171,7 @@ let add_completion lb action =
(****************************************************************** Creation *)
let f :title action:proc filter:deffilter file:deffile :multi :sync =
let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync =
(* Ah ! Now I regret about the names of the widgets... *)
let current_pattern = ref ""
@ -183,34 +183,34 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
let tl = Toplevel.create default_toplevel in
Focus.set tl;
Wm.title_set tl :title;
Wm.title_set tl ~title;
let filter_var = Textvariable.create on:tl () (* new_temporary *)
and selection_var = Textvariable.create on:tl ()
and sync_var = Textvariable.create on:tl () in
let filter_var = Textvariable.create ~on:tl () (* new_temporary *)
and selection_var = Textvariable.create ~on:tl ()
and sync_var = Textvariable.create ~on:tl () in
let frm' = Frame.create tl borderwidth: 1 relief: `Raised in
let frm = Frame.create frm' borderwidth: 8 in
let fl = Label.create frm text: "Filter" in
let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
let frm = Frame.create frm' ~borderwidth: 8 in
let fl = Label.create frm ~text: "Filter" 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 = Frame.create dfl in
let directory_listbox = Listbox.create dflf relief: `Sunken
let directory_listbox = Listbox.create dflf ~relief: `Sunken
and directory_scrollbar = Scrollbar.create dflf in
scroll_link directory_scrollbar directory_listbox;
let dfr = Frame.create df in
let dfrl = Label.create dfr text: "Files" in
let dfrl = Label.create dfr ~text: "Files" in
let dfrf = Frame.create dfr in
let filter_listbox = Listbox.create dfrf relief: `Sunken in
let filter_listbox = Listbox.create dfrf ~relief: `Sunken in
let filter_scrollbar = Scrollbar.create dfrf in
scroll_link filter_scrollbar filter_listbox;
let sl = Label.create frm text: "Selection" in
let filter_entry = myentry_create frm variable: filter_var in
let selection_entry = myentry_create frm variable: selection_var
let sl = Label.create frm ~text: "Selection" in
let filter_entry = myentry_create frm ~variable: filter_var in
let selection_entry = myentry_create frm ~variable: selection_var
in
let cfrm' = Frame.create tl borderwidth: 1 relief: `Raised in
let cfrm = Frame.create cfrm' borderwidth: 8 in
let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
let cfrm = Frame.create cfrm' ~borderwidth: 8 in
let dumf = Frame.create cfrm in
let dumf2 = Frame.create cfrm in
@ -218,7 +218,7 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
(* OLDER let curdir = getcwd () in *)
(* Printf.eprintf "CURDIR %s\n" curdir; *)
let filter =
if string_match pat:(regexp "^/.*") filter pos:0 then filter
if string_match ~pat:(regexp "^/.*") filter ~pos:0 then filter
else
if filter = "" then !global_dir ^ "/*"
else !global_dir ^ "/" ^ filter in
@ -240,10 +240,10 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
in
Textvariable.set filter_var filter;
Textvariable.set selection_var (dirname ^ deffile);
Listbox.delete directory_listbox first:(`Num 0) last:`End;
Listbox.insert directory_listbox index:`End texts:directories;
Listbox.delete filter_listbox first:(`Num 0) last:`End;
Listbox.insert filter_listbox index:`End texts:matched_files;
Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
Listbox.insert directory_listbox ~index:`End ~texts:directories;
Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
!directory_init_completion directory_listbox;
!filter_init_completion filter_listbox
with
@ -269,82 +269,82 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
in
(* and buttons *)
let okb = Button.create cfrm text: "OK" command:
let okb = Button.create cfrm ~text: "OK" ~command:
begin fun () ->
let files =
List.map (Listbox.curselection filter_listbox)
f:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
in
let files = if files = [] then [Textvariable.get selection_var]
else files in
activate files ()
end
in
let flb = Button.create cfrm text: "Filter"
command: (fun () -> configure (Textvariable.get filter_var)) in
let ccb = Button.create cfrm text: "Cancel"
command: (fun () -> activate [] ()) in
let flb = Button.create cfrm ~text: "Filter"
~command: (fun () -> configure (Textvariable.get filter_var)) in
let ccb = Button.create cfrm ~text: "Cancel"
~command: (fun () -> activate [] ()) in
(* binding *)
bind selection_entry events:[`KeyPressDetail "Return"] breakable:true
action:(fun _ -> activate [Textvariable.get selection_var] ());
bind filter_entry events:[`KeyPressDetail "Return"]
action:(fun _ -> configure (Textvariable.get filter_var));
bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true
~action:(fun _ -> activate [Textvariable.get selection_var] ());
bind filter_entry ~events:[`KeyPressDetail "Return"]
~action:(fun _ -> configure (Textvariable.get filter_var));
let action _ =
let files =
List.map (Listbox.curselection filter_listbox)
f:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
in
activate files ()
in
bind filter_listbox events:[`Modified([`Double], `ButtonPressDetail 1)]
breakable:true :action;
if multi then Listbox.configure filter_listbox selectmode: `Multiple;
bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
~breakable:true ~action;
if multi then Listbox.configure filter_listbox ~selectmode: `Multiple;
filter_init_completion := add_completion filter_listbox action;
let action _ =
try
configure (!current_dir ^ ((function
[x] -> Listbox.get directory_listbox index:x
[x] -> Listbox.get directory_listbox ~index:x
| _ -> (* you must choose at least one directory. *)
Bell.ring (); raise Not_selected)
(Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern)
with _ -> () in
bind directory_listbox events:[`Modified([`Double], `ButtonPressDetail 1)]
breakable:true :action;
Listbox.configure directory_listbox selectmode: `Browse;
bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
~breakable:true ~action;
Listbox.configure directory_listbox ~selectmode: `Browse;
directory_init_completion := add_completion directory_listbox action;
pack [frm'; frm] fill: `X;
pack [frm'; frm] ~fill: `X;
(* 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: `X ipadx: 8;
pack [df] ~side: `Top ~fill: `X ~ipadx: 8;
(* directory *)
pack [dfl] side: `Left;
pack [dfll] side: `Top anchor: `W;
pack [dflf] side: `Top;
pack [dfl] ~side: `Left;
pack [dfll] ~side: `Top ~anchor: `W;
pack [dflf] ~side: `Top;
pack [coe directory_listbox; coe directory_scrollbar]
side: `Left fill: `Y;
~side: `Left ~fill: `Y;
(* files *)
pack [dfr] side: `Right;
pack [dfrl] side: `Top anchor: `W;
pack [dfrf] side: `Top;
pack [coe filter_listbox; coe filter_scrollbar] side: `Left fill: `Y;
pack [dfr] ~side: `Right;
pack [dfrl] ~side: `Top ~anchor: `W;
pack [dfrf] ~side: `Top;
pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y;
(* selection *)
pack [sl] side: `Top anchor: `W;
pack [selection_entry] side: `Top fill: `X;
pack [sl] ~side: `Top ~anchor: `W;
pack [selection_entry] ~side: `Top ~fill: `X;
(* create OK, Filter and Cancel buttons *)
pack [cfrm'] fill: `X;
pack [cfrm] fill: `X;
pack [okb] side: `Left;
pack [dumf] side: `Left expand: true;
pack [flb] side: `Left;
pack [dumf2] side: `Left expand: true;
pack [ccb] side: `Left;
pack [cfrm'] ~fill: `X;
pack [cfrm] ~fill: `X;
pack [okb] ~side: `Left;
pack [dumf] ~side: `Left ~expand: true;
pack [flb] ~side: `Left;
pack [dumf2] ~side: `Left ~expand: true;
pack [ccb] ~side: `Left;
configure deffilter;

16
otherlibs/labltk/support/fileevent.ml
View File

@ -31,16 +31,16 @@ external rem_file_output : file_descr -> unit
let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
let add_fileinput :fd callback:f =
let add_fileinput ~fd ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table key:id data:(fun _ -> f());
Hashtbl.add fd_table key:(fd, 'r') data:id;
Hashtbl.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl.add fd_table ~key:(fd, 'r') ~data:id;
if !Protocol.debug then begin
Protocol.prerr_cbid id; prerr_endline " for fileinput"
end;
add_file_input fd id
let remove_fileinput :fd =
let remove_fileinput ~fd =
try
let id = Hashtbl.find fd_table (fd, 'r') in
clear_callback id;
@ -54,16 +54,16 @@ let remove_fileinput :fd =
with
Not_found -> ()
let add_fileoutput :fd callback:f =
let add_fileoutput ~fd ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table key:id data:(fun _ -> f());
Hashtbl.add fd_table key:(fd, 'w') data:id;
Hashtbl.add callback_naming_table ~key:id ~data:(fun _ -> f());
Hashtbl.add fd_table ~key:(fd, 'w') ~data:id;
if !Protocol.debug then begin
Protocol.prerr_cbid id; prerr_endline " for fileoutput"
end;
add_file_output fd id
let remove_fileoutput :fd =
let remove_fileoutput ~fd =
try
let id = Hashtbl.find fd_table (fd, 'w') in
clear_callback id;

28
otherlibs/labltk/support/protocol.ml
View File

@ -27,7 +27,7 @@ type tkArgs =
type cbid = int
external opentk : display:string -> class:string -> unit
external opentk : display:string -> clas:string -> unit
= "camltk_opentk"
external tcl_eval : string -> string
= "camltk_tcl_eval"
@ -57,10 +57,10 @@ let debug =
let dump_args args =
let rec print_arg = function
TkToken s -> prerr_string s; prerr_string " "
| TkTokenList l -> List.iter f:print_arg l
| TkTokenList l -> List.iter ~f:print_arg l
| TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
in
Array.iter f:print_arg args;
Array.iter ~f:print_arg args;
prerr_newline()
(*
@ -105,11 +105,11 @@ let string_of_cbid = string_of_int
(* Add a new callback, associated to widget w *)
(* The callback should be cleared when w is destroyed *)
let register_callback w callback:f =
let register_callback w ~callback:f =
let id = new_function_id () in
Hashtbl.add callback_naming_table key:id data:f;
Hashtbl.add callback_naming_table ~key:id ~data:f;
if (forget_type w) <> (forget_type Widget.dummy) then
Hashtbl.add callback_memo_table key:(forget_type w) data:id;
Hashtbl.add callback_memo_table ~key:(forget_type w) ~data:id;
(string_of_cbid id)
let clear_callback id =
@ -119,7 +119,7 @@ let clear_callback id =
let remove_callbacks w =
let w = forget_type w in
let cb_ids = Hashtbl.find_all callback_memo_table w in
List.iter f:clear_callback cb_ids;
List.iter ~f:clear_callback cb_ids;
for i = 1 to List.length cb_ids do
Hashtbl.remove callback_memo_table w
done
@ -140,10 +140,10 @@ let install_cleanup () =
let call_destroy_hooks = function
[wname] ->
let w = cTKtoCAMLwidget wname in
List.iter f:(fun f -> f w) !destroy_hooks
List.iter ~f:(fun f -> f w) !destroy_hooks
| _ -> raise (TkError "bad cleanup callback") in
let fid = new_function_id () in
Hashtbl.add callback_naming_table key:fid data:call_destroy_hooks;
Hashtbl.add callback_naming_table ~key:fid ~data:call_destroy_hooks;
(* setup general destroy callback *)
tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}")
@ -155,7 +155,7 @@ let prerr_cbid id =
let dispatch_callback id args =
if !debug then begin
prerr_cbid id;
List.iter f:(fun x -> prerr_string " "; prerr_string x) args;
List.iter ~f:(fun x -> prerr_string " "; prerr_string x) args;
prerr_newline()
end;
(Hashtbl.find callback_naming_table id) args;
@ -176,8 +176,8 @@ let _ = callback_init ()
(* Different version of initialisation functions *)
(* Native opentk is [opentk display class] *)
let openTk ?(:display = "") ?(:class = "LablTk") () =
opentk :display :class;
let openTk ?(display = "") ?(clas = "LablTk") () =
opentk ~display ~clas;
install_cleanup();
Widget.default_toplevel
@ -191,8 +191,8 @@ let mainLoop =
(* [register tclname f] makes [f] available from Tcl with
name [tclname] *)
let register tclname callback:cb =
let s = register_callback Widget.default_toplevel callback:cb in
let register tclname ~callback =
let s = register_callback Widget.default_toplevel ~callback in
tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
tclname s)

2
otherlibs/labltk/support/protocol.mli
View File

@ -38,7 +38,7 @@ val add_destroy_hook : (any widget -> unit) -> unit
(* Opening, closing, and mainloop *)
val openTk : ?display:string -> ?class:string -> unit -> toplevel widget
val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget
val closeTk : unit -> unit
val mainLoop : unit -> unit

6
otherlibs/labltk/support/support.ml
View File

@ -17,7 +17,7 @@
(* Parsing results of Tcl *)
(* List.split a string according to char_sep predicate *)
let split_str pred:char_sep str =
let split_str ~pred:char_sep str =
let len = String.length str in
let rec skip_sep cur =
if cur >= len then cur
@ -26,11 +26,11 @@ let split_str pred:char_sep str =
let rec split beg cur =
if cur >= len then
if beg = cur then []
else [String.sub str pos:beg len:(len - beg)]
else [String.sub str ~pos:beg ~len:(len - beg)]
else if char_sep str.[cur]
then
let nextw = skip_sep cur in
(String.sub str pos:beg len:(cur - beg))
(String.sub str ~pos:beg ~len:(cur - beg))
::(split nextw nextw)
else split beg (succ cur) in
let wstart = skip_sep 0 in

10
otherlibs/labltk/support/textvariable.ml
View File

@ -36,7 +36,7 @@ let add_handle var cbid =
r := cbid :: !r
with
Not_found ->
Hashtbl.add handles key:var data:(ref [cbid])
Hashtbl.add handles ~key:var ~data:(ref [cbid])
let exceptq x =
let rec ex acc = function
@ -61,7 +61,7 @@ let rem_handle var cbid =
let rem_all_handles var =
try
let r = Hashtbl.find handles var in
List.iter f:(internal_untracevar var) !r;
List.iter ~f:(internal_untracevar var) !r;
Hashtbl.remove handles var
with
Not_found -> ()
@ -74,7 +74,7 @@ let handle vname f =
clear_callback id;
rem_handle vname id;
f() in
Hashtbl.add callback_naming_table key:id data:wrapped;
Hashtbl.add callback_naming_table ~key:id ~data:wrapped;
add_handle vname id;
if !Protocol.debug then begin
prerr_cbid id; prerr_string " for variable "; prerr_endline vname
@ -95,7 +95,7 @@ let add w v =
with
Not_found ->
let r = ref StringSet.empty in
Hashtbl.add memo key:w data:r;
Hashtbl.add memo ~key:w ~data:r;
r in
r := StringSet.add v !r
@ -108,7 +108,7 @@ let free v =
let freew w =
try
let r = Hashtbl.find memo w in
StringSet.iter f:free !r;
StringSet.iter ~f:free !r;
Hashtbl.remove memo w
with
Not_found -> ()

10
otherlibs/labltk/support/timer.ml
View File

@ -28,19 +28,19 @@ external internal_rem_timer : tkTimer -> unit
type t = tkTimer * cbid (* the token and the cb id *)
(* A timer is used only once, so we must clean the callback table *)
let add ms:milli callback:f =
let add ~ms ~callback =
let id = new_function_id () in
let wrapped _ =
clear_callback id; (* do it first in case f raises exception *)
f() in
Hashtbl.add callback_naming_table key:id data:wrapped;
callback() in
Hashtbl.add callback_naming_table ~key:id ~data:wrapped;
if !Protocol.debug then begin
prerr_cbid id; prerr_endline " for timer"
end;
let t = internal_add_timer milli id in
let t = internal_add_timer ms id in
t,id
let set ms:milli callback:f = ignore (add ms:milli callback:f);;
let set ~ms ~callback = ignore (add ~ms ~callback);;
(* If the timer has never been used, there is a small space leak in
the C heap, where a copy of id has been stored *)

10
otherlibs/labltk/support/widget.ml
View File

@ -66,7 +66,7 @@ let known_class = function
let default_toplevel =
let wname = "." in
let w = Typed (wname, "toplevel") in
Hashtbl.add table key:wname data:w;
Hashtbl.add table ~key:wname ~data:w;
w
(* Dummy widget to which global callbacks are associated *)
@ -103,7 +103,7 @@ let naming_scheme = [
"toplevel", "top" ]
let widget_any_table = List.map f:fst naming_scheme
let widget_any_table = List.map ~f:fst naming_scheme
(* subtypes *)
let widget_button_table = [ "button" ]
and widget_canvas_table = [ "canvas" ]
@ -130,7 +130,7 @@ let new_suffix clas n =
(* The function called by generic creation *)
let counter = ref 0
let new_atom :parent ?name:nom clas =
let new_atom ~parent ?name:nom clas =
let parentpath = name parent in
let path =
match nom with
@ -145,12 +145,12 @@ let new_atom :parent ?name:nom clas =
else parentpath ^ "." ^ name
in
let w = Typed(path,clas) in
Hashtbl.add table key:path data:w;
Hashtbl.add table ~key:path ~data:w;
w
(* Just create a path. Only to check existence of widgets *)
(* Use with care *)
let atom :parent name:pathcomp =
let atom ~parent ~name:pathcomp =
let parentpath = name parent in
let path =
if parentpath = "."

4
otherlibs/threads/threadUnix.mli
View File

@ -70,8 +70,8 @@ val sleep : int -> unit
(*** Sockets *)
val socket : domain:Unix.socket_domain ->
type:Unix.socket_type -> proto:int -> Unix.file_descr
val socketpair : domain:Unix.socket_domain -> type:Unix.socket_type ->
kind:Unix.socket_type -> proto:int -> Unix.file_descr
val socketpair : domain:Unix.socket_domain -> kind:Unix.socket_type ->
proto:int -> Unix.file_descr * Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit

6
otherlibs/unix/unix.mli
View File

@ -306,7 +306,7 @@ val fstat : file_descr -> stats
val unlink : string -> unit
(* Removes the named file *)
val rename : old:string -> new:string -> unit
val rename : src:string -> dst:string -> unit
(* [rename old new] changes the name of a file from [old] to [new]. *)
val link : src:string -> dst:string -> unit
(* [link source dest] creates a hard link named [dest] to the file
@ -713,12 +713,12 @@ type sockaddr =
[port] is the port number. *)
val socket :
domain:socket_domain -> type:socket_type -> protocol:int -> file_descr
domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr
(* Create a new socket in the given domain, and with the
given kind. The third argument is the protocol type; 0 selects
the default protocol for that kind of sockets. *)
val socketpair :
domain:socket_domain -> type:socket_type -> protocol:int ->
domain:socket_domain -> kind:socket_type -> protocol:int ->
file_descr * file_descr
(* Create a pair of unnamed sockets, connected together. *)
val accept : file_descr -> file_descr * sockaddr

1
parsing/lexer.mli
View File

@ -21,6 +21,7 @@ type error =
| Unterminated_comment
| Unterminated_string
| Unterminated_string_in_comment
| Keyword_as_label of string
;;
exception Error of error * int * int

37
parsing/lexer.mll
View File

@ -23,6 +23,7 @@ type error =
| Unterminated_comment
| Unterminated_string
| Unterminated_string_in_comment
| Keyword_as_label of string
;;
exception Error of error * int * int
@ -159,6 +160,8 @@ let report_error ppf = function
fprintf ppf "String literal not terminated"
| Unterminated_string_in_comment ->
fprintf ppf "This comment contains an unterminated string literal"
| Keyword_as_label kwd ->
fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
;;
}
@ -170,9 +173,6 @@ let identchar =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
let symbolchar2 =
['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~']
(* ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *)
let decimal_literal = ['0'-'9']+
let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
let oct_literal = '0' ['o' 'O'] ['0'-'7']+
@ -185,20 +185,22 @@ rule token = parse
{ token lexbuf }
| "_"
{ UNDERSCORE }
| lowercase identchar * ':' [ ^ ':' '=' '>']
| "~" { TILDE }
| "~" lowercase identchar * ':'
{ let s = Lexing.lexeme lexbuf in
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
LABEL (String.sub s 0 (String.length s - 2)) }
(*
| lowercase identchar * ':'
let name = String.sub s 1 (String.length s - 2) in
if Hashtbl.mem keyword_table name then
raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
Lexing.lexeme_end lexbuf));
LABEL name }
| "?" { QUESTION }
| "?" lowercase identchar * ':'
{ let s = Lexing.lexeme lexbuf in
LABEL (String.sub s 0 (String.length s - 1)) }
| '%' lowercase identchar *
*)
| ':' lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
let l = String.length s - 1 in
LABELID (String.sub s 1 l) }
let name = String.sub s 1 (String.length s - 2) in
if Hashtbl.mem keyword_table name then
raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
Lexing.lexeme_end lexbuf));
OPTLABEL name }
| lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
try
@ -262,7 +264,6 @@ rule token = parse
| ")" { RPAREN }
| "*" { STAR }
| "," { COMMA }
| "?" { QUESTION }
| "??" { QUESTION2 }
| "->" { MINUSGREATER }
| "." { DOT }
@ -294,9 +295,9 @@ rule token = parse
| "-" { SUBTRACTIVE "-" }
| "-." { SUBTRACTIVE "-." }
| ['!' '~'] symbolchar *
| "!" symbolchar *
{ PREFIXOP(Lexing.lexeme lexbuf) }
| '?' symbolchar2 *
| ['~' '?'] symbolchar +
{ PREFIXOP(Lexing.lexeme lexbuf) }
| ['=' '<' '>' '|' '&' '$'] symbolchar *
{ INFIXOP0(Lexing.lexeme lexbuf) }

115
parsing/parser.mly
View File

@ -244,7 +244,6 @@ let bigarray_set arr arg newval =
%token INITIALIZER
%token <int> INT
%token <string> LABEL
%token <string> LABELID
%token LAZY
%token LBRACE
%token LBRACELESS
@ -265,6 +264,7 @@ let bigarray_set arr arg newval =
%token OBJECT
%token OF
%token OPEN
%token <string> OPTLABEL
%token OR
%token PARSER
%token <string> PREFIXOP
@ -285,6 +285,7 @@ let bigarray_set arr arg newval =
%token STRUCT
%token <string> SUBTRACTIVE
%token THEN
%token TILDE
%token TO
%token TRUE
%token TRY
@ -606,10 +607,10 @@ value:
symbol_rloc () }
;
virtual_method:
METHOD PRIVATE VIRTUAL label_colon core_type
{ $4, Private, $5, symbol_rloc () }
| METHOD VIRTUAL private_flag label_colon core_type
{ $4, $3, $5, symbol_rloc () }
METHOD PRIVATE VIRTUAL label COLON core_type
{ $4, Private, $6, symbol_rloc () }
| METHOD VIRTUAL private_flag label COLON core_type
{ $4, $3, $6, symbol_rloc () }
;
concrete_method :
METHOD private_flag label fun_binding
@ -621,13 +622,18 @@ concrete_method :
class_type:
class_signature
{ $1 }
| QUESTION LABEL simple_core_type_or_tuple MINUSGREATER class_type
| QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun("?" ^ $2 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$3]);
ptyp_loc = $3.ptyp_loc},
$5)) }
| LABEL simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun($1, $2, $4)) }
{ptyp_desc = Ptyp_constr(Lident "option", [$4]);
ptyp_loc = $4.ptyp_loc},
$6)) }
| OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun("?" ^ $1 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$2]);
ptyp_loc = $2.ptyp_loc},
$4)) }
| LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun($1, $3, $5)) }
| simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun("", $1, $3)) }
;
@ -662,8 +668,8 @@ class_sig_fields:
| class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
;
value_type:
mutable_flag label_colon core_type
{ $2, $1, Some $3, symbol_rloc () }
mutable_flag label COLON core_type
{ $2, $1, Some $4, symbol_rloc () }
/*
XXX Should be removed
| mutable_flag label
@ -671,8 +677,8 @@ XXX Should be removed
*/
;
method_type:
METHOD private_flag label_colon core_type
{ $3, $2, $4, symbol_rloc () }
METHOD private_flag label COLON core_type
{ $3, $2, $5, symbol_rloc () }
;
constrain:
core_type EQUAL core_type { $1, $3, symbol_rloc () }
@ -682,8 +688,8 @@ class_descriptions:
| class_description { [$1] }
;
class_description:
virtual_flag class_type_parameters label_colon class_type
{ {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $4;
virtual_flag class_type_parameters LIDENT COLON class_type
{ {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $5;
pci_loc = symbol_rloc ()} }
;
class_type_declarations:
@ -706,36 +712,42 @@ seq_expr:
labeled_simple_pattern:
QUESTION LPAREN label_let_pattern opt_default RPAREN
{ ("?" ^ fst $3, $4, snd $3) }
| QUESTION label_simple_pattern
| QUESTION label_var
{ ("?" ^ fst $2, None, snd $2) }
| LPAREN label_let_pattern RPAREN
{ if !Clflags.classic then syntax_error () else (fst $2, None, snd $2) }
| label_simple_pattern
{ (fst $1, None, snd $1) }
| OPTLABEL LPAREN let_pattern opt_default RPAREN
{ ("?" ^ $1, $4, $3) }
| OPTLABEL pattern_var
{ ("?" ^ $1, None, $2) }
| TILDE LPAREN label_let_pattern RPAREN
{ (fst $3, None, snd $3) }
| TILDE label_var
{ (fst $2, None, snd $2) }
| LABEL simple_pattern
{ ($1, None, $2) }
| simple_pattern
{ ("", None, $1) }
;
pattern_var:
LIDENT { mkpat(Ppat_var $1) }
;
opt_default:
/* empty */ { None }
| EQUAL seq_expr { Some $2 }
;
label_let_pattern:
label_pattern
label_var
{ $1 }
| label_pattern COLON core_type
| label_var COLON core_type
{ let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) }
;
label_pattern:
LABEL pattern
{ ($1, $2) }
| LABELID
{ ($1, mkpat(Ppat_var $1)) }
label_var:
LIDENT { ($1, mkpat(Ppat_var $1)) }
;
label_simple_pattern:
LABEL simple_pattern
{ ($1, $2) }
| LABELID
{ ($1, mkpat(Ppat_var $1)) }
let_pattern:
pattern
{ $1 }
| pattern COLON core_type
{ mkpat(Ppat_constraint($1, $3)) }
;
expr:
simple_expr
@ -918,14 +930,19 @@ labeled_simple_expr:
{ ("", $1) }
| label_expr
{ $1 }
| QUESTION label_expr
{ ("?" ^ fst $2, snd $2) }
;
label_expr:
LABEL simple_expr
{ ($1, $2) }
| LABELID
{ ($1, mkexp(Pexp_ident(Lident $1))) }
| TILDE label_ident
{ $2 }
| QUESTION label_ident
{ ("?" ^ fst $2, snd $2) }
| OPTLABEL simple_expr
{ ("?" ^ $1, $2) }
;
label_ident:
LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) }
;
/*
simple_expr_list:
@ -1183,7 +1200,7 @@ label_declarations:
| label_declarations SEMI label_declaration { $3 :: $1 }
;
label_declaration:
mutable_flag label_colon core_type { ($2, $1, $3) }
mutable_flag label COLON core_type { ($2, $1, $4) }
;
/* "with" constraints (additional type equations over signature components) */
@ -1216,12 +1233,16 @@ core_type:
core_type2:
simple_core_type_or_tuple
{ $1 }
| QUESTION LABEL core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
| QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow("?" ^ $2 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$3]);
ptyp_loc = $3.ptyp_loc}, $5)) }
| LABEL core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow($1, $2, $4)) }
{ptyp_desc = Ptyp_constr(Lident "option", [$4]);
ptyp_loc = $4.ptyp_loc}, $6)) }
| OPTLABEL core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow("?" ^ $1 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$2]);
ptyp_loc = $2.ptyp_loc}, $4)) }
| LIDENT COLON core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow($1, $3, $5)) }
| core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow("", $1, $3)) }
;
@ -1317,15 +1338,11 @@ meth_list:
| DOTDOT { [mkfield Pfield_var] }
;
field:
label_colon core_type { mkfield(Pfield($1, $2)) }
label COLON core_type { mkfield(Pfield($1, $3)) }
;
label:
LIDENT { $1 }
;
label_colon:
LIDENT COLON { $1 }
| LABEL { $1 }
;
/* Constants */

2
stdlib/sys.mli
View File

@ -23,7 +23,7 @@ external file_exists: string -> bool = "sys_file_exists"
(* Test if a file with the given name exists. *)
external remove: string -> unit = "sys_remove"
(* Remove the given file name from the file system. *)
external rename : old:string -> new:string -> unit = "sys_rename"
external rename : src:string -> dst:string -> unit = "sys_rename"
(* Rename a file. The first argument is the old name and the
second is the new name. *)
external getenv: string -> string = "sys_getenv"

2
typing/typeclass.ml
View File

@ -1081,7 +1081,7 @@ let report_error ppf = function
| Apply_wrong_label l ->
let mark_label = function
| "" -> "out label"
| l -> sprintf " label %s:" l in
| l -> sprintf " label %s" l in
fprintf ppf "This argument cannot be applied with%s" (mark_label l)
| Pattern_type_clash ty ->
(* XXX Trace *)

4
typing/typecore.ml
View File

@ -1291,7 +1291,7 @@ let report_error ppf = function
| Apply_wrong_label (l, ty) ->
let print_label ppf = function
| "" -> fprintf ppf "without label"
| l -> fprintf ppf "with label %s:" l in
| l -> fprintf ppf "with label %s" l in
reset_and_mark_loops ty;
fprintf ppf
"@[<v>@[<2>Expecting function has type@ %a@]@,\
@ -1346,7 +1346,7 @@ let report_error ppf = function
| Abstract_wrong_label (l, ty) ->
let label_mark = function
| "" -> "but its argument is not labeled"
| l -> sprintf "but its argument is labeled %s:" l in
| l -> sprintf "but its argument is labeled %s" l in
reset_and_mark_loops ty;
fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
type_expr ty (label_mark l)

2
utils/config.mlp
View File

@ -12,7 +12,7 @@
(* $Id$ *)
let version = "2.99+16 (2000-04-08)"
let version = "2.99+17 (2000-04-12)"
let standard_library =
try