summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/browser
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/browser')
-rw-r--r--otherlibs/labltk/browser/editor.ml46
-rw-r--r--otherlibs/labltk/browser/jg_message.ml7
-rw-r--r--otherlibs/labltk/browser/main.ml2
-rw-r--r--otherlibs/labltk/browser/searchpos.ml138
-rw-r--r--otherlibs/labltk/browser/searchpos.mli11
-rw-r--r--otherlibs/labltk/browser/typecheck.ml67
-rw-r--r--otherlibs/labltk/browser/viewer.ml23
7 files changed, 207 insertions, 87 deletions
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index ff6b379a8..2b280be0f 100644
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -34,6 +34,7 @@ let compiler_preferences () =
(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)
@@ -42,17 +43,25 @@ let compiler_preferences () =
"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 ])
+ "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
@@ -205,16 +214,16 @@ let search_pos_window txt ~x ~y =
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.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) ->
+ try if txt.structure <> [] then begin match
+ Searchpos.search_pos_structure txt.structure ~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 =
@@ -222,20 +231,21 @@ let search_pos_menu txt ~x ~y =
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.structure <> [] then
- try Searchpos.search_pos_structure txt.structure ~pos
- with Searchpos.Found_str (kind, env) ->
+ try if txt.structure <> [] then begin match
+ Searchpos.search_pos_structure txt.structure ~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
- else
- try Searchpos.search_pos_signature
- txt.psignature ~pos ~env:!Searchid.start_env;
- ()
- with Searchpos.Found_sig (kind, lid, env) ->
+ 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 =
diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml
index 6e15a4992..efbc5bb83 100644
--- a/otherlibs/labltk/browser/jg_message.ml
+++ b/otherlibs/labltk/browser/jg_message.ml
@@ -46,7 +46,12 @@ 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
+ Some frame ->
+(* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in
+ pack [label] ~side:`Top ~fill:`X;
+ let frame2 = Frame.create frame in
+ pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *)
+ coe frame, frame
| None ->
let tl = Jg_toplevel.titled title in
Jg_bind.escape_destroy tl;
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 2c8bfd184..0379060b4 100644
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -26,6 +26,8 @@ let _ =
"-labels", Arg.Clear Clflags.classic, " <obsolete>";
"-nolabels", Arg.Set Clflags.classic,
" Ignore non-optional labels in types";
+ "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s),
+ "<command> Pipe sources through preprocessor <command>";
"-rectypes", Arg.Set Clflags.recursive_types,
" Allow arbitrary recursive types";
"-oldui", Arg.Clear st, " Revert back to old UI";
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 61722baaf..d780385d8 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -38,7 +38,23 @@ let lines_to_chars n ~text:s =
in ltc n ~pos:0
let in_loc loc ~pos =
- pos >= loc.loc_start && pos < loc.loc_end
+ loc.loc_ghost || pos >= loc.loc_start && pos < loc.loc_end
+
+let le_loc loc1 loc2 =
+ loc1.loc_start <= loc2.loc_start
+ && loc1.loc_end >= loc2.loc_end
+
+let add_found ~found sol ~env ~loc =
+ if loc.loc_ghost then () else
+ if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then ()
+ else found := (sol, env, loc) ::
+ List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc))
+
+let observe ~ref ?init f x =
+ let old = !ref in
+ begin match init with None -> () | Some x -> ref := x end;
+ try (f x : unit); let v = !ref in ref := old; v
+ with exn -> ref := old; raise exn
let rec string_of_longident = function
Lident s -> s
@@ -79,11 +95,12 @@ end
type skind = [`Type|`Class|`Module|`Modtype]
-exception Found_sig of skind * Longident.t * Env.t
+let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list)
+let add_found_sig = add_found ~found:found_sig
let rec search_pos_type t ~pos ~env =
if in_loc ~pos t.ptyp_loc then
- begin (match t.ptyp_desc with
+ begin match t.ptyp_desc with
Ptyp_any
| Ptyp_var _ -> ()
| Ptyp_variant(tl, _, _) ->
@@ -96,7 +113,7 @@ let rec search_pos_type t ~pos ~env =
List.iter tl ~f:(search_pos_type ~pos ~env)
| Ptyp_constr (lid, tl) ->
List.iter tl ~f:(search_pos_type ~pos ~env);
- raise (Found_sig (`Type, lid, env))
+ add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
| Ptyp_object fl ->
List.iter fl ~f:
begin function
@@ -105,16 +122,15 @@ let rec search_pos_type t ~pos ~env =
end
| Ptyp_class (lid, tl, _) ->
List.iter tl ~f:(search_pos_type ~pos ~env);
- raise (Found_sig (`Type, lid, env))
- | Ptyp_alias (t, _) -> search_pos_type ~pos ~env t);
- raise Not_found
+ add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
+ | Ptyp_alias (t, _) -> search_pos_type ~pos ~env t
end
let rec search_pos_class_type cl ~pos ~env =
- if in_loc cl.pcty_loc ~pos then begin
+ if in_loc cl.pcty_loc ~pos then
begin match cl.pcty_desc with
Pcty_constr (lid, _) ->
- raise (Found_sig (`Class, lid, env))
+ add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc
| Pcty_signature (_, cfl) ->
List.iter cfl ~f:
begin function
@@ -135,9 +151,7 @@ let rec search_pos_class_type cl ~pos ~env =
| Pcty_fun (_, ty, cty) ->
search_pos_type ty ~pos ~env;
search_pos_class_type cty ~pos ~env
- end;
- raise Not_found
- end
+ end
let search_pos_type_decl td ~pos ~env =
if in_loc ~pos td.ptype_loc then begin
@@ -152,8 +166,7 @@ let search_pos_type_decl td ~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)
- end;
- raise Not_found
+ end
end
let rec search_pos_signature l ~pos ~env =
@@ -172,14 +185,14 @@ 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 match pt.psig_desc with
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)
| Psig_exception (_, l) ->
List.iter l ~f:(search_pos_type ~pos ~env);
- raise (Found_sig (`Type, Lident "exn", env))
+ add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc
| Psig_module (_, t) ->
search_pos_module t ~pos ~env
| Psig_modtype (_, Pmodtype_manifest t) ->
@@ -192,18 +205,16 @@ let rec search_pos_signature l ~pos ~env =
List.iter l
~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_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc
| 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
begin match m.pmty_desc with
- Pmty_ident lid -> raise (Found_sig (`Modtype, lid, env))
+ Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc
| Pmty_signature sg -> search_pos_signature sg ~pos ~env
| Pmty_functor (_ , m1, m2) ->
search_pos_module m1 ~pos ~env;
@@ -215,14 +226,17 @@ and search_pos_module m ~pos ~env =
_, Pwith_type t -> search_pos_type_decl t ~pos ~env
| _ -> ()
end
- end;
- raise Not_found
+ end
end
+let search_pos_signature l ~pos ~env =
+ observe ~ref:found_sig (search_pos_signature ~pos ~env) l
+
(* the module display machinery *)
type module_widgets =
{ mw_frame: Widget.frame Widget.widget;
+ mw_title: Widget.label Widget.widget option;
mw_detach: Widget.button Widget.widget;
mw_edit: Widget.button Widget.widget;
mw_intf: Widget.button Widget.widget }
@@ -299,12 +313,14 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
in
let tl, tw, finish =
try match path, !default_frame with
- None, Some mw when not detach ->
+ None, Some ({mw_title=Some label} as mw) when not detach ->
Button.configure mw.mw_detach
~command:(fun () -> view_signature sign ~title ~env);
pack [mw.mw_detach] ~side:`Left;
Pack.forget [mw.mw_edit; mw.mw_intf];
List.iter ~f:destroy (Winfo.children mw.mw_frame);
+ Label.configure label ~text:title;
+ pack [label] ~fill:`X;
Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
| None, _ -> raise Not_found
| Some path, _ ->
@@ -314,6 +330,11 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
view_module path ~env;
find_shown_module path
in
+ begin match mw.mw_title with None -> ()
+ | Some label ->
+ Label.configure label ~text:title;
+ pack [label] ~fill:`X
+ end;
Button.configure mw.mw_detach
~command:(fun () -> view_signature sign ~title ~env ~detach:true);
pack [mw.mw_detach] ~side:`Left;
@@ -370,23 +391,24 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
~action:(fun ev ->
let `Linechar (l, c) =
Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in
- try try
- search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env;
- break ()
- with Found_sig (kind, lid, env) -> view_decl lid ~kind ~env
+ try
+ match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+ with [] -> break ()
+ | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env
with Not_found | Env.Error _ -> ());
- bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] ~breakable:true
+ bind tw ~events:[`ButtonPressDetail 3] ~breakable:true
+ ~fields:[`MouseX;`MouseY]
~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
- try try
- 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 x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in
- Menu.popup menu ~x ~y
+ try
+ match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+ with [] -> break ()
+ | ((kind, lid), env, loc) :: _ ->
+ 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
with Not_found -> ())
and view_signature_item sign ~path ~env =
@@ -515,7 +537,6 @@ type fkind = [
| `Class of Path.t * Types.class_type
| `Module of Path.t * Types.module_type
]
-exception Found_str of fkind * Env.t
let view_type kind ~env =
match kind with
@@ -607,6 +628,9 @@ let view_type_menu kind ~env ~parent =
end;
menu
+let found_str = ref ([] : (fkind * Env.t * Location.t) list)
+let add_found_str = add_found ~found:found_str
+
let rec search_pos_structure ~pos str =
List.iter str ~f:
begin function
@@ -636,7 +660,8 @@ 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))
+ add_found_str (`Class (path, cl.cl_type))
+ ~env:!start_env ~loc:cl.cl_loc
| Tclass_structure cls ->
List.iter cls.cl_field ~f:
begin function
@@ -671,17 +696,19 @@ and search_pos_class_expr ~pos cl =
| Tclass_constraint (cl, _, _, _) ->
search_pos_class_expr cl ~pos
end;
- raise (Found_str
- (`Class (Pident (Ident.create "c"), cl.cl_type), !start_env))
+ add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type))
+ ~env:!start_env ~loc:cl.cl_loc
end
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))
+ add_found_str (`Exp(`Val path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
| Texp_constant v ->
- raise (Found_str (`Exp(`Const, exp.exp_type), exp.exp_env))
+ add_found_str (`Exp(`Const, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
| Texp_let (_, expl, exp) ->
List.iter expl ~f:
begin fun (pat, exp') ->
@@ -738,12 +765,15 @@ and search_pos_expr ~pos exp =
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))
+ add_found_str (`Exp(`New path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
| Texp_instvar (_,path) ->
- raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env))
+ add_found_str (`Exp(`Var path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
| Texp_setinstvar (_, path, exp) ->
search_pos_expr exp ~pos;
- raise (Found_str (`Exp(`Var path, exp.exp_type), exp.exp_env))
+ add_found_str (`Exp(`Var path, exp.exp_type))
+ ~env:exp.exp_env ~loc:exp.exp_loc
| Texp_override (_, l) ->
List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos)
| Texp_letmodule (id, modexp, exp) ->
@@ -753,7 +783,7 @@ and search_pos_expr ~pos exp =
| Texp_assert exp ->
search_pos_expr exp ~pos
end;
- raise (Found_str (`Exp(`Expr, exp.exp_type), exp.exp_env))
+ add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
end
and search_pos_pat ~pos ~env pat =
@@ -761,10 +791,11 @@ and search_pos_pat ~pos ~env pat =
begin match pat.pat_desc with
Tpat_any -> ()
| Tpat_var id ->
- raise (Found_str (`Exp(`Val (Pident id), pat.pat_type), env))
+ add_found_str (`Exp(`Val (Pident id), pat.pat_type))
+ ~env ~loc:pat.pat_loc
| Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env
| Tpat_constant _ ->
- raise (Found_str (`Exp(`Const, pat.pat_type), env))
+ add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
| Tpat_tuple l ->
List.iter l ~f:(search_pos_pat ~pos ~env)
| Tpat_construct (_, l) ->
@@ -778,21 +809,24 @@ and search_pos_pat ~pos ~env pat =
| Tpat_or (a, b) ->
search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env
end;
- raise (Found_str (`Exp(`Pat, pat.pat_type), env))
+ add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc
end
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))
+ add_found_str (`Module (path, m.mod_type))
+ ~env:m.mod_env ~loc:m.mod_loc
| 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
end;
- raise (Found_str (`Module (Pident (Ident.create "M"), m.mod_type),
- m.mod_env))
+ add_found_str (`Module (Pident (Ident.create "M"), m.mod_type))
+ ~env:m.mod_env ~loc:m.mod_loc
end
+
+let search_pos_structure ~pos str =
+ observe ~ref:found_str (search_pos_structure ~pos) str
diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
index 962a45d67..f887955d1 100644
--- a/otherlibs/labltk/browser/searchpos.mli
+++ b/otherlibs/labltk/browser/searchpos.mli
@@ -19,6 +19,7 @@ val top_widgets : any widget list ref
type module_widgets =
{ mw_frame: frame widget;
+ mw_title: label widget option;
mw_detach: button widget;
mw_edit: button widget;
mw_intf: button widget }
@@ -45,10 +46,9 @@ val view_modtype_id : Longident.t -> env:Env.t -> unit
val view_type_decl : Path.t -> env:Env.t -> unit
type skind = [`Type|`Class|`Module|`Modtype]
-exception Found_sig of skind * Longident.t * Env.t
val search_pos_signature :
- Parsetree.signature -> pos:int -> env:Env.t -> unit
- (* raises Found_sig to return its result, or Not_found *)
+ Parsetree.signature -> pos:int -> env:Env.t ->
+ ((skind * Longident.t) * Env.t * Location.t) list
val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit
val view_decl_menu :
Longident.t ->
@@ -61,10 +61,9 @@ type fkind = [
| `Class of Path.t * Types.class_type
| `Module of Path.t * Types.module_type
]
-exception Found_str of fkind * Env.t
val search_pos_structure :
- pos:int -> Typedtree.structure_item list -> unit
- (* raises Found_str to return its result *)
+ pos:int -> Typedtree.structure_item list ->
+ (fkind * Env.t * Location.t) list
val view_type : fkind -> env:Env.t -> unit
val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index a7a184795..9f9a64b9b 100644
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -20,6 +20,63 @@ open Location
open Jg_tk
open Mytypes
+(* Optionally preprocess a source file *)
+
+let preprocess ~pp ~ext text =
+ let sourcefile = Filename.temp_file "caml" ext in
+ begin try
+ let oc = open_out_bin sourcefile in
+ output_string oc text;
+ flush oc;
+ close_out oc
+ with _ ->
+ failwith "Preprocessing error"
+ end;
+ let tmpfile = Filename.temp_file "camlpp" ext in
+ let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
+ if Ccomp.command comm <> 0 then begin
+ Sys.remove sourcefile;
+ Sys.remove tmpfile;
+ failwith "Preprocessing error"
+ end;
+ Sys.remove sourcefile;
+ tmpfile
+
+exception Outdated_version
+
+let parse_pp ~parse ~wrap ~ext text =
+ match !Clflags.preprocessor with
+ None -> parse (Lexing.from_string text)
+ | Some pp ->
+ let tmpfile = preprocess ~pp ~ext text in
+ let ast_magic =
+ if ext = ".ml" then Config.ast_impl_magic_number
+ else Config.ast_intf_magic_number in
+ let ic = open_in_bin tmpfile in
+ let ast =
+ try
+ let buffer = String.create (String.length ast_magic) in
+ really_input ic buffer 0 (String.length ast_magic);
+ if buffer = ast_magic then begin
+ ignore (input_value ic);
+ wrap (input_value ic)
+ end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
+ raise Outdated_version
+ else
+ raise Exit
+ with
+ Outdated_version ->
+ close_in ic;
+ Sys.remove tmpfile;
+ failwith "Ocaml and preprocessor have incompatible versions"
+ | _ ->
+ seek_in ic 0;
+ parse (Lexing.from_channel ic)
+ in
+ close_in ic;
+ Sys.remove tmpfile;
+ ast
+
let nowarnings = ref false
let f txt =
@@ -36,13 +93,15 @@ let f txt =
try
if Filename.check_suffix txt.name ".mli" then
- let psign = Parse.interface (Lexing.from_string text) in
+ let psign = parse_pp text ~ext:".mli"
+ ~parse:Parse.interface ~wrap:(fun x -> x) in
txt.psignature <- psign;
txt.signature <- Typemod.transl_signature !env psign
else (* others are interpreted as .ml *)
- let psl = Parse.use_file (Lexing.from_string text) in
+ let psl = parse_pp text ~ext:".ml"
+ ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in
List.iter psl ~f:
begin function
Ptop_def pstr ->
@@ -58,7 +117,7 @@ let f txt =
| Typecore.Error _ | Typemod.Error _
| Typeclass.Error _ | Typedecl.Error _
| Typetexp.Error _ | Includemod.Error _
- | Env.Error _ | Ctype.Tags _ as exn ->
+ | Env.Error _ | Ctype.Tags _ | Failure _ as exn ->
let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in
error_messages := et :: !error_messages;
let s, e = match exn with
@@ -90,6 +149,8 @@ let f txt =
Env.report_error Format.std_formatter err; 0, 0
| Ctype.Tags(l, l') ->
Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; 0, 0
+ | Failure s ->
+ Format.printf "%s.@." s; 0, 0
| _ -> assert false
in
end_message ();
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index b82e1f63f..0240dfe3b 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -141,7 +141,7 @@ let choose_symbol ~title ~env ?signature ?path l =
let frame = Frame.create tl in
pack [frame] ~side:`Bottom ~fill:`X;
add_shown_module path
- ~widgets:{ mw_frame = frame; mw_detach = detach;
+ ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach;
mw_edit = edit; mw_intf = intf }
end
@@ -402,8 +402,10 @@ class st_viewer ?(dir=Unix.getcwd()) ?on () =
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
+ and viewmenu = new Jg_menu.c "View" ~parent:menus
and helpmenu = new Jg_menu.c "Help" ~parent:menus in
let boxes_frame = Frame.create tl ~name:"boxes" in
+ let label = Label.create tl ~anchor:`W ~padx:10 in
let view = Frame.create tl in
let buttons = Frame.create tl in
let all = Button.create buttons ~text:"Show all" ~padx:20
@@ -413,6 +415,7 @@ class st_viewer ?(dir=Unix.getcwd()) ?on () =
and intf = Button.create buttons ~text:"Intf" in
object (self)
val mutable boxes = []
+ val mutable show_all = fun () -> ()
method create_box =
let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in
@@ -429,10 +432,13 @@ object (self)
begin fun index ->
view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env
end;
+ bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+ ~action:(fun _ -> show_all ());
Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1);
List.iter [1;2] ~f:(fun _ -> ignore self#create_box);
Searchpos.default_frame := Some
- { mw_frame = view; mw_detach = detach; mw_edit = edit; mw_intf = intf };
+ { mw_frame = view; mw_title = Some label;
+ mw_detach = detach; mw_edit = edit; mw_intf = intf };
(* Buttons *)
pack [close] ~side:`Right ~fill:`X ~expand:true;
@@ -453,16 +459,20 @@ object (self)
~command:(fun () -> reset_modules mbox; Env.reset_cache ());
modmenu#add_command "Search symbol..." ~command:search_symbol;
+ (* View menu *)
+ viewmenu#add_command "Show all" ~command:(fun () -> show_all ());
+
(* Help menu *)
helpmenu#add_command "Manual..." ~command:show_help;
- pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W;
+ pack [filemenu#button; modmenu#button; viewmenu#button]
+ ~side:`Left ~ipadx:5 ~anchor:`W;
pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5;
pack [menus] ~side:`Top ~fill:`X;
(* pack [close; search] ~fill:`X ~side:`Right ~expand:true; *)
pack [boxes_frame] ~fill:`Both ~expand:true;
- pack [view] ~fill:`X ~expand:false;
pack [buttons] ~fill:`X ~side:`Bottom ~expand:false;
+ pack [view] ~fill:`Both ~side:`Bottom ~expand:true;
reset_modules mbox
val mutable shown_paths = []
@@ -539,12 +549,11 @@ object (self)
begin match signature with
None -> ()
| Some signature ->
- Button.configure all ~command:
+ show_all <-
begin fun () ->
current := None;
view_signature signature ~title ~env ?path
- end;
- pack [all] ~side:`Right ~fill:`X ~expand:true
+ end
end
end
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-27 15:09:53 +0000