diff options
| -rw-r--r-- | testsuite/tests/typing-short-paths/short-paths.ml | 29 | ||||
| -rw-r--r-- | testsuite/tests/typing-short-paths/short-paths.ml.reference | 23 | ||||
| -rw-r--r-- | toplevel/toploop.ml | 4 | ||||
| -rw-r--r-- | typing/env.ml | 36 | ||||
| -rw-r--r-- | typing/env.mli | 1 | ||||
| -rw-r--r-- | typing/printtyp.ml | 80 | ||||
| -rw-r--r-- | typing/printtyp.mli | 2 |
7 files changed, 155 insertions, 20 deletions
diff --git a/testsuite/tests/typing-short-paths/short-paths.ml b/testsuite/tests/typing-short-paths/short-paths.ml index 9537d4b38..561609060 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml +++ b/testsuite/tests/typing-short-paths/short-paths.ml @@ -1,6 +1,3 @@ -#directory "+compiler-libs";; -Clflags.real_paths := false;; - module Core = struct module Int = struct module T = struct @@ -23,3 +20,29 @@ open Core.Std let x = Int.Map.empty ;; let y = x + x ;; + +(* Avoid ambiguity *) + +module M = struct type t = A type u = C end +module N = struct type t = B end +open M open N;; +A;; +B;; +C;; + +include M open M;; +C;; + +module L = struct type v = V end +open L;; +V;; +module L = struct type v = V end +open L;; +V;; + + +type t1 = A;; +module M1 = struct type u = v and v = t1 end;; +module N1 = struct type u = v and v = M1.v end;; +type t1 = B;; +module N2 = struct type u = v and v = M1.v end;; diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference index f85186f6e..0d67eddc3 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml.reference +++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference @@ -1,9 +1,5 @@ -# # Characters -1--1: - Clflags.real_paths := false;; - -Error: Reference to undefined global `Clflags' -# module Core : +# module Core : sig module Int : sig @@ -101,4 +97,21 @@ Error: Reference to undefined global `Clflags' ^ Error: This expression has type 'a Int.Map.t but an expression was expected of type int +# module M : sig type t = A type u = C end +module N : sig type t = B end +# - : M.t = A +# - : N.t = B +# - : u = C +# type t = M.t = A +type u = M.u = C +# - : u = C +# module L : sig type v = V end +# - : v = V +# module L : sig type v = V end +# - : v = V +# type t1 = A +# module M1 : sig type u = v and v = t1 end +# module N1 : sig type u = v and v = t1 end +# type t1 = B +# module N2 : sig type u = v and v = M1.v end # diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index f1ded5e05..914e73c74 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -163,7 +163,9 @@ let load_lambda ppf lam = (* Print the outcome of an evaluation *) -let rec pr_item env = function +let rec pr_item env items = + Printtyp.hide_rec_items items; + match items with | Sig_value(id, decl) :: rem -> let tree = Printtyp.tree_of_value_description id decl in let valopt = diff --git a/typing/env.ml b/typing/env.ml index 477a07a45..b4fb7256e 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -810,6 +810,42 @@ let iter_env proj1 proj2 f env = let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f +let find_all_comps proj s (p,mcomps) = + match EnvLazy.force !components_of_module_maker' mcomps with + Functor_comps _ -> [] + | Structure_comps comps -> + try let (c,n) = Tbl.find s (proj comps) in [Pdot(p,s,n), c] + with Not_found -> [] + +let rec find_shadowed_comps path env = + match path with + Pident id -> + List.map fst (Ident.find_all (Ident.name id) env.components) + | Pdot (p, s, _) -> + let l = find_shadowed_comps p env in + let l' = + List.map (find_all_comps (fun comps -> comps.comp_components) s) l in + List.flatten l' + | Papply _ -> [] + +let find_shadowed proj1 proj2 path env = + match path with + Pident id -> + List.map fst (Ident.find_all (Ident.name id) (proj1 env)) + | Pdot (p, s, _) -> + let l = find_shadowed_comps p env in + let l' = List.map (find_all_comps proj2 s) l in + List.flatten l' + | Papply _ -> [] + +let find_shadowed_types path env = + let l = + find_shadowed + (fun env -> env.types) (fun comps -> comps.comp_types) path env + in + List.map fst l + + (* GADT instance tracking *) let add_gadt_instance_level lv env = diff --git a/typing/env.mli b/typing/env.mli index 2227be833..9d4632c3b 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -37,6 +37,7 @@ type type_descriptions = val iter_types: (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> t -> unit +val find_shadowed_types: Path.t -> t -> Path.t list (* Lookup by paths *) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 23b22a568..2f12780c6 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -213,6 +213,8 @@ let apply_subst s1 tyl = | Map l1 -> List.map (List.nth tyl) l1 | Id -> tyl +type best_path = Paths of Path.t list | Best of Path.t + let printing_env = ref Env.empty let printing_map = ref (Lazy.lazy_from_val Tbl.empty) @@ -276,11 +278,12 @@ let set_printing_env env = let (p1, s1) = normalize_type_path env p' ~cache:true in if s1 = Id then try - let p2 = Tbl.find p1 !map in - if path_size p < path_size p2 then raise Not_found + let r = Tbl.find p1 !map in + match !r with + Paths l -> r := Paths (p :: l) + | Best _ -> () with Not_found -> - (* printf "%a --> %a@." path p1 path p; *) - map := Tbl.add p1 p !map) + map := Tbl.add p1 (ref (Paths [p])) !map) env; !map end @@ -293,12 +296,42 @@ let wrap_printing_env env f = try_finally f (fun () -> set_printing_env Env.empty) end +let is_unambiguous path env = + let l = Env.find_shadowed_types path env in + List.exists (Path.same path) l || (* concrete paths are ok *) + match l with + [] -> true + | p :: rem -> + (* allow also coherent paths: *) + let normalize p = fst (normalize_type_path ~cache:true env p) in + let p' = normalize p in + List.for_all (fun p -> Path.same (normalize p) p') rem || + (* also allow repeatedly defining and opening (for toplevel) *) + let id = lid_of_path p in + List.for_all (fun p -> lid_of_path p = id) rem && + Path.same p (fst (Env.lookup_type id env)) + +let rec get_best_path r = + match !r with + Best p' -> p' + | Paths [] -> raise Not_found + | Paths l -> + r := Paths []; + List.iter + (fun p -> + match !r with + Best p' when path_size p >= path_size p' -> () + | _ -> if is_unambiguous p !printing_env then r := Best p) + l; + get_best_path r + let best_type_path p = if !Clflags.real_paths || !printing_env == Env.empty then (p, Id) else let (p', s) = normalize_type_path !printing_env p in - (try Tbl.find p' (Lazy.force !printing_map) with Not_found -> p'), + (try get_best_path (Tbl.find p' (Lazy.force !printing_map)) + with Not_found -> p'), s (* Print a type expression *) @@ -1023,6 +1056,26 @@ let filter_rem_sig item rem = | _ -> ([], rem) +let dummy = + { type_params = []; type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = []; + type_newtype_level = None; type_loc = Location.none; } + +let hide_rec_items = function + | Sig_type(id, decl, rs) ::rem + when rs <> Trec_next && not !Clflags.real_paths -> + let rec get_ids = function + Sig_type (id, _, Trec_next) :: rem -> + id :: get_ids rem + | _ -> [] + in + let ids = id :: get_ids rem in + set_printing_env + (List.fold_right + (fun id -> Env.add_type (Ident.rename id) dummy) + ids !printing_env) + | _ -> () + let rec tree_of_modtype = function | Mty_ident p -> Omty_ident (tree_of_path p) @@ -1034,11 +1087,15 @@ let rec tree_of_modtype = function wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res) and tree_of_signature sg = - wrap_env (fun env -> env) tree_of_signature_rec sg + wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg -and tree_of_signature_rec = function +and tree_of_signature_rec env' = function [] -> [] | item :: rem -> + begin match item with + Sig_type (_, _, rs) when rs <> Trec_next -> () + | _ -> set_printing_env env' + end; let (sg, rem) = filter_rem_sig item rem in let trees = match item with @@ -1047,6 +1104,7 @@ and tree_of_signature_rec = function | Sig_type(id, _, _) when is_row_name (Ident.name id) -> [] | Sig_type(id, decl, rs) -> + hide_rec_items (item :: rem); [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] | Sig_exception(id, decl) -> [tree_of_exception_declaration id decl] @@ -1059,8 +1117,8 @@ and tree_of_signature_rec = function | Sig_class_type(id, decl, rs) -> [tree_of_cltype_declaration id decl rs] in - set_printing_env (Env.add_signature (item :: sg) !printing_env); - trees @ tree_of_signature_rec rem + let env' = Env.add_signature (item :: sg) env' in + trees @ tree_of_signature_rec env' rem and tree_of_modtype_declaration id decl = let mty = @@ -1227,7 +1285,7 @@ let explanation unif t3 t4 ppf = | Tnil, Tconstr _ | Tconstr _, Tnil -> fprintf ppf "@,@[The %s object type has an abstract row, it cannot be closed@]" - (if t4.desc = Tnil then "first" else "second") + (if t4.desc = Tnil then "first" else "second") | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in begin match @@ -1345,7 +1403,7 @@ let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = match tpl with [] -> assert false | [tp, tp'] -> - fprintf ppf + fprintf ppf "@[%t@;<1 2>%a@ \ %t@;<1 2>%a\ @]" diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 0ded9b789..e319f18f1 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -79,3 +79,5 @@ val report_ambiguous_type_error: formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit +(* for toploop *) +val hide_rec_items: signature_item list -> unit |