ocaml/otherlibs/labltk/browser/editor.ml

(*************************************************************************)
(*                                                                       *)
(*                Objective Caml 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.                                             *)
(*                                                                       *)
(*************************************************************************)

(* $Id$ *)

open Tk
open Parsetree
open Location
open Jg_tk
open Mytypes

let lex_on_load = ref true
and type_on_load = ref false

let compiler_preferences () =
  let tl = Jg_toplevel.titled "Compiler" in
  Wm.transient_set tl master:Widget.default_toplevel;
  let mk_chkbutton :text :ref =
    let variable = Textvariable.create on:tl () in
    if !ref then Textvariable.set variable to:"1";
    Checkbutton.create tl :text :variable,
    (fun () -> ref := Textvariable.get variable = "1")
  in
  let chkbuttons, setflags = List.split
      (List.map fun:(fun (text, ref) -> mk_chkbutton :text :ref)
        ["No pervasives", Clflags.nopervasives;
         "No warnings", Typecheck.nowarnings;
         "Classic", Clflags.classic;
         "Lex on load", lex_on_load;
         "Type on load", type_on_load])
  in
  let buttons = Frame.create tl in
  let ok = Button.create buttons text:"Ok" padx:20 command:
      begin fun () ->
        List.iter fun:(fun f -> f ()) setflags;
        destroy tl
      end
  and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel"
  in
  pack chkbuttons side:`Top anchor:`W;
  pack [ok;cancel] side:`Left fill:`X expand:true;
  pack [buttons] side:`Bottom fill:`X

let rec exclude key:txt = function
    [] -> []
  | x :: l -> if txt.number = x.number then l else x :: exclude key:txt l

let goto_line tw =
  let tl = Jg_toplevel.titled "Go to" in
  Wm.transient_set tl master:Widget.default_toplevel;
  Jg_bind.escape_destroy tl;
  let ef = Frame.create tl in
  let fl = Frame.create ef
  and fi = Frame.create ef in
  let ll = Label.create fl text:"Line number:"
  and il = Entry.create fi width:10
  and lc = Label.create fl text:"Col number:"
  and ic = Entry.create fi width:10
  and get_int ew =
      try int_of_string (Entry.get ew)
      with Failure "int_of_string" -> 0
  in
  let buttons = Frame.create tl in
  let ok = Button.create buttons text:"Ok" command:
    begin fun () ->
      let l = get_int il
      and c = get_int ic in
      Text.mark_set tw mark:"insert" index:(`Linechar (l,0), [`Char c]);
      Text.see tw index:(`Mark "insert", []);
      destroy tl
    end
  and cancel = Jg_button.create_destroyer tl parent:buttons text:"Cancel" in

  Focus.set il;
  List.iter [il; ic] fun:
  begin fun w ->
    Jg_bind.enter_focus w;
    Jg_bind.return_invoke w button:ok
  end;
  pack [ll; lc] side:`Top anchor:`W;
  pack [il; ic] side:`Top fill:`X expand:true;
  pack [fl; fi] side:`Left fill:`X expand:true;
  pack [ok; cancel] side:`Left fill:`X expand:true;
  pack [ef; buttons] side:`Top fill:`X expand:true

let select_shell txt =
  let shells = Shell.get_all () in
  let shells = Sort.list shells order:(fun (x,_) (y,_) -> x <= y) in
  let tl = Jg_toplevel.titled "Select Shell" in
  Jg_bind.escape_destroy tl;
  Wm.transient_set tl master:(Winfo.toplevel txt.tw);
  let label = Label.create tl text:"Send to:"
  and box = Listbox.create tl
  and frame = Frame.create tl in
  Jg_bind.enter_focus box;
  let cancel = Jg_button.create_destroyer tl parent:frame text:"Cancel"
  and ok = Button.create frame text:"Ok" command:
      begin fun () ->
        try
          let name = Listbox.get box index:`Active in
          txt.shell <- Some (name, List.assoc key:name shells);
          destroy tl
        with Not_found -> txt.shell <- None; destroy tl
      end
  in
  Listbox.insert box index:`End texts:(List.map fun:fst shells);
  Listbox.configure box height:(List.length shells);
  bind box events:[`KeyPressDetail"Return"] 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,[]) end:(i2,[]) in
        sh#send phrase;
        try
          ignore(Str.search_forward phrase pat:(Str.regexp ";;") pos:0);
          sh#send "\n"
        with Not_found ->
          sh#send ";;\n"
      with Not_found | Protocol.TkError _ ->
        let text = Text.get txt.tw start:tstart end: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 pred:(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.structure = [] & txt.psignature = [] then () else
  let `Linechar (l, c) = Text.index txt.tw index:(`Atxy(x,y), []) in
  let text = Jg_text.get_all txt.tw in
  let pos = Searchpos.lines_to_chars l in:text + c in
  try if txt.structure <> [] then
    try Searchpos.search_pos_structure txt.structure :pos
    with Searchpos.Found_str (kind, env) ->
      Searchpos.view_type kind :env
  else
    try Searchpos.search_pos_signature
        txt.psignature :pos env:!Searchid.start_env;
      ()
    with Searchpos.Found_sig (kind, lid, env) ->
      Searchpos.view_decl lid :kind :env
  with Not_found -> ()

let search_pos_menu txt :x :y =
  if txt.structure = [] & txt.psignature = [] then () else
  let `Linechar (l, c) = Text.index txt.tw index:(`Atxy(x,y), []) in
  let text = Jg_text.get_all txt.tw in
  let pos = Searchpos.lines_to_chars l in:text + c in
  try if txt.structure <> [] then
    try Searchpos.search_pos_structure txt.structure :pos
    with Searchpos.Found_str (kind, env) ->
      let menu = Searchpos.view_type_menu kind :env parent:txt.tw in
      let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
      Menu.popup menu :x :y
  else
    try Searchpos.search_pos_signature
        txt.psignature :pos env:!Searchid.start_env;
      ()
    with Searchpos.Found_sig (kind, lid, env) ->
      let menu = Searchpos.view_decl_menu lid :kind :env parent:txt.tw in
      let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in
      Menu.popup menu :x :y
  with Not_found -> ()

let string_width s =
  let width = ref 0 in
  for i = 0 to String.length s - 1 do
    if s.[i] = '\t' then width := (!width / 8 + 1) * 8
    else incr width
  done;
  !width

let indent_line =
  let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in
  fun tw ->
    let `Linechar(l,c) = Text.index tw index:(ins,[])
    and line = Text.get tw start:(ins,[`Linestart]) end:(ins,[`Lineend]) in
    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
    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])
          end:(ins,[`Line(-1);`Lineend]) in
      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 len:indent ' ')

(* The editor class *)

class editor :top :menus = object (self)
  val file_menu = new Jg_menu.c "File" parent:menus
  val edit_menu = new Jg_menu.c "Edit" parent:menus
  val compiler_menu = new Jg_menu.c "Compiler" parent:menus
  val module_menu = new Jg_menu.c "Modules" parent:menus
  val window_menu = new Jg_menu.c "Windows" parent:menus
  val label =
    Checkbutton.create menus state:`Disabled
      onvalue:"modified" offvalue:"unchanged"
  val mutable current_dir = Unix.getcwd ()
  val mutable error_messages = []
  val mutable windows = []
  val mutable current_tw = Text.create top
  val vwindow = Textvariable.create on:top ()
  val mutable window_counter = 0

  method reset_window_menu =
    Menu.delete window_menu#menu first:(`Num 0) last:`End;
    List.iter
      (Sort.list windows order:
         (fun w1 w2 -> Filename.basename w1.name < Filename.basename w2.name))
      fun:
      begin fun txt ->
        Menu.add_radiobutton window_menu#menu
          label:(Filename.basename txt.name)
          variable:vwindow value:txt.number
          command:(fun () -> self#set_edit txt)
      end

  method set_edit txt  =
    if windows <> [] then
      Pack.forget [(List.hd windows).frame];
    windows <- txt :: exclude key:txt windows;
    self#reset_window_menu;
    current_tw <- txt.tw;
    Checkbutton.configure label text:(Filename.basename txt.name)
      variable:txt.modified;
    Textvariable.set vwindow to:txt.number;
    Text.yview txt.tw scroll:(`Page 0);
    pack [txt.frame] fill:`Both expand:true side:`Bottom

  method new_window name =
    let tl, tw, sb = Jg_text.create_with_scrollbar top in
    Text.configure tw background:`White;
    Jg_bind.enter_focus tw;
    window_counter <- window_counter + 1;
    let txt =
      { name = name; tw = tw; frame = tl;
        number = string_of_int window_counter;
        modified = Textvariable.create on:tw ();
        shell = None;
        structure = []; signature = []; psignature = [] }
    in
    let control c = Char.chr (Char.code c - 96) in
    bind tw events:[`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 item:ev.ev_Char.[0]
             (List.map fun:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y']))
        then Textvariable.set txt.modified to:"modified");
    bind tw events:[`KeyPressDetail"Tab"] breakable:true
      action:(fun _ ->
        indent_line tw;
        Textvariable.set txt.modified to:"modified";
        break ());
    bind tw events:[`Modified([`Control],`KeyPressDetail"k")]
      action:(fun _ ->
        let text =
          Text.get tw start:(`Mark"insert",[]) end:(`Mark"insert",[`Lineend])
        in 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 ()
        end);
    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 _ ->
        Textvariable.set txt.modified to:"modified";
        Lexical.tag txt.tw start:(`Mark"insert", [`Linestart])
          end:(`Mark"insert", [`Lineend]));
    bind tw events:[`Modified([`Double], `ButtonPressDetail 1)]
      fields:[`MouseX;`MouseY]
      action:(fun ev -> search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY);
    bind tw events:[`ButtonPressDetail 3] fields:[`MouseX;`MouseY]
      action:(fun ev -> search_pos_menu txt x:ev.ev_MouseX y:ev.ev_MouseY);

    pack [sb] fill:`Y side:`Right;
    pack [tw] fill:`Both expand:true side:`Left;
    self#set_edit txt;
    Checkbutton.deselect label;
    Lexical.init_tags txt.tw

  method clear_errors () =
    Text.tag_remove current_tw tag:"error" start:tstart end:tend;
    List.iter error_messages
      fun:(fun tl -> try destroy tl with Protocol.TkError _ -> ());
    error_messages <- []

  method typecheck () =
    self#clear_errors ();
    error_messages <- Typecheck.f (List.hd windows)

  method lex () =
    Text.tag_remove current_tw tag:"error" start:tstart end:tend;
    Lexical.tag current_tw

  method save_text ?name:l txt =
    let l = match l with None -> [txt.name] | Some l -> l in
    if l = [] then () else
    let name = List.hd l in
    if txt.name <> name then current_dir <- Filename.dirname name;
    try
      if Sys.file_exists name then
        if txt.name = name then
          Sys.rename old:name new:(name ^ "~")
        else begin match
          Jg_message.ask master:top title:"Save"
            ("File `" ^ name ^ "' exists. Overwrite it?")
        with `yes -> () | `no | `cancel -> raise Exit
        end;
      let file = open_out name in
      let text = Text.get txt.tw start:tstart end:(tposend 1) in
      output_string text to:file;
      close_out file;
      Checkbutton.configure label text:(Filename.basename name);
      Checkbutton.deselect label;
      txt.name <- name
    with
      Sys_error _ | Exit -> ()

  method load_text l =
    if l = [] then () else
    let name = List.hd l in
    try
      let index =
        try
          self#set_edit (List.find windows pred:(fun x -> x.name = name));
          let txt = List.hd windows in
          if Textvariable.get txt.modified = "modified" then
            begin match Jg_message.ask master:top title:"Open"
                ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
            with `yes -> self#save_text txt
            | `no -> ()
            | `cancel -> raise Exit
            end;
          Checkbutton.deselect label;
          (Text.index current_tw index:(`Mark"insert", []), [])
        with Not_found -> self#new_window name; tstart
      in
      current_dir <- Filename.dirname name;
      let file = open_in name
      and tw = current_tw
      and len = ref 0
      and buf = String.create len:4096 in
      Text.delete tw start:tstart end:tend;
      while
        len := input file :buf pos:0 len: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 suff:".ml" or
        Filename.check_suffix name suff:".mli"
      then begin
        if !lex_on_load then self#lex ();
        if !type_on_load then self#typecheck ()
      end
    with
      Sys_error _ | Exit -> ()

  method close_window txt =
    try
      if Textvariable.get txt.modified = "modified" then
        begin match Jg_message.ask master:top title:"Close"
            ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
        with `yes -> self#save_text txt
        | `no -> ()
        | `cancel -> raise Exit
        end;
      windows <- exclude key:txt windows;
      if windows = [] then
        self#new_window (current_dir ^ "/untitled")
      else self#set_edit (List.hd windows);
      destroy txt.frame
    with Exit -> ()

  method open_file () =
    Fileselect.f title:"Open File" action:self#load_text
      dir:current_dir filter:("*.{ml,mli}") sync:true ()

  method save_file () = self#save_text (List.hd windows)

  method close_file () = self#close_window (List.hd windows)

  method quit () =
    try
      List.iter windows fun:
        begin fun txt ->
          if Textvariable.get txt.modified = "modified" then
            match Jg_message.ask master:top title:"Quit"
                ("`" ^ Filename.basename txt.name ^ "' modified. Save it?")
            with `yes -> self#save_text txt
            | `no -> ()
            | `cancel -> raise Exit
        end;
      bind top events:[`Destroy];
      destroy top; break ()
    with Exit -> break ()

  method reopen :file :pos =
    if not (Winfo.ismapped top) then Wm.deiconify top;
    match file with None -> ()
    | Some file ->
        self#load_text [file]; 
        Text.mark_set current_tw mark:"insert" index:(tpos pos);
        Text.yview_index current_tw
          index:(`Linechar(1,0),[`Char pos; `Line (-2)])

  initializer
    (* Create a first window *)
    self#new_window (current_dir ^ "/untitled");

    (* Bindings for the main window *)
    List.iter
      [ [`Control], "s", (fun () -> Jg_text.search_string current_tw);
        [`Control], "g", (fun () -> goto_line current_tw);
        [`Alt], "s", self#save_file;
        [`Alt], "x", (fun () -> send_phrase (List.hd windows));
        [`Alt], "l", self#lex;
        [`Alt], "t", self#typecheck ]
      fun: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:
      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 "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:compiler_preferences;
    compiler_menu#add_command "Lex" accelerator:"M-l"
      command:self#lex;
    compiler_menu#add_command "Typecheck" accelerator:"M-t"
      command:self#typecheck;
    compiler_menu#add_command "Clear errors"
      command:self#clear_errors;
    compiler_menu#add_command "Signature..." command:
      begin fun () ->
        let txt = List.hd windows in if txt.signature <> [] then
          let basename = Filename.basename txt.name in
          let modname = String.capitalize
              (try Filename.chop_extension basename with _ -> basename) in
          let env =
            Env.add_module (Ident.create modname)
              (Types.Tmty_signature txt.signature)
              Env.initial
          in Viewer.view_defined (Longident.Lident modname) :env
      end;

    (* Modules *)
    module_menu#add_command "Path editor..."
      command:(fun () -> Setpath.f dir:current_dir; ());
    module_menu#add_command "Reset cache"
      command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ());
    module_menu#add_command "Search symbol..."
      command:Viewer.search_symbol;
    module_menu#add_command "Close all"
      command:Viewer.close_all_views;

    (* pack everything *)
    pack (List.map fun:(fun m -> coe m#button)
            [file_menu; edit_menu; compiler_menu; module_menu; window_menu]
          @ [coe label])
      side:`Left ipadx:5 anchor:`W;
    pack [menus] before:(List.hd windows).frame side:`Top fill:`X
end

(* The main function starts here ! *)

let already_open : editor option ref = ref None

let editor ?:file ?(:pos=0) () =

  if match !already_open with None -> false
  | Some ed ->
      try ed#reopen :file :pos; true
      with Protocol.TkError _ -> already_open := None; false
  then () else
    let top = Jg_toplevel.titled "Editor" in
    let menus = Frame.create top name:"menubar" in
    let ed = new editor :top :menus in
    already_open := Some ed;
    if file <> None then ed#reopen :file :pos

let f ?:file ?:pos ?(:opendialog=false) () =
  if opendialog then
    Fileselect.f title:"Open File"
      action:(function [file] -> editor :file () | _ -> ())
      filter:("*.{ml,mli}") sync:true ()
  else editor ?:file ?:pos ()