1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667
|
(*************************************************************************)
(* *)
(* OCaml LablTk library *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique and Kyoto University. All rights reserved. *)
(* This file is distributed under the terms of the GNU Library *)
(* General Public License, with the special exception on linking *)
(* described in file ../../../LICENSE. *)
(* *)
(*************************************************************************)
(* $Id$ *)
open StdLabels
open Tk
open Parsetree
open Location
open Jg_tk
open Mytypes
let lex_on_load = ref true
and type_on_load = ref false
let compiler_preferences master =
let tl = Jg_toplevel.titled "Compiler" in
Wm.transient_set tl ~master;
let mk_chkbutton ~text ~ref ~invert =
let variable = Textvariable.create ~on:tl () in
if (if invert then not !ref else !ref) then
Textvariable.set variable "1";
Checkbutton.create tl ~text ~variable,
(fun () ->
ref := Textvariable.get variable = (if invert then "0" else "1"))
in
let use_pp = ref (!Clflags.preprocessor <> None) in
let chkbuttons, setflags = List.split
(List.map
~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert)
[ "No pervasives", Clflags.nopervasives, false;
"No warnings", Typecheck.nowarnings, false;
"No labels", Clflags.classic, false;
"Recursive types", Clflags.recursive_types, false;
"Lex on load", lex_on_load, false;
"Type on load", type_on_load, false;
"Preprocessor", use_pp, false ])
in
let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in
begin match !Clflags.preprocessor with None -> ()
| Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp
end;
let buttons = Frame.create tl in
let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command:
begin fun () ->
List.iter ~f:(fun f -> f ()) setflags;
Clflags.preprocessor :=
if !use_pp then Some (Entry.get pp_command) else None;
destroy tl
end
and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel"
in
pack chkbuttons ~side:`Top ~anchor:`W;
pack [pp_command] ~side:`Top ~anchor:`E;
pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true;
pack [buttons] ~side:`Bottom ~fill:`X
let rec exclude txt = function
[] -> []
| x :: l -> if txt.number = x.number then l else x :: exclude txt l
let goto_line tw =
let tl = Jg_toplevel.titled "Go to" in
Wm.transient_set tl ~master:(Winfo.toplevel tw);
Jg_bind.escape_destroy tl;
let ef = Frame.create tl in
let fl = Frame.create ef
and fi = Frame.create ef in
let ll = Label.create fl ~text:"Line ~number:"
and il = Entry.create fi ~width:10
and lc = Label.create fl ~text:"Col ~number:"
and ic = Entry.create fi ~width:10
and get_int ew =
try int_of_string (Entry.get ew)
with Failure "int_of_string" -> 0
in
let buttons = Frame.create tl in
let ok = Button.create buttons ~text:"Ok" ~command:
begin fun () ->
let l = get_int il
and c = get_int ic in
Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]);
Text.see tw ~index:(`Mark "insert", []);
destroy tl
end
and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in
Focus.set il;
List.iter [il; ic] ~f:
begin fun w ->
Jg_bind.enter_focus w;
Jg_bind.return_invoke w ~button:ok
end;
pack [ll; lc] ~side:`Top ~anchor:`W;
pack [il; ic] ~side:`Top ~fill:`X ~expand:true;
pack [fl; fi] ~side:`Left ~fill:`X ~expand:true;
pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true;
pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true
let select_shell txt =
let shells = Shell.get_all () in
let shells = List.sort shells ~cmp:compare in
let tl = Jg_toplevel.titled "Select Shell" in
Jg_bind.escape_destroy tl;
Wm.transient_set tl ~master:(Winfo.toplevel txt.tw);
let label = Label.create tl ~text:"Send to:"
and box = Listbox.create tl
and frame = Frame.create tl in
Jg_bind.enter_focus box;
let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel"
and ok = Button.create frame ~text:"Ok" ~command:
begin fun () ->
try
let name = Listbox.get box ~index:`Active in
txt.shell <- Some (name, List.assoc name shells);
destroy tl
with Not_found -> txt.shell <- None; destroy tl
end
in
Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells);
Listbox.configure box ~height:(List.length shells);
bind box ~events:[`KeyPressDetail"Return"] ~breakable:true
~action:(fun _ -> Button.invoke ok; break ());
bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true
~fields:[`MouseX;`MouseY]
~action:(fun ev ->
Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY));
Button.invoke ok; break ());
pack [label] ~side:`Top ~anchor:`W;
pack [box] ~side:`Top ~fill:`Both;
pack [frame] ~side:`Bottom ~fill:`X ~expand:true;
pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true
open Parser
let send_phrase txt =
if txt.shell = None then begin
match Shell.get_all () with [] -> ()
| [sh] -> txt.shell <- Some sh
| l -> select_shell txt
end;
match txt.shell with None -> ()
| Some (_,sh) ->
try
let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in
let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in
sh#send phrase;
if Str.string_match (Str.regexp ";;") phrase 0
then sh#send "\n" else sh#send ";;\n"
with Not_found | Protocol.TkError _ ->
let text = Text.get txt.tw ~start:tstart ~stop:tend in
let buffer = Lexing.from_string text in
let start = ref 0
and block_start = ref []
and pend = ref (-1)
and after = ref false in
while !pend = -1 do
let token = Lexer.token buffer in
let pos =
if token = SEMISEMI then Lexing.lexeme_end buffer
else Lexing.lexeme_start buffer
in
let bol = (pos = 0) || text.[pos-1] = '\n' in
if not !after &&
Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge)
~index:(`Mark"insert",[])
then begin
after := true;
let anon, real =
List.partition !block_start ~f:(fun x -> x = -1) in
block_start := anon;
if real <> [] then start := List.hd real;
end;
match token with
CLASS | EXTERNAL | EXCEPTION | FUNCTOR
| LET | MODULE | OPEN | TYPE | VAL | SHARP when bol ->
if !block_start = [] then
if !after then pend := pos else start := pos
else block_start := pos :: List.tl !block_start
| SEMISEMI ->
if !block_start = [] then
if !after then pend := Lexing.lexeme_start buffer
else start := pos
else block_start := pos :: List.tl !block_start
| BEGIN | OBJECT ->
block_start := -1 :: !block_start
| STRUCT | SIG ->
block_start := Lexing.lexeme_end buffer :: !block_start
| END ->
if !block_start = [] then
if !after then pend := pos else ()
else block_start := List.tl !block_start
| EOF ->
pend := pos
| _ ->
()
done;
let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in
sh#send phrase;
sh#send ";;\n"
let search_pos_window txt ~x ~y =
if txt.type_info = [] && txt.psignature = [] then () else
let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
let text = Jg_text.get_all txt.tw in
let pos = Searchpos.lines_to_chars l ~text + c in
try if txt.type_info <> [] then begin match
Searchpos.search_pos_info txt.type_info ~pos
with [] -> ()
| (kind, env, loc) :: _ -> Searchpos.view_type kind ~env
end else begin match
Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
with [] -> ()
| ((kind, lid), env, loc) :: _ ->
Searchpos.view_decl lid ~kind ~env
end
with Not_found -> ()
let search_pos_menu txt ~x ~y =
if txt.type_info = [] && txt.psignature = [] then () else
let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in
let text = Jg_text.get_all txt.tw in
let pos = Searchpos.lines_to_chars l ~text + c in
try if txt.type_info <> [] then begin match
Searchpos.search_pos_info txt.type_info ~pos
with [] -> ()
| (kind, env, loc) :: _ ->
let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in
let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
Menu.popup menu ~x ~y
end else begin match
Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env
with [] -> ()
| ((kind, lid), env, loc) :: _ ->
let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in
let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
Menu.popup menu ~x ~y
end
with Not_found -> ()
let string_width s =
let width = ref 0 in
for i = 0 to String.length s - 1 do
if s.[i] = '\t' then width := (!width / 8 + 1) * 8
else incr width
done;
!width
let indent_line =
let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in
fun tw ->
let `Linechar(l,c) = Text.index tw ~index:(ins,[])
and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in
ignore (Str.string_match reg line 0);
let len = Str.match_end () in
if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else
let width = string_width (Str.matched_string line) in
Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]);
let indent =
if l <= 1 then 2 else
let previous =
Text.get tw ~start:(ins,[`Line(-1);`Linestart])
~stop:(ins,[`Line(-1);`Lineend]) in
ignore (Str.string_match reg previous 0);
let previous = Str.matched_string previous in
let width_previous = string_width previous in
if width_previous <= width then 2 else width_previous - width
in
Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ')
(* The editor class *)
class editor ~top ~menus = object (self)
val file_menu = new Jg_menu.c "File" ~parent:menus
val edit_menu = new Jg_menu.c "Edit" ~parent:menus
val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus
val module_menu = new Jg_menu.c "Modules" ~parent:menus
val window_menu = new Jg_menu.c "Windows" ~parent:menus
initializer
Menu.add_checkbutton menus ~state:`Disabled
~onvalue:"modified" ~offvalue:"unchanged"
val mutable current_dir = Unix.getcwd ()
val mutable error_messages = []
val mutable windows = []
val mutable current_tw = Text.create top
val vwindow = Textvariable.create ~on:top ()
val mutable window_counter = 0
method has_window name =
List.exists windows ~f:(fun x -> x.name = name)
method reset_window_menu =
Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End;
List.iter
(List.sort windows ~cmp:
(fun w1 w2 ->
compare (Filename.basename w1.name) (Filename.basename w2.name)))
~f:
begin fun txt ->
Menu.add_radiobutton window_menu#menu
~label:(Filename.basename txt.name)
~variable:vwindow ~value:txt.number
~command:(fun () -> self#set_edit txt)
end
method set_file_name txt =
Menu.configure_checkbutton menus `Last
~label:(Filename.basename txt.name)
~variable:txt.modified
method set_edit txt =
if windows <> [] then
Pack.forget [(List.hd windows).frame];
windows <- txt :: exclude txt windows;
self#reset_window_menu;
current_tw <- txt.tw;
self#set_file_name txt;
Textvariable.set vwindow txt.number;
Text.yview txt.tw ~scroll:(`Page 0);
pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom
method new_window name =
let tl, tw, sb = Jg_text.create_with_scrollbar top in
Text.configure tw ~background:`White;
Jg_bind.enter_focus tw;
window_counter <- window_counter + 1;
let txt =
{ name = name; tw = tw; frame = tl;
number = string_of_int window_counter;
modified = Textvariable.create ~on:tw ();
shell = None;
structure = []; type_info = []; signature = []; psignature = [] }
in
let control c = Char.chr (Char.code c - 96) in
bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore;
bind tw ~events:[`KeyPress] ~fields:[`Char]
~action:(fun ev ->
if ev.ev_Char <> "" &&
(ev.ev_Char.[0] >= ' ' ||
List.mem ev.ev_Char.[0]
(List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y']))
then Textvariable.set txt.modified "modified");
bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true
~action:(fun _ ->
indent_line tw;
Textvariable.set txt.modified "modified";
break ());
bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")]
~action:(fun _ ->
let text =
Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend])
in ignore (Str.string_match (Str.regexp "[ \t]*") text 0);
if Str.match_end () <> String.length text then begin
Clipboard.clear ();
Clipboard.append ~data:text ()
end);
bind tw ~events:[`KeyRelease] ~fields:[`Char]
~action:(fun ev ->
if ev.ev_Char <> "" then
Lexical.tag tw ~start:(`Mark"insert", [`Linestart])
~stop:(`Mark"insert", [`Lineend]));
bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw);
bind tw ~events:[`ButtonPressDetail 2]
~action:(fun _ ->
Textvariable.set txt.modified "modified";
Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart])
~stop:(`Mark"insert", [`Lineend]));
bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
~fields:[`MouseX;`MouseY]
~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY]
~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY);
pack [sb] ~fill:`Y ~side:`Right;
pack [tw] ~fill:`Both ~expand:true ~side:`Left;
self#set_edit txt;
Textvariable.set txt.modified "unchanged";
Lexical.init_tags txt.tw
method clear_errors () =
Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
List.iter error_messages
~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
error_messages <- []
method typecheck () =
self#clear_errors ();
error_messages <- Typecheck.f (List.hd windows)
method lex () =
List.iter [ Widget.default_toplevel; top ]
~f:(Toplevel.configure ~cursor:(`Xcursor "watch"));
Text.configure current_tw ~cursor:(`Xcursor "watch");
ignore (Timer.add ~ms:1 ~callback:
begin fun () ->
Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend;
Lexical.tag current_tw;
Text.configure current_tw ~cursor:(`Xcursor "xterm");
List.iter [ Widget.default_toplevel; top ]
~f:(Toplevel.configure ~cursor:(`Xcursor ""))
end)
method save_text ?name:l txt =
let l = match l with None -> [txt.name] | Some l -> l in
if l = [] then () else
let name = List.hd l in
if txt.name <> name then current_dir <- Filename.dirname name;
try
if Sys.file_exists name then
if txt.name = name then begin
let backup = name ^ "~" in
if Sys.file_exists backup then Sys.remove backup;
try Sys.rename name backup with Sys_error _ -> ()
end else begin
match Jg_message.ask ~master:top ~title:"Save"
("File `" ^ name ^ "' exists. Overwrite it?")
with `Yes -> Sys.remove name
| `No -> raise (Sys_error "")
| `Cancel -> raise Exit
end;
let file = open_out name in
let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in
output_string file text;
close_out file;
txt.name <- name;
self#set_file_name txt
with
Sys_error _ ->
Jg_message.info ~master:top ~title:"Error"
("Could not save `" ^ name ^ "'.")
| Exit -> ()
method load_text l =
if l = [] then () else
let name = List.hd l in
try
let index =
try
self#set_edit (List.find windows ~f:(fun x -> x.name = name));
let txt = List.hd windows in
if Textvariable.get txt.modified = "modified" then
begin match Jg_message.ask ~master:top ~title:"Open"
("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
with `Yes -> self#save_text txt
| `No -> ()
| `Cancel -> raise Exit
end;
Textvariable.set txt.modified "unchanged";
(Text.index current_tw ~index:(`Mark"insert", []), [])
with Not_found -> self#new_window name; tstart
in
current_dir <- Filename.dirname name;
let file = open_in name
and tw = current_tw
and len = ref 0
and buf = String.create 4096 in
Text.delete tw ~start:tstart ~stop:tend;
while
len := input file buf 0 4096;
!len > 0
do
Jg_text.output tw ~buf ~pos:0 ~len:!len
done;
close_in file;
Text.mark_set tw ~mark:"insert" ~index;
Text.see tw ~index;
if Filename.check_suffix name ".ml" ||
Filename.check_suffix name ".mli"
then begin
if !lex_on_load then self#lex ();
if !type_on_load then self#typecheck ()
end
with
Sys_error _ | Exit -> ()
method close_window txt =
try
if Textvariable.get txt.modified = "modified" then
begin match Jg_message.ask ~master:top ~title:"Close"
("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
with `Yes -> self#save_text txt
| `No -> ()
| `Cancel -> raise Exit
end;
windows <- exclude txt windows;
if windows = [] then
self#new_window (current_dir ^ "/untitled")
else self#set_edit (List.hd windows);
destroy txt.frame
with Exit -> ()
method open_file () =
Fileselect.f ~title:"Open File" ~action:self#load_text
~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true ()
method save_file () = self#save_text (List.hd windows)
method close_file () = self#close_window (List.hd windows)
method quit ?(cancel=true) () =
try
List.iter windows ~f:
begin fun txt ->
if Textvariable.get txt.modified = "modified" then
match Jg_message.ask ~master:top ~title:"Quit" ~cancel
("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
with `Yes -> self#save_text txt
| `No -> ()
| `Cancel -> raise Exit
end;
bind top ~events:[`Destroy];
destroy top
with Exit -> ()
method reopen ~file ~pos =
if not (Winfo.ismapped top) then Wm.deiconify top;
match file with None -> ()
| Some file ->
self#load_text [file];
Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos);
try
let index =
Text.search current_tw ~switches:[`Backwards] ~pattern:"*)"
~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in
let index =
Text.search current_tw ~switches:[`Backwards] ~pattern:"(*"
~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in
let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart])
~stop:(index,[`Line(-1);`Lineend]) in
for i = 0 to String.length s - 1 do
match s.[i] with '\t'|' ' -> () | _ -> raise Not_found
done;
Text.yview_index current_tw ~index:(index,[`Line(-1)])
with _ ->
Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)])
initializer
(* Create a first window *)
self#new_window (current_dir ^ "/untitled");
(* Bindings for the main window *)
List.iter
[ [`Control], "s", (fun () -> Jg_text.search_string current_tw);
[`Control], "g", (fun () -> goto_line current_tw);
[`Alt], "s", self#save_file;
[`Alt], "x", (fun () -> send_phrase (List.hd windows));
[`Alt], "l", self#lex;
[`Alt], "t", self#typecheck ]
~f:begin fun (modi,key,act) ->
bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true
~action:(fun _ -> act (); break ())
end;
bind top ~events:[`Destroy] ~fields:[`Widget] ~action:
begin fun ev ->
if Widget.name ev.ev_Widget = Widget.name top
then self#quit ~cancel:false ()
end;
(* File menu *)
file_menu#add_command "Open File..." ~command:self#open_file;
file_menu#add_command "Reopen"
~command:(fun () -> self#load_text [(List.hd windows).name]);
file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s";
file_menu#add_command "Save As..." ~underline:5 ~command:
begin fun () ->
let txt = List.hd windows in
Fileselect.f ~title:"Save as File"
~action:(fun name -> self#save_text txt ~name)
~dir:(Filename.dirname txt.name)
~filter:"*.{ml,mli}"
~file:(Filename.basename txt.name)
~sync:true ~usepath:false ()
end;
file_menu#add_command "Close File" ~command:self#close_file;
file_menu#add_command "Close Window" ~command:self#quit ~underline:6;
(* Edit menu *)
edit_menu#add_command "Paste selection" ~command:
begin fun () ->
Text.insert current_tw ~index:(`Mark"insert",[])
~text:(Selection.get ~displayof:top ())
end;
edit_menu#add_command "Goto..." ~accelerator:"C-g"
~command:(fun () -> goto_line current_tw);
edit_menu#add_command "Search..." ~accelerator:"C-s"
~command:(fun () -> Jg_text.search_string current_tw);
edit_menu#add_command "To shell" ~accelerator:"M-x"
~command:(fun () -> send_phrase (List.hd windows));
edit_menu#add_command "Select shell..."
~command:(fun () -> select_shell (List.hd windows));
(* Compiler menu *)
compiler_menu#add_command "Preferences..."
~command:(fun () -> compiler_preferences top);
compiler_menu#add_command "Lex" ~accelerator:"M-l"
~command:self#lex;
compiler_menu#add_command "Typecheck" ~accelerator:"M-t"
~command:self#typecheck;
compiler_menu#add_command "Clear errors"
~command:self#clear_errors;
compiler_menu#add_command "Signature..." ~command:
begin fun () ->
let txt = List.hd windows in if txt.signature <> [] then
let basename = Filename.basename txt.name in
let modname = String.capitalize
(try Filename.chop_extension basename with _ -> basename) in
let env =
Env.add_module (Ident.create modname)
(Types.Mty_signature txt.signature)
!Searchid.start_env
in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true
end;
(* Modules *)
module_menu#add_command "Path editor..."
~command:(fun () -> Setpath.set ~dir:current_dir);
module_menu#add_command "Reset cache"
~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ());
module_menu#add_command "Search symbol..."
~command:Viewer.search_symbol;
module_menu#add_command "Close all"
~command:Viewer.close_all_views;
end
(* The main function starts here ! *)
let already_open : editor list ref = ref []
let editor ?file ?(pos=0) ?(reuse=false) () =
if !already_open <> [] &&
let ed = List.hd !already_open
(* try
let name = match file with Some f -> f | None -> raise Not_found in
List.find !already_open ~f:(fun ed -> ed#has_window name)
with Not_found -> List.hd !already_open *)
in try
ed#reopen ~file ~pos;
true
with Protocol.TkError _ ->
already_open := [] (* List.filter !already_open ~f:((<>) ed) *);
false
then () else
let top = Jg_toplevel.titled "OCamlBrowser Editor" in
let menus = Jg_menu.menubar top in
let ed = new editor ~top ~menus in
already_open := !already_open @ [ed];
if file <> None then ed#reopen ~file ~pos
let f ?file ?pos ?(opendialog=false) () =
if opendialog then
Fileselect.f ~title:"Open File"
~action:(function [file] -> editor ~file () | _ -> ())
~filter:("*.{ml,mli}") ~sync:true ()
else editor ?file ?pos ~reuse:(file <> None) ()
|