Blame browser/setpath.ml

Packit bd2e5d
(*************************************************************************)
Packit bd2e5d
(*                                                                       *)
Packit bd2e5d
(*                         OCaml LablTk library                          *)
Packit bd2e5d
(*                                                                       *)
Packit bd2e5d
(*            Jacques Garrigue, Kyoto University RIMS                    *)
Packit bd2e5d
(*                                                                       *)
Packit bd2e5d
(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
Packit bd2e5d
(*   en Automatique and Kyoto University.  All rights reserved.          *)
Packit bd2e5d
(*   This file is distributed under the terms of the GNU Library         *)
Packit bd2e5d
(*   General Public License, with the special exception on linking       *)
Packit bd2e5d
(*   described in file ../../../LICENSE.                                 *)
Packit bd2e5d
(*                                                                       *)
Packit bd2e5d
(*************************************************************************)
Packit bd2e5d
Packit bd2e5d
(* $Id$ *)
Packit bd2e5d
Packit bd2e5d
open StdLabels
Packit bd2e5d
open Tk
Packit bd2e5d
Packit bd2e5d
(* Listboxes *)
Packit bd2e5d
Packit bd2e5d
let update_hooks = ref []
Packit bd2e5d
Packit bd2e5d
let add_update_hook f = update_hooks := f :: !update_hooks
Packit bd2e5d
Packit bd2e5d
let exec_update_hooks () =
Packit bd2e5d
    update_hooks := List.filter !update_hooks ~f:
Packit bd2e5d
      begin fun f ->
Packit bd2e5d
        try f (); true
Packit bd2e5d
        with Protocol.TkError _ -> false
Packit bd2e5d
      end
Packit bd2e5d
Packit bd2e5d
let set_load_path l =
Packit bd2e5d
    Config.load_path := l;
Packit bd2e5d
    exec_update_hooks ()
Packit bd2e5d
Packit bd2e5d
let get_load_path () = !Config.load_path
Packit bd2e5d
Packit bd2e5d
let renew_dirs box ~var ~dir =
Packit bd2e5d
  Textvariable.set var dir;
Packit bd2e5d
  Listbox.delete box ~first:(`Num 0) ~last:`End;
Packit bd2e5d
  Listbox.insert box ~index:`End
Packit bd2e5d
    ~texts:(Useunix.get_directories_in_files ~path:dir
Packit bd2e5d
                 (Useunix.get_files_in_directory dir));
Packit bd2e5d
  Jg_box.recenter box ~index:(`Num 0)
Packit bd2e5d
Packit bd2e5d
let renew_path box =
Packit bd2e5d
  Listbox.delete box ~first:(`Num 0) ~last:`End;
Packit bd2e5d
  Listbox.insert box ~index:`End ~texts:!Config.load_path;
Packit bd2e5d
  Jg_box.recenter box ~index:(`Num 0)
Packit bd2e5d
Packit bd2e5d
let add_to_path ~dirs ?(base="") box =
Packit bd2e5d
  let dirs =
Packit bd2e5d
    if base = "" then dirs else
Packit bd2e5d
    if dirs = [] then [base] else
Packit bd2e5d
    List.map dirs ~f:
Packit bd2e5d
      begin function
Packit bd2e5d
          "." -> base
Packit bd2e5d
        | ".." -> Filename.dirname base
Packit bd2e5d
        | x -> Filename.concat base x
Packit bd2e5d
      end
Packit bd2e5d
  in
Packit bd2e5d
  set_load_path
Packit bd2e5d
    (dirs @ List.fold_left dirs ~init:(get_load_path ())
Packit bd2e5d
              ~f:(fun acc x -> List2.exclude x acc))
Packit bd2e5d
Packit bd2e5d
let remove_path box ~dirs =
Packit bd2e5d
  set_load_path
Packit bd2e5d
    (List.fold_left dirs ~init:(get_load_path ())
Packit bd2e5d
       ~f:(fun acc x -> List2.exclude x acc))
Packit bd2e5d
Packit bd2e5d
(* main function *)
Packit bd2e5d
Packit bd2e5d
let f ~dir =
Packit bd2e5d
  let current_dir = ref dir in
Packit bd2e5d
  let tl = Jg_toplevel.titled "Edit Load Path" in
Packit bd2e5d
  Jg_bind.escape_destroy tl;
Packit bd2e5d
  let var_dir = Textvariable.create ~on:tl () in
Packit bd2e5d
  let caplab = Label.create tl ~text:"Path"
Packit bd2e5d
  and dir_name = Entry.create tl ~textvariable:var_dir
Packit bd2e5d
  and browse = Frame.create tl in
Packit bd2e5d
  let dirs = Frame.create browse
Packit bd2e5d
  and path = Frame.create browse in
Packit bd2e5d
  let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs
Packit bd2e5d
  and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path
Packit bd2e5d
  in
Packit bd2e5d
  add_update_hook (fun () -> renew_path pathbox);
Packit bd2e5d
  Listbox.configure pathbox ~width:40 ~selectmode:`Multiple;
Packit bd2e5d
  Listbox.configure dirbox ~selectmode:`Multiple;
Packit bd2e5d
  Jg_box.add_completion dirbox ~action:
Packit bd2e5d
    begin fun index ->
Packit bd2e5d
      begin match Listbox.get dirbox ~index with
Packit bd2e5d
        "." -> ()
Packit bd2e5d
      | ".." -> current_dir := Filename.dirname !current_dir
Packit bd2e5d
      | x -> current_dir := !current_dir ^ "/" ^ x
Packit bd2e5d
      end;
Packit bd2e5d
      renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
Packit bd2e5d
      Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
Packit bd2e5d
    end;
Packit bd2e5d
  Jg_box.add_completion pathbox ~action:
Packit bd2e5d
    begin fun index ->
Packit bd2e5d
      current_dir := Listbox.get pathbox ~index;
Packit bd2e5d
      renew_dirs dirbox ~var:var_dir ~dir:!current_dir
Packit bd2e5d
    end;
Packit bd2e5d
Packit bd2e5d
  bind dir_name ~events:[`KeyPressDetail"Return"]
Packit bd2e5d
    ~action:(fun _ ->
Packit bd2e5d
      let dir = Textvariable.get var_dir in
Packit bd2e5d
      if Useunix.is_directory dir then begin
Packit bd2e5d
        current_dir := dir;
Packit bd2e5d
        renew_dirs dirbox ~var:var_dir ~dir
Packit bd2e5d
      end);
Packit bd2e5d
Packit bd2e5d
  (* Avoid space being used by the completion mechanism *)
Packit bd2e5d
  let bind_space_toggle lb =
Packit bd2e5d
    bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in
Packit bd2e5d
  bind_space_toggle dirbox;
Packit bd2e5d
  bind_space_toggle pathbox;
Packit bd2e5d
Packit bd2e5d
  let add_paths _ =
Packit bd2e5d
    add_to_path pathbox ~base:!current_dir
Packit bd2e5d
      ~dirs:(List.map (Listbox.curselection dirbox)
Packit bd2e5d
              ~f:(fun x -> Listbox.get dirbox ~index:x));
Packit bd2e5d
    Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
Packit bd2e5d
  and remove_paths _ =
Packit bd2e5d
    remove_path pathbox
Packit bd2e5d
      ~dirs:(List.map (Listbox.curselection pathbox)
Packit bd2e5d
              ~f:(fun x -> Listbox.get pathbox ~index:x))
Packit bd2e5d
  in
Packit bd2e5d
  bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths;
Packit bd2e5d
  bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths;
Packit bd2e5d
Packit bd2e5d
  let dirlab = Label.create dirs ~text:"Directories"
Packit bd2e5d
  and pathlab = Label.create path ~text:"Load path"
Packit bd2e5d
  and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths
Packit bd2e5d
  and pathbuttons = Frame.create path in
Packit bd2e5d
  let removebutton =
Packit bd2e5d
    Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths
Packit bd2e5d
  and ok =
Packit bd2e5d
    Jg_button.create_destroyer tl ~parent:pathbuttons
Packit bd2e5d
  in
Packit bd2e5d
  renew_dirs dirbox ~var:var_dir ~dir:!current_dir;
Packit bd2e5d
  renew_path pathbox;
Packit bd2e5d
  pack [dirsb] ~side:`Right ~fill:`Y;
Packit bd2e5d
  pack [dirbox] ~side:`Left ~fill:`Y ~expand:true;
Packit bd2e5d
  pack [pathsb] ~side:`Right ~fill:`Y;
Packit bd2e5d
  pack [pathbox] ~side:`Left ~fill:`Both ~expand:true;
Packit bd2e5d
  pack [dirlab] ~side:`Top ~anchor:`W ~padx:10;
Packit bd2e5d
  pack [addbutton] ~side:`Bottom ~fill:`X;
Packit bd2e5d
  pack [dirframe] ~fill:`Y ~expand:true;
Packit bd2e5d
  pack [pathlab] ~side:`Top ~anchor:`W ~padx:10;
Packit bd2e5d
  pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true;
Packit bd2e5d
  pack [pathbuttons] ~fill:`X ~side:`Bottom;
Packit bd2e5d
  pack [pathframe] ~fill:`Both ~expand:true;
Packit bd2e5d
  pack [dirs] ~side:`Left ~fill:`Y;
Packit bd2e5d
  pack [path] ~side:`Right ~fill:`Both ~expand:true;
Packit bd2e5d
  pack [caplab] ~side:`Top ~anchor:`W ~padx:10;
Packit bd2e5d
  pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X;
Packit bd2e5d
  pack [browse] ~side:`Bottom ~expand:true ~fill:`Both;
Packit bd2e5d
  tl
Packit bd2e5d
Packit bd2e5d
let set ~dir = ignore (f ~dir);;