l4/pkg/ocaml/contrib/otherlibs/labltk/browser/main.ml

   1 (*************************************************************************)
   2 (*                                                                       *)
   3 (*                Objective Caml LablTk library                          *)
   4 (*                                                                       *)
   5 (*            Jacques Garrigue, Kyoto University RIMS                    *)
   6 (*                                                                       *)
   7 (*   Copyright 1999 Institut National de Recherche en Informatique et    *)
   8 (*   en Automatique and Kyoto University.  All rights reserved.          *)
   9 (*   This file is distributed under the terms of the GNU Library         *)
  10 (*   General Public License, with the special exception on linking       *)
  11 (*   described in file ../../../LICENSE.                                 *)
  12 (*                                                                       *)
  13 (*************************************************************************)
  14
  15 (* $Id: main.ml 7382 2006-04-16 23:28:22Z doligez $ *)
  16
  17 open StdLabels
  18 module Unix = UnixLabels
  19 open Tk
  20
  21 let fatal_error text =
  22   let top = openTk ~clas:"OCamlBrowser" () in
  23   let mw = Message.create top ~text ~padx:20 ~pady:10
  24       ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W
  25   and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in
  26   pack [mw] ~side:`Top ~fill:`Both;
  27   pack [b] ~side:`Bottom;
  28   mainLoop ();
  29   exit 0
  30
  31 let rec get_incr key = function
  32     [] -> raise Not_found
  33   | (k, c, d) :: rem ->
  34       if k = key then
  35         match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true
  36       else get_incr key rem
  37
  38 let check ~spec argv =
  39   let i = ref 1 in
  40   while !i < Array.length argv do
  41     try
  42       let a = get_incr argv.(!i) spec in
  43       incr i; if a then incr i
  44     with Not_found ->
  45       i := Array.length argv + 1
  46   done;
  47   !i = Array.length argv
  48
  49 open Printf
  50
  51 let print_version () =
  52   printf "The Objective Caml browser, version %s\n" Sys.ocaml_version;
  53   exit 0;
  54 ;;
  55
  56 let usage ~spec errmsg =
  57   let b = Buffer.create 1024 in
  58   bprintf b "%s\n" errmsg;
  59   List.iter (function (key, _, doc) -> bprintf b "  %s %s\n" key doc) spec;
  60   Buffer.contents b
  61
  62 let _ =
  63   let is_win32 = Sys.os_type = "Win32" in
  64   if is_win32 then
  65     Format.pp_set_formatter_output_functions Format.err_formatter
  66       (fun _ _ _ -> ()) (fun _ -> ());
  67
  68   let path = ref [] in
  69   let st = ref true in
  70   let spec =
  71     [ "-I", Arg.String (fun s -> path := s :: !path),
  72       "<dir>  Add <dir> to the list of include directories";
  73       "-labels", Arg.Clear Clflags.classic, " <obsolete>";
  74       "-nolabels", Arg.Set Clflags.classic,
  75       " Ignore non-optional labels in types";
  76       "-oldui", Arg.Clear st, " Revert back to old UI";
  77       "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s),
  78       "<command>  Pipe sources through preprocessor <command>";
  79       "-rectypes", Arg.Set Clflags.recursive_types,
  80       " Allow arbitrary recursive types";
  81       "-version", Arg.Unit print_version,
  82         " Print version and exit";
  83       "-w", Arg.String (fun s -> Shell.warnings := s),
  84       "<flags>  Enable or disable warnings according to <flags>:\n\
  85         \032    A/a enable/disable all warnings\n\
  86         \032    C/c enable/disable suspicious comment\n\
  87         \032    D/d enable/disable deprecated features\n\
  88         \032    E/e enable/disable fragile match\n\
  89         \032    F/f enable/disable partially applied function\n\
  90         \032    L/l enable/disable labels omitted in application\n\
  91         \032    M/m enable/disable overriden method\n\
  92         \032    P/p enable/disable partial match\n\
  93         \032    S/s enable/disable non-unit statement\n\
  94         \032    U/u enable/disable unused match case\n\
  95         \032    V/v enable/disable hidden instance variable\n\
  96         \032    X/x enable/disable all other warnings\n\
  97         \032    default setting is \"Ale\"\n\
  98         \032    (all warnings but labels and fragile match enabled)"; ]
  99   and errmsg = "Command line: ocamlbrowser <options>" in
 100   if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg);
 101   Arg.parse spec
 102     (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
 103     errmsg;
 104   Config.load_path :=
 105     Sys.getcwd ()
 106     :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
 107     @ [Config.standard_library];
 108   Warnings.parse_options false !Shell.warnings;
 109   Unix.putenv "TERM" "noterminal";
 110   begin
 111     try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial
 112     with _ ->
 113       fatal_error
 114         (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'"
 115            "Couldn't initialize environment."
 116            (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB")
 117            "points to the Objective Caml library."
 118            Config.standard_library)
 119   end;
 120
 121   Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env);
 122   Searchpos.editor_ref := Editor.f;
 123
 124   let top = openTk ~clas:"OCamlBrowser" () in
 125   Jg_config.init ();
 126
 127   (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *)
 128   at_exit Shell.kill_all;
 129
 130
 131   if !st then Viewer.st_viewer ~on:top ()
 132   else Viewer.f ~on:top ();
 133
 134   while true do
 135     try
 136       if is_win32 then mainLoop ()
 137       else Printexc.print mainLoop ()
 138     with Protocol.TkError _ ->
 139       if not is_win32 then flush stderr
 140   done