shorten paths in signatures and toplevel output
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/short-paths@12066 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
50de05d31d
commit
21301af8c8
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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 *)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue