Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

shorten paths in signatures and toplevel output 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/short-paths@12066 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2012-01-22 05:56:11 +00:00
parent 50de05d31d
commit 21301af8c8
5 changed files with 76 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
driver/compile.ml
View File

@ -83,9 +83,10 @@ let interface ppf sourcefile outputprefix =
let ast =
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
let sg = Typemod.transl_signature (initial_env()) ast in
let env = initial_env () in
let sg = Typemod.transl_signature env ast in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
fprintf std_formatter "%a@." (Printtyp.signature env)
(Typemod.simplify_signature sg);
Warnings.check_fatal ();
if not !Clflags.print_types then

21
toplevel/toploop.ml
View File

@ -230,14 +230,19 @@ let execute_phrase print_outcome ppf phr =
match res with
| Result v ->
if print_outcome then
match str with
| [Tstr_eval exp] ->
let outv = outval_of_value newenv v exp.exp_type in
let ty = Printtyp.tree_of_type_scheme exp.exp_type in
Ophr_eval (outv, ty)
| [] -> Ophr_signature []
| _ -> Ophr_signature (item_list newenv
(Typemod.simplify_signature sg))
let out =
Printtyp.set_env newenv;
match str with
| [Tstr_eval exp] ->
let outv = outval_of_value newenv v exp.exp_type in
let ty = Printtyp.tree_of_type_scheme exp.exp_type in
Ophr_eval (outv, ty)
| [] -> Ophr_signature []
| _ -> Ophr_signature (item_list newenv
(Typemod.simplify_signature sg))
in
Printtyp.set_env Env.empty;
out
else Ophr_signature []
| Exception exn ->
toplevel_env := oldenv;

64
typing/printtyp.ml
View File

@ -192,6 +192,7 @@ let () = Btype.print_raw := raw_type_expr
(* Normalize paths *)
let printing_env = ref Env.empty
let set_env env = printing_env := env
let rec path_length = function
Pident _ -> 1
@ -899,6 +900,39 @@ let cltype_declaration id ppf cl =
(* Print a module type *)
let rec add_decls env = function
| Tsig_class(id, decl, _) :: rem ->
add_decls (Env.add_class id decl env) rem
| Tsig_cltype(id, decl, _) :: Tsig_type(id', decl', _) :: rem ->
add_decls (Env.add_type id' decl' (Env.add_cltype id decl env)) rem
| Tsig_type(id, decl, _) :: rem ->
(Env.add_type id decl env, rem)
| Tsig_module(id, mty, _) :: rem ->
(Env.add_module id mty env, rem)
| _ -> assert false
let recursion = function
Tsig_type(_,_,rs)
| Tsig_module(_,_,rs)
| Tsig_class(_,_,rs)
| Tsig_cltype(_,_,rs) -> rs
| _ -> Trec_not
let rec add_rec_decls rs0 env sg =
match sg with
item :: _ when recursion item = rs0 ->
let (env, rem) = add_decls env sg in
if rs0 = Trec_not then env else
add_rec_decls Trec_next env rem
| _ -> env
let wrap_env rs sg f =
if rs = Trec_next then f () else
let env = !printing_env in
printing_env := add_rec_decls rs env sg;
let tree = f () in
printing_env := env; tree
let rec tree_of_modtype = function
| Tmty_ident p ->
Omty_ident (tree_of_path p)
@ -914,20 +948,24 @@ and tree_of_signature = function
tree_of_value_description id decl :: tree_of_signature rem
| Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
tree_of_signature rem
| Tsig_type(id, decl, rs) :: rem ->
Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
tree_of_signature rem
| Tsig_type(id, decl, rs) :: rem as sg ->
wrap_env rs sg (fun () ->
Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
tree_of_signature rem)
| Tsig_exception(id, decl) :: rem ->
tree_of_exception_declaration id decl :: tree_of_signature rem
| Tsig_module(id, mty, rs) :: rem ->
Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
tree_of_signature rem
| Tsig_module(id, mty, rs) :: rem as sg ->
wrap_env rs sg (fun () ->
Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
tree_of_signature rem)
| Tsig_modtype(id, decl) :: rem ->
tree_of_modtype_declaration id decl :: tree_of_signature rem
| Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
tree_of_class_declaration id decl rs :: tree_of_signature rem
| Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
tree_of_cltype_declaration id decl rs :: tree_of_signature rem
| Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem as sg ->
wrap_env rs sg (fun () ->
tree_of_class_declaration id decl rs :: tree_of_signature rem)
| Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem as sg ->
wrap_env rs sg (fun () ->
tree_of_cltype_declaration id decl rs :: tree_of_signature rem)
| _ ->
assert false
@ -951,8 +989,10 @@ let modtype_declaration id ppf decl =
let print_signature ppf tree =
fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
let signature ppf sg =
fprintf ppf "%a" print_signature (tree_of_signature sg)
let signature env ppf sg =
printing_env := env;
fprintf ppf "%a" print_signature (tree_of_signature sg);
printing_env := Env.empty
(* Print an unification error *)

3
typing/printtyp.mli
View File

@ -23,6 +23,7 @@ val ident: formatter -> Ident.t -> unit
val tree_of_path: Path.t -> out_ident
val path: formatter -> Path.t -> unit
val raw_type_expr: formatter -> type_expr -> unit
val set_env: Env.t -> unit
val reset: unit -> unit
val mark_loops: type_expr -> unit
val reset_and_mark_loops: type_expr -> unit
@ -44,7 +45,7 @@ val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_i
val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit
val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item
val modtype: formatter -> module_type -> unit
val signature: formatter -> signature -> unit
val signature: Env.t -> formatter -> signature -> unit
val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item
val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
val class_type: formatter -> class_type -> unit

8
typing/typemod.ml
View File

@ -213,11 +213,14 @@ let map_rec fn decls rem =
| [] -> rem
| d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
let map_rec' = map_rec
(*
let rec map_rec' fn decls rem =
match decls with
| (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
fn Trec_not d1 :: map_rec' fn dl rem
| _ -> map_rec fn decls rem
*)
(* Auxiliary for translating recursively-defined module types.
Return a module type that approximates the shape of the given module
@ -382,7 +385,8 @@ and transl_signature env sg =
match item.psig_desc with
| Psig_value(name, sdesc) ->
let desc = Typedecl.transl_value_decl env item.psig_loc sdesc in
let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
let (id, newenv) = Env.enter_value name desc env
~check:(fun s -> Warnings.Unused_value_declaration s) in
let rem = transl_sig newenv srem in
if List.exists (Ident.equal id) (get_values rem) then rem
else Tsig_value(id, desc) :: rem
@ -1088,7 +1092,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
let (str, sg, finalenv) = type_structure initial_env ast Location.none in
let simple_sg = simplify_signature sg in
if !Clflags.print_types then begin
fprintf std_formatter "%a@." Printtyp.signature simple_sg;
fprintf std_formatter "%a@." (Printtyp.signature initial_env) simple_sg;
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
end else begin
let sourceintf =