From 24fd8b49330471a7b806f29b073e818de4419c61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 13 Dec 2024 15:33:12 +0100 Subject: [PATCH 1/5] Revert changes to printtyp --- src/ocaml/typing/printtyp.ml | 2691 ++++++++++++++++++++++++++++++++- src/ocaml/typing/printtyp.mli | 50 +- 2 files changed, 2693 insertions(+), 48 deletions(-) diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 85eed321f1..833db2360a 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -15,65 +15,2664 @@ (* Printing functions *) -module Fmt = Format_doc -module Doc = Printtyp_doc +module M = Misc.String.Map +module S = Misc.String.Set -include Doc +open Misc +open Ctype +open Format +open Longident +open Path +open Asttypes +open Types +open Btype +open Outcometree + +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style (* Print a long identifier *) let longident = Pprintast.longident -let ident = Fmt.compat Doc.ident -let path = Fmt.compat Doc.path -let type_path = Fmt.compat Doc.type_path -let raw_type_expr = Fmt.compat Doc.raw_type_expr -let wrap_printing_env = Doc.wrap_printing_env -let type_expr = Fmt.compat Doc.type_expr -let prepared_type_expr = Fmt.compat Doc.prepared_type_expr -let constructor_arguments = Fmt.compat Doc.constructor_arguments -let type_scheme = Fmt.compat Doc.type_scheme -let prepared_type_scheme = Fmt.compat Doc.prepared_type_scheme -let shared_type_scheme = Fmt.compat Doc.shared_type_scheme -let value_description = Fmt.compat1 Doc.value_description -let label = Fmt.compat Doc.label -let prepared_constructor = Fmt.compat Doc.prepared_constructor -let constructor = Fmt.compat Doc.constructor -let prepared_type_declaration = Fmt.compat1 Doc.prepared_type_declaration -let type_declaration = Fmt.compat1 Doc.type_declaration - -let prepared_extension_constructor = - Fmt.compat1 Doc.prepared_extension_constructor - -let extension_constructor = Fmt.compat1 Doc.extension_constructor -let extension_only_constructor = Fmt.compat1 Doc.extension_only_constructor -let modtype = Fmt.compat Doc.modtype -let signature = Fmt.compat Doc.signature + +let () = Env.print_longident := longident + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name +end + +(** Some identifiers may require hiding when printing *) +type bound_ident = { hide:bool; ident:Ident.t } + +(* printing environment for path shortening and naming *) +let printing_env = ref Env.empty + +(* When printing, it is important to only observe the + current printing environment, without reading any new + cmi present on the file system *) +let in_printing_env f = Env.without_cmis f !printing_env + + type namespace = Shape.Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + + let lookup = + let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in + function + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor|Constructor|Label) -> + fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value|Constructor|Label) | None -> + Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type + +end + +(** {2 Conflicts printing} + Conflicts arise when multiple items are attributed the same name, + the following module stores the global conflict references and + provides the printing functions for explaining the source of + the conflicts. +*) +module Conflicts = struct + type explanation = + { kind: namespace; name:string; root_name:string; location:Location.t} + let explanations = ref M.empty + + let add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Format.fprintf ppf "@[%a:@,Definition of %s %a@]" + Location.print_loc r.location (Sig_component_kind.to_string r.kind) + Style.inline_code r.name + + let print_located_explanations ppf l = + Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l + + let reset () = explanations := M.empty + let list_explanations () = + let c = !explanations in + reset (); + c |> M.bindings |> List.map snd |> List.sort Stdlib.compare + + + let print_toplevel_hint ppf l = + let conj ppf () = Format.fprintf ppf " and@ " in + let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in + let root_names = List.map (fun r -> r.kind, r.root_name) l in + let unique_root_names = List.sort_uniq Stdlib.compare root_names in + let submsgs = Array.make Namespace.size [] in + let () = List.iter (fun (n,_ as x) -> + submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) + ) unique_root_names in + let pp_submsg ppf names = + match names with + | [] -> () + | [namespace, a] -> + Format.fprintf ppf + "@ \ + @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ + @ Did you try to redefine them?@]" + Namespace.pp namespace + Style.inline_code a Namespace.pp namespace + | (namespace, _) :: _ :: _ -> + Format.fprintf ppf + "@ \ + @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ + @ Did you try to redefine them?@]" + pp_namespace_plural namespace + Format.(pp_print_list ~pp_sep:conj Style.inline_code) + (List.map snd names) + pp_namespace_plural namespace in + Array.iter (pp_submsg ppf) submsgs + + let print_explanations ppf = + let ltop, l = + (* isolate toplevel locations, since they are too imprecise *) + let from_toplevel a = + a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in + List.partition from_toplevel (list_explanations ()) + in + begin match l with + | [] -> () + | l -> Format.fprintf ppf "@,%a" print_located_explanations l + end; + (* if there are name collisions in a toplevel session, + display at least one generic hint by namespace *) + print_toplevel_hint ppf ltop + + let exists () = M.cardinal !explanations >0 +end + +module Naming_context = struct + +let enabled = ref true +let enable b = enabled := b + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers during the + error processing, we are thus disabling disambiguation on the argument name +*) +let fuzzy = ref S.empty +let with_arg id f = + protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + +let with_hidden ids f = + let update m id = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor | Constructor | Label -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Naming_context.ident_name + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace s with + | path' -> Path.same path path' + | exception Not_found -> true) + | _ -> false + +let find_double_underscore s = + let len = String.length s in + let rec loop i = + if i + 1 >= len then + None + else if s.[i] = '_' && s.[i + 1] = '_' then + Some i + else + loop (i + 1) + in + loop 0 + +let rec module_path_is_an_alias_of env path ~alias_of = + match Env.find_module path env with + | { md_type = Mty_alias path'; _ } -> + Path.same path' alias_of || + module_path_is_an_alias_of env path' ~alias_of + | _ -> false + | exception Not_found -> false + +(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +let rec rewrite_double_underscore_paths env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths env a, + rewrite_double_underscore_paths env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | Pident id -> + let name = Ident.name id in + match find_double_underscore name with + | None -> p + | Some i -> + let better_lid = + Ldot + (Lident (String.sub name 0 i), + Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2))) + in + match Env.find_module_by_name better_lid env with + | exception Not_found -> p + | p', _ -> + if module_path_is_an_alias_of env p' ~alias_of:p then + p' + else + p + +let rewrite_double_underscore_paths env p = + if env == Env.empty then + p + else + rewrite_double_underscore_paths env p + +let rec tree_of_path ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + +let path ppf p = + !Oprint.out_ident ppf (tree_of_path None p) + +let string_of_path p = + Format.asprintf "%a" path p + +let strings_of_paths namespace p = + let trees = List.map (tree_of_path namespace) p in + List.map (Format.asprintf "%a" !Oprint.out_ident) trees + +let () = Env.print_path := path + +(* Print a recursive annotation *) + +let tree_of_rec = function + | Trec_not -> Orec_not + | Trec_first -> Orec_first + | Trec_next -> Orec_next + +(* Print a raw type expression, with sharing *) + +let raw_list pr ppf = function + [] -> fprintf ppf "[]" + | a :: l -> + fprintf ppf "@[<1>[%a%t]@]" pr a + (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + +let kind_vars = ref [] +let kind_count = ref 0 + +let string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {desc = Tlink t} when not (List.memq t v) -> + safe_repr (t::v) t + | t' -> t' + +let rec list_of_memo = function + Mnil -> [] + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + +let print_name ppf = function + None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s + +let visited = ref [] +let rec raw_type ppf ty = + let ty = safe_repr [] ty in + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin + visited := ty :: !visited; + fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level + ty.scope raw_type_desc ty.desc + end +and raw_type_list tl = raw_list raw_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl +and raw_type_desc ppf = function + Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow(l,t1,t2,c) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t + (fun ppf -> + match !nm with None -> fprintf ppf " None" + | Some(p,tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tfield (f, k, t1, t2) -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind k) + raw_type t1 raw_type t2 + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t + | Tsubst (t, Some t') -> + fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> + fprintf ppf "@[%s,@ %a@]" l raw_field f)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match name with None -> fprintf ppf "None" + | Some(p,tl) -> + fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + | Tpackage (p, fl) -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl + +and raw_row_fixed ppf = function +| None -> fprintf ppf "None" +| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" +| Some Types.Rigid -> fprintf ppf "Some Rigid" +| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t +| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p + +and raw_field ppf rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +let raw_type_expr ppf t = + visited := []; kind_vars := []; kind_count := 0; + raw_type ppf t; + visited := []; kind_vars := [] + +let () = Btype.print_raw := raw_type_expr + +(* Normalize paths *) + +let set_printing_env env = + printing_env := + if !Clflags.real_paths then Env.empty + else env + +let wrap_printing_env env f = + set_printing_env (Env.update_short_paths env); + try_finally f ~always:(fun () -> set_printing_env Env.empty) + +let wrap_printing_env ?error:_ env f = + Env.without_cmis (wrap_printing_env env) f + +type type_result = Short_paths.type_result = + | Nth of int + | Path of int list option * Path.t + +type type_resolution = Short_paths.type_resolution = + | Nth of int + | Subst of int list + | Id + +let apply_subst ns args = + List.map (List.nth args) ns + +let apply_subst_opt nso args = + match nso with + | None -> args + | Some ns -> apply_subst ns args + +let apply_nth n args = + List.nth args n + +let best_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then Path(None, p) + else Short_paths.find_type (Env.short_paths !printing_env) p + +let best_type_path_resolution p = + if !Clflags.real_paths || !printing_env == Env.empty + then Id + else Short_paths.find_type_resolution (Env.short_paths !printing_env) p + +let best_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_type_simple (Env.short_paths !printing_env) p + +let best_module_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module_type (Env.short_paths !printing_env) p + +let best_module_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module (Env.short_paths !printing_env) p + +let best_class_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then None, p + else Short_paths.find_class_type (Env.short_paths !printing_env) p + +let best_class_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + f (apply_nth n tyl) + | Subst ns -> + List.iter f (apply_subst ns tyl) + | Id -> + List.iter f tyl + end + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +module Internal_names : sig + + val reset : unit -> unit + + val add : Path.t -> unit + + val print_explanations : Env.t -> Format.formatter -> unit + +end = struct + + let names = ref Ident.Set.empty + + let reset () = + names := Ident.Set.empty + + let add p = + match p with + | Pident id -> + let name = Ident.name id in + if String.length name > 0 && name.[0] = '$' then begin + names := Ident.Set.add id !names + end + | Pdot _ | Papply _ | Pextra_ty _ -> () + + let print_explanations env ppf = + let constrs = + Ident.Set.fold + (fun id acc -> + let p = Pident id in + match Env.find_type p env with + | exception Not_found -> acc + | decl -> + match type_origin decl with + | Existential constr -> + let prev = String.Map.find_opt constr acc in + let prev = Option.value ~default:[] prev in + String.Map.add constr (tree_of_path None p :: prev) acc + | Definition | Rec_check_regularity -> acc) + !names String.Map.empty + in + String.Map.iter + (fun constr out_idents -> + match out_idents with + | [] -> () + | [out_ident] -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ + bound by the constructor@ %a.@]" + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr + | out_ident :: out_idents -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ + bound by the constructor@ %a.@]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") + (Style.as_inline_code !Oprint.out_ident)) + (List.rev out_idents) + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr) + constrs + +end + +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr list) + + let weak_counter = ref 1 + let weak_var_map = ref TypeMap.empty + let named_weak_vars = ref String.Set.empty + + let reset_names () = + names := []; + name_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || String.Set.mem name !named_weak_vars + + let rec new_name () = + let name = Misc.letter_of_int !name_counter in + incr name_counter; + if name_is_already_used name then new_name () else name + + let rec new_weak_name ty () = + let name = "weak" ^ Int.to_string !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else begin + named_weak_vars := String.Set.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name + end + + let new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.find t !weak_var_map with Not_found -> + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so + * try adding a number until we find a name that's not taken. *) + let available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name + + let check_name_of_type ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme t then + begin + TypeMap.add t name m, + String.Set.add name s + end + else m, s in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in + named_weak_vars := s; + weak_var_map := m +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + +let add_delayed t = + if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy ~non_gen px = + Names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) + +let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> begin + match best_type_path_resolution p with + | Nth _ -> false + | Subst _ | Id -> true + end + | _ -> true + +(* let namable_row row = + row.row_name <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _, _) -> + row.row_closed && if c then l = [] else List.length l = 1 + | _ -> true) + row.row_fields *) +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + +(*let rec mark_loops_rec visited ty = + let ty = repr ty in + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias px else + let visited = px :: visited in + match ty.desc with + | Tvar _ -> add_named_var ty + | Tarrow(_, ty1, ty2, _) -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + mark_loops_rec visited (apply_nth n tyl) + | Subst ns -> + List.iter (mark_loops_rec visited) (apply_subst ns tyl) + | Id -> + List.iter (mark_loops_rec visited) tyl + end + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl + | Tvariant row -> + if List.memq px !visited_objects then add_alias px else + begin + let row = row_repr row in + if not (static_row row) then + visited_objects := px :: !visited_objects; + match row.row_name with + | Some(_p, tyl) when namable_row row -> + List.iter (mark_loops_rec visited) tyl + | _ -> + iter_row (mark_loops_rec visited) row + end + | Tobject (fi, nm) -> + if List.memq px !visited_objects then add_alias px else + begin + if opened_object ty then + visited_objects := px :: !visited_objects; + begin match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpresent then + mark_loops_rec visited ty) + fields + | Some (_, l) -> + List.iter (mark_loops_rec visited) (List.tl l) + end + end + | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Tfield(_, _, _, ty2) -> + mark_loops_rec visited ty2 + | Tnil -> () + | Tsubst _ -> () (* we do not print arguments *) + | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" + | Tpoly (ty, tyl) -> + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty + | Tunivar _ -> add_named_var ty *) +let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty +let mark_loops ty = + mark_loops_rec [] ty;; + +let prepare_type ty = + reserve_names ty; + mark_loops ty;; + +let reset_loop_marks () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +let reset_except_context () = + Names.reset_names (); reset_loop_marks (); Internal_names.reset () + +let reset () = + Conflicts.reset (); + reset_except_context () + +let prepare_for_printing tyl = + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + add_alias_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Names.name_of_type name_gen tty) + | Tarrow(l, ty1, ty2, _) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let t1 = + if is_optional l then + match get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode tyl) + | Tconstr(p, tyl, _abbrev) -> begin + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(nso, p') -> + Internal_names.add p'; + let tyl' = apply_subst_opt nso tyl in + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else fields in + let present = + List.filter + (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) + fields in + let all_present = List.length present = List.length fields in + begin match name with + | Some(p, tyl) when nameable_row row -> + let out_variant = + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(s, p) -> + let id = tree_of_path (Some Type) p in + let args = tree_of_typlist mode (apply_subst_opt s tyl) in + Otyp_constr (id, args) + in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) + List.iter add_delayed tyl; + let tl = List.map (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let p = best_module_type_path p in + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; + alias_nongen_row mode px ty; + if is_aliased_proxy px && aliasable ty then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + add_printed_alias_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode fi nm = + begin match nm with + | None -> + let pr_fields fi = + let (fields, rest) = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let p' = best_type_path_simple p in + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Printtyp.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type ppf ty +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +let type_expr ppf ty = + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty + +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty + +let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty + +let type_path ppf p = + let p = best_class_type_path_simple p in + let t = tree_of_path (Some Type) p in + !Oprint.out_ident ppf t + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme ty + +(* Print one type declaration *) + +let tree_of_constraints params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl + else ty :: tyl) + (* Two parameters might be identical due to a constraint but we need to + print them differently in order to make the output syntactically valid. + We use [Ttuple [ty]] because it is printed as [ty]. *) + (* Replacing fold_left by fold_right does not work! *) + [] tyl + in List.rev params + +let prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter add_alias params; + List.iter prepare_type params; + List.iter (add_printed_alias ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract _ -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + let type_param ot_variance = + function + | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + in + let type_defined decl = + let abstr = + match decl.type_kind with + Type_abstract _ -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> + decl.type_private = Private + | Type_variant (tll, _rep) -> + decl.type_private = Private || + List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> + decl.type_manifest = None + in + let vari = + List.map2 + (fun ty v -> + let is_var = is_Tvar ty in + if abstr || not is_var then + let inj = + type_kind_is_abstract decl && Variance.mem Inj v && + match decl.type_manifest with + | None -> true + | Some ty -> (* only abstract or private row types *) + decl.type_private = Private && + Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) + and (co, cn) = Variance.get_upper v in + (if not cn then Covariant else + if not co then Contravariant else NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + (Ident.name id, + List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) + in + let (name, args) = type_defined decl in + let constraints = tree_of_constraints params in + let ty, priv, unboxed = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + (rep = Variant_unboxed) + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed _ -> true | _ -> false) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = Type_immediacy.of_attributes decl.type_attributes; + otype_unboxed = unboxed; + otype_cstrs = constraints } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_context(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + +let constructor ppf c = + reset_except_context (); + add_constructor_to_preparation c; + prepared_constructor ppf c + +let label ppf l = + reset_except_context (); + prepare_type l.ld_type; + !Oprint.out_label ppf (tree_of_label l) + +let tree_of_type_declaration id decl rs = + Osig_type (tree_of_type_decl id decl, tree_of_rec rs) + +let tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) + +let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) + +let add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_type_declaration id decl Trec_first) + +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + +(* Print an extension declaration *) + +let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) + +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let prepared_tree_of_extension_constructor + id ext es + = + let type_path = best_type_path_simple ext.ext_type_path in + let ty_name = Path.name type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (add_printed_alias ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + ) + in + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + let ext = + { oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_private = ext.ext_private } + in + let es = + match es with + Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) + +let tree_of_extension_constructor id ext es = + reset_except_context (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +let extension_only_constructor id ppf ext = + reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + Format.fprintf ppf "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* Print a value declaration *) + +let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) + let id = Ident.name id in + let ty = tree_of_type_scheme decl.val_type in + let vd = + { oval_name = id; + oval_type = ty; + oval_prims = []; + oval_attributes = [] } + in + let vd = + match decl.val_kind with + | Val_prim p -> Primitive.print p vd + | _ -> vd + in + Osig_value vd + +let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) + +(* Print a class type *) + +let method_type priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px + else visited_objects := px :: !visited_objects; + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else begin + let nso, p = best_class_type_path p in + let tyl = apply_subst_opt nso tyl in + let namespace = Namespace.best_class_namespace p in + Octy_constr (tree_of_path namespace p, tree_of_typlist Type_scheme tyl) + end + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) + else None + in + let csil = [] in + let csil = + List.fold_left + (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) + csil (tree_of_constraints params) + in + let all_vars = + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] + in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + in + Octy_signature (self_ty, List.rev csil) + | Cty_arrow (l, ty, cty) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let tr = + if is_optional l then + match get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + +let class_type ppf cty = + reset (); + prepare_class_type [] cty; + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) + +let tree_of_class_param param variance = + let ot_variance = + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + (if not (mem May_pos v) then Contravariant else + if not (mem May_neg v) then Covariant else NoVariance), + NoInjectivity) + +let tree_of_class_declaration id cl rs = + let params = filter_params cl.cty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.cty_type; + let px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; + + let vir_flag = cl.cty_new = None in + Osig_class + (vir_flag, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.cty_variance), + tree_of_class_type Type_scheme params cl.cty_type, + tree_of_rec rs) + +let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) + +let tree_of_cltype_declaration id cl rs = + let params = cl.clty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme params cl.clty_type, + tree_of_rec rs) + +let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) + +(* Print a module type *) + +let wrap_env fenv ftree arg = + let env = !printing_env in + let env' = Env.update_short_paths (fenv env) in + set_printing_env env'; + let tree = ftree arg in + set_printing_env env; + tree + +let dummy = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + +(** we hide items being defined from short-path to avoid shortening + [type t = Path.To.t] into [type t = t]. +*) + +let ident_sigitem = function + | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} + | Types.Sig_class(ident,_,_,_) + | Types.Sig_class_type (ident,_,_,_) + | Types.Sig_module(ident,_, _,_,_) + | Types.Sig_value (ident,_,_) + | Types.Sig_modtype (ident,_,_) + | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } + +let hide ids env = + let hide_id id env = + (* Global idents cannot be renamed *) + if id.hide && not (Ident.global id.ident) then + Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env + else env + in + List.fold_right hide_id ids env + +let with_hidden_items ids f = + let with_hidden_in_printing_env ids f = + wrap_env (hide ids) (Naming_context.with_hidden ids) f + in + if not !Clflags.real_paths then + with_hidden_in_printing_env ids f + else + Naming_context.with_hidden ids f + +let add_sigitem env x = + Env.add_signature (Signature_group.flatten x) env + +let rec tree_of_modtype ?(ellipsis=false) = function + | Mty_ident p -> + let p = best_module_type_path p in + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (if ellipsis then [Osig_ellipsis] + else tree_of_signature sg) + | Mty_functor(param, ty_res) -> + let param, env = + tree_of_functor_parameter param + in + let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in + Omty_functor (param, res) + | Mty_alias p -> + let p = best_module_path p in + Omty_alias (tree_of_path (Some Module) p) + | Mty_for_hole -> Omty_hole + +and tree_of_functor_parameter = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + Env.add_module ~arg:true id Mp_present ty_arg + in + Some (name, tree_of_modtype ~ellipsis:false ty_arg), env + +and tree_of_signature sg = + wrap_env (fun env -> env)(fun sg -> + let tree_groups = tree_of_signature_rec !printing_env sg in + List.concat_map (fun (_env,l) -> List.map snd l) tree_groups + ) sg + +and tree_of_signature_rec env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + let collect_trees_of_rec_group group = + let env = !printing_env in + let env', group_trees = + trees_of_recursive_sigitem_group env group + in + set_printing_env env'; + (env, group_trees) in + set_printing_env env'; + List.map collect_trees_of_rec_group structured + +and trees_of_recursive_sigitem_group env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in + let env = Env.add_signature syntactic_group.pre_ghosts env in + match syntactic_group.group with + | Not_rec x -> add_sigitem env x, [display x] + | Rec_group items -> + let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in + List.fold_left add_sigitem env items, + with_hidden_items ids (fun () -> List.map display items) + +and tree_of_sigitem = function + | Sig_value(id, decl, _) -> + tree_of_value_description id decl + | Sig_type(id, decl, rs, _) -> + tree_of_type_declaration id decl rs + | Sig_typext(id, ext, es, _) -> + tree_of_extension_constructor id ext es + | Sig_module(id, _, md, rs, _) -> + let ellipsis = + List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes in + tree_of_module id md.md_type rs ~ellipsis + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration id decl + | Sig_class(id, decl, rs, _) -> + tree_of_class_declaration id decl rs + | Sig_class_type(id, decl, rs, _) -> + tree_of_cltype_declaration id decl rs + +and tree_of_modtype_declaration id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) let rec functor_parameters ~sep custom_printer = function | [] -> ignore | [id,param] -> - Format.dprintf "%t%t" - (custom_printer param) - (functor_param ~sep ~custom_printer id []) + Format.dprintf "%t%t" + (custom_printer param) + (functor_param ~sep ~custom_printer id []) | (id,param) :: q -> - Format.dprintf "%t%a%t" - (custom_printer param) - sep () - (functor_param ~sep ~custom_printer id q) + Format.dprintf "%t%a%t" + (custom_printer param) + sep () + (functor_param ~sep ~custom_printer id q) and functor_param ~sep ~custom_printer id q = match id with | None -> functor_parameters ~sep custom_printer q | Some id -> - Doc.Naming_context.with_arg id - (fun () -> functor_parameters ~sep custom_printer q) + Naming_context.with_arg id + (fun () -> functor_parameters ~sep custom_printer q) + + + +let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) +let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + +(* For the toplevel: merge with tree_of_signature? *) + +let print_items showval env x = + Names.refresh_weak(); + Conflicts.reset (); + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x + +(* Print a signature body (used by -i when compiling a .ml) *) + +let print_signature ppf tree = + fprintf ppf "@[%a@]" !Oprint.out_signature tree + +let signature ppf sg = + fprintf ppf "%a" print_signature (tree_of_signature sg) + +(* Print a signature body (used by -i when compiling a .ml) *) +let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) + Conflicts.reset (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") + && Conflicts.exists () + then begin + let conflicts = Format.asprintf "%t" Conflicts.print_explanations in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + fprintf ppf "%a" print_signature t + +(* Trace-specific printing *) + +(* A configuration type that controls which trace we print. This could be + exposed, but we instead expose three separate + [report_{unification,equality,moregen}_error] functions. This also lets us + give the unification case an extra optional argument without adding it to the + equality and moregen cases. *) +type 'variety trace_format = + | Unification : Errortrace.unification trace_format + | Equality : Errortrace.comparison trace_format + | Moregen : Errortrace.comparison trace_format + +let incompatibility_phrase (type variety) : variety trace_format -> string = + function + | Unification -> "is not compatible with type" + | Equality -> "is not equal to type" + | Moregen -> "is not compatible with type" + +(* Print a unification error *) + +let same_path t t' = + eq_type t t' || + match get_desc t, get_desc t' with + | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin + match best_type_path p, best_type_path p' with + | Nth n, Nth n' when n = n' -> true + | Path(nso, p), Path(nso', p') when Path.same p p' -> + let tl = apply_subst_opt nso tl in + let tl' = apply_subst_opt nso' tl' in + List.length tl = List.length tl' && + List.for_all2 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; + let t' = if proxy t == proxy t' then unalias t' else t' in + (* beware order matter due to side effect, + e.g. when printing object types *) + let first = tree_of_typexp mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +let type_expansion ppf = function + | Same t -> Style.as_inline_code !Oprint.out_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + (Style.as_inline_code !Oprint.out_type) t + (Style.as_inline_code !Oprint.out_type) t' + +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let trees_of_type_path_expansion (tp,tp') = + if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else + Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') + +let type_path_expansion ppf = function + | Same p -> Style.as_inline_code !Oprint.out_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + (Style.as_inline_code !Oprint.out_ident) p + (Style.as_inline_code !Oprint.out_ident) p' + +let rec trace fst txt ppf = function + | {Errortrace.got; expected} :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" + type_expansion got txt type_expansion expected + (trace false txt) rem + | _ -> () + +type printing_status = + | Discard + | Keep + | Optional_refinement + (** An [Optional_refinement] printing status is attributed to trace + elements that are focusing on a new subpart of a structural type. + Since the whole type should have been printed earlier in the trace, + we only print those elements if they are the last printed element + of a trace, and there is no explicit explanation for the + type error. + *) + +let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = t2'} } = + if is_constr_row ~allow_ident:true t1' + || is_constr_row ~allow_ident:true t2' + then Discard + else if same_path t1 t1' && same_path t2 t2' then Optional_refinement + else Keep + +let printing_status = function + | Errortrace.Diff d -> diff_printing_status d + | Errortrace.Escape {kind = Constraint} -> Keep + | _ -> Keep + +(** Flatten the trace and remove elements that are always discarded + during printing *) + +(* Takes [printing_status] to change behavior for [Subtype] *) +let prepare_any_trace printing_status tr = + let clean_trace x l = match printing_status x with + | Keep -> x :: l + | Optional_refinement when l = [] -> [x] + | Optional_refinement | Discard -> l + in + match tr with + | [] -> [] + | elt :: rem -> elt :: List.fold_right clean_trace rem [] + +let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.map f tr) + +(** Keep elements that are [Diff _ ] and take the decision + for the last element, require a prepared trace *) +let rec filter_trace keep_last = function + | [] -> [] + | [Errortrace.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem + | _ :: rem -> filter_trace keep_last rem + +let type_path_list = + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) + type_path_expansion + +(* Hide variant name and var, to force printing the expanded type *) +let hide_variant_name t = + match get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with + Tvariant _ | Tobject _ when compact -> + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) + +let print_tag ppf s = Style.inline_code ppf ("`" ^ s) + +let print_tags = + let comma ppf () = Format.fprintf ppf ",@ " in + Format.pp_print_list ~pp_sep:comma print_tag + +let is_unit env ty = + match get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + +let unifiable env ty1 ty2 = + let snap = Btype.snapshot () in + let res = + try Ctype.unify env ty1 ty2; true + with Unify _ -> false + in + Btype.backtrack snap; + res + +let explanation_diff env t3 t4 : (Format.formatter -> unit) option = + match get_desc t3, get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit env ty1 && unifiable env ty2 t4 -> + Some (fun ppf -> + fprintf ppf + "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" + Style.inline_code "()" + ) + | _, Tarrow (_, ty1, ty2, _) + when is_unit env ty1 && unifiable env t3 ty2 -> + Some (fun ppf -> + fprintf ppf + "@,@[@{Hint@}: Did you forget to wrap the expression using \ + %a?@]" + Style.inline_code "fun () ->" + ) + | _ -> + None + +let explain_fixed_row_case ppf = function + | Errortrace.Cannot_be_closed -> + fprintf ppf "it cannot be closed" + | Errortrace.Cannot_add_tags tags -> + fprintf ppf "it may not allow the tag(s) %a" + print_tags tags + +let explain_fixed_row pos expl = match expl with + | Fixed_private -> + dprintf "The %a variant type is private" Errortrace.print_pos pos + | Univar x -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos + (Style.as_inline_code type_expr_with_reserved_names) x + | Reified p -> + dprintf "The %a variant type is bound to %a" + Errortrace.print_pos pos + (Style.as_inline_code + (fun ppf p -> + Internal_names.add p; + print_path p ppf)) + p + | Rigid -> ignore + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(dprintf "@,Types for tag %a are incompatible" + print_tag s + ) + (* Unification *) + | Errortrace.No_intersection -> + Some(dprintf "@,These two variant types have no intersection") + | Errortrace.No_tags(pos,fields) -> Some( + dprintf + "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" + Errortrace.print_pos pos + print_tags (List.map fst fields) + ) + | Errortrace.Fixed_row (pos, + k, + (Univar _ | Reified _ | Fixed_private as e)) -> + Some ( + dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) + explain_fixed_row_case k + ) + | Errortrace.Fixed_row (_,_, Rigid) -> + (* this case never happens *) + None + (* Equality & Moregen *) + | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag %a is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + print_tag s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | Errortrace.Openness pos -> + Some(dprintf "@,The %a variant type is open and the %a is not" + Errortrace.print_pos pos + Errortrace.print_pos (Errortrace.swap_position pos)) + +let explain_escape pre = function + | Errortrace.Univ u -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre + (Style.as_inline_code type_expr_with_reserved_names) u + ) + | Errortrace.Constructor p -> Some( + dprintf + "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + pre (Style.as_inline_code path) p + ) + | Errortrace.Module_type p -> Some( + dprintf + "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" + pre (Style.as_inline_code path) p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre + (Style.as_inline_code type_expr_with_reserved_names) t + "it would escape the scope of its equation" + ) + | Errortrace.Self -> + Some (dprintf "%t@,Self type cannot escape its class" pre) + | Errortrace.Constraint -> + None + +let explain_object (type variety) : variety Errortrace.obj -> _ = function + | Errortrace.Missing_field (pos,f) -> Some( + dprintf "@,@[The %a object type has no method %a@]" + Errortrace.print_pos pos Style.inline_code f + ) + | Errortrace.Abstract_row pos -> Some( + dprintf + "@,@[The %a object type has an abstract row, it cannot be closed@]" + Errortrace.print_pos pos + ) + | Errortrace.Self_cannot_be_closed -> + Some (dprintf "@,Self type cannot be unified with a closed object type") + +let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %a has type@ %a,@ \ + but the expected method type was@ %a@]" + Style.inline_code name + (Style.as_inline_code type_expr_with_reserved_names) diff.got + (Style.as_inline_code type_expr_with_reserved_names) diff.expected + +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro + (Style.as_inline_code type_expr_with_reserved_names) ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + explain_incompatible_fields name diff + | _ -> ignore + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; diff} -> + Some(explain_incompatible_fields name diff) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.Rec_occur(x,y) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + (Style.as_inline_code prepared_type_expr) x + (Style.as_inline_code prepared_type_expr) y + ppf) + | _ -> + (* We had a delayed unification of the type variable with + a non-variable after the occur check. *) + Some ignore + (* There is no need to search further for an explanation, but + we don't want to print a message of the form: + {[ The type int occurs inside int list -> 'a |} + *) + end + +let mismatch intro env trace = + Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) + +let explain mis ppf = + match mis with + | None -> () + | Some explain -> explain ppf + +let warn_on_missing_def env ppf t = + match get_desc t with + | Tconstr (p,_,_) -> + begin match Env.find_type p env with + | exception Not_found -> + fprintf ppf + "@,@[Type %a is abstract because@ no corresponding\ + @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p + | { type_manifest = Some _; _ } -> () + | { type_manifest = None; _ } as decl -> + match type_origin decl with + | Rec_check_regularity -> + fprintf ppf + "@,@[Type %a was considered abstract@ when checking\ + @ constraints@ in this@ recursive type definition.@]" + (Style.as_inline_code path) p + | Definition | Existential _ -> () + end + | _ -> () + +let prepare_expansion_head empty_tr = function + | Errortrace.Diff d -> + Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) + | _ -> None + +let head_error_printer mode txt_got txt_but = function + | None -> ignore + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) d in + dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" + txt_got type_expansion d.Errortrace.got + txt_but type_expansion d.Errortrace.expected + +let warn_on_missing_defs env ppf = function + | None -> () + | Some Errortrace.{got = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + tr + in + let mis = mismatch txt1 env tr in + match tr with + | [] -> assert false + | elt :: tr -> + try + print_labels := not !Clflags.classic; + let tr = filter_trace (mis = None) tr in + let head = prepare_expansion_head (tr=[]) elt in + let tr = List.map (Errortrace.map_diff prepare_expansion) tr in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + fprintf ppf + "@[\ + @[%t%t@]%a%t\ + @]" + head_error + ty_expect_explanation + (trace false (incompatibility_phrase trace_format)) tr + (explain mis); + if env <> Env.empty + then warn_on_missing_defs env ppf head; + Internal_names.print_explanations env ppf; + Conflicts.print_explanations ppf; + print_labels := true + with exn -> + print_labels := true; + raise exn + +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +module Subtype = struct + (* There's a frustrating amount of code duplication between this module and + the outside code, particularly in [prepare_trace] and [filter_trace]. + Unfortunately, [Subtype] is *just* similar enough to have code duplication, + while being *just* different enough (it's only [Diff]) for the abstraction + to be nonobvious. Someday, perhaps... *) + + let printing_status = function + | Errortrace.Subtype.Diff d -> diff_printing_status d + + let prepare_unification_trace = prepare_trace + + let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.Subtype.map f tr) + + let trace filter_trace get_diff fst keep_last txt ppf tr = + print_labels := not !Clflags.classic; + try match tr with + | elt :: tr' -> + let diffed_elt = get_diff elt in + let tr = + trees_of_trace Type + @@ List.map (Errortrace.map_diff prepare_expansion) + @@ filter_trace keep_last tr' in + let tr = + match fst, diffed_elt with + | true, Some elt -> elt :: tr + | _, _ -> tr + in + trace fst txt ppf tr; + print_labels := true + | _ -> () + with exn -> + print_labels := true; + raise exn + + let rec filter_subtype_trace keep_last = function + | [] -> [] + | [Errortrace.Subtype.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Subtype.Diff d :: rem -> + d :: filter_subtype_trace keep_last rem + + let unification_get_diff = function + | Errortrace.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (explain mis) + Conflicts.print_explanations + ) +end + +let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tp0 = trees_of_type_path_expansion tp0 in + match tpl with + [] -> assert false + | [tp] -> + fprintf ppf + "@[%t@;<1 2>%a@ \ + %t@;<1 2>%a\ + @]" + txt1 type_path_expansion (trees_of_type_path_expansion tp) + txt3 type_path_expansion tp0 + | _ -> + fprintf ppf + "@[%t@;<1 2>@[%a@]\ + @ %t@;<1 2>%a\ + @]" + txt2 type_path_list (List.map trees_of_type_path_expansion tpl) + txt3 type_path_expansion tp0) + +(* Adapt functions to exposed interface *) +let tree_of_path = tree_of_path None +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let type_expansion mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +let tree_of_type_declaration ident td rs = + with_hidden_items [{hide=true; ident}] + (fun () -> tree_of_type_declaration ident td rs) + +let shorten_type_path env p = + wrap_printing_env env + (fun () -> best_type_path_simple p) + +let shorten_module_type_path env p = + wrap_printing_env env + (fun () -> best_module_type_path p) -let modtype_declaration = Fmt.compat1 Doc.modtype_declaration -let class_type = Fmt.compat Doc.class_type -let class_declaration = Fmt.compat1 Doc.class_declaration -let cltype_declaration = Fmt.compat1 Doc.cltype_declaration -let type_expansion = Fmt.compat1 Doc.type_expansion -let printed_signature = Fmt.compat1 Doc.printed_signature +let shorten_module_path env p = + wrap_printing_env env + (fun () -> best_module_path p) +let shorten_class_type_path env p = + wrap_printing_env env + (fun () -> best_class_type_path_simple p) -let () = Env.print_longident := Doc.longident -let () = Env.print_path := Doc.path -let () = Env.shorten_module_path := shorten_module_path +let () = + Env.shorten_module_path := shorten_module_path diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index 0df51e40f9..2769fe0322 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -19,8 +19,6 @@ open Format open Types open Outcometree -module Doc : sig include module type of Printtyp_doc end - val longident: formatter -> Longident.t -> unit val ident: formatter -> Ident.t -> unit val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string @@ -32,6 +30,11 @@ val type_path: formatter -> Path.t -> unit (** Print a type path taking account of [-short-paths]. Calls should be within [wrap_printing_env]. *) +module Out_name: sig + val create: string -> out_name + val print: out_name -> string +end + type namespace := Shape.Sig_component_kind.t option val strings_of_paths: namespace -> Path.t list -> string list @@ -50,6 +53,41 @@ val shorten_module_type_path: Env.t -> Path.t -> Path.t val shorten_module_path: Env.t -> Path.t -> Path.t val shorten_class_type_path: Env.t -> Path.t -> Path.t +module Naming_context: sig + val enable: bool -> unit + (** When contextual names are enabled, the mapping between identifiers + and names is ensured to be one-to-one. *) +end + +(** The [Conflicts] module keeps track of conflicts arising when attributing + names to identifiers and provides functions that can print explanations + for these conflict in error messages *) +module Conflicts: sig + val exists: unit -> bool + (** [exists()] returns true if the current naming context renamed + an identifier to avoid a name collision *) + + type explanation = + { kind: Shape.Sig_component_kind.t; + name:string; + root_name:string; + location:Location.t + } + + val list_explanations: unit -> explanation list +(** [list_explanations()] return the list of conflict explanations + collected up to this point, and reset the list of collected + explanations *) + + val print_located_explanations: + Format.formatter -> explanation list -> unit + + val print_explanations: Format.formatter -> unit + (** Print all conflict explanations collected up to this point *) + + val reset: unit -> unit +end + val reset: unit -> unit @@ -194,6 +232,14 @@ val report_comparison_error : (formatter -> unit) -> (formatter -> unit) -> unit +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + unit +end (* for toploop *) val print_items: (Env.t -> signature_item -> 'a option) -> From 194b5ce345e6417ce729a0224dccce0b1829dfaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 13 Dec 2024 16:01:35 +0100 Subject: [PATCH 2/5] Remove what moved to errortrace_report --- src/ocaml/typing/printtyp.ml | 590 ----------------------------------- 1 file changed, 590 deletions(-) diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 833db2360a..ba0c1fc9f2 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -2068,596 +2068,6 @@ let printed_signature sourcefile ppf sg = end; fprintf ppf "%a" print_signature t -(* Trace-specific printing *) - -(* A configuration type that controls which trace we print. This could be - exposed, but we instead expose three separate - [report_{unification,equality,moregen}_error] functions. This also lets us - give the unification case an extra optional argument without adding it to the - equality and moregen cases. *) -type 'variety trace_format = - | Unification : Errortrace.unification trace_format - | Equality : Errortrace.comparison trace_format - | Moregen : Errortrace.comparison trace_format - -let incompatibility_phrase (type variety) : variety trace_format -> string = - function - | Unification -> "is not compatible with type" - | Equality -> "is not equal to type" - | Moregen -> "is not compatible with type" - -(* Print a unification error *) - -let same_path t t' = - eq_type t t' || - match get_desc t, get_desc t' with - | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin - match best_type_path p, best_type_path p' with - | Nth n, Nth n' when n = n' -> true - | Path(nso, p), Path(nso', p') when Path.same p p' -> - let tl = apply_subst_opt nso tl in - let tl' = apply_subst_opt nso' tl' in - List.length tl = List.length tl' && - List.for_all2 eq_type tl tl' - | _ -> false - end - | _ -> - false - -type 'a diff = Same of 'a | Diff of 'a * 'a - -let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = - reset_loop_marks (); - mark_loops t; - if same_path t t' - then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end - else begin - mark_loops t'; - let t' = if proxy t == proxy t' then unalias t' else t' in - (* beware order matter due to side effect, - e.g. when printing object types *) - let first = tree_of_typexp mode t in - let second = tree_of_typexp mode t' in - if first = second then Same first - else Diff(first,second) - end - -let type_expansion ppf = function - | Same t -> Style.as_inline_code !Oprint.out_type ppf t - | Diff(t,t') -> - fprintf ppf "@[<2>%a@ =@ %a@]" - (Style.as_inline_code !Oprint.out_type) t - (Style.as_inline_code !Oprint.out_type) t' - -let trees_of_trace mode = - List.map (Errortrace.map_diff (trees_of_type_expansion mode)) - -let trees_of_type_path_expansion (tp,tp') = - if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else - Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') - -let type_path_expansion ppf = function - | Same p -> Style.as_inline_code !Oprint.out_ident ppf p - | Diff(p,p') -> - fprintf ppf "@[<2>%a@ =@ %a@]" - (Style.as_inline_code !Oprint.out_ident) p - (Style.as_inline_code !Oprint.out_ident) p' - -let rec trace fst txt ppf = function - | {Errortrace.got; expected} :: rem -> - if not fst then fprintf ppf "@,"; - fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" - type_expansion got txt type_expansion expected - (trace false txt) rem - | _ -> () - -type printing_status = - | Discard - | Keep - | Optional_refinement - (** An [Optional_refinement] printing status is attributed to trace - elements that are focusing on a new subpart of a structural type. - Since the whole type should have been printed earlier in the trace, - we only print those elements if they are the last printed element - of a trace, and there is no explicit explanation for the - type error. - *) - -let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; - expected = {ty = t2; expanded = t2'} } = - if is_constr_row ~allow_ident:true t1' - || is_constr_row ~allow_ident:true t2' - then Discard - else if same_path t1 t1' && same_path t2 t2' then Optional_refinement - else Keep - -let printing_status = function - | Errortrace.Diff d -> diff_printing_status d - | Errortrace.Escape {kind = Constraint} -> Keep - | _ -> Keep - -(** Flatten the trace and remove elements that are always discarded - during printing *) - -(* Takes [printing_status] to change behavior for [Subtype] *) -let prepare_any_trace printing_status tr = - let clean_trace x l = match printing_status x with - | Keep -> x :: l - | Optional_refinement when l = [] -> [x] - | Optional_refinement | Discard -> l - in - match tr with - | [] -> [] - | elt :: rem -> elt :: List.fold_right clean_trace rem [] - -let prepare_trace f tr = - prepare_any_trace printing_status (Errortrace.map f tr) - -(** Keep elements that are [Diff _ ] and take the decision - for the last element, require a prepared trace *) -let rec filter_trace keep_last = function - | [] -> [] - | [Errortrace.Diff d as elt] - when printing_status elt = Optional_refinement -> - if keep_last then [d] else [] - | Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem - | _ :: rem -> filter_trace keep_last rem - -let type_path_list = - Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) - type_path_expansion - -(* Hide variant name and var, to force printing the expanded type *) -let hide_variant_name t = - match get_desc t with - | Tvariant row -> - let Row {fields; more; name; fixed; closed} = row_repr row in - if name = None then t else - newty2 ~level:(get_level t) - (Tvariant - (create_row ~fields ~fixed ~closed ~name:None - ~more:(newvar2 (get_level more)))) - | _ -> t - -let prepare_expansion Errortrace.{ty; expanded} = - let expanded = hide_variant_name expanded in - reserve_names ty; - if not (same_path ty expanded) then reserve_names expanded; - Errortrace.{ty; expanded} - -let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = - match get_desc expanded with - Tvariant _ | Tobject _ when compact -> - reserve_names ty; Errortrace.{ty; expanded = ty} - | _ -> prepare_expansion ty_exp - -let print_path p = - Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) - -let print_tag ppf s = Style.inline_code ppf ("`" ^ s) - -let print_tags = - let comma ppf () = Format.fprintf ppf ",@ " in - Format.pp_print_list ~pp_sep:comma print_tag - -let is_unit env ty = - match get_desc (Ctype.expand_head env ty) with - | Tconstr (p, _, _) -> Path.same p Predef.path_unit - | _ -> false - -let unifiable env ty1 ty2 = - let snap = Btype.snapshot () in - let res = - try Ctype.unify env ty1 ty2; true - with Unify _ -> false - in - Btype.backtrack snap; - res - -let explanation_diff env t3 t4 : (Format.formatter -> unit) option = - match get_desc t3, get_desc t4 with - | Tarrow (_, ty1, ty2, _), _ - when is_unit env ty1 && unifiable env ty2 t4 -> - Some (fun ppf -> - fprintf ppf - "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" - Style.inline_code "()" - ) - | _, Tarrow (_, ty1, ty2, _) - when is_unit env ty1 && unifiable env t3 ty2 -> - Some (fun ppf -> - fprintf ppf - "@,@[@{Hint@}: Did you forget to wrap the expression using \ - %a?@]" - Style.inline_code "fun () ->" - ) - | _ -> - None - -let explain_fixed_row_case ppf = function - | Errortrace.Cannot_be_closed -> - fprintf ppf "it cannot be closed" - | Errortrace.Cannot_add_tags tags -> - fprintf ppf "it may not allow the tag(s) %a" - print_tags tags - -let explain_fixed_row pos expl = match expl with - | Fixed_private -> - dprintf "The %a variant type is private" Errortrace.print_pos pos - | Univar x -> - reserve_names x; - dprintf "The %a variant type is bound to the universal type variable %a" - Errortrace.print_pos pos - (Style.as_inline_code type_expr_with_reserved_names) x - | Reified p -> - dprintf "The %a variant type is bound to %a" - Errortrace.print_pos pos - (Style.as_inline_code - (fun ppf p -> - Internal_names.add p; - print_path p ppf)) - p - | Rigid -> ignore - -let explain_variant (type variety) : variety Errortrace.variant -> _ = function - (* Common *) - | Errortrace.Incompatible_types_for s -> - Some(dprintf "@,Types for tag %a are incompatible" - print_tag s - ) - (* Unification *) - | Errortrace.No_intersection -> - Some(dprintf "@,These two variant types have no intersection") - | Errortrace.No_tags(pos,fields) -> Some( - dprintf - "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" - Errortrace.print_pos pos - print_tags (List.map fst fields) - ) - | Errortrace.Fixed_row (pos, - k, - (Univar _ | Reified _ | Fixed_private as e)) -> - Some ( - dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) - explain_fixed_row_case k - ) - | Errortrace.Fixed_row (_,_, Rigid) -> - (* this case never happens *) - None - (* Equality & Moregen *) - | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( - dprintf - "@,@[The tag %a is guaranteed to be present in the %a variant type,\ - @ but not in the %a@]" - print_tag s - Errortrace.print_pos (Errortrace.swap_position pos) - Errortrace.print_pos pos - ) - | Errortrace.Openness pos -> - Some(dprintf "@,The %a variant type is open and the %a is not" - Errortrace.print_pos pos - Errortrace.print_pos (Errortrace.swap_position pos)) - -let explain_escape pre = function - | Errortrace.Univ u -> - reserve_names u; - Some( - dprintf "%t@,The universal variable %a would escape its scope" - pre - (Style.as_inline_code type_expr_with_reserved_names) u - ) - | Errortrace.Constructor p -> Some( - dprintf - "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - pre (Style.as_inline_code path) p - ) - | Errortrace.Module_type p -> Some( - dprintf - "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" - pre (Style.as_inline_code path) p - ) - | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> - reserve_names t; - Some( - dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" - pre - (Style.as_inline_code type_expr_with_reserved_names) t - "it would escape the scope of its equation" - ) - | Errortrace.Self -> - Some (dprintf "%t@,Self type cannot escape its class" pre) - | Errortrace.Constraint -> - None - -let explain_object (type variety) : variety Errortrace.obj -> _ = function - | Errortrace.Missing_field (pos,f) -> Some( - dprintf "@,@[The %a object type has no method %a@]" - Errortrace.print_pos pos Style.inline_code f - ) - | Errortrace.Abstract_row pos -> Some( - dprintf - "@,@[The %a object type has an abstract row, it cannot be closed@]" - Errortrace.print_pos pos - ) - | Errortrace.Self_cannot_be_closed -> - Some (dprintf "@,Self type cannot be unified with a closed object type") - -let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = - reserve_names diff.got; - reserve_names diff.expected; - dprintf "@,@[The method %a has type@ %a,@ \ - but the expected method type was@ %a@]" - Style.inline_code name - (Style.as_inline_code type_expr_with_reserved_names) diff.got - (Style.as_inline_code type_expr_with_reserved_names) diff.expected - -let explanation (type variety) intro prev env - : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function - | Errortrace.Diff {got; expected} -> - explanation_diff env got.expanded expected.expanded - | Errortrace.Escape {kind; context} -> - let pre = - match context, kind, prev with - | Some ctx, _, _ -> - reserve_names ctx; - dprintf "@[%t@;<1 2>%a@]" intro - (Style.as_inline_code type_expr_with_reserved_names) ctx - | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> - explain_incompatible_fields name diff - | _ -> ignore - in - explain_escape pre kind - | Errortrace.Incompatible_fields { name; diff} -> - Some(explain_incompatible_fields name diff) - | Errortrace.Variant v -> - explain_variant v - | Errortrace.Obj o -> - explain_object o - | Errortrace.Rec_occur(x,y) -> - reserve_names x; - reserve_names y; - begin match get_desc x with - | Tvar _ | Tunivar _ -> - Some(fun ppf -> - reset_loop_marks (); - mark_loops x; - mark_loops y; - dprintf "@,@[The type variable %a occurs inside@ %a@]" - (Style.as_inline_code prepared_type_expr) x - (Style.as_inline_code prepared_type_expr) y - ppf) - | _ -> - (* We had a delayed unification of the type variable with - a non-variable after the occur check. *) - Some ignore - (* There is no need to search further for an explanation, but - we don't want to print a message of the form: - {[ The type int occurs inside int list -> 'a |} - *) - end - -let mismatch intro env trace = - Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) - -let explain mis ppf = - match mis with - | None -> () - | Some explain -> explain ppf - -let warn_on_missing_def env ppf t = - match get_desc t with - | Tconstr (p,_,_) -> - begin match Env.find_type p env with - | exception Not_found -> - fprintf ppf - "@,@[Type %a is abstract because@ no corresponding\ - @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p - | { type_manifest = Some _; _ } -> () - | { type_manifest = None; _ } as decl -> - match type_origin decl with - | Rec_check_regularity -> - fprintf ppf - "@,@[Type %a was considered abstract@ when checking\ - @ constraints@ in this@ recursive type definition.@]" - (Style.as_inline_code path) p - | Definition | Existential _ -> () - end - | _ -> () - -let prepare_expansion_head empty_tr = function - | Errortrace.Diff d -> - Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) - | _ -> None - -let head_error_printer mode txt_got txt_but = function - | None -> ignore - | Some d -> - let d = Errortrace.map_diff (trees_of_type_expansion mode) d in - dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" - txt_got type_expansion d.Errortrace.got - txt_but type_expansion d.Errortrace.expected - -let warn_on_missing_defs env ppf = function - | None -> () - | Some Errortrace.{got = {ty=te1; expanded=_}; - expected = {ty=te2; expanded=_} } -> - warn_on_missing_def env ppf te1; - warn_on_missing_def env ppf te2 - -(* [subst] comes out of equality, and is [[]] otherwise *) -let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = - reset (); - (* We want to substitute in the opposite order from [Eqtype] *) - Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); - let tr = - prepare_trace - (fun ty_exp -> - Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) - tr - in - let mis = mismatch txt1 env tr in - match tr with - | [] -> assert false - | elt :: tr -> - try - print_labels := not !Clflags.classic; - let tr = filter_trace (mis = None) tr in - let head = prepare_expansion_head (tr=[]) elt in - let tr = List.map (Errortrace.map_diff prepare_expansion) tr in - let head_error = head_error_printer mode txt1 txt2 head in - let tr = trees_of_trace mode tr in - fprintf ppf - "@[\ - @[%t%t@]%a%t\ - @]" - head_error - ty_expect_explanation - (trace false (incompatibility_phrase trace_format)) tr - (explain mis); - if env <> Env.empty - then warn_on_missing_defs env ppf head; - Internal_names.print_explanations env ppf; - Conflicts.print_explanations ppf; - print_labels := true - with exn -> - print_labels := true; - raise exn - -let report_error trace_format ppf mode env tr - ?(subst = []) - ?(type_expected_explanation = fun _ -> ()) - txt1 txt2 = - wrap_printing_env ~error:true env (fun () -> - error trace_format mode subst env tr txt1 ppf txt2 - type_expected_explanation) - -let report_unification_error - ppf env ({trace} : Errortrace.unification_error) = - report_error Unification ppf Type env - ?subst:None trace - -let report_equality_error - ppf mode env ({subst; trace} : Errortrace.equality_error) = - report_error Equality ppf mode env - ~subst ?type_expected_explanation:None trace - -let report_moregen_error - ppf mode env ({trace} : Errortrace.moregen_error) = - report_error Moregen ppf mode env - ?subst:None ?type_expected_explanation:None trace - -let report_comparison_error ppf mode env = function - | Errortrace.Equality_error error -> report_equality_error ppf mode env error - | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error - -module Subtype = struct - (* There's a frustrating amount of code duplication between this module and - the outside code, particularly in [prepare_trace] and [filter_trace]. - Unfortunately, [Subtype] is *just* similar enough to have code duplication, - while being *just* different enough (it's only [Diff]) for the abstraction - to be nonobvious. Someday, perhaps... *) - - let printing_status = function - | Errortrace.Subtype.Diff d -> diff_printing_status d - - let prepare_unification_trace = prepare_trace - - let prepare_trace f tr = - prepare_any_trace printing_status (Errortrace.Subtype.map f tr) - - let trace filter_trace get_diff fst keep_last txt ppf tr = - print_labels := not !Clflags.classic; - try match tr with - | elt :: tr' -> - let diffed_elt = get_diff elt in - let tr = - trees_of_trace Type - @@ List.map (Errortrace.map_diff prepare_expansion) - @@ filter_trace keep_last tr' in - let tr = - match fst, diffed_elt with - | true, Some elt -> elt :: tr - | _, _ -> tr - in - trace fst txt ppf tr; - print_labels := true - | _ -> () - with exn -> - print_labels := true; - raise exn - - let rec filter_subtype_trace keep_last = function - | [] -> [] - | [Errortrace.Subtype.Diff d as elt] - when printing_status elt = Optional_refinement -> - if keep_last then [d] else [] - | Errortrace.Subtype.Diff d :: rem -> - d :: filter_subtype_trace keep_last rem - - let unification_get_diff = function - | Errortrace.Diff diff -> - Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) - | _ -> None - - let subtype_get_diff = function - | Errortrace.Subtype.Diff diff -> - Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) - - let report_error - ppf - env - (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) - txt1 = - wrap_printing_env ~error:true env (fun () -> - reset (); - let tr_sub = prepare_trace prepare_expansion tr_sub in - let tr_unif = prepare_unification_trace prepare_expansion tr_unif in - let keep_first = match tr_unif with - | [Obj _ | Variant _ | Escape _ ] | [] -> true - | _ -> false in - fprintf ppf "@[%a" - (trace filter_subtype_trace subtype_get_diff true keep_first txt1) - tr_sub; - if tr_unif = [] then fprintf ppf "@]" else - let mis = mismatch (dprintf "Within this type") env tr_unif in - fprintf ppf "%a%t%t@]" - (trace filter_trace unification_get_diff false - (mis = None) "is not compatible with type") tr_unif - (explain mis) - Conflicts.print_explanations - ) -end - -let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = - wrap_printing_env ~error:true env (fun () -> - reset (); - let tp0 = trees_of_type_path_expansion tp0 in - match tpl with - [] -> assert false - | [tp] -> - fprintf ppf - "@[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]" - txt1 type_path_expansion (trees_of_type_path_expansion tp) - txt3 type_path_expansion tp0 - | _ -> - fprintf ppf - "@[%t@;<1 2>@[%a@]\ - @ %t@;<1 2>%a\ - @]" - txt2 type_path_list (List.map trees_of_type_path_expansion tpl) - txt3 type_path_expansion tp0) - -(* Adapt functions to exposed interface *) -let tree_of_path = tree_of_path None -let tree_of_modtype = tree_of_modtype ~ellipsis:false -let type_expansion mode ppf ty_exp = - type_expansion ppf (trees_of_type_expansion mode ty_exp) -let tree_of_type_declaration ident td rs = - with_hidden_items [{hide=true; ident}] - (fun () -> tree_of_type_declaration ident td rs) - let shorten_type_path env p = wrap_printing_env env (fun () -> best_type_path_simple p) From b9db846d0b22841b1421e3c14d454f0d3b46bd62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 13 Dec 2024 17:58:51 +0100 Subject: [PATCH 3/5] Re-apply short-paths changes to the Out_type module --- src/analysis/browse_misc.ml | 6 +- src/analysis/completion.ml | 13 +- src/analysis/destruct.ml | 4 +- src/analysis/inlay_hints.ml | 2 +- src/analysis/polarity_search.ml | 2 +- src/analysis/signature_help.ml | 2 +- src/analysis/type_search.ml | 4 +- src/analysis/type_utils.ml | 2 +- src/ocaml/typing/out_type.ml | 240 +- src/ocaml/typing/out_type.mli | 12 +- src/ocaml/typing/printtyp.ml | 2184 +------------ src/ocaml/typing/printtyp.mli | 297 +- src/ocaml/typing/printtyp_doc.ml | 2714 ----------------- src/ocaml/typing/printtyp_doc.mli | 243 -- src/ocaml/typing/typecore.ml | 2 +- src/ocaml/typing/typedecl.ml | 2 +- tests/test-dirs/errors/reg503.t | 2 +- tests/test-dirs/issue1322.t/run.t | 2 +- ...ch-by-type-comparison-to-polarity-search.t | 10 +- tests/test-dirs/search/search-by-type.t/run.t | 23 +- tests/test-dirs/short-paths.t/run.t | 2 +- tests/test-dirs/type-enclosing/gadt_wrong.t | 2 +- .../test-dirs/type-enclosing/generic-types.t | 2 +- tests/test-dirs/type-enclosing/types.t/run.t | 4 +- 24 files changed, 485 insertions(+), 5291 deletions(-) delete mode 100644 src/ocaml/typing/printtyp_doc.ml delete mode 100644 src/ocaml/typing/printtyp_doc.mli diff --git a/src/analysis/browse_misc.ml b/src/analysis/browse_misc.ml index 5968885798..acb96d4cee 100644 --- a/src/analysis/browse_misc.ml +++ b/src/analysis/browse_misc.ml @@ -34,7 +34,9 @@ let dummy_type_scheme desc = let print_constructor c = let open Types in match c.cstr_args with - | [] -> Printtyp.tree_of_type_scheme (dummy_type_scheme (get_desc c.cstr_res)) + | [] -> + Out_type.tree_of_typexp Type_scheme + (dummy_type_scheme (get_desc c.cstr_res)) | args -> let desc = Tarrow @@ -43,7 +45,7 @@ let print_constructor c = c.cstr_res, commu_ok ) in - Printtyp.tree_of_type_scheme (dummy_type_scheme desc) + Out_type.tree_of_typexp Type_scheme (dummy_type_scheme desc) let summary_prev = function | Env.Env_empty -> None diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index 2543b8052d..53df7869bb 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -47,21 +47,22 @@ type raw_info = let raw_info_printer : raw_info -> _ = function | `Constructor c -> `Print (Out_type (Browse_misc.print_constructor c)) - | `Modtype mt -> `Print (Out_module_type (Printtyp.tree_of_modtype mt)) + | `Modtype mt -> `Print (Out_module_type (Out_type.tree_of_modtype mt)) | `Modtype_declaration (id, mtd) -> - `Print (Out_sig_item (Printtyp.tree_of_modtype_declaration id mtd)) + `Print (Out_sig_item (Out_type.tree_of_modtype_declaration id mtd)) | `None -> `String "" | `String s -> `String s | `Type_declaration (id, tdecl) -> `Print (Out_sig_item - (Printtyp.tree_of_type_declaration id tdecl Types.Trec_first)) - | `Type_scheme te -> `Print (Out_type (Printtyp.tree_of_type_scheme te)) + (Out_type.tree_of_type_declaration id tdecl Types.Trec_first)) + | `Type_scheme te -> + `Print (Out_type (Out_type.tree_of_typexp Type_scheme te)) | `Variant (label, arg) -> begin match arg with | None -> `String label | Some te -> - `Concat (label ^ " of ", Out_type (Printtyp.tree_of_type_scheme te)) + `Concat (label ^ " of ", Out_type (Out_type.tree_of_typexp Type_scheme te)) end (* List methods of an object. @@ -829,7 +830,7 @@ let application_context ~prefix path = type, but not across different invocations. [reset] followed by calls to [mark_loops] and [type_sch] provide that *) - Printtyp.reset (); + Out_type.reset (); let pr t = let ppf, to_string = Format.to_string () in Printtyp.shared_type_scheme ppf t; diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index e45bb5ca01..7b16b58aa4 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -109,7 +109,7 @@ let rec gen_patterns ?(recurse = true) env type_expr = [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] | Type_variant (constructors, _) -> let prefix = - let path = Printtyp.shorten_type_path env path in + let path = Out_type.shorten_type_path env path in fun name -> let env_check = Env.find_constructor_by_name in Misc_utils.Path.to_shortest_lid ~env ~name ~env_check path @@ -630,7 +630,7 @@ let refine_partial_match last_case_loc config source patterns = let unmangling_tables = (constrs, labels) in (* Unmangling and prefixing *) let pat = - qualify_constructors ~unmangling_tables Printtyp.shorten_type_path pat + qualify_constructors ~unmangling_tables Out_type.shorten_type_path pat in (* Untyping and casing *) let ppat = filter_pat_attr (Untypeast.untype_pattern pat) in diff --git a/src/analysis/inlay_hints.ml b/src/analysis/inlay_hints.ml index 0f19feb868..54de9cda65 100644 --- a/src/analysis/inlay_hints.ml +++ b/src/analysis/inlay_hints.ml @@ -132,7 +132,7 @@ type hint = Lexing.position * string let create_hint env typ loc = let label = - Printtyp.wrap_printing_env env (fun () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> Format.asprintf "%a" Printtyp.type_scheme typ) in let position = loc.Location.loc_end in diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index b01c971317..2cf4ce0fd5 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -154,7 +154,7 @@ let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules () = |> List.map ~f:(fun (cost, path, desc) -> let name = Printtyp.wrap_printing_env env @@ fun () -> - let path = Printtyp.rewrite_double_underscore_paths env path in + let path = Out_type.rewrite_double_underscore_paths env path in Format.asprintf "%a" Printtyp.path path in let doc = None in diff --git a/src/analysis/signature_help.ml b/src/analysis/signature_help.ml index 3f84261b90..166a76c039 100644 --- a/src/analysis/signature_help.ml +++ b/src/analysis/signature_help.ml @@ -83,7 +83,7 @@ let print_parameter_offset ?arg:argument ppf buffer env label ty = arguments to the corresponding parameter. (They should always be in the correct order in the typedtree, even if they are not in order in the source file.) *) let separate_function_signature ~args (e : Typedtree.expression) = - Type_utils.Printtyp.reset (); + Out_type.reset (); let buffer = Buffer.create 16 in let ppf = Format.formatter_of_buffer buffer in let rec separate ?(parameters = []) args ty = diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 48337219ca..ba934726d9 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -39,7 +39,7 @@ let sherlodoc_type_of env typ = | Types.Ttuple elts -> Type_parsed.tuple @@ List.map ~f:aux elts | Types.Tarrow (_, a, b, _) -> Type_parsed.Arrow (aux a, aux b) | Types.Tconstr (p, args, _) -> - let p = Printtyp.rewrite_double_underscore_paths env p in + let p = Out_type.rewrite_double_underscore_paths env p in let name = Format.asprintf "%a" Printtyp.path p in Type_parsed.Tycon (name, List.map ~f:aux args) | _ -> Type_parsed.Unhandled @@ -95,7 +95,7 @@ let compute_value query env _ path desc acc = let typ = sherlodoc_type_of env d in let name = Printtyp.wrap_printing_env env @@ fun () -> - let path = Printtyp.rewrite_double_underscore_paths env path in + let path = Out_type.rewrite_double_underscore_paths env path in Format.asprintf "%a" Printtyp.path path in let cost = Query.distance_for query ~path:name typ in diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 2615254f31..dbb142ecdc 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -145,7 +145,7 @@ module Printtyp = struct ppf mty let wrap_printing_env env ~verbosity:v f = - let_ref verbosity v (fun () -> wrap_printing_env env f) + let_ref verbosity v (fun () -> wrap_printing_env ~error:true env f) end let si_modtype_opt = function diff --git a/src/ocaml/typing/out_type.ml b/src/ocaml/typing/out_type.ml index 356f8fc8a7..647b5b5c92 100644 --- a/src/ocaml/typing/out_type.ml +++ b/src/ocaml/typing/out_type.ml @@ -438,7 +438,7 @@ let tree_of_rec = function type param_subst = Id | Nth of int | Map of int list -let is_nth = function +let _is_nth = function Nth _ -> true | _ -> false @@ -447,7 +447,7 @@ let compose l1 = function | Map l2 -> Map (List.map (List.nth l1) l2) | Nth n -> Nth (List.nth l1 n) -let apply_subst s1 tyl = +let _apply_subst s1 tyl = if tyl = [] then [] (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) else @@ -560,7 +560,7 @@ let set_printing_env env = end let wrap_printing_env env f = - set_printing_env env; + set_printing_env (Env.update_short_paths env); try_finally f ~always:(fun () -> set_printing_env Env.empty) let wrap_printing_env ~error env f = @@ -607,7 +607,7 @@ let rec get_best_path r = l; get_best_path r -let best_type_path p = +let best_type_path_original p = if !printing_env == Env.empty then (p, Id) else if !Clflags.real_paths @@ -625,6 +625,61 @@ let best_type_path p = (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) (p'', s) +type type_result = Short_paths.type_result = + | Nth of int + | Path of int list option * Path.t + +type type_resolution = Short_paths.type_resolution = + | Nth of int + | Subst of int list + | Id + +let apply_subst ns args = + List.map (List.nth args) ns + +let apply_subst_opt nso args = + match nso with + | None -> args + | Some ns -> apply_subst ns args + +let apply_nth n args = + List.nth args n + +let best_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then Path(None, p) + else Short_paths.find_type (Env.short_paths !printing_env) p + +let best_type_path_resolution p = + if !Clflags.real_paths || !printing_env == Env.empty + then Id + else Short_paths.find_type_resolution (Env.short_paths !printing_env) p + +let best_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_type_simple (Env.short_paths !printing_env) p + +let best_module_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module_type (Env.short_paths !printing_env) p + +let best_module_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module (Env.short_paths !printing_env) p + +let best_class_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then None, p + else Short_paths.find_class_type (Env.short_paths !printing_env) p + +let best_class_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p + (* When building a tree for a best type path, we should not disambiguate identifiers whenever the short-path algorithm detected a better path than the original one.*) @@ -660,9 +715,15 @@ let nameable_row row = subterms that would be printed by the type printer. *) let printer_iter_type_expr f ty = match get_desc ty with - | Tconstr(p, tyl, _) -> - let (_p', s) = best_type_path p in - List.iter f (apply_subst s tyl) + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + f (apply_nth n tyl) + | Subst ns -> + List.iter f (apply_subst ns tyl) + | Id -> + List.iter f tyl + end | Tvariant row -> begin match row_name row with | Some(_p, tyl) when nameable_row row -> @@ -960,10 +1021,14 @@ module Aliases = struct let aliasable ty = match get_desc ty with Tvar _ | Tunivar _ | Tpoly _ -> false - | Tconstr (p, _, _) -> - not (is_nth (snd (best_type_path p))) + | Tconstr (p, _, _) -> begin + match best_type_path_resolution p with + | Nth _ -> false + | Subst _ | Id -> true + end | _ -> true + (* let should_visit_object ty = match get_desc ty with | Tvariant row -> not (static_row row) @@ -987,6 +1052,67 @@ module Aliases = struct mark_loops_rec visited ty | _ -> printer_iter_type_expr (mark_loops_rec visited) ty + *) + + let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_proxy px else + let visited = px :: visited in + match Types.get_desc ty with + | Tvar _ -> Variable_names.reserve ty + | Tarrow(_, ty1, ty2, _) -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + mark_loops_rec visited (apply_nth n tyl) + | Subst ns -> + List.iter (mark_loops_rec visited) (apply_subst ns tyl) + | Id -> + List.iter (mark_loops_rec visited) tyl + end + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl + | Tvariant row -> + if List.memq px !visited_objects then add_proxy px else + begin + if not (static_row row) then + visited_objects := px :: !visited_objects; + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter (mark_loops_rec visited) tyl + | _ -> + iter_row (mark_loops_rec visited) row + end + | Tobject (fi, nm) -> + if List.memq px !visited_objects then add_proxy px else + begin + if opened_object ty then + visited_objects := px :: !visited_objects; + begin match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + mark_loops_rec visited ty) + fields + | Some (_, l) -> + List.iter (mark_loops_rec visited) (List.tl l) + end + end + | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpublic -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Tfield(_, _, _, ty2) -> + mark_loops_rec visited ty2 + | Tnil -> () + | Tsubst _ -> () (* we do not print arguments *) + | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" + | Tpoly (ty, tyl) -> + List.iter (fun t -> add t) tyl; + mark_loops_rec visited ty + | Tunivar _ -> Variable_names.reserve ty let mark_loops ty = mark_loops_rec [] ty @@ -1054,15 +1180,14 @@ let rec tree_of_typexp mode ty = Otyp_arrow (lab, t1, tree_of_typexp mode ty2) | Ttuple tyl -> Otyp_tuple (tree_of_typlist mode tyl) - | Tconstr(p, tyl, _abbrev) -> - let p', s = best_type_path p in - let tyl' = apply_subst s tyl in - if is_nth s && not (tyl'=[]) - then tree_of_typexp mode (List.hd tyl') - else begin - Internal_names.add p'; - Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') - end + | Tconstr(p, tyl, _abbrev) -> begin + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(nso, p') -> + Internal_names.add p'; + let tyl' = apply_subst_opt nso tyl in + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') + end | Tvariant row -> let Row {fields; name; closed; _} = row_repr row in let fields = @@ -1080,11 +1205,14 @@ let rec tree_of_typexp mode ty = let all_present = List.length present = List.length fields in begin match name with | Some(p, tyl) when nameable_row row -> - let (p', s) = best_type_path p in - let id = tree_of_best_type_path p p' in - let args = tree_of_typlist mode (apply_subst s tyl) in let out_variant = - if is_nth s then List.hd args else Otyp_constr (id, args) in + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(s, p) -> + let id = tree_of_path (Some Type) p in + let args = tree_of_typlist mode (apply_subst_opt s tyl) in + Otyp_constr (id, args) + in if closed && all_present then out_variant else @@ -1127,6 +1255,7 @@ let rec tree_of_typexp mode ty = | Tunivar _ -> Otyp_var (false, Variable_names.(name_of_type new_name) tty) | Tpackage (p, fl) -> + let p = best_module_type_path p in let fl = List.map (fun (li, ty) -> ( @@ -1179,8 +1308,7 @@ and tree_of_typobject mode fi nm = Otyp_object {fields; open_row} | Some (p, _ty :: tyl) -> let args = tree_of_typlist mode tyl in - let (p', s) = best_type_path p in - assert (s = Id); + let p' = best_type_path_simple p in Otyp_class (tree_of_best_type_path p p', args) | _ -> fatal_error "Out_type.tree_of_typobject" @@ -1472,7 +1600,8 @@ let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = let prepared_tree_of_extension_constructor id ext es = - let ty_name = Path.name ext.ext_type_path in + let type_path = best_type_path_simple ext.ext_type_path in + let ty_name = Path.name type_path in let ty_params = filter_params ext.ext_type_params in let type_param = function @@ -1593,6 +1722,8 @@ let rec tree_of_class_type mode params = then tree_of_class_type mode params cty else + let nso, p' = best_class_type_path p' in + let tyl = apply_subst_opt nso tyl in let namespace = Namespace.best_class_namespace p' in Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) | Cty_signature sign -> @@ -1710,6 +1841,16 @@ let tree_of_cltype_declaration id cl rs = (* Print a module type *) +(* Wrap env from merlin: + +let wrap_env fenv ftree arg = + let env = !printing_env in + let env' = Env.update_short_paths (fenv env) in + set_printing_env env'; + let tree = ftree arg in + set_printing_env env; + tree + *) let wrap_env fenv ftree arg = (* We save the current value of the short-path cache *) (* From keys *) @@ -1719,7 +1860,7 @@ let wrap_env fenv ftree arg = let old_map = !printing_map in let old_depth = !printing_depth in let old_cont = !printing_cont in - set_printing_env (fenv env); + set_printing_env (Env.update_short_paths (fenv env)); let tree = ftree arg in if !Clflags.real_paths || same_printing_env env then () @@ -1771,7 +1912,7 @@ let hide ids env = let hide_id id env = (* Global idents cannot be renamed *) if id.hide && not (Ident.global id.ident) then - Env.add_type ~check:false (Ident.rename id.ident) dummy env + Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env else env in List.fold_right hide_id ids env @@ -1791,6 +1932,7 @@ let add_sigitem env x = let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> + let p = best_module_path p in Omty_ident (tree_of_path (Some Module_type) p) | Mty_signature sg -> Omty_signature (if ellipsis then [Osig_ellipsis] @@ -1802,6 +1944,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in Omty_functor (param, res) | Mty_alias p -> + let p = best_module_path p in Omty_alias (tree_of_path (Some Module) p) | Mty_for_hole -> Omty_hole @@ -1888,21 +2031,20 @@ let print_items showval env x = List.concat_map post_process @@ tree_of_signature_rec env x let same_path t t' = - let open Types in eq_type t t' || match get_desc t, get_desc t' with - Tconstr(p,tl,_), Tconstr(p',tl',_) -> - let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in - begin match s1, s2 with - Nth n1, Nth n2 when n1 = n2 -> true - | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> - let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in - List.length tl = List.length tl' && - List.for_all2 eq_type tl tl' + | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin + match best_type_path p, best_type_path p' with + | Nth n, Nth n' when n = n' -> true + | Path(nso, p), Path(nso', p') when Path.same p p' -> + let tl = apply_subst_opt nso tl in + let tl' = apply_subst_opt nso' tl' in + List.length tl = List.length tl' && + List.for_all2 eq_type tl tl' | _ -> false - end + end | _ -> - false + false type 'a diff = Same of 'a | Diff of 'a * 'a @@ -1964,6 +2106,26 @@ let tree_of_class_type kind cty = tree_of_class_type kind [] cty let prepare_class_type cty = prepare_class_type [] cty let tree_of_type_path p = - let (p', s) = best_type_path p in + let (p', s) = best_type_path_original p in let p'' = if (s = Id) then p' else p in tree_of_best_type_path p p'' + +let wrap_printing_env ?(error = true) = wrap_printing_env ~error +let shorten_type_path env p = + wrap_printing_env env + (fun () -> best_type_path_simple p) + +let shorten_module_type_path env p = + wrap_printing_env env + (fun () -> best_module_type_path p) + +let shorten_module_path env p = + wrap_printing_env env + (fun () -> best_module_path p) + +let shorten_class_type_path env p = + wrap_printing_env env + (fun () -> best_class_type_path_simple p) + +let () = + Env.shorten_module_path := shorten_module_path diff --git a/src/ocaml/typing/out_type.mli b/src/ocaml/typing/out_type.mli index b134fa1196..acbc5b6598 100644 --- a/src/ocaml/typing/out_type.mli +++ b/src/ocaml/typing/out_type.mli @@ -39,7 +39,7 @@ open Outcometree (** {1 Wrapping functions}*) -val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a +val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a (** Call the function using the environment for type path shortening This affects all the printing and tree cration functions functions below Also, if [~error:true], then disable the loading of cmis *) @@ -257,3 +257,13 @@ val reset: unit -> unit (** Reset all contexts except for conflicts *) val reset_except_conflicts: unit -> unit + +(** {1 Merlin Short Path }*) + +val best_type_path_simple: Path.t -> Path.t +val best_class_type_path_simple: Path.t -> Path.t + +val shorten_type_path: Env.t -> Path.t -> Path.t +val shorten_module_type_path: Env.t -> Path.t -> Path.t +val shorten_module_path: Env.t -> Path.t -> Path.t +val shorten_class_type_path: Env.t -> Path.t -> Path.t diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index ba0c1fc9f2..e46c197ed8 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -13,2076 +13,200 @@ (* *) (**************************************************************************) -(* Printing functions *) +open Out_type +module Fmt = Format_doc -module M = Misc.String.Map -module S = Misc.String.Set - -open Misc -open Ctype -open Format -open Longident -open Path -open Asttypes -open Types -open Btype -open Outcometree - -module Sig_component_kind = Shape.Sig_component_kind -module Style = Misc.Style - -(* Print a long identifier *) -let longident = Pprintast.longident - -let () = Env.print_longident := longident - -(* Print an identifier avoiding name collisions *) - -module Out_name = struct - let create x = { printed_name = x } - let print x = x.printed_name -end - -(** Some identifiers may require hiding when printing *) -type bound_ident = { hide:bool; ident:Ident.t } - -(* printing environment for path shortening and naming *) -let printing_env = ref Env.empty +let namespaced_ident namespace id = + Out_name.print (ident_name (Some namespace) id) -(* When printing, it is important to only observe the - current printing environment, without reading any new - cmi present on the file system *) -let in_printing_env f = Env.without_cmis f !printing_env +module Doc = struct + let wrap_printing_env = wrap_printing_env - type namespace = Shape.Sig_component_kind.t = - | Value - | Type - | Constructor - | Label - | Module - | Module_type - | Extension_constructor - | Class - | Class_type + let longident = Pprintast.Doc.longident + let ident ppf id = Fmt.pp_print_string ppf + (Out_name.print (ident_name None id)) -module Namespace = struct - let id = function - | Type -> 0 - | Module -> 1 - | Module_type -> 2 - | Class -> 3 - | Class_type -> 4 - | Extension_constructor | Value | Constructor | Label -> 5 - (* we do not handle those component *) - let size = 1 + id Value + let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + let type_expansion k ppf e = + pp_type_expansion ppf (trees_of_type_expansion k e) - let pp ppf x = - Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) - let lookup = - let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in - function - | Some Type -> to_lookup Env.find_type_by_name - | Some Module -> to_lookup Env.find_module_by_name - | Some Module_type -> to_lookup Env.find_modtype_by_name - | Some Class -> to_lookup Env.find_class_by_name - | Some Class_type -> to_lookup Env.find_cltype_by_name - | None | Some(Value|Extension_constructor|Constructor|Label) -> - fun _ -> raise Not_found + let type_expr ppf ty = + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty - let location namespace id = - let path = Path.Pident id in - try Some ( - match namespace with - | Some Type -> (in_printing_env @@ Env.find_type path).type_loc - | Some Module -> (in_printing_env @@ Env.find_module path).md_loc - | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc - | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc - | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Some (Extension_constructor|Value|Constructor|Label) | None -> - Location.none - ) with Not_found -> None + let shared_type_scheme ppf ty = + add_type_to_preparation ty; + typexp Type_scheme ppf ty - let best_class_namespace = function - | Papply _ | Pdot _ -> Some Module - | Pextra_ty _ -> assert false (* Only in type path *) - | Pident c -> - match location (Some Class) c with - | Some _ -> Some Class - | None -> Some Class_type + let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty -end + let path ppf p = + !Oprint.out_ident ppf (tree_of_path ~disambiguation:false p) -(** {2 Conflicts printing} - Conflicts arise when multiple items are attributed the same name, - the following module stores the global conflict references and - provides the printing functions for explaining the source of - the conflicts. -*) -module Conflicts = struct - type explanation = - { kind: namespace; name:string; root_name:string; location:Location.t} - let explanations = ref M.empty + let () = Env.print_path := path - let add namespace name id = - match Namespace.location (Some namespace) id with - | None -> () - | Some location -> - let explanation = - { kind = namespace; location; name; root_name=Ident.name id} - in - explanations := M.add name explanation !explanations + let type_path ppf p = !Oprint.out_ident ppf (tree_of_type_path p) - let collect_explanation namespace id ~name = - let root_name = Ident.name id in - (* if [name] is of the form "root_name/%d", we register both - [id] and the identifier in scope for [root_name]. - *) - if root_name <> name && not (M.mem name !explanations) then - begin - add namespace name id; - if not (M.mem root_name !explanations) then - (* lookup the identifier in scope with name [root_name] and - add it too - *) - match Namespace.lookup (Some namespace) root_name with - | Pident root_id -> add namespace root_name root_id - | exception Not_found | _ -> () - end + let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) - let pp_explanation ppf r= - Format.fprintf ppf "@[%a:@,Definition of %s %a@]" - Location.print_loc r.location (Sig_component_kind.to_string r.kind) - Style.inline_code r.name - - let print_located_explanations ppf l = - Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l - - let reset () = explanations := M.empty - let list_explanations () = - let c = !explanations in + let class_type ppf cty = reset (); - c |> M.bindings |> List.map snd |> List.sort Stdlib.compare - + prepare_class_type cty; + !Oprint.out_class_type ppf (tree_of_class_type Type cty) - let print_toplevel_hint ppf l = - let conj ppf () = Format.fprintf ppf " and@ " in - let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in - let root_names = List.map (fun r -> r.kind, r.root_name) l in - let unique_root_names = List.sort_uniq Stdlib.compare root_names in - let submsgs = Array.make Namespace.size [] in - let () = List.iter (fun (n,_ as x) -> - submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) - ) unique_root_names in - let pp_submsg ppf names = - match names with - | [] -> () - | [namespace, a] -> - Format.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ - @ Did you try to redefine them?@]" - Namespace.pp namespace - Style.inline_code a Namespace.pp namespace - | (namespace, _) :: _ :: _ -> - Format.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ - @ Did you try to redefine them?@]" - pp_namespace_plural namespace - Format.(pp_print_list ~pp_sep:conj Style.inline_code) - (List.map snd names) - pp_namespace_plural namespace in - Array.iter (pp_submsg ppf) submsgs + let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) - let print_explanations ppf = - let ltop, l = - (* isolate toplevel locations, since they are too imprecise *) - let from_toplevel a = - a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in - List.partition from_toplevel (list_explanations ()) - in - begin match l with - | [] -> () - | l -> Format.fprintf ppf "@,%a" print_located_explanations l - end; - (* if there are name collisions in a toplevel session, - display at least one generic hint by namespace *) - print_toplevel_hint ppf ltop - - let exists () = M.cardinal !explanations >0 -end + let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) -module Naming_context = struct + let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) + let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) -let enabled = ref true -let enable b = enabled := b + let constructor ppf c = + reset_except_conflicts (); + add_constructor_to_preparation c; + prepared_constructor ppf c -(* Names bound in recursive definitions should be considered as bound - in the environment when printing identifiers but not when trying - to find shortest path. - For instance, if we define - [{ - module Avoid__me = struct - type t = A - end - type t = X - type u = [` A of t * t ] - module M = struct - type t = A of [ u | `B ] - type r = Avoid__me.t - end - }] - It is is important that in the definition of [t] that the outer type [t] is - printed as [t/2] reserving the name [t] to the type being defined in the - current recursive definition. - Contrarily, in the definition of [r], one should not shorten the - path [Avoid__me.t] to [r] until the end of the definition of [r]. - The [bound_in_recursion] bridges the gap between those two slightly different - notions of printing environment. -*) -let bound_in_recursion = ref M.empty + let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) -(* When dealing with functor arguments, identity becomes fuzzy because the same - syntactic argument may be represented by different identifiers during the - error processing, we are thus disabling disambiguation on the argument name -*) -let fuzzy = ref S.empty -let with_arg id f = - protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f -let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + let label ppf l = + prepare_for_printing [l.Types.ld_type]; + !Oprint.out_label ppf (tree_of_label l) -let with_hidden ids f = - let update m id = M.add (Ident.name id.ident) id.ident m in - let updated = List.fold_left update !bound_in_recursion ids in - protect_refs [ R(bound_in_recursion, updated )] f + let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) -let human_id id index = - (* The identifier with index [k] is the (k+1)-th most recent identifier in - the printing environment. We print them as [name/(k+1)] except for [k=0] - which is printed as [name] rather than [name/1]. - *) - if index = 0 then - Ident.name id - else - let ordinal = index + 1 in - String.concat "/" [Ident.name id; string_of_int ordinal] + (* Print an extension declaration *) -let indexed_name namespace id = - let find namespace id env = match namespace with - | Type -> Env.find_type_index id env - | Module -> Env.find_module_index id env - | Module_type -> Env.find_modtype_index id env - | Class -> Env.find_class_index id env - | Class_type-> Env.find_cltype_index id env - | Value | Extension_constructor | Constructor | Label -> None - in - let index = - match M.find_opt (Ident.name id) !bound_in_recursion with - | Some rec_bound_id -> - (* the identifier name appears in the current group of recursive - definition *) - if Ident.same rec_bound_id id then - Some 0 - else - (* the current recursive definition shadows one more time the - previously existing identifier with the same name *) - Option.map succ (in_printing_env (find namespace id)) - | None -> - in_printing_env (find namespace id) - in - let index = - (* If [index] is [None] at this point, it might indicate that - the identifier id is not defined in the environment, while there - are other identifiers in scope that share the same name. - Currently, this kind of partially incoherent environment happens - within functor error messages where the left and right hand side - have a different views of the environment at the source level. - Printing the source-level by using a default index of `0` - seems like a reasonable compromise in this situation however.*) - Option.value index ~default:0 - in - human_id id index -let ident_name namespace id = - match namespace, !enabled with - | None, _ | _, false -> Out_name.create (Ident.name id) - | Some namespace, true -> - if fuzzy_id namespace id then Out_name.create (Ident.name id) - else - let name = indexed_name namespace id in - Conflicts.collect_explanation namespace id ~name; - Out_name.create name -end -let ident_name = Naming_context.ident_name - -let ident ppf id = pp_print_string ppf - (Out_name.print (Naming_context.ident_name None id)) - -let namespaced_ident namespace id = - Out_name.print (Naming_context.ident_name (Some namespace) id) - -(* Print a path *) - -let ident_stdlib = Ident.create_persistent "Stdlib" - -let non_shadowed_stdlib namespace = function - | Pdot(Pident id, s) as path -> - Ident.same id ident_stdlib && - (match Namespace.lookup namespace s with - | path' -> Path.same path path' - | exception Not_found -> true) - | _ -> false - -let find_double_underscore s = - let len = String.length s in - let rec loop i = - if i + 1 >= len then - None - else if s.[i] = '_' && s.[i + 1] = '_' then - Some i - else - loop (i + 1) - in - loop 0 - -let rec module_path_is_an_alias_of env path ~alias_of = - match Env.find_module path env with - | { md_type = Mty_alias path'; _ } -> - Path.same path' alias_of || - module_path_is_an_alias_of env path' ~alias_of - | _ -> false - | exception Not_found -> false - -(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias - for Foo__bar. This pattern is used by the stdlib. *) -let rec rewrite_double_underscore_paths env p = - match p with - | Pdot (p, s) -> - Pdot (rewrite_double_underscore_paths env p, s) - | Papply (a, b) -> - Papply (rewrite_double_underscore_paths env a, - rewrite_double_underscore_paths env b) - | Pextra_ty (p, extra) -> - Pextra_ty (rewrite_double_underscore_paths env p, extra) - | Pident id -> + let extension_only_constructor id ppf (ext:Types.extension_constructor) = + reset_except_conflicts (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter add_type_to_preparation ext.ext_ret_type; let name = Ident.name id in - match find_double_underscore name with - | None -> p - | Some i -> - let better_lid = - Ldot - (Lident (String.sub name 0 i), - Unit_info.modulize - (String.sub name (i + 2) (String.length name - i - 2))) - in - match Env.find_module_by_name better_lid env with - | exception Not_found -> p - | p', _ -> - if module_path_is_an_alias_of env p' ~alias_of:p then - p' - else - p - -let rewrite_double_underscore_paths env p = - if env == Env.empty then - p - else - rewrite_double_underscore_paths env p - -let rec tree_of_path ?(disambiguation=true) namespace p = - let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in - let namespace = if disambiguation then namespace else None in - match p with - | Pident id -> - Oide_ident (ident_name namespace id) - | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> - Oide_ident (Out_name.create s) - | Pdot(p, s) -> - Oide_dot (tree_of_path (Some Module) p, s) - | Papply(p1, p2) -> - let t1 = tree_of_path (Some Module) p1 in - let t2 = tree_of_path (Some Module) p2 in - Oide_apply (t1, t2) - | Pextra_ty (p, extra) -> begin - (* inline record types are syntactically prevented from escaping their - binding scope, and are never shown to users. *) - match extra with - Pcstr_ty s -> - Oide_dot (tree_of_path (Some Type) p, s) - | Pext_ty -> - tree_of_path None p - end - -let tree_of_path ?disambiguation namespace p = - tree_of_path ?disambiguation namespace - (rewrite_double_underscore_paths !printing_env p) - -let path ppf p = - !Oprint.out_ident ppf (tree_of_path None p) - -let string_of_path p = - Format.asprintf "%a" path p - -let strings_of_paths namespace p = - let trees = List.map (tree_of_path namespace) p in - List.map (Format.asprintf "%a" !Oprint.out_ident) trees - -let () = Env.print_path := path - -(* Print a recursive annotation *) - -let tree_of_rec = function - | Trec_not -> Orec_not - | Trec_first -> Orec_first - | Trec_next -> Orec_next - -(* Print a raw type expression, with sharing *) - -let raw_list pr ppf = function - [] -> fprintf ppf "[]" - | a :: l -> - fprintf ppf "@[<1>[%a%t]@]" pr a - (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) - -let kind_vars = ref [] -let kind_count = ref 0 - -let string_of_field_kind v = - match field_kind_repr v with - | Fpublic -> "Fpublic" - | Fabsent -> "Fabsent" - | Fprivate -> "Fprivate" - -let rec safe_repr v t = - match Transient_expr.coerce t with - {desc = Tlink t} when not (List.memq t v) -> - safe_repr (t::v) t - | t' -> t' - -let rec list_of_memo = function - Mnil -> [] - | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem - | Mlink rem -> list_of_memo !rem - -let print_name ppf = function - None -> fprintf ppf "None" - | Some name -> fprintf ppf "\"%s\"" name - -let string_of_label = function - Nolabel -> "" - | Labelled s -> s - | Optional s -> "?"^s - -let visited = ref [] -let rec raw_type ppf ty = - let ty = safe_repr [] ty in - if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin - visited := ty :: !visited; - fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level - ty.scope raw_type_desc ty.desc - end -and raw_type_list tl = raw_list raw_type tl -and raw_lid_type_list tl = - raw_list (fun ppf (lid, typ) -> - fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) - tl -and raw_type_desc ppf = function - Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow(l,t1,t2,c) -> - fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" - (string_of_label l) raw_type t1 raw_type t2 - (if is_commu_ok c then "Cok" else "Cunknown") - | Ttuple tl -> - fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl - | Tconstr (p, tl, abbrev) -> - fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p - raw_type_list tl - (raw_list path) (list_of_memo !abbrev) - | Tobject (t, nm) -> - fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t - (fun ppf -> - match !nm with None -> fprintf ppf " None" - | Some(p,tl) -> - fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) - | Tfield (f, k, t1, t2) -> - fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (string_of_field_kind k) - raw_type t1 raw_type t2 - | Tnil -> fprintf ppf "Tnil" - | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t - | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t - | Tsubst (t, Some t') -> - fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' - | Tunivar name -> fprintf ppf "Tunivar %a" print_name name - | Tpoly (t, tl) -> - fprintf ppf "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl - | Tvariant row -> - let Row {fields; more; name; fixed; closed} = row_repr row in - fprintf ppf - "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" - "row_fields=" - (raw_list (fun ppf (l, f) -> - fprintf ppf "@[%s,@ %a@]" l raw_field f)) - fields - "row_more=" raw_type more - "row_closed=" closed - "row_fixed=" raw_row_fixed fixed - "row_name=" - (fun ppf -> - match name with None -> fprintf ppf "None" - | Some(p,tl) -> - fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) - | Tpackage (p, fl) -> - fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl - -and raw_row_fixed ppf = function -| None -> fprintf ppf "None" -| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" -| Some Types.Rigid -> fprintf ppf "Some Rigid" -| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t -| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p - -and raw_field ppf rf = - match_row_field - ~absent:(fun _ -> fprintf ppf "RFabsent") - ~present:(function - | None -> - fprintf ppf "RFpresent None" - | Some t -> - fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) - ~either:(fun c tl m e -> - fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c - raw_type_list tl m - (fun ppf -> - match e with None -> fprintf ppf " RFnone" - | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) - rf - -let raw_type_expr ppf t = - visited := []; kind_vars := []; kind_count := 0; - raw_type ppf t; - visited := []; kind_vars := [] - -let () = Btype.print_raw := raw_type_expr - -(* Normalize paths *) - -let set_printing_env env = - printing_env := - if !Clflags.real_paths then Env.empty - else env - -let wrap_printing_env env f = - set_printing_env (Env.update_short_paths env); - try_finally f ~always:(fun () -> set_printing_env Env.empty) - -let wrap_printing_env ?error:_ env f = - Env.without_cmis (wrap_printing_env env) f - -type type_result = Short_paths.type_result = - | Nth of int - | Path of int list option * Path.t - -type type_resolution = Short_paths.type_resolution = - | Nth of int - | Subst of int list - | Id - -let apply_subst ns args = - List.map (List.nth args) ns - -let apply_subst_opt nso args = - match nso with - | None -> args - | Some ns -> apply_subst ns args - -let apply_nth n args = - List.nth args n - -let best_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then Path(None, p) - else Short_paths.find_type (Env.short_paths !printing_env) p - -let best_type_path_resolution p = - if !Clflags.real_paths || !printing_env == Env.empty - then Id - else Short_paths.find_type_resolution (Env.short_paths !printing_env) p - -let best_type_path_simple p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_type_simple (Env.short_paths !printing_env) p - -let best_module_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_module_type (Env.short_paths !printing_env) p - -let best_module_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_module (Env.short_paths !printing_env) p - -let best_class_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then None, p - else Short_paths.find_class_type (Env.short_paths !printing_env) p - -let best_class_type_path_simple p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p - -(* When building a tree for a best type path, we should not disambiguate - identifiers whenever the short-path algorithm detected a better path than - the original one.*) -let tree_of_best_type_path p p' = - if Path.same p p' then tree_of_path (Some Type) p' - else tree_of_path ~disambiguation:false None p' - -(* Print a type expression *) - -let proxy ty = Transient_expr.repr (proxy ty) - -(* When printing a type scheme, we print weak names. When printing a plain - type, we do not. This type controls that behavior *) -type type_or_scheme = Type | Type_scheme - -let is_non_gen mode ty = - match mode with - | Type_scheme -> is_Tvar ty && get_level ty <> generic_level - | Type -> false - -let nameable_row row = - row_name row <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _) -> - row_closed row && if c then l = [] else List.length l = 1 - | _ -> true) - (row_fields row) - -(* This specialized version of [Btype.iter_type_expr] normalizes and - short-circuits the traversal of the [type_expr], so that it covers only the - subterms that would be printed by the type printer. *) -let printer_iter_type_expr f ty = - match get_desc ty with - | Tconstr(p, tyl, _) -> begin - match best_type_path_resolution p with - | Nth n -> - f (apply_nth n tyl) - | Subst ns -> - List.iter f (apply_subst ns tyl) - | Id -> - List.iter f tyl - end - | Tvariant row -> begin - match row_name row with - | Some(_p, tyl) when nameable_row row -> - List.iter f tyl - | _ -> - iter_row f row - end - | Tobject (fi, nm) -> begin - match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpublic then - f ty) - fields - | Some (_, l) -> - List.iter f (List.tl l) - end - | Tfield(_, kind, ty1, ty2) -> - if field_kind_repr kind = Fpublic then - f ty1; - f ty2 - | _ -> - Btype.iter_type_expr f ty - -module Internal_names : sig - - val reset : unit -> unit - - val add : Path.t -> unit - - val print_explanations : Env.t -> Format.formatter -> unit - -end = struct - - let names = ref Ident.Set.empty - - let reset () = - names := Ident.Set.empty - - let add p = - match p with - | Pident id -> - let name = Ident.name id in - if String.length name > 0 && name.[0] = '$' then begin - names := Ident.Set.add id !names - end - | Pdot _ | Papply _ | Pextra_ty _ -> () - - let print_explanations env ppf = - let constrs = - Ident.Set.fold - (fun id acc -> - let p = Pident id in - match Env.find_type p env with - | exception Not_found -> acc - | decl -> - match type_origin decl with - | Existential constr -> - let prev = String.Map.find_opt constr acc in - let prev = Option.value ~default:[] prev in - String.Map.add constr (tree_of_path None p :: prev) acc - | Definition | Rec_check_regularity -> acc) - !names String.Map.empty - in - String.Map.iter - (fun constr out_idents -> - match out_idents with - | [] -> () - | [out_ident] -> - fprintf ppf - "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ - bound by the constructor@ %a.@]" - (Style.as_inline_code !Oprint.out_ident) out_ident - Style.inline_code constr - | out_ident :: out_idents -> - fprintf ppf - "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ - bound by the constructor@ %a.@]" - (Format.pp_print_list - ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") - (Style.as_inline_code !Oprint.out_ident)) - (List.rev out_idents) - (Style.as_inline_code !Oprint.out_ident) out_ident - Style.inline_code constr) - constrs - -end - -module Names : sig - val reset_names : unit -> unit - - val add_named_vars : type_expr -> unit - val add_subst : (type_expr * type_expr) list -> unit - - val new_name : unit -> string - val new_var_name : non_gen:bool -> type_expr -> unit -> string - - val name_of_type : (unit -> string) -> transient_expr -> string - val check_name_of_type : non_gen:bool -> transient_expr -> unit - - val remove_names : transient_expr list -> unit - - val with_local_names : (unit -> 'a) -> 'a - - (* Refresh the weak variable map in the toplevel; for [print_items], which is - itself for the toplevel *) - val refresh_weak : unit -> unit -end = struct - (* We map from types to names, but not directly; we also store a substitution, - which maps from types to types. The lookup process is - "type -> apply substitution -> find name". The substitution is presumed to - be acyclic. *) - let names = ref ([] : (transient_expr * string) list) - let name_subst = ref ([] : (transient_expr * transient_expr) list) - let name_counter = ref 0 - let named_vars = ref ([] : string list) - let visited_for_named_vars = ref ([] : transient_expr list) - - let weak_counter = ref 1 - let weak_var_map = ref TypeMap.empty - let named_weak_vars = ref String.Set.empty - - let reset_names () = - names := []; - name_subst := []; - name_counter := 0; - named_vars := []; - visited_for_named_vars := [] - - let add_named_var tty = - match tty.desc with - Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else - named_vars := name :: !named_vars - | _ -> () - - let rec add_named_vars ty = - let tty = Transient_expr.repr ty in - let px = proxy ty in - if not (List.memq px !visited_for_named_vars) then begin - visited_for_named_vars := px :: !visited_for_named_vars; - match tty.desc with - | Tvar _ | Tunivar _ -> - add_named_var tty - | _ -> - printer_iter_type_expr add_named_vars ty - end - - let rec substitute ty = - match List.assq ty !name_subst with - | ty' -> substitute ty' - | exception Not_found -> ty - - let add_subst subst = - name_subst := - List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) - subst - @ !name_subst - - let name_is_already_used name = - List.mem name !named_vars - || List.exists (fun (_, name') -> name = name') !names - || String.Set.mem name !named_weak_vars - - let rec new_name () = - let name = Misc.letter_of_int !name_counter in - incr name_counter; - if name_is_already_used name then new_name () else name - - let rec new_weak_name ty () = - let name = "weak" ^ Int.to_string !weak_counter in - incr weak_counter; - if name_is_already_used name then new_weak_name ty () - else begin - named_weak_vars := String.Set.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; - name - end - - let new_var_name ~non_gen ty () = - if non_gen then new_weak_name ty () - else new_name () - - let name_of_type name_generator t = - (* We've already been through repr at this stage, so t is our representative - of the union-find class. *) - let t = substitute t in - try List.assq t !names with Not_found -> - try TransientTypeMap.find t !weak_var_map with Not_found -> - let name = - match t.desc with - Tvar (Some name) | Tunivar (Some name) -> - (* Some part of the type we've already printed has assigned another - * unification variable to that name. We want to keep the name, so - * try adding a number until we find a name that's not taken. *) - let available name = - List.for_all - (fun (_, name') -> name <> name') - !names - in - if available name then name - else - let suffixed i = name ^ Int.to_string i in - let i = Misc.find_first_mono (fun i -> available (suffixed i)) in - suffixed i - | _ -> - (* No name available, create a new one *) - name_generator () - in - (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; - name - - let check_name_of_type ~non_gen px = - let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in - ignore(name_of_type name_gen px) - - let remove_names tyl = - let tyl = List.map substitute tyl in - names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names - - let with_local_names f = - let old_names = !names in - let old_subst = !name_subst in - names := []; - name_subst := []; - try_finally - ~always:(fun () -> - names := old_names; - name_subst := old_subst) - f - - let refresh_weak () = - let refresh t name (m,s) = - if is_non_gen Type_scheme t then - begin - TypeMap.add t name m, - String.Set.add name s - end - else m, s in - let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in - named_weak_vars := s; - weak_var_map := m -end - -let reserve_names ty = - normalize_type ty; - Names.add_named_vars ty - -let visited_objects = ref ([] : transient_expr list) -let aliased = ref ([] : transient_expr list) -let delayed = ref ([] : transient_expr list) -let printed_aliases = ref ([] : transient_expr list) - -(* [printed_aliases] is a subset of [aliased] that records only those aliased - types that have actually been printed; this allows us to avoid naming loops - that the user will never see. *) - -let add_delayed t = - if not (List.memq t !delayed) then delayed := t :: !delayed - -let is_aliased_proxy px = List.memq px !aliased - -let add_alias_proxy px = - if not (is_aliased_proxy px) then - aliased := px :: !aliased - -let add_alias ty = add_alias_proxy (proxy ty) - -let add_printed_alias_proxy ~non_gen px = - Names.check_name_of_type ~non_gen px; - printed_aliases := px :: !printed_aliases - -let add_printed_alias ty = add_printed_alias_proxy (proxy ty) - -let aliasable ty = - match get_desc ty with - Tvar _ | Tunivar _ | Tpoly _ -> false - | Tconstr (p, _, _) -> begin - match best_type_path_resolution p with - | Nth _ -> false - | Subst _ | Id -> true - end - | _ -> true - -(* let namable_row row = - row.row_name <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _, _) -> - row.row_closed && if c then l = [] else List.length l = 1 - | _ -> true) - row.row_fields *) -let should_visit_object ty = - match get_desc ty with - | Tvariant row -> not (static_row row) - | Tobject _ -> opened_object ty - | _ -> false - -(*let rec mark_loops_rec visited ty = - let ty = repr ty in - let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias px else - let visited = px :: visited in - match ty.desc with - | Tvar _ -> add_named_var ty - | Tarrow(_, ty1, ty2, _) -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl - | Tconstr(p, tyl, _) -> begin - match best_type_path_resolution p with - | Nth n -> - mark_loops_rec visited (apply_nth n tyl) - | Subst ns -> - List.iter (mark_loops_rec visited) (apply_subst ns tyl) - | Id -> - List.iter (mark_loops_rec visited) tyl - end - | Tpackage (_, fl) -> - List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl - | Tvariant row -> - if List.memq px !visited_objects then add_alias px else - begin - let row = row_repr row in - if not (static_row row) then - visited_objects := px :: !visited_objects; - match row.row_name with - | Some(_p, tyl) when namable_row row -> - List.iter (mark_loops_rec visited) tyl - | _ -> - iter_row (mark_loops_rec visited) row - end - | Tobject (fi, nm) -> - if List.memq px !visited_objects then add_alias px else - begin - if opened_object ty then - visited_objects := px :: !visited_objects; - begin match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then - mark_loops_rec visited ty) - fields - | Some (_, l) -> - List.iter (mark_loops_rec visited) (List.tl l) - end - end - | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield(_, _, _, ty2) -> - mark_loops_rec visited ty2 - | Tnil -> () - | Tsubst _ -> () (* we do not print arguments *) - | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" - | Tpoly (ty, tyl) -> - List.iter (fun t -> add_alias t) tyl; - mark_loops_rec visited ty - | Tunivar _ -> add_named_var ty *) -let rec mark_loops_rec visited ty = - let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias_proxy px else - let tty = Transient_expr.repr ty in - let visited = px :: visited in - match tty.desc with - | Tvariant _ | Tobject _ -> - if List.memq px !visited_objects then add_alias_proxy px else begin - if should_visit_object ty then - visited_objects := px :: !visited_objects; - printer_iter_type_expr (mark_loops_rec visited) ty - end - | Tpoly(ty, tyl) -> - List.iter add_alias tyl; - mark_loops_rec visited ty - | _ -> - printer_iter_type_expr (mark_loops_rec visited) ty -let mark_loops ty = - mark_loops_rec [] ty;; - -let prepare_type ty = - reserve_names ty; - mark_loops ty;; - -let reset_loop_marks () = - visited_objects := []; aliased := []; delayed := []; printed_aliases := [] - -let reset_except_context () = - Names.reset_names (); reset_loop_marks (); Internal_names.reset () - -let reset () = - Conflicts.reset (); - reset_except_context () - -let prepare_for_printing tyl = - reset_except_context (); - List.iter prepare_type tyl - -let add_type_to_preparation = prepare_type - -(* Disabled in classic mode when printing an unification error *) -let print_labels = ref true - -let alias_nongen_row mode px ty = - match get_desc ty with - | Tvariant _ | Tobject _ -> - if is_non_gen mode (Transient_expr.type_expr px) then - add_alias_proxy px - | _ -> () - -let rec tree_of_typexp mode ty = - let px = proxy ty in - if List.memq px !printed_aliases && not (List.memq px !delayed) then - let non_gen = is_non_gen mode (Transient_expr.type_expr px) in - let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in - Otyp_var (non_gen, name) else - - let pr_typ () = - let tty = Transient_expr.repr ty in - match tty.desc with - | Tvar _ -> - let non_gen = is_non_gen mode ty in - let name_gen = Names.new_var_name ~non_gen ty in - Otyp_var (non_gen, Names.name_of_type name_gen tty) - | Tarrow(l, ty1, ty2, _) -> - let lab = - if !print_labels || is_optional l then l else Nolabel - in - let t1 = - if is_optional l then - match get_desc ty1 with - | Tconstr(path, [ty], _) - when Path.same path Predef.path_option -> - tree_of_typexp mode ty - | _ -> Otyp_stuff "" - else tree_of_typexp mode ty1 in - Otyp_arrow (lab, t1, tree_of_typexp mode ty2) - | Ttuple tyl -> - Otyp_tuple (tree_of_typlist mode tyl) - | Tconstr(p, tyl, _abbrev) -> begin - match best_type_path p with - | Nth n -> tree_of_typexp mode (apply_nth n tyl) - | Path(nso, p') -> - Internal_names.add p'; - let tyl' = apply_subst_opt nso tyl in - Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') - end - | Tvariant row -> - let Row {fields; name; closed; _} = row_repr row in - let fields = - if closed then - List.filter (fun (_, f) -> row_field_repr f <> Rabsent) - fields - else fields in - let present = - List.filter - (fun (_, f) -> - match row_field_repr f with - | Rpresent _ -> true - | _ -> false) - fields in - let all_present = List.length present = List.length fields in - begin match name with - | Some(p, tyl) when nameable_row row -> - let out_variant = - match best_type_path p with - | Nth n -> tree_of_typexp mode (apply_nth n tyl) - | Path(s, p) -> - let id = tree_of_path (Some Type) p in - let args = tree_of_typlist mode (apply_subst_opt s tyl) in - Otyp_constr (id, args) - in - if closed && all_present then - out_variant - else - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (Ovar_typ out_variant, closed, tags) - | _ -> - let fields = List.map (tree_of_row_field mode) fields in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (Ovar_fields fields, closed, tags) - end - | Tobject (fi, nm) -> - tree_of_typobject mode fi !nm - | Tnil | Tfield _ -> - tree_of_typobject mode ty None - | Tsubst _ -> - (* This case should only happen when debugging the compiler *) - Otyp_stuff "" - | Tlink _ -> - fatal_error "Printtyp.tree_of_typexp" - | Tpoly (ty, []) -> - tree_of_typexp mode ty - | Tpoly (ty, tyl) -> - (*let print_names () = - List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; - prerr_string "; " in *) - if tyl = [] then tree_of_typexp mode ty else begin - let tyl = List.map Transient_expr.repr tyl in - let old_delayed = !delayed in - (* Make the names delayed, so that the real type is - printed once when used as proxy *) - List.iter add_delayed tyl; - let tl = List.map (Names.name_of_type Names.new_name) tyl in - let tr = Otyp_poly (tl, tree_of_typexp mode ty) in - (* Forget names when we leave scope *) - Names.remove_names tyl; - delayed := old_delayed; tr - end - | Tunivar _ -> - Otyp_var (false, Names.name_of_type Names.new_name tty) - | Tpackage (p, fl) -> - let p = best_module_type_path p in - let fl = - List.map - (fun (li, ty) -> ( - String.concat "." (Longident.flatten li), - tree_of_typexp mode ty - )) fl in - Otyp_module (tree_of_path (Some Module_type) p, fl) - in - if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; - alias_nongen_row mode px ty; - if is_aliased_proxy px && aliasable ty then begin - let non_gen = is_non_gen mode (Transient_expr.type_expr px) in - add_printed_alias_proxy ~non_gen px; - (* add_printed_alias chose a name, thus the name generator - doesn't matter.*) - let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in - Otyp_alias {non_gen; aliased = pr_typ (); alias } end - else pr_typ () - -and tree_of_row_field mode (l, f) = - match row_field_repr f with - | Rpresent None | Reither(true, [], _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) - | Reither(c, tyl, _) -> - if c (* contradiction: constant constructor with an argument *) - then (l, true, tree_of_typlist mode tyl) - else (l, false, tree_of_typlist mode tyl) - | Rabsent -> (l, false, [] (* actually, an error *)) - -and tree_of_typlist mode tyl = - List.map (tree_of_typexp mode) tyl - -and tree_of_typobject mode fi nm = - begin match nm with - | None -> - let pr_fields fi = - let (fields, rest) = flatten_fields fi in - let present_fields = - List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpublic -> (n, t) :: l - | _ -> l) - fields [] in - let sorted_fields = - List.sort - (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields mode rest sorted_fields in - let (fields, open_row) = pr_fields fi in - Otyp_object {fields; open_row} - | Some (p, _ty :: tyl) -> - let args = tree_of_typlist mode tyl in - let p' = best_type_path_simple p in - Otyp_class (tree_of_best_type_path p p', args) - | _ -> - fatal_error "Printtyp.tree_of_typobject" - end - -and tree_of_typfields mode rest = function - | [] -> - let open_row = - match get_desc rest with - | Tvar _ | Tunivar _ | Tconstr _-> true - | Tnil -> false - | _ -> fatal_error "typfields (1)" - in - ([], open_row) - | (s, t) :: l -> - let field = (s, tree_of_typexp mode t) in - let (fields, rest) = tree_of_typfields mode rest l in - (field :: fields, rest) - -let typexp mode ppf ty = - !Oprint.out_type ppf (tree_of_typexp mode ty) - -let prepared_type_expr ppf ty = typexp Type ppf ty -let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty - -let type_expr ppf ty = - (* [type_expr] is used directly by error message printers, - we mark eventual loops ourself to avoid any misuse and stack overflow *) - prepare_for_printing [ty]; - prepared_type_expr ppf ty - -(* "Half-prepared" type expression: [ty] should have had its names reserved, but - should not have had its loops marked. *) -let type_expr_with_reserved_names ppf ty = - reset_loop_marks (); - mark_loops ty; - prepared_type_expr ppf ty - -let shared_type_scheme ppf ty = - prepare_type ty; - typexp Type_scheme ppf ty - -let type_scheme ppf ty = - prepare_for_printing [ty]; - prepared_type_scheme ppf ty - -let type_path ppf p = - let p = best_class_type_path_simple p in - let t = tree_of_path (Some Type) p in - !Oprint.out_ident ppf t - -let tree_of_type_scheme ty = - prepare_for_printing [ty]; - tree_of_typexp Type_scheme ty - -(* Print one type declaration *) - -let tree_of_constraints params = - List.fold_right - (fun ty list -> - let ty' = unalias ty in - if proxy ty != proxy ty' then - let tr = tree_of_typexp Type_scheme ty in - (tr, tree_of_typexp Type_scheme ty') :: list - else list) - params [] - -let filter_params tyl = - let params = - List.fold_left - (fun tyl ty -> - if List.exists (eq_type ty) tyl - then newty2 ~level:generic_level (Ttuple [ty]) :: tyl - else ty :: tyl) - (* Two parameters might be identical due to a constraint but we need to - print them differently in order to make the output syntactically valid. - We use [Ttuple [ty]] because it is printed as [ty]. *) - (* Replacing fold_left by fold_right does not work! *) - [] tyl - in List.rev params - -let prepare_type_constructor_arguments = function - | Cstr_tuple l -> List.iter prepare_type l - | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l - -let tree_of_label l = - (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) - -let tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist Type l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] - -let tree_of_single_constructor cd = - let name = Ident.name cd.cd_id in - let ret = Option.map (tree_of_typexp Type) cd.cd_res in - let args = tree_of_constructor_arguments cd.cd_args in - { - ocstr_name = name; - ocstr_args = args; - ocstr_return_type = ret; - } - -(* When printing GADT constructor, we need to forget the naming decision we took - for the type parameters and constraints. Indeed, in - {[ - type 'a t = X: 'a -> 'b t - ]} - It is fine to print both the type parameter ['a] and the existentially - quantified ['a] in the definition of the constructor X as ['a] - *) -let tree_of_constructor_in_decl cd = - match cd.cd_res with - | None -> tree_of_single_constructor cd - | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) - -let prepare_decl id decl = - let params = filter_params decl.type_params in - begin match decl.type_manifest with - | Some ty -> - let vars = free_variables ty in - List.iter - (fun ty -> - if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars - then set_type_desc ty (Tvar None)) - params - | None -> () - end; - List.iter add_alias params; - List.iter prepare_type params; - List.iter (add_printed_alias ~non_gen:false) params; - let ty_manifest = - match decl.type_manifest with - | None -> None - | Some ty -> - let ty = - (* Special hack to hide variant name *) - match get_desc ty with - Tvariant row -> - begin match row_name row with - Some (Pident id', _) when Ident.same id id' -> - newgenty (Tvariant (set_row_name row None)) - | _ -> ty - end - | _ -> ty - in - prepare_type ty; - Some ty - in - begin match decl.type_kind with - | Type_abstract _ -> () - | Type_variant (cstrs, _rep) -> - List.iter - (fun c -> - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res) - cstrs - | Type_record(l, _rep) -> - List.iter (fun l -> prepare_type l.ld_type) l - | Type_open -> () - end; - ty_manifest, params - -let tree_of_type_decl id decl = - let ty_manifest, params = prepare_decl id decl in - let type_param ot_variance = - function - | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} - in - let type_defined decl = - let abstr = - match decl.type_kind with - Type_abstract _ -> - decl.type_manifest = None || decl.type_private = Private - | Type_record _ -> - decl.type_private = Private - | Type_variant (tll, _rep) -> - decl.type_private = Private || - List.exists (fun cd -> cd.cd_res <> None) tll - | Type_open -> - decl.type_manifest = None - in - let vari = - List.map2 - (fun ty v -> - let is_var = is_Tvar ty in - if abstr || not is_var then - let inj = - type_kind_is_abstract decl && Variance.mem Inj v && - match decl.type_manifest with - | None -> true - | Some ty -> (* only abstract or private row types *) - decl.type_private = Private && - Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) - and (co, cn) = Variance.get_upper v in - (if not cn then Covariant else - if not co then Contravariant else NoVariance), - (if inj then Injective else NoInjectivity) - else (NoVariance, NoInjectivity)) - decl.type_params decl.type_variance + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type in - (Ident.name id, - List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) - params vari) - in - let tree_of_manifest ty1 = - match ty_manifest with - | None -> ty1 - | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) - in - let (name, args) = type_defined decl in - let constraints = tree_of_constraints params in - let ty, priv, unboxed = - match decl.type_kind with - | Type_abstract _ -> - begin match ty_manifest with - | None -> (Otyp_abstract, Public, false) - | Some ty -> - tree_of_typexp Type ty, decl.type_private, false - end - | Type_variant (cstrs, rep) -> - tree_of_manifest - (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), - decl.type_private, - (rep = Variant_unboxed) - | Type_record(lbls, rep) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private, - (match rep with Record_unboxed _ -> true | _ -> false) - | Type_open -> - tree_of_manifest Otyp_open, - decl.type_private, - false - in - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_immediate = Type_immediacy.of_attributes decl.type_attributes; - otype_unboxed = unboxed; - otype_cstrs = constraints } - -let add_type_decl_to_preparation id decl = - ignore @@ prepare_decl id decl - -let tree_of_prepared_type_decl id decl = - tree_of_type_decl id decl - -let tree_of_type_decl id decl = - reset_except_context(); - tree_of_type_decl id decl - -let add_constructor_to_preparation c = - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res - -let prepared_constructor ppf c = - !Oprint.out_constr ppf (tree_of_single_constructor c) - -let constructor ppf c = - reset_except_context (); - add_constructor_to_preparation c; - prepared_constructor ppf c - -let label ppf l = - reset_except_context (); - prepare_type l.ld_type; - !Oprint.out_label ppf (tree_of_label l) - -let tree_of_type_declaration id decl rs = - Osig_type (tree_of_type_decl id decl, tree_of_rec rs) - -let tree_of_prepared_type_declaration id decl rs = - Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) - -let type_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) - -let add_type_declaration_to_preparation id decl = - add_type_decl_to_preparation id decl - -let prepared_type_declaration id ppf decl = - !Oprint.out_sig_item ppf - (tree_of_prepared_type_declaration id decl Trec_first) - -let constructor_arguments ppf a = - let tys = tree_of_constructor_arguments a in - !Oprint.out_type ppf (Otyp_tuple tys) - -(* Print an extension declaration *) - -let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = - let ret = Option.map (tree_of_typexp Type) ext_ret_type in - let args = tree_of_constructor_arguments ext_args in - (args, ret) - -(* When printing extension constructor, it is important to ensure that -after printing the constructor, we are still in the scope of the constructor. -For GADT constructor, this can be done by printing the type parameters inside -their own isolated scope. This ensures that in -{[ - type 'b t += A: 'b -> 'b any t -]} -the type parameter `'b` is not bound when printing the type variable `'b` from -the constructor definition from the type parameter. - -Contrarily, for non-gadt constructor, we must keep the same scope for -the type parameters and the constructor because a type constraint may -have changed the name of the type parameter: -{[ -type -'a t = .. constraint 'a> = 'a -(* the universal 'a is here to steal the name 'a from the type parameter *) -type 'a t = X of 'a -]} *) - -let add_extension_constructor_to_preparation ext = - let ty_params = filter_params ext.ext_type_params in - List.iter add_alias ty_params; - List.iter prepare_type ty_params; - prepare_type_constructor_arguments ext.ext_args; - Option.iter prepare_type ext.ext_ret_type - -let prepared_tree_of_extension_constructor - id ext es - = - let type_path = best_type_path_simple ext.ext_type_path in - let ty_name = Path.name type_path in - let ty_params = filter_params ext.ext_type_params in - let type_param = - function - | Otyp_var (_, id) -> id - | _ -> "?" - in - let param_scope f = - match ext.ext_ret_type with - | None -> - (* normal constructor: same scope for parameters and the constructor *) - f () - | Some _ -> - (* gadt constructor: isolated scope for the type parameters *) - Names.with_local_names f - in - let ty_params = - param_scope - (fun () -> - List.iter (add_printed_alias ~non_gen:false) ty_params; - List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params - ) - in - let name = Ident.name id in - let args, ret = - extension_constructor_args_and_ret_type_subtree - ext.ext_args - ext.ext_ret_type - in - let ext = - { oext_name = name; - oext_type_name = ty_name; - oext_type_params = ty_params; - oext_args = args; - oext_ret_type = ret; - oext_private = ext.ext_private } - in - let es = - match es with - Text_first -> Oext_first - | Text_next -> Oext_next - | Text_exception -> Oext_exception - in - Osig_typext (ext, es) - -let tree_of_extension_constructor id ext es = - reset_except_context (); - add_extension_constructor_to_preparation ext; - prepared_tree_of_extension_constructor id ext es - -let extension_constructor id ppf ext = - !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) - -let prepared_extension_constructor id ppf ext = - !Oprint.out_sig_item ppf - (prepared_tree_of_extension_constructor id ext Text_first) - -let extension_only_constructor id ppf ext = - reset_except_context (); - prepare_type_constructor_arguments ext.ext_args; - Option.iter prepare_type ext.ext_ret_type; - let name = Ident.name id in - let args, ret = - extension_constructor_args_and_ret_type_subtree - ext.ext_args - ext.ext_ret_type - in - Format.fprintf ppf "@[%a@]" - !Oprint.out_constr { - ocstr_name = name; + Fmt.fprintf ppf "@[%a@]" + !Oprint.out_constr { + Outcometree.ocstr_name = name; ocstr_args = args; ocstr_return_type = ret; } -(* Print a value declaration *) - -let tree_of_value_description id decl = - (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) - let id = Ident.name id in - let ty = tree_of_type_scheme decl.val_type in - let vd = - { oval_name = id; - oval_type = ty; - oval_prims = []; - oval_attributes = [] } - in - let vd = - match decl.val_kind with - | Val_prim p -> Primitive.print p vd - | _ -> vd - in - Osig_value vd - -let value_description id ppf decl = - !Oprint.out_sig_item ppf (tree_of_value_description id decl) - -(* Print a class type *) - -let method_type priv ty = - match priv, get_desc ty with - | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) - | _ , _ -> (ty, []) - -let prepare_method _lab (priv, _virt, ty) = - let ty, _ = method_type priv ty in - prepare_type ty - -let tree_of_method mode (lab, priv, virt, ty) = - let (ty, tyl) = method_type priv ty in - let tty = tree_of_typexp mode ty in - Names.remove_names (List.map Transient_expr.repr tyl); - let priv = priv <> Mpublic in - let virt = virt = Virtual in - Ocsg_method (lab, priv, virt, tty) - -let rec prepare_class_type params = function - | Cty_constr (_p, tyl, cty) -> - let row = Btype.self_type_row cty in - if List.memq (proxy row) !visited_objects - || not (List.for_all is_Tvar params) - || List.exists (deep_occur row) tyl - then prepare_class_type params cty - else List.iter prepare_type tyl - | Cty_signature sign -> - (* Self may have a name *) - let px = proxy sign.csig_self_row in - if List.memq px !visited_objects then add_alias_proxy px - else visited_objects := px :: !visited_objects; - Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; - Meths.iter prepare_method sign.csig_meths - | Cty_arrow (_, ty, cty) -> - prepare_type ty; - prepare_class_type params cty - -let rec tree_of_class_type mode params = - function - | Cty_constr (p, tyl, cty) -> - let row = Btype.self_type_row cty in - if List.memq (proxy row) !visited_objects - || not (List.for_all is_Tvar params) - then - tree_of_class_type mode params cty - else begin - let nso, p = best_class_type_path p in - let tyl = apply_subst_opt nso tyl in - let namespace = Namespace.best_class_namespace p in - Octy_constr (tree_of_path namespace p, tree_of_typlist Type_scheme tyl) - end - | Cty_signature sign -> - let px = proxy sign.csig_self_row in - let self_ty = - if is_aliased_proxy px then - Some - (Otyp_var (false, Names.name_of_type Names.new_name px)) - else None - in - let csil = [] in - let csil = - List.fold_left - (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) - csil (tree_of_constraints params) - in - let all_vars = - Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] - in - (* Consequence of PR#3607: order of Map.fold has changed! *) - let all_vars = List.rev all_vars in - let csil = - List.fold_left - (fun csil (l, m, v, t) -> - Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) - :: csil) - csil all_vars - in - let all_meths = - Meths.fold - (fun l (p, v, t) all -> (l, p, v, t) :: all) - sign.csig_meths [] - in - let all_meths = List.rev all_meths in - let csil = - List.fold_left - (fun csil meth -> tree_of_method mode meth :: csil) - csil all_meths - in - Octy_signature (self_ty, List.rev csil) - | Cty_arrow (l, ty, cty) -> - let lab = - if !print_labels || is_optional l then l else Nolabel - in - let tr = - if is_optional l then - match get_desc ty with - | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> - tree_of_typexp mode ty - | _ -> Otyp_stuff "" - else tree_of_typexp mode ty in - Octy_arrow (lab, tr, tree_of_class_type mode params cty) - -let class_type ppf cty = - reset (); - prepare_class_type [] cty; - !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) - -let tree_of_class_param param variance = - let ot_variance = - if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in - match tree_of_typexp Type_scheme param with - Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} - -let class_variance = - let open Variance in let open Asttypes in - List.map (fun v -> - (if not (mem May_pos v) then Contravariant else - if not (mem May_neg v) then Covariant else NoVariance), - NoInjectivity) - -let tree_of_class_declaration id cl rs = - let params = filter_params cl.cty_params in - - reset_except_context (); - List.iter add_alias params; - prepare_class_type params cl.cty_type; - let px = proxy (Btype.self_type_row cl.cty_type) in - List.iter prepare_type params; - - List.iter (add_printed_alias ~non_gen:false) params; - if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; - - let vir_flag = cl.cty_new = None in - Osig_class - (vir_flag, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.cty_variance), - tree_of_class_type Type_scheme params cl.cty_type, - tree_of_rec rs) - -let class_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) - -let tree_of_cltype_declaration id cl rs = - let params = cl.clty_params in - - reset_except_context (); - List.iter add_alias params; - prepare_class_type params cl.clty_type; - let px = proxy (Btype.self_type_row cl.clty_type) in - List.iter prepare_type params; - - List.iter (add_printed_alias ~non_gen:false) params; - if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; - - let sign = Btype.signature_of_class_type cl.clty_type in - let has_virtual_vars = - Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) - sign.csig_vars false - in - let has_virtual_meths = - Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) - sign.csig_meths false - in - Osig_class_type - (has_virtual_vars || has_virtual_meths, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.clty_variance), - tree_of_class_type Type_scheme params cl.clty_type, - tree_of_rec rs) - -let cltype_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) - -(* Print a module type *) - -let wrap_env fenv ftree arg = - let env = !printing_env in - let env' = Env.update_short_paths (fenv env) in - set_printing_env env'; - let tree = ftree arg in - set_printing_env env; - tree - -let dummy = - { - type_params = []; - type_arity = 0; - type_kind = Type_abstract Definition; - type_private = Public; - type_manifest = None; - type_variance = []; - type_separability = []; - type_is_newtype = false; - type_expansion_scope = Btype.lowest_level; - type_loc = Location.none; - type_attributes = []; - type_immediate = Unknown; - type_unboxed_default = false; - type_uid = Uid.internal_not_actually_unique; - } - -(** we hide items being defined from short-path to avoid shortening - [type t = Path.To.t] into [type t = t]. -*) - -let ident_sigitem = function - | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} - | Types.Sig_class(ident,_,_,_) - | Types.Sig_class_type (ident,_,_,_) - | Types.Sig_module(ident,_, _,_,_) - | Types.Sig_value (ident,_,_) - | Types.Sig_modtype (ident,_,_) - | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } - -let hide ids env = - let hide_id id env = - (* Global idents cannot be renamed *) - if id.hide && not (Ident.global id.ident) then - Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env - else env - in - List.fold_right hide_id ids env - -let with_hidden_items ids f = - let with_hidden_in_printing_env ids f = - wrap_env (hide ids) (Naming_context.with_hidden ids) f - in - if not !Clflags.real_paths then - with_hidden_in_printing_env ids f - else - Naming_context.with_hidden ids f - -let add_sigitem env x = - Env.add_signature (Signature_group.flatten x) env - -let rec tree_of_modtype ?(ellipsis=false) = function - | Mty_ident p -> - let p = best_module_type_path p in - Omty_ident (tree_of_path (Some Module_type) p) - | Mty_signature sg -> - Omty_signature (if ellipsis then [Osig_ellipsis] - else tree_of_signature sg) - | Mty_functor(param, ty_res) -> - let param, env = - tree_of_functor_parameter param - in - let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in - Omty_functor (param, res) - | Mty_alias p -> - let p = best_module_path p in - Omty_alias (tree_of_path (Some Module) p) - | Mty_for_hole -> Omty_hole - -and tree_of_functor_parameter = function - | Unit -> - None, fun k -> k - | Named (param, ty_arg) -> - let name, env = - match param with - | None -> None, fun env -> env - | Some id -> - Some (Ident.name id), - Env.add_module ~arg:true id Mp_present ty_arg - in - Some (name, tree_of_modtype ~ellipsis:false ty_arg), env - -and tree_of_signature sg = - wrap_env (fun env -> env)(fun sg -> - let tree_groups = tree_of_signature_rec !printing_env sg in - List.concat_map (fun (_env,l) -> List.map snd l) tree_groups - ) sg - -and tree_of_signature_rec env' sg = - let structured = List.of_seq (Signature_group.seq sg) in - let collect_trees_of_rec_group group = - let env = !printing_env in - let env', group_trees = - trees_of_recursive_sigitem_group env group - in - set_printing_env env'; - (env, group_trees) in - set_printing_env env'; - List.map collect_trees_of_rec_group structured - -and trees_of_recursive_sigitem_group env - (syntactic_group: Signature_group.rec_group) = - let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in - let env = Env.add_signature syntactic_group.pre_ghosts env in - match syntactic_group.group with - | Not_rec x -> add_sigitem env x, [display x] - | Rec_group items -> - let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in - List.fold_left add_sigitem env items, - with_hidden_items ids (fun () -> List.map display items) - -and tree_of_sigitem = function - | Sig_value(id, decl, _) -> - tree_of_value_description id decl - | Sig_type(id, decl, rs, _) -> - tree_of_type_declaration id decl rs - | Sig_typext(id, ext, es, _) -> - tree_of_extension_constructor id ext es - | Sig_module(id, _, md, rs, _) -> - let ellipsis = - List.exists (function - | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true - | _ -> false) - md.md_attributes in - tree_of_module id md.md_type rs ~ellipsis - | Sig_modtype(id, decl, _) -> - tree_of_modtype_declaration id decl - | Sig_class(id, decl, rs, _) -> - tree_of_class_declaration id decl rs - | Sig_class_type(id, decl, rs, _) -> - tree_of_cltype_declaration id decl rs - -and tree_of_modtype_declaration id decl = - let mty = - match decl.mtd_type with - | None -> Omty_abstract - | Some mty -> tree_of_modtype mty - in - Osig_modtype (Ident.name id, mty) - -and tree_of_module id ?ellipsis mty rs = - Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) - -let rec functor_parameters ~sep custom_printer = function - | [] -> ignore - | [id,param] -> - Format.dprintf "%t%t" - (custom_printer param) - (functor_param ~sep ~custom_printer id []) - | (id,param) :: q -> - Format.dprintf "%t%a%t" - (custom_printer param) - sep () - (functor_param ~sep ~custom_printer id q) -and functor_param ~sep ~custom_printer id q = - match id with - | None -> functor_parameters ~sep custom_printer q - | Some id -> - Naming_context.with_arg id - (fun () -> functor_parameters ~sep custom_printer q) - - - -let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) -let modtype_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) - -(* For the toplevel: merge with tree_of_signature? *) - -let print_items showval env x = - Names.refresh_weak(); - Conflicts.reset (); - let extend_val env (sigitem,outcome) = outcome, showval env sigitem in - let post_process (env,l) = List.map (extend_val env) l in - List.concat_map post_process @@ tree_of_signature_rec env x + (* Print a signature body (used by -i when compiling a .ml) *) + + let print_signature ppf tree = + Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree + + let signature ppf sg = + Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) + + (* Merlin: Print a type path taking account of [-short-paths]. + Calls should be within [wrap_printing_env]. *) + (* let type_path ppf p = + let p = best_class_type_path_simple p in + let t = tree_of_path (Some Type) p in + !Oprint.out_ident ppf t *) + + (* Merlin *) + + let rec functor_parameters ~sep custom_printer = function + | [] -> ignore + | [id,param] -> + Format.dprintf "%t%t" + (custom_printer param) + (functor_param ~sep ~custom_printer id []) + | (id,param) :: q -> + Format.dprintf "%t%a%t" + (custom_printer param) + sep () + (functor_param ~sep ~custom_printer id q) + and functor_param ~sep ~custom_printer id q = + match id with + | None -> functor_parameters ~sep custom_printer q + | Some id -> + Ident_names.with_fuzzy id + (fun () -> functor_parameters ~sep custom_printer q) + let _ = ignore (functor_parameters, functor_param) (* todo *) + + + (* For the toplevel: merge with tree_of_signature? *) + + (* let print_items showval env x = + Variable_names.refresh_weak(); + Ident_conflicts.reset (); + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x *) +end +open Doc -(* Print a signature body (used by -i when compiling a .ml) *) +let string_of_path p = Fmt.asprintf "%a" path p -let print_signature ppf tree = - fprintf ppf "@[%a@]" !Oprint.out_signature tree +let strings_of_paths namespace p = + let trees = List.map (namespaced_tree_of_path namespace) p in + List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees + +let wrap_printing_env = wrap_printing_env +let ident = Fmt.compat ident +let longident = Fmt.compat longident +let path = Fmt.compat path +let type_path = Fmt.compat type_path +let type_expr = Fmt.compat type_expr +let type_scheme = Fmt.compat type_scheme +let shared_type_scheme = Fmt.compat shared_type_scheme + +let type_declaration = Fmt.compat1 type_declaration +let type_expansion = Fmt.compat1 type_expansion +let value_description = Fmt.compat1 value_description +let label = Fmt.compat label +let constructor = Fmt.compat constructor +let constructor_arguments = Fmt.compat constructor_arguments +let extension_constructor = Fmt.compat1 extension_constructor +let extension_only_constructor = Fmt.compat1 extension_only_constructor + +let modtype = Fmt.compat modtype +let modtype_declaration = Fmt.compat1 modtype_declaration +let signature = Fmt.compat signature + +let class_declaration = Fmt.compat1 class_declaration +let class_type = Fmt.compat class_type +let cltype_declaration = Fmt.compat1 cltype_declaration -let signature ppf sg = - fprintf ppf "%a" print_signature (tree_of_signature sg) (* Print a signature body (used by -i when compiling a .ml) *) let printed_signature sourcefile ppf sg = (* we are tracking any collision event for warning 63 *) - Conflicts.reset (); + Ident_conflicts.reset (); let t = tree_of_signature sg in - if Warnings.(is_active @@ Erroneous_printed_signature "") - && Conflicts.exists () - then begin - let conflicts = Format.asprintf "%t" Conflicts.print_explanations in - Location.prerr_warning (Location.in_file sourcefile) - (Warnings.Erroneous_printed_signature conflicts); - Warnings.check_fatal () - end; - fprintf ppf "%a" print_signature t - -let shorten_type_path env p = - wrap_printing_env env - (fun () -> best_type_path_simple p) - -let shorten_module_type_path env p = - wrap_printing_env env - (fun () -> best_module_type_path p) - -let shorten_module_path env p = - wrap_printing_env env - (fun () -> best_module_path p) - -let shorten_class_type_path env p = - wrap_printing_env env - (fun () -> best_class_type_path_simple p) - -let () = - Env.shorten_module_path := shorten_module_path + if Warnings.(is_active @@ Erroneous_printed_signature "") then + begin match Ident_conflicts.err_msg () with + | None -> () + | Some msg -> + let conflicts = Fmt.asprintf "%a" Fmt.pp_doc msg in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + Fmt.compat print_signature ppf t diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index 2769fe0322..a0c654ab1c 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -15,240 +15,93 @@ (* Printing functions *) -open Format + open Types -open Outcometree -val longident: formatter -> Longident.t -> unit -val ident: formatter -> Ident.t -> unit +type namespace := Shape.Sig_component_kind.t + val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string -val tree_of_path: Path.t -> out_ident -val path: formatter -> Path.t -> unit val string_of_path: Path.t -> string +val strings_of_paths: namespace -> Path.t list -> string list +(** Print a list of paths, using the same naming context to + avoid name collisions *) -val type_path: formatter -> Path.t -> unit +(* val type_path: formatter -> Path.t -> unit (** Print a type path taking account of [-short-paths]. - Calls should be within [wrap_printing_env]. *) + Calls should be within [wrap_printing_env]. *) *) -module Out_name: sig - val create: string -> out_name - val print: out_name -> string -end +(** [printed_signature sourcefile ppf sg] print the signature [sg] of + [sourcefile] with potential warnings for name collisions *) +val printed_signature: string -> Format.formatter -> signature -> unit -type namespace := Shape.Sig_component_kind.t option +module type Printers := sig -val strings_of_paths: namespace -> Path.t list -> string list - (** Print a list of paths, using the same naming context to - avoid name collisions *) - -val raw_type_expr: formatter -> type_expr -> unit -val string_of_label: Asttypes.arg_label -> string - -val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a - (* Call the function using the environment for type path shortening *) - (* This affects all the printing functions below *) - (* Also, if [~error:true], then disable the loading of cmis *) -val shorten_type_path: Env.t -> Path.t -> Path.t -val shorten_module_type_path: Env.t -> Path.t -> Path.t -val shorten_module_path: Env.t -> Path.t -> Path.t -val shorten_class_type_path: Env.t -> Path.t -> Path.t - -module Naming_context: sig - val enable: bool -> unit - (** When contextual names are enabled, the mapping between identifiers - and names is ensured to be one-to-one. *) -end + val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a + (** Call the function using the environment for type path shortening This + affects all the printing functions below Also, if [~error:true], then + disable the loading of cmis *) -(** The [Conflicts] module keeps track of conflicts arising when attributing - names to identifiers and provides functions that can print explanations - for these conflict in error messages *) -module Conflicts: sig - val exists: unit -> bool - (** [exists()] returns true if the current naming context renamed - an identifier to avoid a name collision *) - - type explanation = - { kind: Shape.Sig_component_kind.t; - name:string; - root_name:string; - location:Location.t - } - - val list_explanations: unit -> explanation list -(** [list_explanations()] return the list of conflict explanations - collected up to this point, and reset the list of collected - explanations *) - - val print_located_explanations: - Format.formatter -> explanation list -> unit - - val print_explanations: Format.formatter -> unit - (** Print all conflict explanations collected up to this point *) - - val reset: unit -> unit -end + type 'a printer + val longident: Longident.t printer + val ident: Ident.t printer + val path: Path.t printer + val type_path: Path.t printer + (** Print a type path taking account of [-short-paths]. + Calls should be within [wrap_printing_env]. *) -val reset: unit -> unit - -(** Print out a type. This will pick names for type variables, and will not - reuse names for common type variables shared across multiple type - expressions. (It will also reset the printing state, which matters for - other type formatters such as [prepared_type_expr].) If you want multiple - types to use common names for type variables, see [prepare_for_printing] and - [prepared_type_expr]. *) -val type_expr: formatter -> type_expr -> unit - -(** [prepare_for_printing] resets the global printing environment, a la [reset], - and prepares the types for printing by reserving names and marking loops. - Any type variables that are shared between multiple types in the input list - will be given the same name when printed with [prepared_type_expr]. *) -val prepare_for_printing: type_expr list -> unit - -(** [add_type_to_preparation ty] extend a previous type expression preparation - to the type expression [ty] -*) -val add_type_to_preparation: type_expr -> unit - -val prepared_type_expr: formatter -> type_expr -> unit -(** The function [prepared_type_expr] is a less-safe but more-flexible version - of [type_expr] that should only be called on [type_expr]s that have been - passed to [prepare_for_printing]. Unlike [type_expr], this function does no - extra work before printing a type; in particular, this means that any loops - in the type expression may cause a stack overflow (see #8860) since this - function does not mark any loops. The benefit of this is that if multiple - type expressions are prepared simultaneously and then printed with - [prepared_type_expr], they will use the same names for the same type - variables. *) - -val constructor_arguments: formatter -> constructor_arguments -> unit -val tree_of_type_scheme: type_expr -> out_type -val type_scheme: formatter -> type_expr -> unit -val prepared_type_scheme: formatter -> type_expr -> unit -val shared_type_scheme: formatter -> type_expr -> unit -(** [shared_type_scheme] is very similar to [type_scheme], but does not reset - the printing context first. This is intended to be used in cases where the - printing should have a particularly wide context, such as documentation - generators; most use cases, such as error messages, have narrower contexts - for which [type_scheme] is better suited. *) - -val tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> formatter -> value_description -> unit -val label : formatter -> label_declaration -> unit -val add_constructor_to_preparation : constructor_declaration -> unit -val prepared_constructor : formatter -> constructor_declaration -> unit -val constructor : formatter -> constructor_declaration -> unit -val tree_of_type_declaration: - Ident.t -> type_declaration -> rec_status -> out_sig_item -val add_type_declaration_to_preparation : - Ident.t -> type_declaration -> unit -val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit -val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_extension_constructor: - Ident.t -> extension_constructor -> ext_status -> out_sig_item -val add_extension_constructor_to_preparation : - extension_constructor -> unit -val prepared_extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -val extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints extension constructor with the type signature: - type ('a, 'b) bar += A of float -*) - -val extension_only_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints only extension constructor without type signature: - A of float -*) - -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item -val modtype: formatter -> module_type -> unit -val signature: formatter -> signature -> unit -val tree_of_modtype: module_type -> out_module_type -val tree_of_modtype_declaration: - Ident.t -> modtype_declaration -> out_sig_item - -(** Print a list of functor parameters while adjusting the printing environment - for each functor argument. - - Currently, we are disabling disambiguation for functor argument name to - avoid the need to track the moving association between identifiers and - syntactic names in situation like: - - got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) - expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) -*) -val functor_parameters: - sep:(Format.formatter -> unit -> unit) -> - ('b -> Format.formatter -> unit) -> - (Ident.t option * 'b) list -> Format.formatter -> unit - -type type_or_scheme = Type | Type_scheme - -val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: type_or_scheme -> type_expr -> out_type -val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit -val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit -val type_expansion : - type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit -val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type -val report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit - -val report_unification_error : - formatter -> - Env.t -> Errortrace.unification_error -> - ?type_expected_explanation:(formatter -> unit) -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_equality_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.equality_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_moregen_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.moregen_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_comparison_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.comparison_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -module Subtype : sig - val report_error : - formatter -> - Env.t -> - Errortrace.Subtype.error -> - string -> - unit -end + (** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want + multiple types to use common names for type variables, see + {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) + val type_expr: type_expr printer -(* for toploop *) -val print_items: (Env.t -> signature_item -> 'a option) -> - Env.t -> signature_item list -> (out_sig_item * 'a option) list + val type_scheme: type_expr printer -(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias - for Foo__bar. This pattern is used by the stdlib. *) -val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + val shared_type_scheme: type_expr printer + (** [shared_type_scheme] is very similar to [type_scheme], but does not + reset the printing context first. This is intended to be used in cases + where the printing should have a particularly wide context, such as + documentation generators; most use cases, such as error messages, have + narrower contexts for which [type_scheme] is better suited. *) -(** [printed_signature sourcefile ppf sg] print the signature [sg] of - [sourcefile] with potential warnings for name collisions *) -val printed_signature: string -> formatter -> signature -> unit + val type_expansion: + Out_type.type_or_scheme -> Errortrace.expanded_type printer + + val label : label_declaration printer + + val constructor : constructor_declaration printer + val constructor_arguments: constructor_arguments printer + + val extension_constructor: + Ident.t -> extension_constructor printer + (** Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float + *) + + val extension_only_constructor: + Ident.t -> extension_constructor printer + (** Prints only extension constructor without type signature: + A of float + *) + + + val value_description: Ident.t -> value_description printer + val type_declaration: Ident.t -> type_declaration printer + val modtype_declaration: Ident.t -> modtype_declaration printer + val class_declaration: Ident.t -> class_declaration printer + val cltype_declaration: Ident.t -> class_type_declaration printer + + + val modtype: module_type printer + val signature: signature printer + val class_type: class_type printer + +end + +module Doc : Printers with type 'a printer := 'a Format_doc.printer + +(** For compatibility with Format printers *) +include Printers with type 'a printer := 'a Format_doc.format_printer diff --git a/src/ocaml/typing/printtyp_doc.ml b/src/ocaml/typing/printtyp_doc.ml deleted file mode 100644 index a83b9ff3aa..0000000000 --- a/src/ocaml/typing/printtyp_doc.ml +++ /dev/null @@ -1,2714 +0,0 @@ -open Misc -open Longident -open Path -open Asttypes -open Types -open Btype -open Ctype -open Outcometree - -module M = Misc.String.Map -module S = Misc.String.Set -module Sig_component_kind = Shape.Sig_component_kind -module Style = Misc.Style -module Fmt = Format_doc - -module Out_name = struct - let create x = { printed_name = x } - let print x = x.printed_name -end - -(** Some identifiers may require hiding when printing *) -type bound_ident = { hide:bool; ident:Ident.t } - -let longident = Pprintast.Doc.longident - -(* printing environment for path shortening and naming *) -let printing_env = ref Env.empty - -(* When printing, it is important to only observe the - current printing environment, without reading any new - cmi present on the file system *) -let in_printing_env f = Env.without_cmis f !printing_env - -type namespace = Shape.Sig_component_kind.t = - | Value - | Type - | Constructor - | Label - | Module - | Module_type - | Extension_constructor - | Class - | Class_type - - -module Namespace = struct - - let id = function - | Type -> 0 - | Module -> 1 - | Module_type -> 2 - | Class -> 3 - | Class_type -> 4 - | Extension_constructor | Value | Constructor | Label -> 5 - (* we do not handle those component *) - - let size = 1 + id Value - - - let pp ppf x = - Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x) - - let lookup = - let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in - function - | Some Type -> to_lookup Env.find_type_by_name - | Some Module -> to_lookup Env.find_module_by_name - | Some Module_type -> to_lookup Env.find_modtype_by_name - | Some Class -> to_lookup Env.find_class_by_name - | Some Class_type -> to_lookup Env.find_cltype_by_name - | None | Some(Value|Extension_constructor|Constructor|Label) -> - fun _ -> raise Not_found - - let location namespace id = - let path = Path.Pident id in - try Some ( - match namespace with - | Some Type -> (in_printing_env @@ Env.find_type path).type_loc - | Some Module -> (in_printing_env @@ Env.find_module path).md_loc - | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc - | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc - | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Some (Extension_constructor|Value|Constructor|Label) | None -> - Location.none - ) with Not_found -> None - - let best_class_namespace = function - | Papply _ | Pdot _ -> Some Module - | Pextra_ty _ -> assert false (* Only in type path *) - | Pident c -> - match location (Some Class) c with - | Some _ -> Some Class - | None -> Some Class_type - -end - - -module Conflicts = struct - type explanation = - { kind: namespace; name:string; root_name:string; location:Location.t} - let explanations = ref M.empty - - let add namespace name id = - match Namespace.location (Some namespace) id with - | None -> () - | Some location -> - let explanation = - { kind = namespace; location; name; root_name=Ident.name id} - in - explanations := M.add name explanation !explanations - - let collect_explanation namespace id ~name = - let root_name = Ident.name id in - (* if [name] is of the form "root_name/%d", we register both - [id] and the identifier in scope for [root_name]. - *) - if root_name <> name && not (M.mem name !explanations) then - begin - add namespace name id; - if not (M.mem root_name !explanations) then - (* lookup the identifier in scope with name [root_name] and - add it too - *) - match Namespace.lookup (Some namespace) root_name with - | Pident root_id -> add namespace root_name root_id - | exception Not_found | _ -> () - end - - let pp_explanation ppf r= - Format.fprintf ppf "@[%a:@,Definition of %s %a@]" - Location.print_loc r.location (Sig_component_kind.to_string r.kind) - (Fmt.compat Style.inline_code) r.name - - let print_located_explanations ppf l = - Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l - - let pp_explanation_as_doc ppf r= - Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" - Location.Doc.loc r.location (Sig_component_kind.to_string r.kind) - Style.inline_code r.name - - let print_located_explanations_as_doc ppf l = - Fmt.fprintf ppf "@[%a@]" (Fmt.pp_print_list pp_explanation_as_doc) l - - let reset () = explanations := M.empty - let list_explanations () = - let c = !explanations in - reset (); - c |> M.bindings |> List.map snd |> List.sort Stdlib.compare - - let compat_inline = Fmt.compat Style.inline_code - let compat_ns = Fmt.compat Namespace.pp - - let print_toplevel_hint_as_doc ppf l = - let conj ppf () = Fmt.fprintf ppf " and@ " in - let pp_namespace_plural ppf n = Fmt.fprintf ppf "%as" Namespace.pp n in - let root_names = List.map (fun r -> r.kind, r.root_name) l in - let unique_root_names = List.sort_uniq Stdlib.compare root_names in - let submsgs = Array.make Namespace.size [] in - let () = List.iter (fun (n,_ as x) -> - submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) - ) unique_root_names in - let pp_submsg ppf names = - match names with - | [] -> () - | [namespace, a] -> - Fmt.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ - @ Did you try to redefine them?@]" - Namespace.pp namespace - Style.inline_code a Namespace.pp namespace - | (namespace, _) :: _ :: _ -> - Fmt.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ - @ Did you try to redefine them?@]" - pp_namespace_plural namespace - (Fmt.pp_print_list ~pp_sep:conj Style.inline_code) - (List.map snd names) - pp_namespace_plural namespace in - Array.iter (pp_submsg ppf) submsgs - - - let print_toplevel_hint ppf l = - let conj ppf () = Format.fprintf ppf " and@ " in - let pp_namespace_plural ppf n = Format.fprintf ppf "%as" compat_ns n in - let root_names = List.map (fun r -> r.kind, r.root_name) l in - let unique_root_names = List.sort_uniq Stdlib.compare root_names in - let submsgs = Array.make Namespace.size [] in - let () = List.iter (fun (n,_ as x) -> - submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) - ) unique_root_names in - let pp_submsg ppf names = - match names with - | [] -> () - | [namespace, a] -> - Format.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ - @ Did you try to redefine them?@]" - compat_ns namespace - compat_inline a compat_ns namespace - | (namespace, _) :: _ :: _ -> - Format.fprintf ppf - "@ \ - @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ - in@ this@ toplevel@ session.@ \ - Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ - @ Did you try to redefine them?@]" - pp_namespace_plural namespace - (Format.pp_print_list ~pp_sep:conj compat_inline) - (List.map snd names) - pp_namespace_plural namespace in - Array.iter (pp_submsg ppf) submsgs - - - let print_explanations ppf = - let ltop, l = - (* isolate toplevel locations, since they are too imprecise *) - let from_toplevel a = - a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in - List.partition from_toplevel (list_explanations ()) - in - begin match l with - | [] -> () - | l -> Format.fprintf ppf "@,%a" print_located_explanations l - end; - (* if there are name collisions in a toplevel session, - display at least one generic hint by namespace *) - print_toplevel_hint ppf ltop - - let print_explanations_as_doc ppf = - let ltop, l = - (* isolate toplevel locations, since they are too imprecise *) - let from_toplevel a = - a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in - List.partition from_toplevel (list_explanations ()) - in - begin match l with - | [] -> () - | l -> Fmt.fprintf ppf "@,%a" print_located_explanations_as_doc l - end; - (* if there are name collisions in a toplevel session, - display at least one generic hint by namespace *) - print_toplevel_hint_as_doc ppf ltop - - let exists () = M.cardinal !explanations >0 -end - -module Naming_context = struct - - let enabled = ref true - let enable b = enabled := b - - (* Names bound in recursive definitions should be considered as bound - in the environment when printing identifiers but not when trying - to find shortest path. - For instance, if we define - [{ - module Avoid__me = struct - type t = A - end - type t = X - type u = [` A of t * t ] - module M = struct - type t = A of [ u | `B ] - type r = Avoid__me.t - end - }] - It is is important that in the definition of [t] that the outer type [t] is - printed as [t/2] reserving the name [t] to the type being defined in the - current recursive definition. - Contrarily, in the definition of [r], one should not shorten the - path [Avoid__me.t] to [r] until the end of the definition of [r]. - The [bound_in_recursion] bridges the gap between those two slightly different - notions of printing environment. - *) - let bound_in_recursion = ref M.empty - - (* When dealing with functor arguments, identity becomes fuzzy because the same - syntactic argument may be represented by different identifiers during the - error processing, we are thus disabling disambiguation on the argument name - *) - let fuzzy = ref S.empty - let with_arg id f = - protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f - let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy - - let with_hidden ids f = - let update m id = M.add (Ident.name id.ident) id.ident m in - let updated = List.fold_left update !bound_in_recursion ids in - protect_refs [ R(bound_in_recursion, updated )] f - - let human_id id index = - (* The identifier with index [k] is the (k+1)-th most recent identifier in - the printing environment. We print them as [name/(k+1)] except for [k=0] - which is printed as [name] rather than [name/1]. - *) - if index = 0 then - Ident.name id - else - let ordinal = index + 1 in - String.concat "/" [Ident.name id; string_of_int ordinal] - - let indexed_name namespace id = - let find namespace id env = match namespace with - | Type -> Env.find_type_index id env - | Module -> Env.find_module_index id env - | Module_type -> Env.find_modtype_index id env - | Class -> Env.find_class_index id env - | Class_type-> Env.find_cltype_index id env - | Value | Extension_constructor | Constructor | Label -> None - in - let index = - match M.find_opt (Ident.name id) !bound_in_recursion with - | Some rec_bound_id -> - (* the identifier name appears in the current group of recursive - definition *) - if Ident.same rec_bound_id id then - Some 0 - else - (* the current recursive definition shadows one more time the - previously existing identifier with the same name *) - Option.map succ (in_printing_env (find namespace id)) - | None -> - in_printing_env (find namespace id) - in - let index = - (* If [index] is [None] at this point, it might indicate that - the identifier id is not defined in the environment, while there - are other identifiers in scope that share the same name. - Currently, this kind of partially incoherent environment happens - within functor error messages where the left and right hand side - have a different views of the environment at the source level. - Printing the source-level by using a default index of `0` - seems like a reasonable compromise in this situation however.*) - Option.value index ~default:0 - in - human_id id index - - let ident_name namespace id = - match namespace, !enabled with - | None, _ | _, false -> Out_name.create (Ident.name id) - | Some namespace, true -> - if fuzzy_id namespace id then Out_name.create (Ident.name id) - else - let name = indexed_name namespace id in - Conflicts.collect_explanation namespace id ~name; - Out_name.create name - -end - -let ident_name = Naming_context.ident_name - -let ident ppf id = - Fmt.pp_print_string ppf - (Out_name.print (Naming_context.ident_name None id)) - -let namespaced_ident namespace id = - Out_name.print (Naming_context.ident_name (Some namespace) id) - -(* Print a Path *) - -let ident_stdlib = Ident.create_persistent "Stdlib" - -let non_shadowed_stdlib namespace = function - | Pdot(Pident id, s) as path -> - Ident.same id ident_stdlib && - (match Namespace.lookup namespace s with - | path' -> Path.same path path' - | exception Not_found -> true) - | _ -> false - -let find_double_underscore s = - let len = String.length s in - let rec loop i = - if i + 1 >= len then - None - else if s.[i] = '_' && s.[i + 1] = '_' then - Some i - else - loop (i + 1) - in - loop 0 - -let rec module_path_is_an_alias_of env path ~alias_of = - match Env.find_module path env with - | { md_type = Mty_alias path'; _ } -> - Path.same path' alias_of || - module_path_is_an_alias_of env path' ~alias_of - | _ -> false - | exception Not_found -> false - -(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias - for Foo__bar. This pattern is used by the stdlib. *) -let rec rewrite_double_underscore_paths env p = - match p with - | Pdot (p, s) -> - Pdot (rewrite_double_underscore_paths env p, s) - | Papply (a, b) -> - Papply (rewrite_double_underscore_paths env a, - rewrite_double_underscore_paths env b) - | Pextra_ty (p, extra) -> - Pextra_ty (rewrite_double_underscore_paths env p, extra) - | Pident id -> - let name = Ident.name id in - match find_double_underscore name with - | None -> p - | Some i -> - let better_lid = - Ldot - (Lident (String.sub name 0 i), - Unit_info.modulize - (String.sub name (i + 2) (String.length name - i - 2))) - in - match Env.find_module_by_name better_lid env with - | exception Not_found -> p - | p', _ -> - if module_path_is_an_alias_of env p' ~alias_of:p then - p' - else - p - -let rewrite_double_underscore_paths env p = - if env == Env.empty then - p - else - rewrite_double_underscore_paths env p - -let rec tree_of_path ?(disambiguation=true) namespace p = - let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in - let namespace = if disambiguation then namespace else None in - match p with - | Pident id -> - Oide_ident (ident_name namespace id) - | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> - Oide_ident (Out_name.create s) - | Pdot(p, s) -> - Oide_dot (tree_of_path (Some Module) p, s) - | Papply(p1, p2) -> - let t1 = tree_of_path (Some Module) p1 in - let t2 = tree_of_path (Some Module) p2 in - Oide_apply (t1, t2) - | Pextra_ty (p, extra) -> begin - (* inline record types are syntactically prevented from escaping their - binding scope, and are never shown to users. *) - match extra with - Pcstr_ty s -> - Oide_dot (tree_of_path (Some Type) p, s) - | Pext_ty -> - tree_of_path None p - end - -let tree_of_path ?disambiguation namespace p = - tree_of_path ?disambiguation namespace - (rewrite_double_underscore_paths !printing_env p) - -let path ppf p = - !Oprint.out_ident ppf (tree_of_path None p) - -let string_of_path p = - Fmt.asprintf "%a" path p - -let strings_of_paths namespace p = - let trees = List.map (tree_of_path namespace) p in - List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees - -let () = Env.print_path := path - -(* Print a recursive annotation *) - -let tree_of_rec = function - | Trec_not -> Orec_not - | Trec_first -> Orec_first - | Trec_next -> Orec_next - -(* Print a raw type expression, with sharing *) - -let raw_list pr ppf = function - [] -> Fmt.fprintf ppf "[]" - | a :: l -> - Fmt.fprintf ppf "@[<1>[%a%t]@]" pr a - (fun ppf -> List.iter (fun x -> Fmt.fprintf ppf ";@,%a" pr x) l) - -let kind_vars = ref [] -let kind_count = ref 0 - - -let string_of_field_kind v = - match field_kind_repr v with - | Fpublic -> "Fpublic" - | Fabsent -> "Fabsent" - | Fprivate -> "Fprivate" - -let rec safe_repr v t = - match Transient_expr.coerce t with - {desc = Tlink t} when not (List.memq t v) -> - safe_repr (t::v) t - | t' -> t' - -let rec list_of_memo = function - Mnil -> [] - | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem - | Mlink rem -> list_of_memo !rem - -let print_name ppf = function - None -> Fmt.fprintf ppf "None" - | Some name -> Fmt.fprintf ppf "\"%s\"" name - -let string_of_label = function - Nolabel -> "" - | Labelled s -> s - | Optional s -> "?"^s - -let visited = ref [] - -let rec raw_type ppf ty = - let ty = safe_repr [] ty in - if List.memq ty !visited then Fmt.fprintf ppf "{id=%d}" ty.id else begin - let scope = Transient_expr.get_scope ty in - visited := ty :: !visited; - Fmt.fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level - scope raw_type_desc ty.desc - end -and raw_type_list tl = raw_list raw_type tl -and raw_lid_type_list tl = - raw_list (fun ppf (lid, typ) -> - Fmt.fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) - tl -and raw_type_desc ppf = function - Tvar name -> Fmt.fprintf ppf "Tvar %a" print_name name - | Tarrow(l,t1,t2,c) -> - Fmt.fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" - (string_of_label l) raw_type t1 raw_type t2 - (if is_commu_ok c then "Cok" else "Cunknown") - | Ttuple tl -> - Fmt.fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl - | Tconstr (p, tl, abbrev) -> - Fmt.fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p - raw_type_list tl - (raw_list path) (list_of_memo !abbrev) - | Tobject (t, nm) -> - Fmt.fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t - (fun ppf -> - match !nm with None -> Fmt.fprintf ppf " None" - | Some(p,tl) -> - Fmt.fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) - | Tfield (f, k, t1, t2) -> - Fmt.fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (string_of_field_kind k) - raw_type t1 raw_type t2 - | Tnil -> Fmt.fprintf ppf "Tnil" - | Tlink t -> Fmt.fprintf ppf "@[<1>Tlink@,%a@]" raw_type t - | Tsubst (t, None) -> Fmt.fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t - | Tsubst (t, Some t') -> - Fmt.fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' - | Tunivar name -> Fmt.fprintf ppf "Tunivar %a" print_name name - | Tpoly (t, tl) -> - Fmt.fprintf ppf "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl - | Tvariant row -> - let Row {fields; more; name; fixed; closed} = row_repr row in - Fmt.fprintf ppf - "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" - "row_fields=" - (raw_list (fun ppf (l, f) -> - Fmt.fprintf ppf "@[%s,@ %a@]" l raw_field f)) - fields - "row_more=" raw_type more - "row_closed=" closed - "row_fixed=" raw_row_fixed fixed - "row_name=" - (fun ppf -> - match name with None -> Fmt.fprintf ppf "None" - | Some(p,tl) -> - Fmt.fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) - | Tpackage (p, fl) -> - Fmt.fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl - -and raw_row_fixed ppf = function - | None -> Fmt.fprintf ppf "None" - | Some Types.Fixed_private -> Fmt.fprintf ppf "Some Fixed_private" - | Some Types.Rigid -> Fmt.fprintf ppf "Some Rigid" - | Some Types.Univar t -> Fmt.fprintf ppf "Some(Univar(%a))" raw_type t - | Some Types.Reified p -> Fmt.fprintf ppf "Some(Reified(%a))" path p - -and raw_field ppf rf = - match_row_field - ~absent:(fun _ -> Fmt.fprintf ppf "RFabsent") - ~present:(function - | None -> - Fmt.fprintf ppf "RFpresent None" - | Some t -> - Fmt.fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) - ~either:(fun c tl m e -> - Fmt.fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c - raw_type_list tl m - (fun ppf -> - match e with _, None -> Fmt.fprintf ppf " RFnone" - | _, Some f -> Fmt.fprintf ppf "@,@[<1>(%a)@]" raw_field f)) - rf - -let raw_type_expr ppf t = - visited := []; kind_vars := []; kind_count := 0; - raw_type ppf t; - visited := []; kind_vars := [] - - -(* Normalize paths *) - -let set_printing_env env = - printing_env := - if !Clflags.real_paths then Env.empty - else env - -let wrap_printing_env env f = - set_printing_env (Env.update_short_paths env); - try_finally f ~always:(fun () -> set_printing_env Env.empty) - - -let wrap_printing_env ?error:_ env f = - Env.without_cmis (wrap_printing_env env) f - -type type_result = Short_paths.type_result = - | Nth of int - | Path of int list option * Path.t - -type type_resolution = Short_paths.type_resolution = - | Nth of int - | Subst of int list - | Id - -let apply_subst ns args = - List.map (List.nth args) ns - -let apply_subst_opt nso args = - match nso with - | None -> args - | Some ns -> apply_subst ns args - - -let apply_nth n args = - List.nth args n - -let best_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then Path(None, p) - else Short_paths.find_type (Env.short_paths !printing_env) p - -let best_type_path_resolution p = - if !Clflags.real_paths || !printing_env == Env.empty - then Id - else Short_paths.find_type_resolution (Env.short_paths !printing_env) p - -let best_type_path_simple p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_type_simple (Env.short_paths !printing_env) p - -let best_module_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_module_type (Env.short_paths !printing_env) p - -let best_module_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_module (Env.short_paths !printing_env) p - -let best_class_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then None, p - else Short_paths.find_class_type (Env.short_paths !printing_env) p - -let best_class_type_path_simple p = - if !Clflags.real_paths || !printing_env == Env.empty - then p - else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p - -(* When building a tree for a best type path, we should not disambiguate - identifiers whenever the short-path algorithm detected a better path than - the original one.*) -let tree_of_best_type_path p p' = - if Path.same p p' then tree_of_path (Some Type) p' - else tree_of_path ~disambiguation:false None p' - -(* Print a type expression *) - -let proxy ty = Transient_expr.repr (Btype.proxy ty) - -(* When printing a type scheme, we print weak names. When printing a plain - type, we do not. This type controls that behavior *) -type type_or_scheme = Type | Type_scheme - - - -let is_non_gen mode ty = - match mode with - | Type_scheme -> is_Tvar ty && get_level ty <> generic_level - | Type -> false - -let nameable_row row = - row_name row <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _) -> - row_closed row && if c then l = [] else List.length l = 1 - | _ -> true) - (row_fields row) - -(* This specialized version of [Btype.iter_type_expr] normalizes and - short-circuits the traversal of the [type_expr], so that it covers only the - subterms that would be printed by the type printer. *) -let printer_iter_type_expr f ty = - match get_desc ty with - | Tconstr(p, tyl, _) -> begin - match best_type_path_resolution p with - | Nth n -> - f (apply_nth n tyl) - | Subst ns -> - List.iter f (apply_subst ns tyl) - | Id -> - List.iter f tyl - end - | Tvariant row -> begin - match row_name row with - | Some(_p, tyl) when nameable_row row -> - List.iter f tyl - | _ -> - iter_row f row - end - | Tobject (fi, nm) -> begin - match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpublic then - f ty) - fields - | Some (_, l) -> - List.iter f (List.tl l) - end - | Tfield(_, kind, ty1, ty2) -> - if field_kind_repr kind = Fpublic then - f ty1; - f ty2 - | _ -> - Btype.iter_type_expr f ty - - -module Internal_names : sig - val reset : unit -> unit - val add : Path.t -> unit - val print_explanations : Env.t -> Format.formatter -> unit -end = struct - - let names = ref Ident.Set.empty - - let reset () = - names := Ident.Set.empty - - let add p = - match p with - | Pident id -> - let name = Ident.name id in - if String.length name > 0 && name.[0] = '$' then begin - names := Ident.Set.add id !names - end - | Pdot _ | Papply _ | Pextra_ty _ -> () - - let print_explanations env ppf = - let constrs = - Ident.Set.fold - (fun id acc -> - let p = Pident id in - match Env.find_type p env with - | exception Not_found -> acc - | decl -> - match type_origin decl with - | Existential constr -> - let prev = String.Map.find_opt constr acc in - let prev = Option.value ~default:[] prev in - String.Map.add constr (tree_of_path None p :: prev) acc - | Definition | Rec_check_regularity -> acc) - !names String.Map.empty - in - String.Map.iter - (fun constr out_idents -> - match out_idents with - | [] -> () - | [out_ident] -> - Format.fprintf ppf - "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ - bound by the constructor@ %a.@]" - (Fmt.compat1 Style.as_inline_code !Oprint.out_ident) out_ident - (Fmt.compat Style.inline_code) constr - | out_ident :: out_idents -> - Format.fprintf ppf - "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ - bound by the constructor@ %a.@]" - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - (Fmt.compat1 Style.as_inline_code !Oprint.out_ident)) - (List.rev out_idents) - (Fmt.compat1 Style.as_inline_code !Oprint.out_ident) out_ident - (Fmt.compat Style.inline_code) constr) - constrs - -end - -module Names : sig - val reset_names : unit -> unit - - val add_named_vars : type_expr -> unit - val add_subst : (type_expr * type_expr) list -> unit - - val new_name : unit -> string - val new_var_name : non_gen:bool -> type_expr -> unit -> string - - val name_of_type : (unit -> string) -> transient_expr -> string - val check_name_of_type : non_gen:bool -> transient_expr -> unit - - val remove_names : transient_expr list -> unit - - val with_local_names : (unit -> 'a) -> 'a - - (* Refresh the weak variable map in the toplevel; for [print_items], which is - itself for the toplevel *) - val refresh_weak : unit -> unit -end = struct - (* We map from types to names, but not directly; we also store a substitution, - which maps from types to types. The lookup process is - "type -> apply substitution -> find name". The substitution is presumed to - be acyclic. *) - let names = ref ([] : (transient_expr * string) list) - let name_subst = ref ([] : (transient_expr * transient_expr) list) - let name_counter = ref 0 - let named_vars = ref ([] : string list) - let visited_for_named_vars = ref ([] : transient_expr list) - - let weak_counter = ref 1 - let weak_var_map = ref TypeMap.empty - let named_weak_vars = ref String.Set.empty - - let reset_names () = - names := []; - name_subst := []; - name_counter := 0; - named_vars := []; - visited_for_named_vars := [] - - let add_named_var tty = - match tty.desc with - Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else - named_vars := name :: !named_vars - | _ -> () - - let rec add_named_vars ty = - let tty = Transient_expr.repr ty in - let px = proxy ty in - if not (List.memq px !visited_for_named_vars) then begin - visited_for_named_vars := px :: !visited_for_named_vars; - match tty.desc with - | Tvar _ | Tunivar _ -> - add_named_var tty - | _ -> - printer_iter_type_expr add_named_vars ty - end - - let rec substitute ty = - match List.assq ty !name_subst with - | ty' -> substitute ty' - | exception Not_found -> ty - - let add_subst subst = - name_subst := - List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) - subst - @ !name_subst - - let name_is_already_used name = - List.mem name !named_vars - || List.exists (fun (_, name') -> name = name') !names - || String.Set.mem name !named_weak_vars - - let rec new_name () = - let name = Misc.letter_of_int !name_counter in - incr name_counter; - if name_is_already_used name then new_name () else name - - let rec new_weak_name ty () = - let name = "weak" ^ Int.to_string !weak_counter in - incr weak_counter; - if name_is_already_used name then new_weak_name ty () - else begin - named_weak_vars := String.Set.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; - name - end - - let new_var_name ~non_gen ty () = - if non_gen then new_weak_name ty () - else new_name () - - let name_of_type name_generator t = - (* We've already been through repr at this stage, so t is our representative - of the union-find class. *) - let t = substitute t in - try List.assq t !names with Not_found -> - try TransientTypeMap.find t !weak_var_map with Not_found -> - let name = - match t.desc with - Tvar (Some name) | Tunivar (Some name) -> - (* Some part of the type we've already printed has assigned another - * unification variable to that name. We want to keep the name, so - * try adding a number until we find a name that's not taken. *) - let available name = - List.for_all - (fun (_, name') -> name <> name') - !names - in - if available name then name - else - let suffixed i = name ^ Int.to_string i in - let i = Misc.find_first_mono (fun i -> available (suffixed i)) in - suffixed i - | _ -> - (* No name available, create a new one *) - name_generator () - in - (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; - name - - let check_name_of_type ~non_gen px = - let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in - ignore(name_of_type name_gen px) - - let remove_names tyl = - let tyl = List.map substitute tyl in - names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names - - let with_local_names f = - let old_names = !names in - let old_subst = !name_subst in - names := []; - name_subst := []; - try_finally - ~always:(fun () -> - names := old_names; - name_subst := old_subst) - f - - let refresh_weak () = - let refresh t name (m,s) = - if is_non_gen Type_scheme t then - begin - TypeMap.add t name m, - String.Set.add name s - end - else m, s in - let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in - named_weak_vars := s; - weak_var_map := m -end - -let reserve_names ty = - normalize_type ty; - Names.add_named_vars ty - -let visited_objects = ref ([] : transient_expr list) -let aliased = ref ([] : transient_expr list) -let delayed = ref ([] : transient_expr list) -let printed_aliases = ref ([] : transient_expr list) - -(* [printed_aliases] is a subset of [aliased] that records only those aliased - types that have actually been printed; this allows us to avoid naming loops - that the user will never see. *) - - -let add_delayed t = - if not (List.memq t !delayed) then delayed := t :: !delayed - -let is_aliased_proxy px = List.memq px !aliased - -let add_alias_proxy px = - if not (is_aliased_proxy px) then - aliased := px :: !aliased - -let add_alias ty = add_alias_proxy (proxy ty) - -let add_printed_alias_proxy ~non_gen px = - Names.check_name_of_type ~non_gen px; - printed_aliases := px :: !printed_aliases - -let add_printed_alias ty = add_printed_alias_proxy (proxy ty) - -let aliasable ty = - match get_desc ty with - Tvar _ | Tunivar _ | Tpoly _ -> false - | Tconstr (p, _, _) -> begin - match best_type_path_resolution p with - | Nth _ -> false - | Subst _ | Id -> true - end - | _ -> true - -let should_visit_object ty = - match get_desc ty with - | Tvariant row -> not (static_row row) - | Tobject _ -> opened_object ty - | _ -> false - -let rec mark_loops_rec visited ty = - let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias_proxy px else - let tty = Transient_expr.repr ty in - let visited = px :: visited in - match tty.desc with - | Tvariant _ | Tobject _ -> - if List.memq px !visited_objects then add_alias_proxy px else begin - if should_visit_object ty then - visited_objects := px :: !visited_objects; - printer_iter_type_expr (mark_loops_rec visited) ty - end - | Tpoly(ty, tyl) -> - List.iter add_alias tyl; - mark_loops_rec visited ty - | _ -> - printer_iter_type_expr (mark_loops_rec visited) ty - - -let mark_loops ty = - mark_loops_rec [] ty - -let prepare_type ty = - reserve_names ty; - mark_loops ty - -let reset_loop_marks () = - visited_objects := []; - aliased := []; - delayed := []; - printed_aliases := [] - -let reset_except_context () = - Names.reset_names (); - reset_loop_marks (); - Internal_names.reset () - -let reset () = - Conflicts.reset (); - reset_except_context () - -let prepare_for_printing tyl = - reset_except_context (); - List.iter prepare_type tyl - -let add_type_to_preparation = prepare_type - -(* Disabled in classic mode when printing an unification error *) -let print_labels = ref true - - -let alias_nongen_row mode px ty = - match get_desc ty with - | Tvariant _ | Tobject _ -> - if is_non_gen mode (Transient_expr.type_expr px) then - add_alias_proxy px - | _ -> () - -let rec tree_of_typexp mode ty = - let px = proxy ty in - if List.memq px !printed_aliases && not (List.memq px !delayed) then - let non_gen = is_non_gen mode (Transient_expr.type_expr px) in - let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in - Otyp_var (non_gen, name) else - - let pr_typ () = - let tty = Transient_expr.repr ty in - match tty.desc with - | Tvar _ -> - let non_gen = is_non_gen mode ty in - let name_gen = Names.new_var_name ~non_gen ty in - Otyp_var (non_gen, Names.name_of_type name_gen tty) - | Tarrow(l, ty1, ty2, _) -> - let lab = - if !print_labels || is_optional l then l else Nolabel - in - let t1 = - if is_optional l then - match get_desc ty1 with - | Tconstr(path, [ty], _) - when Path.same path Predef.path_option -> - tree_of_typexp mode ty - | _ -> Otyp_stuff "" - else tree_of_typexp mode ty1 in - Otyp_arrow (lab, t1, tree_of_typexp mode ty2) - | Ttuple tyl -> - Otyp_tuple (tree_of_typlist mode tyl) - | Tconstr(p, tyl, _abbrev) -> begin - match best_type_path p with - | Nth n -> tree_of_typexp mode (apply_nth n tyl) - | Path(nso, p') -> - Internal_names.add p'; - let tyl' = apply_subst_opt nso tyl in - Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') - end - | Tvariant row -> - let Row {fields; name; closed; _} = row_repr row in - let fields = - if closed then - List.filter (fun (_, f) -> row_field_repr f <> Rabsent) - fields - else fields in - let present = - List.filter - (fun (_, f) -> - match row_field_repr f with - | Rpresent _ -> true - | _ -> false) - fields in - let all_present = List.length present = List.length fields in - begin match name with - | Some(p, tyl) when nameable_row row -> - let out_variant = - match best_type_path p with - | Nth n -> tree_of_typexp mode (apply_nth n tyl) - | Path(s, p) -> - let id = tree_of_path (Some Type) p in - let args = tree_of_typlist mode (apply_subst_opt s tyl) in - Otyp_constr (id, args) - in - if closed && all_present then - out_variant - else - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (Ovar_typ out_variant, closed, tags) - | _ -> - let fields = List.map (tree_of_row_field mode) fields in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (Ovar_fields fields, closed, tags) - end - | Tobject (fi, nm) -> - tree_of_typobject mode fi !nm - | Tnil | Tfield _ -> - tree_of_typobject mode ty None - | Tsubst _ -> - (* This case should only happen when debugging the compiler *) - Otyp_stuff "" - | Tlink _ -> - fatal_error "Printtyp.tree_of_typexp" - | Tpoly (ty, []) -> - tree_of_typexp mode ty - | Tpoly (ty, tyl) -> - (*let print_names () = - List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; - prerr_string "; " in *) - if tyl = [] then tree_of_typexp mode ty else begin - let tyl = List.map Transient_expr.repr tyl in - let old_delayed = !delayed in - (* Make the names delayed, so that the real type is - printed once when used as proxy *) - List.iter add_delayed tyl; - let tl = List.map (Names.name_of_type Names.new_name) tyl in - let tr = Otyp_poly (tl, tree_of_typexp mode ty) in - (* Forget names when we leave scope *) - Names.remove_names tyl; - delayed := old_delayed; tr - end - | Tunivar _ -> - Otyp_var (false, Names.name_of_type Names.new_name tty) - | Tpackage (p, fl) -> - let p = best_module_type_path p in - let fl = - List.map - (fun (li, ty) -> ( - String.concat "." (Longident.flatten li), - tree_of_typexp mode ty - )) fl in - Otyp_module (tree_of_path (Some Module_type) p, fl) - in - if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; - alias_nongen_row mode px ty; - if is_aliased_proxy px && aliasable ty then begin - let non_gen = is_non_gen mode (Transient_expr.type_expr px) in - add_printed_alias_proxy ~non_gen px; - (* add_printed_alias chose a name, thus the name generator - doesn't matter.*) - let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in - Otyp_alias {non_gen; aliased = pr_typ (); alias } end - else pr_typ () - -and tree_of_row_field mode (l, f) = - match row_field_repr f with - | Rpresent None | Reither(true, [], _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) - | Reither(c, tyl, _) -> - if c (* contradiction: constant constructor with an argument *) - then (l, true, tree_of_typlist mode tyl) - else (l, false, tree_of_typlist mode tyl) - | Rabsent -> (l, false, [] (* actually, an error *)) - -and tree_of_typlist mode tyl = - List.map (tree_of_typexp mode) tyl - -and tree_of_typobject mode fi nm = - begin match nm with - | None -> - let pr_fields fi = - let (fields, rest) = flatten_fields fi in - let present_fields = - List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpublic -> (n, t) :: l - | _ -> l) - fields [] in - let sorted_fields = - List.sort - (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields mode rest sorted_fields in - let (fields, open_row) = pr_fields fi in - Otyp_object {fields; open_row} - | Some (p, _ty :: tyl) -> - let args = tree_of_typlist mode tyl in - let p' = best_type_path_simple p in - Otyp_class (tree_of_best_type_path p p', args) - | _ -> - fatal_error "Printtyp.tree_of_typobject" - end - -and tree_of_typfields mode rest = function - | [] -> - let open_row = - match get_desc rest with - | Tvar _ | Tunivar _ | Tconstr _-> true - | Tnil -> false - | _ -> fatal_error "typfields (1)" - in - ([], open_row) - | (s, t) :: l -> - let field = (s, tree_of_typexp mode t) in - let (fields, rest) = tree_of_typfields mode rest l in - (field :: fields, rest) - -let typexp mode ppf ty = - !Oprint.out_type ppf (tree_of_typexp mode ty) - -let prepared_type_expr ppf ty = typexp Type ppf ty -let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty - -let type_expr ppf ty = - (* [type_expr] is used directly by error message printers, - we mark eventual loops ourself to avoid any misuse and stack overflow *) - prepare_for_printing [ty]; - prepared_type_expr ppf ty - -(* "Half-prepared" type expression: [ty] should have had its names reserved, but - should not have had its loops marked. *) -let type_expr_with_reserved_names ppf ty = - reset_loop_marks (); - mark_loops ty; - prepared_type_expr ppf ty - -let shared_type_scheme ppf ty = - prepare_type ty; - typexp Type_scheme ppf ty - -let type_scheme ppf ty = - prepare_for_printing [ty]; - prepared_type_scheme ppf ty - -let type_path ppf p = - let p = best_class_type_path_simple p in - let t = tree_of_path (Some Type) p in - !Oprint.out_ident ppf t - -let tree_of_type_scheme ty = - prepare_for_printing [ty]; - tree_of_typexp Type_scheme ty - -(* Print one type declaration *) - -let tree_of_constraints params = - List.fold_right - (fun ty list -> - let ty' = unalias ty in - if proxy ty != proxy ty' then - let tr = tree_of_typexp Type_scheme ty in - (tr, tree_of_typexp Type_scheme ty') :: list - else list) - params [] - -let filter_params tyl = - let params = - List.fold_left - (fun tyl ty -> - if List.exists (eq_type ty) tyl - then newty2 ~level:generic_level (Ttuple [ty]) :: tyl - else ty :: tyl) - (* Two parameters might be identical due to a constraint but we need to - print them differently in order to make the output syntactically valid. - We use [Ttuple [ty]] because it is printed as [ty]. *) - (* Replacing fold_left by fold_right does not work! *) - [] tyl - in List.rev params - -let prepare_type_constructor_arguments = function - | Cstr_tuple l -> List.iter prepare_type l - | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l - -let tree_of_label l = { - olab_name = Ident.name l.ld_id; - olab_mut = l.ld_mutable; - olab_type = tree_of_typexp Type l.ld_type; -} - -let tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist Type l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] - -let tree_of_single_constructor cd = - let name = Ident.name cd.cd_id in - let ret = Option.map (tree_of_typexp Type) cd.cd_res in - let args = tree_of_constructor_arguments cd.cd_args in - { ocstr_name = name; - ocstr_args = args; - ocstr_return_type = ret; - } - - -(* When printing GADT constructor, we need to forget the naming decision we took - for the type parameters and constraints. Indeed, in - {[ - type 'a t = X: 'a -> 'b t - ]} - It is fine to print both the type parameter ['a] and the existentially - quantified ['a] in the definition of the constructor X as ['a] -*) -let tree_of_constructor_in_decl cd = - match cd.cd_res with - | None -> tree_of_single_constructor cd - | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) - -let prepare_decl id decl = - let params = filter_params decl.type_params in - begin match decl.type_manifest with - | Some ty -> - let vars = free_variables ty in - List.iter - (fun ty -> - if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars - then set_type_desc ty (Tvar None)) - params - | None -> () - end; - List.iter add_alias params; - List.iter prepare_type params; - List.iter (add_printed_alias ~non_gen:false) params; - let ty_manifest = - match decl.type_manifest with - | None -> None - | Some ty -> - let ty = - (* Special hack to hide variant name *) - match get_desc ty with - Tvariant row -> - begin match row_name row with - Some (Pident id', _) when Ident.same id id' -> - newgenty (Tvariant (set_row_name row None)) - | _ -> ty - end - | _ -> ty - in - prepare_type ty; - Some ty - in - begin match decl.type_kind with - | Type_abstract _ -> () - | Type_variant (cstrs, _rep) -> - List.iter - (fun c -> - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res) - cstrs - | Type_record(l, _rep) -> - List.iter (fun l -> prepare_type l.ld_type) l - | Type_open -> () - end; - ty_manifest, params - -let tree_of_type_decl id decl = - let ty_manifest, params = prepare_decl id decl in - let type_param ot_variance = - function - | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} - in - let type_defined decl = - let abstr = - match decl.type_kind with - Type_abstract _ -> - decl.type_manifest = None || decl.type_private = Private - | Type_record _ -> - decl.type_private = Private - | Type_variant (tll, _rep) -> - decl.type_private = Private || - List.exists (fun cd -> cd.cd_res <> None) tll - | Type_open -> - decl.type_manifest = None - in - let vari = - List.map2 - (fun ty v -> - let is_var = is_Tvar ty in - if abstr || not is_var then - let inj = - type_kind_is_abstract decl && Variance.mem Inj v && - match decl.type_manifest with - | None -> true - | Some ty -> (* only abstract or private row types *) - decl.type_private = Private && - Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) - and (co, cn) = Variance.get_upper v in - (if not cn then Covariant else - if not co then Contravariant else NoVariance), - (if inj then Injective else NoInjectivity) - else (NoVariance, NoInjectivity)) - decl.type_params decl.type_variance - in - (Ident.name id, - List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) - params vari) - in - let tree_of_manifest ty1 = - match ty_manifest with - | None -> ty1 - | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) - in - let (name, args) = type_defined decl in - let constraints = tree_of_constraints params in - let ty, priv, unboxed = - match decl.type_kind with - | Type_abstract _ -> - begin match ty_manifest with - | None -> (Otyp_abstract, Public, false) - | Some ty -> - tree_of_typexp Type ty, decl.type_private, false - end - | Type_variant (cstrs, rep) -> - tree_of_manifest - (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), - decl.type_private, - (rep = Variant_unboxed) - | Type_record(lbls, rep) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private, - (match rep with Record_unboxed _ -> true | _ -> false) - | Type_open -> - tree_of_manifest Otyp_open, - decl.type_private, - false - in - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_immediate = Type_immediacy.of_attributes decl.type_attributes; - otype_unboxed = unboxed; - otype_cstrs = constraints } - -let add_type_decl_to_preparation id decl = - ignore @@ prepare_decl id decl - -let tree_of_prepared_type_decl id decl = - tree_of_type_decl id decl - -let tree_of_type_decl id decl = - reset_except_context(); - tree_of_type_decl id decl - -let add_constructor_to_preparation c = - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res - -let prepared_constructor ppf c = - !Oprint.out_constr ppf (tree_of_single_constructor c) - -let constructor ppf c = - reset_except_context (); - add_constructor_to_preparation c; - prepared_constructor ppf c - -let label ppf l = - reset_except_context (); - prepare_type l.ld_type; - !Oprint.out_label ppf (tree_of_label l) - -let tree_of_type_declaration id decl rs = - Osig_type (tree_of_type_decl id decl, tree_of_rec rs) - -let tree_of_prepared_type_declaration id decl rs = - Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) - -let type_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) - -let add_type_declaration_to_preparation id decl = - add_type_decl_to_preparation id decl - -let prepared_type_declaration id ppf decl = - !Oprint.out_sig_item ppf - (tree_of_prepared_type_declaration id decl Trec_first) - -let constructor_arguments ppf a = - let tys = tree_of_constructor_arguments a in - !Oprint.out_type ppf (Otyp_tuple tys) - -(* Print an extension declaration *) - -let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = - let ret = Option.map (tree_of_typexp Type) ext_ret_type in - let args = tree_of_constructor_arguments ext_args in - (args, ret) - -(* When printing extension constructor, it is important to ensure that - after printing the constructor, we are still in the scope of the constructor. - For GADT constructor, this can be done by printing the type parameters inside - their own isolated scope. This ensures that in - {[ - type 'b t += A: 'b -> 'b any t - ]} - the type parameter `'b` is not bound when printing the type variable `'b` from - the constructor definition from the type parameter. - - Contrarily, for non-gadt constructor, we must keep the same scope for - the type parameters and the constructor because a type constraint may - have changed the name of the type parameter: - {[ - type -'a t = .. constraint 'a> = 'a - (* the universal 'a is here to steal the name 'a from the type parameter *) - type 'a t = X of 'a - ]} *) - -let add_extension_constructor_to_preparation ext = - let ty_params = filter_params ext.ext_type_params in - List.iter add_alias ty_params; - List.iter prepare_type ty_params; - prepare_type_constructor_arguments ext.ext_args; - Option.iter prepare_type ext.ext_ret_type - -let prepared_tree_of_extension_constructor - id ext es - = - let type_path = best_type_path_simple ext.ext_type_path in - let ty_name = Path.name type_path in - let ty_params = filter_params ext.ext_type_params in - let type_param = - function - | Otyp_var (_, id) -> id - | _ -> "?" - in - let param_scope f = - match ext.ext_ret_type with - | None -> - (* normal constructor: same scope for parameters and the constructor *) - f () - | Some _ -> - (* gadt constructor: isolated scope for the type parameters *) - Names.with_local_names f - in - let ty_params = - param_scope - (fun () -> - List.iter (add_printed_alias ~non_gen:false) ty_params; - List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params - ) - in - let name = Ident.name id in - let args, ret = - extension_constructor_args_and_ret_type_subtree - ext.ext_args - ext.ext_ret_type - in - let ext = - { oext_name = name; - oext_type_name = ty_name; - oext_type_params = ty_params; - oext_args = args; - oext_ret_type = ret; - oext_private = ext.ext_private } - in - let es = - match es with - Text_first -> Oext_first - | Text_next -> Oext_next - | Text_exception -> Oext_exception - in - Osig_typext (ext, es) - -let tree_of_extension_constructor id ext es = - reset_except_context (); - add_extension_constructor_to_preparation ext; - prepared_tree_of_extension_constructor id ext es - -let extension_constructor id ppf ext = - !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) - -let prepared_extension_constructor id ppf ext = - !Oprint.out_sig_item ppf - (prepared_tree_of_extension_constructor id ext Text_first) - -let extension_only_constructor id ppf ext = - reset_except_context (); - prepare_type_constructor_arguments ext.ext_args; - Option.iter prepare_type ext.ext_ret_type; - let name = Ident.name id in - let args, ret = - extension_constructor_args_and_ret_type_subtree - ext.ext_args - ext.ext_ret_type - in - Fmt.fprintf ppf "@[%a@]" - !Oprint.out_constr { - ocstr_name = name; - ocstr_args = args; - ocstr_return_type = ret; - } - -(* Print a value declaration *) - -let tree_of_value_description id decl = - (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) - let id = Ident.name id in - let ty = tree_of_type_scheme decl.val_type in - let vd = - { oval_name = id; - oval_type = ty; - oval_prims = []; - oval_attributes = [] } - in - let vd = - match decl.val_kind with - | Val_prim p -> Primitive.print p vd - | _ -> vd - in - Osig_value vd - -let value_description id ppf decl = - !Oprint.out_sig_item ppf (tree_of_value_description id decl) - -(* Print a class type *) - - -let method_type priv ty = - match priv, get_desc ty with - | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) - | _ , _ -> (ty, []) - -let prepare_method _lab (priv, _virt, ty) = - let ty, _ = method_type priv ty in - prepare_type ty - -let tree_of_method mode (lab, priv, virt, ty) = - let (ty, tyl) = method_type priv ty in - let tty = tree_of_typexp mode ty in - Names.remove_names (List.map Transient_expr.repr tyl); - let priv = priv <> Mpublic in - let virt = virt = Virtual in - Ocsg_method (lab, priv, virt, tty) - -let rec prepare_class_type params = function - | Cty_constr (_p, tyl, cty) -> - let row = Btype.self_type_row cty in - if List.memq (proxy row) !visited_objects - || not (List.for_all is_Tvar params) - || List.exists (deep_occur row) tyl - then prepare_class_type params cty - else List.iter prepare_type tyl - | Cty_signature sign -> - (* Self may have a name *) - let px = proxy sign.csig_self_row in - if List.memq px !visited_objects then add_alias_proxy px - else visited_objects := px :: !visited_objects; - Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; - Meths.iter prepare_method sign.csig_meths - | Cty_arrow (_, ty, cty) -> - prepare_type ty; - prepare_class_type params cty - -let rec tree_of_class_type mode params = - function - | Cty_constr (p, tyl, cty) -> - let row = Btype.self_type_row cty in - if List.memq (proxy row) !visited_objects - || not (List.for_all is_Tvar params) - then - tree_of_class_type mode params cty - else begin - let nso, p = best_class_type_path p in - let tyl = apply_subst_opt nso tyl in - let namespace = Namespace.best_class_namespace p in - Octy_constr (tree_of_path namespace p, tree_of_typlist Type_scheme tyl) - end - | Cty_signature sign -> - let px = proxy sign.csig_self_row in - let self_ty = - if is_aliased_proxy px then - Some - (Otyp_var (false, Names.name_of_type Names.new_name px)) - else None - in - let csil = [] in - let csil = - List.fold_left - (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) - csil (tree_of_constraints params) - in - let all_vars = - Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] - in - (* Consequence of PR#3607: order of Map.fold has changed! *) - let all_vars = List.rev all_vars in - let csil = - List.fold_left - (fun csil (l, m, v, t) -> - Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) - :: csil) - csil all_vars - in - let all_meths = - Meths.fold - (fun l (p, v, t) all -> (l, p, v, t) :: all) - sign.csig_meths [] - in - let all_meths = List.rev all_meths in - let csil = - List.fold_left - (fun csil meth -> tree_of_method mode meth :: csil) - csil all_meths - in - Octy_signature (self_ty, List.rev csil) - | Cty_arrow (l, ty, cty) -> - let lab = - if !print_labels || is_optional l then l else Nolabel - in - let tr = - if is_optional l then - match get_desc ty with - | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> - tree_of_typexp mode ty - | _ -> Otyp_stuff "" - else tree_of_typexp mode ty in - Octy_arrow (lab, tr, tree_of_class_type mode params cty) - -let class_type ppf cty = - reset (); - prepare_class_type [] cty; - !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) - -let tree_of_class_param param variance = - let ot_variance = - if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in - match tree_of_typexp Type_scheme param with - Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} - -let class_variance = - let open Variance in let open Asttypes in - List.map (fun v -> - (if not (mem May_pos v) then Contravariant else - if not (mem May_neg v) then Covariant else NoVariance), - NoInjectivity) - -let tree_of_class_declaration id cl rs = - let params = filter_params cl.cty_params in - - reset_except_context (); - List.iter add_alias params; - prepare_class_type params cl.cty_type; - let px = proxy (Btype.self_type_row cl.cty_type) in - List.iter prepare_type params; - - List.iter (add_printed_alias ~non_gen:false) params; - if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; - - let vir_flag = cl.cty_new = None in - Osig_class - (vir_flag, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.cty_variance), - tree_of_class_type Type_scheme params cl.cty_type, - tree_of_rec rs) - -let class_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) - -let tree_of_cltype_declaration id cl rs = - let params = cl.clty_params in - - reset_except_context (); - List.iter add_alias params; - prepare_class_type params cl.clty_type; - let px = proxy (Btype.self_type_row cl.clty_type) in - List.iter prepare_type params; - - List.iter (add_printed_alias ~non_gen:false) params; - if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; - - let sign = Btype.signature_of_class_type cl.clty_type in - let has_virtual_vars = - Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) - sign.csig_vars false - in - let has_virtual_meths = - Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) - sign.csig_meths false - in - Osig_class_type - (has_virtual_vars || has_virtual_meths, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.clty_variance), - tree_of_class_type Type_scheme params cl.clty_type, - tree_of_rec rs) - -let cltype_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) - -(* Print a module type *) - -let wrap_env fenv ftree arg = - let env = !printing_env in - let env' = Env.update_short_paths (fenv env) in - set_printing_env env'; - let tree = ftree arg in - set_printing_env env; - tree - -let dummy = - { - type_params = []; - type_arity = 0; - type_kind = Type_abstract Definition; - type_private = Public; - type_manifest = None; - type_variance = []; - type_separability = []; - type_is_newtype = false; - type_expansion_scope = Btype.lowest_level; - type_loc = Location.none; - type_attributes = []; - type_immediate = Unknown; - type_unboxed_default = false; - type_uid = Uid.internal_not_actually_unique; - } - -(** we hide items being defined from short-path to avoid shortening - [type t = Path.To.t] into [type t = t]. -*) - -let ident_sigitem = function - | Types.Sig_type(ident,_,_,_) -> {hide=true; ident} - | Types.Sig_class(ident,_,_,_) - | Types.Sig_class_type (ident,_,_,_) - | Types.Sig_module(ident,_, _,_,_) - | Types.Sig_value (ident,_,_) - | Types.Sig_modtype (ident,_,_) - | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } - - -let hide ids env = - let hide_id id env = - (* Global idents cannot be renamed *) - if id.hide && not (Ident.global id.ident) then - Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env - else env - in - List.fold_right hide_id ids env - -let with_hidden_items ids f = - let with_hidden_in_printing_env ids f = - wrap_env (hide ids) (Naming_context.with_hidden ids) f - in - if not !Clflags.real_paths then - with_hidden_in_printing_env ids f - else - Naming_context.with_hidden ids f - -let add_sigitem env x = - Env.add_signature (Signature_group.flatten x) env - -let rec tree_of_modtype ?(ellipsis=false) = function - | Mty_ident p -> - let p = best_module_type_path p in - Omty_ident (tree_of_path (Some Module_type) p) - | Mty_signature sg -> - Omty_signature (if ellipsis then [Osig_ellipsis] - else tree_of_signature sg) - | Mty_functor(param, ty_res) -> - let param, env = - tree_of_functor_parameter param - in - let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in - Omty_functor (param, res) - | Mty_alias p -> - let p = best_module_path p in - Omty_alias (tree_of_path (Some Module) p) - | Mty_for_hole -> Omty_hole - -and tree_of_functor_parameter = function - | Unit -> - None, fun k -> k - | Named (param, ty_arg) -> - let name, env = - match param with - | None -> None, fun env -> env - | Some id -> - Some (Ident.name id), - Env.add_module ~arg:true id Mp_present ty_arg - in - Some (name, tree_of_modtype ~ellipsis:false ty_arg), env - -and tree_of_signature sg = - wrap_env (fun env -> env)(fun sg -> - let tree_groups = tree_of_signature_rec !printing_env sg in - List.concat_map (fun (_env,l) -> List.map snd l) tree_groups - ) sg - -and tree_of_signature_rec env' sg = - let structured = List.of_seq (Signature_group.seq sg) in - let collect_trees_of_rec_group group = - let env = !printing_env in - let env', group_trees = - trees_of_recursive_sigitem_group env group - in - set_printing_env env'; - (env, group_trees) in - set_printing_env env'; - List.map collect_trees_of_rec_group structured - -and trees_of_recursive_sigitem_group env - (syntactic_group: Signature_group.rec_group) = - let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in - let env = Env.add_signature syntactic_group.pre_ghosts env in - match syntactic_group.group with - | Not_rec x -> add_sigitem env x, [display x] - | Rec_group items -> - let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in - List.fold_left add_sigitem env items, - with_hidden_items ids (fun () -> List.map display items) - -and tree_of_sigitem = function - | Sig_value(id, decl, _) -> - tree_of_value_description id decl - | Sig_type(id, decl, rs, _) -> - tree_of_type_declaration id decl rs - | Sig_typext(id, ext, es, _) -> - tree_of_extension_constructor id ext es - | Sig_module(id, _, md, rs, _) -> - let ellipsis = - List.exists (function - | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true - | _ -> false) - md.md_attributes in - tree_of_module id md.md_type rs ~ellipsis - | Sig_modtype(id, decl, _) -> - tree_of_modtype_declaration id decl - | Sig_class(id, decl, rs, _) -> - tree_of_class_declaration id decl rs - | Sig_class_type(id, decl, rs, _) -> - tree_of_cltype_declaration id decl rs - -and tree_of_modtype_declaration id decl = - let mty = - match decl.mtd_type with - | None -> Omty_abstract - | Some mty -> tree_of_modtype mty - in - Osig_modtype (Ident.name id, mty) - -and tree_of_module id ?ellipsis mty rs = - Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) - -let rec functor_parameters ~sep custom_printer = function - | [] -> ignore - | [id,param] -> - Fmt.dprintf "%t%t" - (custom_printer param) - (functor_param ~sep ~custom_printer id []) - | (id,param) :: q -> - Fmt.dprintf "%t%a%t" - (custom_printer param) - sep () - (functor_param ~sep ~custom_printer id q) -and functor_param ~sep ~custom_printer id q = - match id with - | None -> functor_parameters ~sep custom_printer q - | Some id -> - Naming_context.with_arg id - (fun () -> functor_parameters ~sep custom_printer q) - -let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) -let modtype_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) - - -(* For the toplevel: merge with tree_of_signature? *) - -let print_items showval env x = - Names.refresh_weak(); - Conflicts.reset (); - let extend_val env (sigitem,outcome) = outcome, showval env sigitem in - let post_process (env,l) = List.map (extend_val env) l in - List.concat_map post_process @@ tree_of_signature_rec env x - -(* Print a signature body (used by -i when compiling a .ml) *) - -let print_signature ppf tree = - Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree - -let signature ppf sg = - Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) - -(* Print a signature body (used by -i when compiling a .ml) *) -let printed_signature sourcefile ppf sg = - (* we are tracking any collision event for warning 63 *) - Conflicts.reset (); - let t = tree_of_signature sg in - if Warnings.(is_active @@ Erroneous_printed_signature "") - && Conflicts.exists () - then begin - let conflicts = Fmt.asprintf "%t" Conflicts.print_explanations_as_doc in - Location.prerr_warning (Location.in_file sourcefile) - (Warnings.Erroneous_printed_signature conflicts); - Warnings.check_fatal () - end; - Fmt.fprintf ppf "%a" print_signature t - - -(* Trace-specific printing *) - -(* A configuration type that controls which trace we print. This could be - exposed, but we instead expose three separate - [report_{unification,equality,moregen}_error] functions. This also lets us - give the unification case an extra optional argument without adding it to the - equality and moregen cases. *) -type 'variety trace_format = - | Unification : Errortrace.unification trace_format - | Equality : Errortrace.comparison trace_format - | Moregen : Errortrace.comparison trace_format - -let incompatibility_phrase (type variety) : variety trace_format -> string = - function - | Unification -> "is not compatible with type" - | Equality -> "is not equal to type" - | Moregen -> "is not compatible with type" - -(* Print a unification error *) - -let same_path t t' = - eq_type t t' || - match get_desc t, get_desc t' with - | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin - match best_type_path p, best_type_path p' with - | Nth n, Nth n' when n = n' -> true - | Path(nso, p), Path(nso', p') when Path.same p p' -> - let tl = apply_subst_opt nso tl in - let tl' = apply_subst_opt nso' tl' in - List.length tl = List.length tl' && - List.for_all2 eq_type tl tl' - | _ -> false - end - | _ -> - false - - -type 'a diff = Same of 'a | Diff of 'a * 'a - - -let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = - reset_loop_marks (); - mark_loops t; - if same_path t t' - then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end - else begin - mark_loops t'; - let t' = if proxy t == proxy t' then unalias t' else t' in - (* beware order matter due to side effect, - e.g. when printing object types *) - let first = tree_of_typexp mode t in - let second = tree_of_typexp mode t' in - if first = second then Same first - else Diff(first,second) - end - -let type_expansion ppf = function - | Same t -> Style.as_inline_code !Oprint.out_type ppf t - | Diff(t,t') -> - Fmt.fprintf ppf "@[<2>%a@ =@ %a@]" - (Style.as_inline_code !Oprint.out_type) t - (Style.as_inline_code !Oprint.out_type) t' - - -let trees_of_trace mode = - List.map (Errortrace.map_diff (trees_of_type_expansion mode)) - -let trees_of_type_path_expansion (tp,tp') = - if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else - Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') - -let type_path_expansion ppf = function - | Same p -> Style.as_inline_code !Oprint.out_ident ppf p - | Diff(p,p') -> - Fmt.fprintf ppf "@[<2>%a@ =@ %a@]" - (Style.as_inline_code !Oprint.out_ident) p - (Style.as_inline_code !Oprint.out_ident) p' - -let rec trace fst txt ppf = function - | {Errortrace.got; expected} :: rem -> - if not fst then Fmt.fprintf ppf "@,"; - Fmt.fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" - type_expansion got txt type_expansion expected - (trace false txt) rem - | _ -> () - - -type printing_status = - | Discard - | Keep - | Optional_refinement - (** An [Optional_refinement] printing status is attributed to trace - elements that are focusing on a new subpart of a structural type. - Since the whole type should have been printed earlier in the trace, - we only print those elements if they are the last printed element - of a trace, and there is no explicit explanation for the - type error. - *) - -let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; - expected = {ty = t2; expanded = t2'} } = - if is_constr_row ~allow_ident:true t1' - || is_constr_row ~allow_ident:true t2' - then Discard - else if same_path t1 t1' && same_path t2 t2' then Optional_refinement - else Keep - -let printing_status = function - | Errortrace.Diff d -> diff_printing_status d - | Errortrace.Escape {kind = Constraint} -> Keep - | _ -> Keep - -(** Flatten the trace and remove elements that are always discarded - during printing *) - -(* Takes [printing_status] to change behavior for [Subtype] *) -let prepare_any_trace printing_status tr = - let clean_trace x l = match printing_status x with - | Keep -> x :: l - | Optional_refinement when l = [] -> [x] - | Optional_refinement | Discard -> l - in - match tr with - | [] -> [] - | elt :: rem -> elt :: List.fold_right clean_trace rem [] - -let prepare_trace f tr = - prepare_any_trace printing_status (Errortrace.map f tr) - -(** Keep elements that are [Diff _ ] and take the decision - for the last element, require a prepared trace *) -let rec filter_trace keep_last = function - | [] -> [] - | [Errortrace.Diff d as elt] - when printing_status elt = Optional_refinement -> - if keep_last then [d] else [] - | Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem - | _ :: rem -> filter_trace keep_last rem - -let type_path_list = - Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.pp_print_break ppf 2 0) - type_path_expansion - -(* Hide variant name and var, to force printing the expanded type *) -let hide_variant_name t = - match get_desc t with - | Tvariant row -> - let Row {fields; more; name; fixed; closed} = row_repr row in - if name = None then t else - newty2 ~level:(get_level t) - (Tvariant - (create_row ~fields ~fixed ~closed ~name:None - ~more:(newvar2 (get_level more)))) - | _ -> t - - - -let prepare_expansion Errortrace.{ty; expanded} = - let expanded = hide_variant_name expanded in - reserve_names ty; - if not (same_path ty expanded) then reserve_names expanded; - Errortrace.{ty; expanded} - -let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = - match get_desc expanded with - Tvariant _ | Tobject _ when compact -> - reserve_names ty; Errortrace.{ty; expanded = ty} - | _ -> prepare_expansion ty_exp - -let print_path p = - Fmt.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) - -let print_tag ppf s = Style.inline_code ppf ("`" ^ s) - -let print_tags = - let comma ppf () = Fmt.fprintf ppf ",@ " in - Fmt.pp_print_list ~pp_sep:comma print_tag - -let is_unit env ty = - match get_desc (Ctype.expand_head env ty) with - | Tconstr (p, _, _) -> Path.same p Predef.path_unit - | _ -> false - -let unifiable env ty1 ty2 = - let snap = Btype.snapshot () in - let res = - try Ctype.unify env ty1 ty2; true - with Unify _ -> false - in - Btype.backtrack snap; - res - - -let explanation_diff env t3 t4 : (Format.formatter -> unit) option = - match get_desc t3, get_desc t4 with - | Tarrow (_, ty1, ty2, _), _ - when is_unit env ty1 && unifiable env ty2 t4 -> - Some (fun ppf -> - Format.fprintf ppf - "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" - (Fmt.compat Style.inline_code) "()" - ) - | _, Tarrow (_, ty1, ty2, _) - when is_unit env ty1 && unifiable env t3 ty2 -> - Some (fun ppf -> - Format.fprintf ppf - "@,@[@{Hint@}: Did you forget to wrap the expression using \ - %a?@]" - (Fmt.compat Style.inline_code) "fun () ->" - ) - | _ -> - None - -let explain_fixed_row_case ppf = function - | Errortrace.Cannot_be_closed -> - Format.fprintf ppf "it cannot be closed" - | Errortrace.Cannot_add_tags tags -> - Format.fprintf ppf "it may not allow the tag(s) %a" - (Fmt.compat print_tags) tags - - -let explain_fixed_row pos expl = match expl with - | Fixed_private -> - Format.dprintf "The %a variant type is private" - (Fmt.compat Errortrace.print_pos) pos - | Univar x -> - reserve_names x; - Format.dprintf "The %a variant type is bound to the universal type variable %a" - (Fmt.compat Errortrace.print_pos) pos - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) x - | Reified p -> - Format.dprintf "The %a variant type is bound to %a" - (Fmt.compat Errortrace.print_pos) pos - (Fmt.compat1 Style.as_inline_code - (fun ppf p -> - Internal_names.add p; - print_path p ppf)) - p - | Rigid -> ignore - - -let explain_variant (type variety) : variety Errortrace.variant -> _ = function - (* Common *) - | Errortrace.Incompatible_types_for s -> - Some( - Format.dprintf "@,Types for tag %a are incompatible" (Fmt.compat print_tag) s) - (* Unification *) - | Errortrace.No_intersection -> - Some(Format.dprintf "@,These two variant types have no intersection") - | Errortrace.No_tags(pos,fields) -> Some ( - Format.dprintf - "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" - (Fmt.compat Errortrace.print_pos) pos - (Fmt.compat print_tags) (List.map fst fields)) - | Errortrace.Fixed_row (pos, k, (Univar _ | Reified _ | Fixed_private as e)) -> - Some ( - Format.dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) - explain_fixed_row_case k) - | Errortrace.Fixed_row (_,_, Rigid) -> - (* this case never happens *) - None - (* Equality & Moregen *) - | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( - Format.dprintf - "@,@[The tag %a is guaranteed to be present in the %a variant type,\ - @ but not in the %a@]" - (Fmt.compat print_tag) s - (Fmt.compat Errortrace.print_pos) (Errortrace.swap_position pos) - (Fmt.compat Errortrace.print_pos) pos - ) - | Errortrace.Openness pos -> - Some(Format.dprintf "@,The %a variant type is open and the %a is not" - (Fmt.compat Errortrace.print_pos) pos - (Fmt.compat Errortrace.print_pos) (Errortrace.swap_position pos)) - -let explain_escape pre = function - | Errortrace.Univ u -> - reserve_names u; - Some( - Format.dprintf "%t@,The universal variable %a would escape its scope" - pre - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) u - ) - | Errortrace.Constructor p -> Some( - Format.dprintf - "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - pre (Fmt.compat1 Style.as_inline_code path) p - ) - | Errortrace.Module_type p -> Some( - Format.dprintf - "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" - pre (Fmt.compat1 Style.as_inline_code path) p - ) - | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> - reserve_names t; - Some( - Format.dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" - pre - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) t - "it would escape the scope of its equation" - ) - | Errortrace.Self -> - Some (Format.dprintf "%t@,Self type cannot escape its class" pre) - | Errortrace.Constraint -> - None - - -let explain_object (type variety) : variety Errortrace.obj -> _ = function - | Errortrace.Missing_field (pos,f) -> Some( - Format.dprintf "@,@[The %a object type has no method %a@]" - (Fmt.compat Errortrace.print_pos) pos (Fmt.compat Style.inline_code) f - ) - | Errortrace.Abstract_row pos -> Some( - Format.dprintf - "@,@[The %a object type has an abstract row, it cannot be closed@]" - (Fmt.compat Errortrace.print_pos) pos - ) - | Errortrace.Self_cannot_be_closed -> - Some (Format.dprintf "@,Self type cannot be unified with a closed object type") - -let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = - reserve_names diff.got; - reserve_names diff.expected; - Format.dprintf "@,@[The method %a has type@ %a,@ \ - but the expected method type was@ %a@]" - (Fmt.compat Style.inline_code) name - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) diff.got - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) diff.expected - -let explain_label_mismatch ~got ~expected = - let quoted_label ppf l = Style.inline_code ppf (string_of_label l) in - let quoted_label = Fmt.compat quoted_label in - match got, expected with - | Asttypes.Nolabel, Asttypes.(Labelled _ | Optional _ ) -> - Format.dprintf "@,@[A label@ %a@ was expected@]" - quoted_label expected - | Asttypes.(Labelled _|Optional _), Asttypes.Nolabel -> - Format.dprintf - "@,@[The first argument is labeled@ %a,@ \ - but an unlabeled argument was expected@]" - quoted_label got - | Asttypes.Labelled g, Asttypes.Optional e when g = e -> - Format.dprintf - "@,@[The label@ %a@ was expected to be optional@]" - quoted_label got - | Asttypes.Optional g, Asttypes.Labelled e when g = e -> - Format.dprintf - "@,@[The label@ %a@ was expected to not be optional@]" - quoted_label got - | Asttypes.(Labelled _ | Optional _), Asttypes.(Labelled _ | Optional _) -> - Format.dprintf "@,@[Labels %a@ and@ %a do not match@]" - quoted_label got - quoted_label expected - | Asttypes.Nolabel, Asttypes.Nolabel -> - (* Two empty labels cannot be mismatched*) - assert false - -let explain_first_class_module = function - | Errortrace.Package_cannot_scrape p -> Some( - Format.dprintf "@,@[The module alias %a could not be expanded@]" - (Fmt.compat path) p - ) - | Errortrace.Package_inclusion pr -> - Some(Format.dprintf "@,@[%a@]" Fmt.Doc.format pr) - | Errortrace.Package_coercion pr -> - Some(Format.dprintf "@,@[%a@]" Fmt.Doc.format pr) - -let explanation (type variety) intro prev env - : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function - | Errortrace.Diff {got; expected} -> - explanation_diff env got.expanded expected.expanded - | Errortrace.Escape {kind; context} -> - let pre = - match context, kind, prev with - | Some ctx, _, _ -> - reserve_names ctx; - Format.dprintf "@[%t@;<1 2>%a@]" intro - (Fmt.compat1 Style.as_inline_code type_expr_with_reserved_names) ctx - | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> - explain_incompatible_fields name diff - | _ -> ignore - in - explain_escape pre kind - | Errortrace.Incompatible_fields { name; diff} -> - Some(explain_incompatible_fields name diff) - | Errortrace.Variant v -> - explain_variant v - | Errortrace.Obj o -> - explain_object o - | Errortrace.Function_label_mismatch diff -> - Some (explain_label_mismatch ~got:diff.got ~expected:diff.expected) - | Errortrace.First_class_module fm -> - explain_first_class_module fm - | Errortrace.Rec_occur(x,y) -> - reserve_names x; - reserve_names y; - begin match get_desc x with - | Tvar _ | Tunivar _ -> - Some(fun ppf -> - reset_loop_marks (); - mark_loops x; - mark_loops y; - Format.dprintf "@,@[The type variable %a occurs inside@ %a@]" - (Fmt.compat1 Style.as_inline_code prepared_type_expr) x - (Fmt.compat1 Style.as_inline_code prepared_type_expr) y - ppf) - | _ -> - (* We had a delayed unification of the type variable with - a non-variable after the occur check. *) - Some ignore - (* There is no need to search further for an explanation, but - we don't want to print a message of the form: - {[ The type int occurs inside int list -> 'a |} - *) - end - - -let mismatch intro env trace = - Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) - - -let explain mis ppf = - match mis with - | None -> () - | Some explain -> explain ppf - - -let warn_on_missing_def env ppf t = - match get_desc t with - | Tconstr (p,_,_) -> - begin match Env.find_type p env with - | exception Not_found -> - Fmt.fprintf ppf - "@,@[Type %a is abstract because@ no corresponding\ - @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p - | { type_manifest = Some _; _ } -> () - | { type_manifest = None; _ } as decl -> - match type_origin decl with - | Rec_check_regularity -> - Fmt.fprintf ppf - "@,@[Type %a was considered abstract@ when checking\ - @ constraints@ in this@ recursive type definition.@]" - (Style.as_inline_code path) p - | Definition | Existential _ -> () - end - | _ -> () - - - -let prepare_expansion_head empty_tr = function - | Errortrace.Diff d -> - Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) - | _ -> None - -let head_error_printer mode txt_got txt_but = function - | None -> ignore - | Some d -> - let d = Errortrace.map_diff (trees_of_type_expansion mode) d in - Format.dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" - txt_got (Fmt.compat type_expansion) d.Errortrace.got - txt_but (Fmt.compat type_expansion) d.Errortrace.expected - -let warn_on_missing_defs env ppf = function - | None -> () - | Some Errortrace.{got = {ty=te1; expanded=_}; - expected = {ty=te2; expanded=_} } -> - warn_on_missing_def env ppf te1; - warn_on_missing_def env ppf te2 - -(* [subst] comes out of equality, and is [[]] otherwise *) -let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = - reset (); - (* We want to substitute in the opposite order from [Eqtype] *) - Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); - let tr = - prepare_trace - (fun ty_exp -> - Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) - tr - in - let mis = mismatch txt1 env tr in - match tr with - | [] -> assert false - | elt :: tr -> - try - print_labels := not !Clflags.classic; - let tr = filter_trace (mis = None) tr in - let head = prepare_expansion_head (tr=[]) elt in - let tr = List.map (Errortrace.map_diff prepare_expansion) tr in - let head_error = head_error_printer mode txt1 txt2 head in - let tr = trees_of_trace mode tr in - Format.fprintf ppf - "@[\ - @[%t%t@]%a%t\ - @]" - head_error - ty_expect_explanation - (Fmt.compat2 trace false (incompatibility_phrase trace_format)) tr - (explain mis); - if env <> Env.empty - then (Fmt.compat1 warn_on_missing_defs env) ppf head; - Internal_names.print_explanations env ppf; - Conflicts.print_explanations ppf; - print_labels := true - with exn -> - print_labels := true; - raise exn - -let report_error trace_format ppf mode env tr - ?(subst = []) - ?(type_expected_explanation = fun _ -> ()) - txt1 txt2 = - wrap_printing_env ~error:true env (fun () -> - error trace_format mode subst env tr txt1 ppf txt2 - type_expected_explanation) - -let report_unification_error - ppf env ({trace} : Errortrace.unification_error) = - report_error Unification ppf Type env - ?subst:None trace - -let report_equality_error - ppf mode env ({subst; trace} : Errortrace.equality_error) = - report_error Equality ppf mode env - ~subst ?type_expected_explanation:None trace - -let report_moregen_error - ppf mode env ({trace} : Errortrace.moregen_error) = - report_error Moregen ppf mode env - ?subst:None ?type_expected_explanation:None trace - -let report_comparison_error ppf mode env = function - | Errortrace.Equality_error error -> report_equality_error ppf mode env error - | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error - - -module Subtype = struct - (* There's a frustrating amount of code duplication between this module and - the outside code, particularly in [prepare_trace] and [filter_trace]. - Unfortunately, [Subtype] is *just* similar enough to have code duplication, - while being *just* different enough (it's only [Diff]) for the abstraction - to be nonobvious. Someday, perhaps... *) - - let printing_status = function - | Errortrace.Subtype.Diff d -> diff_printing_status d - - let prepare_unification_trace = prepare_trace - - let prepare_trace f tr = - prepare_any_trace printing_status (Errortrace.Subtype.map f tr) - - let trace filter_trace get_diff fst keep_last txt ppf tr = - print_labels := not !Clflags.classic; - try match tr with - | elt :: tr' -> - let diffed_elt = get_diff elt in - let tr = - trees_of_trace Type - @@ List.map (Errortrace.map_diff prepare_expansion) - @@ filter_trace keep_last tr' in - let tr = - match fst, diffed_elt with - | true, Some elt -> elt :: tr - | _, _ -> tr - in - trace fst txt ppf tr; - print_labels := true - | _ -> () - with exn -> - print_labels := true; - raise exn - - let rec filter_subtype_trace keep_last = function - | [] -> [] - | [Errortrace.Subtype.Diff d as elt] - when printing_status elt = Optional_refinement -> - if keep_last then [d] else [] - | Errortrace.Subtype.Diff d :: rem -> - d :: filter_subtype_trace keep_last rem - - let unification_get_diff = function - | Errortrace.Diff diff -> - Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) - | _ -> None - - let subtype_get_diff = function - | Errortrace.Subtype.Diff diff -> - Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) - - let report_error - ppf - env - (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) - txt1 = - wrap_printing_env ~error:true env (fun () -> - reset (); - let tr_sub = prepare_trace prepare_expansion tr_sub in - let tr_unif = prepare_unification_trace prepare_expansion tr_unif in - let keep_first = match tr_unif with - | [Obj _ | Variant _ | Escape _ ] | [] -> true - | _ -> false in - Format.fprintf ppf "@[%a" - (Fmt.compat (trace filter_subtype_trace subtype_get_diff true keep_first txt1)) - tr_sub; - if tr_unif = [] then Format.fprintf ppf "@]" else - let mis = mismatch (Format.dprintf "Within this type") env tr_unif in - Format.fprintf ppf "%a%t%t@]" - (Fmt.compat (trace filter_trace unification_get_diff false - (mis = None) "is not compatible with type")) tr_unif - (explain mis) - Conflicts.print_explanations - ) -end - - - -let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = - wrap_printing_env ~error:true env (fun () -> - reset (); - let tp0 = trees_of_type_path_expansion tp0 in - match tpl with - [] -> assert false - | [tp] -> - Format.fprintf ppf - "@[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]" - txt1 (Fmt.compat type_path_expansion) (trees_of_type_path_expansion tp) - txt3 (Fmt.compat type_path_expansion) tp0 - | _ -> - Format.fprintf ppf - "@[%t@;<1 2>@[%a@]\ - @ %t@;<1 2>%a\ - @]" - txt2 (Fmt.compat type_path_list) - (List.map trees_of_type_path_expansion tpl) - txt3 (Fmt.compat type_path_expansion) tp0) - -(* Adapt functions to exposed interface *) -let tree_of_path = tree_of_path None -let tree_of_modtype = tree_of_modtype ~ellipsis:false -let type_expansion mode ppf ty_exp = - type_expansion ppf (trees_of_type_expansion mode ty_exp) -let tree_of_type_declaration ident td rs = - with_hidden_items [{hide=true; ident}] - (fun () -> tree_of_type_declaration ident td rs) - -let shorten_type_path env p = - wrap_printing_env env - (fun () -> best_type_path_simple p) - -let shorten_module_type_path env p = - wrap_printing_env env - (fun () -> best_module_type_path p) - -let shorten_module_path env p = - wrap_printing_env env - (fun () -> best_module_path p) - -let shorten_class_type_path env p = - wrap_printing_env env - (fun () -> best_class_type_path_simple p) diff --git a/src/ocaml/typing/printtyp_doc.mli b/src/ocaml/typing/printtyp_doc.mli deleted file mode 100644 index 916dd769c0..0000000000 --- a/src/ocaml/typing/printtyp_doc.mli +++ /dev/null @@ -1,243 +0,0 @@ - -(* Printing functions *) - -open Format_doc -open Types -open Outcometree - -val longident: formatter -> Longident.t -> unit -val ident: formatter -> Ident.t -> unit -val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string -val tree_of_path: Path.t -> out_ident -val path: formatter -> Path.t -> unit -val string_of_path: Path.t -> string - -val type_path: formatter -> Path.t -> unit -(** Print a type path taking account of [-short-paths]. - Calls should be within [wrap_printing_env]. *) - -module Out_name: sig - val create: string -> out_name - val print: out_name -> string -end - -type namespace := Shape.Sig_component_kind.t option - -val strings_of_paths: namespace -> Path.t list -> string list - (** Print a list of paths, using the same naming context to - avoid name collisions *) - -val raw_type_expr: formatter -> type_expr -> unit -val string_of_label: Asttypes.arg_label -> string - -val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a - (* Call the function using the environment for type path shortening *) - (* This affects all the printing functions below *) - (* Also, if [~error:true], then disable the loading of cmis *) -val shorten_type_path: Env.t -> Path.t -> Path.t -val shorten_module_type_path: Env.t -> Path.t -> Path.t -val shorten_module_path: Env.t -> Path.t -> Path.t -val shorten_class_type_path: Env.t -> Path.t -> Path.t - -module Naming_context: sig - val enable: bool -> unit - (** When contextual names are enabled, the mapping between identifiers - and names is ensured to be one-to-one. *) - - val with_arg : Ident.t -> (unit -> 'a) -> 'a -end - -(** The [Conflicts] module keeps track of conflicts arising when attributing - names to identifiers and provides functions that can print explanations - for these conflict in error messages *) -module Conflicts: sig - val exists: unit -> bool - (** [exists()] returns true if the current naming context renamed - an identifier to avoid a name collision *) - - type explanation = - { kind: Shape.Sig_component_kind.t; - name:string; - root_name:string; - location:Location.t - } - - val list_explanations: unit -> explanation list -(** [list_explanations()] return the list of conflict explanations - collected up to this point, and reset the list of collected - explanations *) - - val print_located_explanations: - Format.formatter -> explanation list -> unit - - val print_explanations: Format.formatter -> unit - (** Print all conflict explanations collected up to this point *) - - val reset: unit -> unit -end - - -val reset: unit -> unit - -(** Print out a type. This will pick names for type variables, and will not - reuse names for common type variables shared across multiple type - expressions. (It will also reset the printing state, which matters for - other type formatters such as [prepared_type_expr].) If you want multiple - types to use common names for type variables, see [prepare_for_printing] and - [prepared_type_expr]. *) -val type_expr: formatter -> type_expr -> unit - -(** [prepare_for_printing] resets the global printing environment, a la [reset], - and prepares the types for printing by reserving names and marking loops. - Any type variables that are shared between multiple types in the input list - will be given the same name when printed with [prepared_type_expr]. *) -val prepare_for_printing: type_expr list -> unit - -(** [add_type_to_preparation ty] extend a previous type expression preparation - to the type expression [ty] -*) -val add_type_to_preparation: type_expr -> unit - -val prepared_type_expr: formatter -> type_expr -> unit -(** The function [prepared_type_expr] is a less-safe but more-flexible version - of [type_expr] that should only be called on [type_expr]s that have been - passed to [prepare_for_printing]. Unlike [type_expr], this function does no - extra work before printing a type; in particular, this means that any loops - in the type expression may cause a stack overflow (see #8860) since this - function does not mark any loops. The benefit of this is that if multiple - type expressions are prepared simultaneously and then printed with - [prepared_type_expr], they will use the same names for the same type - variables. *) - -val constructor_arguments: formatter -> constructor_arguments -> unit -val tree_of_type_scheme: type_expr -> out_type -val type_scheme: formatter -> type_expr -> unit -val prepared_type_scheme: formatter -> type_expr -> unit -val shared_type_scheme: formatter -> type_expr -> unit -(** [shared_type_scheme] is very similar to [type_scheme], but does not reset - the printing context first. This is intended to be used in cases where the - printing should have a particularly wide context, such as documentation - generators; most use cases, such as error messages, have narrower contexts - for which [type_scheme] is better suited. *) - -val tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> formatter -> value_description -> unit -val label : formatter -> label_declaration -> unit -val add_constructor_to_preparation : constructor_declaration -> unit -val prepared_constructor : formatter -> constructor_declaration -> unit -val constructor : formatter -> constructor_declaration -> unit -val tree_of_type_declaration: - Ident.t -> type_declaration -> rec_status -> out_sig_item -val add_type_declaration_to_preparation : - Ident.t -> type_declaration -> unit -val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit -val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_extension_constructor: - Ident.t -> extension_constructor -> ext_status -> out_sig_item -val add_extension_constructor_to_preparation : - extension_constructor -> unit -val prepared_extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -val extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints extension constructor with the type signature: - type ('a, 'b) bar += A of float -*) - -val extension_only_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints only extension constructor without type signature: - A of float -*) - -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item -val modtype: formatter -> module_type -> unit -val signature: formatter -> signature -> unit -val tree_of_modtype: module_type -> out_module_type -val tree_of_modtype_declaration: - Ident.t -> modtype_declaration -> out_sig_item - -(** Print a list of functor parameters while adjusting the printing environment - for each functor argument. - - Currently, we are disabling disambiguation for functor argument name to - avoid the need to track the moving association between identifiers and - syntactic names in situation like: - - got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) - expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) -*) -val functor_parameters: - sep:(formatter -> unit -> unit) -> - ('b -> formatter -> unit) -> - (Ident.t option * 'b) list -> formatter -> unit - -type type_or_scheme = Type | Type_scheme - -val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: type_or_scheme -> type_expr -> out_type -val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit -val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit -val type_expansion : - type_or_scheme -> formatter -> Errortrace.expanded_type -> unit -val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type -val report_ambiguous_type_error: - Format.formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - (Format.formatter -> unit) -> (Format.formatter -> unit) -> - (Format.formatter -> unit) -> unit - -val report_unification_error : - Format.formatter -> - Env.t -> Errortrace.unification_error -> - ?type_expected_explanation:(Format.formatter -> unit) -> - (Format.formatter -> unit) -> (Format.formatter -> unit) -> - unit - -val report_equality_error : - Format.formatter -> - type_or_scheme -> - Env.t -> Errortrace.equality_error -> - (Format.formatter -> unit) -> (Format.formatter -> unit) -> - unit - -val report_moregen_error : - Format.formatter -> - type_or_scheme -> - Env.t -> Errortrace.moregen_error -> - (Format.formatter -> unit) -> (Format.formatter -> unit) -> - unit - -val report_comparison_error : - Format.formatter -> - type_or_scheme -> - Env.t -> Errortrace.comparison_error -> - (Format.formatter -> unit) -> (Format.formatter -> unit) -> - unit - -module Subtype : sig - val report_error : - Format.formatter -> - Env.t -> - Errortrace.Subtype.error -> - string -> - unit -end - -(* for toploop *) -val print_items: (Env.t -> signature_item -> 'a option) -> - Env.t -> signature_item list -> (out_sig_item * 'a option) list - -(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias - for Foo__bar. This pattern is used by the stdlib. *) -val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t - -(** [printed_signature sourcefile ppf sg] print the signature [sg] of - [sourcefile] with potential warnings for name collisions *) -val printed_signature: string -> formatter -> signature -> unit diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index ad0c54dbee..50bb030328 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -1252,7 +1252,7 @@ end) = struct [_] -> [] | _ -> let open Printtyp in wrap_printing_env ~error:true env (fun () -> - Out_type.reset(); strings_of_paths (Some Type) tpaths) + Out_type.reset(); strings_of_paths Type tpaths) let disambiguate_by_type env tpath lbls = match lbls with diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 0610c65076..606d57c350 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -1625,7 +1625,7 @@ let check_unboxable env loc ty = let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in Path.Set.fold (fun p () -> - let p = Printtyp.shorten_type_path env p in + let p = Out_type.shorten_type_path env p in Location.prerr_warning loc (Warnings.Unboxable_type_in_prim_decl (Path.name p)) ) diff --git a/tests/test-dirs/errors/reg503.t b/tests/test-dirs/errors/reg503.t index a239bbef80..7511890612 100644 --- a/tests/test-dirs/errors/reg503.t +++ b/tests/test-dirs/errors/reg503.t @@ -24,7 +24,7 @@ FIXME: Type variable are not shared between the two parts of the error message: "valid": true, "message": "Some type variables are unbound in this type: class test : 'a -> object method b : 'b -> 'b end - The method b has type 'a -> 'a where 'a is unbound" + The method b has type 'b -> 'b where 'b is unbound" } ], "notifications": [] diff --git a/tests/test-dirs/issue1322.t/run.t b/tests/test-dirs/issue1322.t/run.t index 3a78027189..d4d4cb9329 100644 --- a/tests/test-dirs/issue1322.t/run.t +++ b/tests/test-dirs/issue1322.t/run.t @@ -17,7 +17,7 @@ "message": "In this with constraint, the new definition of t does not match its original definition in the constrained signature: Type declarations do not match: - type 'a t = 'a option constraint 'a = int + type 'a t = 'a t constraint 'a = int is not included in type 'a t Their parameters differ diff --git a/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t index 0654dbb1f7..bc08f293bb 100644 --- a/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t +++ b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t @@ -82,7 +82,7 @@ a list. } { "name": "Seq.concat", - "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" + "type": "'a Seq.t Seq.t -> 'a Seq.t" } { "name": "Option.join", @@ -90,7 +90,7 @@ a list. } { "name": "Seq.transpose", - "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" + "type": "'a Seq.t Seq.t -> 'a Seq.t Seq.t" } { "name": "Result.join", @@ -130,7 +130,7 @@ map). } { "name": "Seq.map", - "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t" + "type": "('a -> 'b) -> 'a Seq.t -> 'b Seq.t" } { "name": "List.concat_map", @@ -179,7 +179,7 @@ a list. } { "name": "Seq.concat", - "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" + "type": "'a Seq.t Seq.t -> 'a Seq.t" } { "name": "Option.join", @@ -187,7 +187,7 @@ a list. } { "name": "Seq.transpose", - "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" + "type": "'a Seq.t Seq.t -> 'a Seq.t Seq.t" } { "name": "Result.join", diff --git a/tests/test-dirs/search/search-by-type.t/run.t b/tests/test-dirs/search/search-by-type.t/run.t index 8bfee4acfa..67a21de81c 100644 --- a/tests/test-dirs/search/search-by-type.t/run.t +++ b/tests/test-dirs/search/search-by-type.t/run.t @@ -104,7 +104,7 @@ } { "name": "Seq.map", - "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t", + "type": "('a -> 'b) -> 'a Seq.t -> 'b Seq.t", "cost": 10, "doc": null } @@ -144,7 +144,7 @@ "col": 40 }, "name": "Hashtbl.add", - "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "type": "('a, 'b) Hashtbl.t -> 'a -> 'b -> unit", "cost": 1, "doc": null, "constructible": "Hashtbl.add _ _ _" @@ -160,7 +160,7 @@ "col": 44 }, "name": "Hashtbl.replace", - "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "type": "('a, 'b) Hashtbl.t -> 'a -> 'b -> unit", "cost": 2, "doc": null, "constructible": "Hashtbl.replace _ _ _" @@ -176,7 +176,7 @@ "col": 50 }, "name": "Hashtbl.add_seq", - "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "type": "('a, 'b) Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 24, "doc": null, "constructible": "Hashtbl.add_seq _ _" @@ -192,7 +192,7 @@ "col": 54 }, "name": "Hashtbl.replace_seq", - "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "type": "('a, 'b) Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 25, "doc": null, "constructible": "Hashtbl.replace_seq _ _" @@ -209,8 +209,7 @@ }, "name": "Either.map", "type": "left:('a1 -> 'a2) -> - right:('b1 -> 'b2) -> - ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", + right:('b1 -> 'b2) -> ('a1, 'b1) Either.t -> ('a2, 'b2) Either.t", "cost": 44, "doc": null, "constructible": "Either.map ~left:_ ~right:_ _" @@ -226,7 +225,7 @@ "col": 51 }, "name": "MoreLabels.Hashtbl.add", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "type": "('a, 'b) MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", "cost": 47, "doc": null, "constructible": "MoreLabels.Hashtbl.add _ ~key:_ ~data:_" @@ -242,7 +241,7 @@ "col": 52 }, "name": "MoreLabels.Hashtbl.add_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "type": "('a, 'b) MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 48, "doc": null, "constructible": "MoreLabels.Hashtbl.add_seq _ _" @@ -258,7 +257,7 @@ "col": 55 }, "name": "MoreLabels.Hashtbl.replace", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "type": "('a, 'b) MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", "cost": 48, "doc": null, "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" @@ -274,7 +273,7 @@ "col": 56 }, "name": "MoreLabels.Hashtbl.replace_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "type": "('a, 'b) MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 49, "doc": null, "constructible": "MoreLabels.Hashtbl.replace_seq _ _" @@ -290,7 +289,7 @@ "col": 55 }, "name": "Ephemeron.K2.query", - "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", + "type": "('k1, 'k2, 'd) Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", "cost": 53, "doc": null, "constructible": "Ephemeron.K2.query _ _ _" diff --git a/tests/test-dirs/short-paths.t/run.t b/tests/test-dirs/short-paths.t/run.t index 17e5853287..b861fbddf6 100644 --- a/tests/test-dirs/short-paths.t/run.t +++ b/tests/test-dirs/short-paths.t/run.t @@ -17,7 +17,7 @@ "sub": [], "valid": true, "message": "Some type variables are unbound in this type: class b : 'a -> a - The method x has type 'c where 'c is unbound" + The method x has type 'b where 'b is unbound" }, { "start": { diff --git a/tests/test-dirs/type-enclosing/gadt_wrong.t b/tests/test-dirs/type-enclosing/gadt_wrong.t index ba73e211e5..3d683a9464 100644 --- a/tests/test-dirs/type-enclosing/gadt_wrong.t +++ b/tests/test-dirs/type-enclosing/gadt_wrong.t @@ -27,7 +27,7 @@ Initially from issue https://github.com/ocaml/merlin/issues/1125 "line": 3, "col": 7 }, - "type": "(module Stdlib__Int)", + "type": "(module Int)", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/generic-types.t b/tests/test-dirs/type-enclosing/generic-types.t index b3ed43681a..455b044ad7 100644 --- a/tests/test-dirs/type-enclosing/generic-types.t +++ b/tests/test-dirs/type-enclosing/generic-types.t @@ -74,7 +74,7 @@ With index 0 only the first type is shown: "line": 1, "col": 12 }, - "type": "(module Stdlib__List)", + "type": "(module List)", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/types.t/run.t b/tests/test-dirs/type-enclosing/types.t/run.t index cf9d7175a1..e4a5bf69f3 100644 --- a/tests/test-dirs/type-enclosing/types.t/run.t +++ b/tests/test-dirs/type-enclosing/types.t/run.t @@ -108,7 +108,7 @@ FIXME: A type with a type param shouldn't equal itself - aliasing a list type "line": 11, "col": 19 }, - "type": "type 'a l = 'a l", + "type": "type 'a l = 'a list", "tail": "no" } ] @@ -127,7 +127,7 @@ Same result regardless of verbosity: "line": 11, "col": 19 }, - "type": "type 'a l = 'a l", + "type": "type 'a l = 'a list", "tail": "no" } ] From c45c4502ceb193794a64353f4e5acf5bed9fd8b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 13 Dec 2024 19:07:31 +0100 Subject: [PATCH 4/5] Use the manifest to print the type of a type-decl if available --- src/analysis/type_enclosing.ml | 5 +++-- src/analysis/type_utils.ml | 17 +++++++++++++---- tests/test-dirs/sp-normalization.t | 2 +- tests/test-dirs/type-enclosing/inside-tydecl.t | 4 ++-- tests/test-dirs/type-enclosing/issue1335.t | 2 +- tests/test-dirs/type-enclosing/issue1755.t | 2 +- tests/test-dirs/type-enclosing/variants.t/run.t | 4 ++-- 7 files changed, 23 insertions(+), 13 deletions(-) diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index 2b1435e9c0..5e9f6a8e4b 100644 --- a/src/analysis/type_enclosing.ml +++ b/src/analysis/type_enclosing.ml @@ -135,8 +135,9 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs = try let ppf, to_string = Format.to_string () in if Type_utils.type_in_env ~verbosity ~context env ppf source then ( - log ~title:"from_reconstructed" "typed %s" source; - Some (loc, String (to_string ()), `No)) + let result = to_string () in + log ~title:"from_reconstructed" "typed %s : %s" source result; + Some (loc, String result, `No)) else ( log ~title:"from_reconstructed" "FAILED to type %s" source; None) diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index dbb142ecdc..39e8f29b29 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -28,6 +28,9 @@ open Std +let log_section = "type-utils" +let { Logger.log } = Logger.for_section log_section + module Verbosity = Mconfig.Verbosity let protect expr = @@ -246,9 +249,13 @@ let print_exn ppf exn = let print_type ppf env lid = let p, t = Env.find_type_by_name lid.Asttypes.txt env in - Printtyp.type_declaration env - (Ident.create_persistent (* Incorrect, but doesn't matter. *) (Path.last p)) - ppf t + match t.type_manifest with + | None -> + Printtyp.type_declaration env + (Ident.create_persistent + (* Incorrect, but doesn't matter. *) (Path.last p)) + ppf t + | Some type_expr -> Printtyp.type_expr ppf type_expr let print_modtype ppf verbosity env lid = let _p, mtd = Env.find_modtype_by_name lid.Asttypes.txt env in @@ -305,7 +312,9 @@ let type_in_env ?(verbosity = Verbosity.default) ?keywords ~context env ppf expr (* We use information from the context because `Env.find_label_by_name` can fail *) Printtyp.type_expr ppf lbl_des.lbl_arg - | Type -> print_type ppf env longident + | Type -> + log ~title:"type_in_env" "Type type"; + print_type ppf env longident (* TODO: special processing for module aliases ? *) | Module_type -> print_modtype ppf verbosity env longident | Module_path -> print_modpath ppf verbosity env longident diff --git a/tests/test-dirs/sp-normalization.t b/tests/test-dirs/sp-normalization.t index 69f87d8d3a..6e4aea91cb 100644 --- a/tests/test-dirs/sp-normalization.t +++ b/tests/test-dirs/sp-normalization.t @@ -26,7 +26,7 @@ This query should not hang indefinitely "line": 11, "col": 18 }, - "type": "type t = unit", + "type": "unit", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/inside-tydecl.t b/tests/test-dirs/type-enclosing/inside-tydecl.t index 2fda8883cc..6daf9e309d 100644 --- a/tests/test-dirs/type-enclosing/inside-tydecl.t +++ b/tests/test-dirs/type-enclosing/inside-tydecl.t @@ -15,7 +15,7 @@ test node = core_type exprs = [t1] source = t1; context = type - typed t1 + typed t1 : t1 result = [ File "inside_decl.ml", line 1, characters 18-20 ] { "class": "return", @@ -29,7 +29,7 @@ test "line": 1, "col": 20 }, - "type": "type t1 = t1", + "type": "t1", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/issue1335.t b/tests/test-dirs/type-enclosing/issue1335.t index 99cafcb8ea..bc58bdcef7 100644 --- a/tests/test-dirs/type-enclosing/issue1335.t +++ b/tests/test-dirs/type-enclosing/issue1335.t @@ -24,7 +24,7 @@ provide better result. "line": 4, "col": 15 }, - "type": "type 'a t = 'b t", + "type": "'a t", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/issue1755.t b/tests/test-dirs/type-enclosing/issue1755.t index a8a3262781..7f417cffb1 100644 --- a/tests/test-dirs/type-enclosing/issue1755.t +++ b/tests/test-dirs/type-enclosing/issue1755.t @@ -21,7 +21,7 @@ provide better result. "line": 1, "col": 25 }, - "type": "type b = b", + "type": "b", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/variants.t/run.t b/tests/test-dirs/type-enclosing/variants.t/run.t index 93df6704a0..e2bb85dc76 100644 --- a/tests/test-dirs/type-enclosing/variants.t/run.t +++ b/tests/test-dirs/type-enclosing/variants.t/run.t @@ -10,7 +10,7 @@ "line": 2, "col": 18 }, - "type": "type core = [ `A | `B ]", + "type": "[ `A | `B ]", "tail": "no" }, { @@ -119,7 +119,7 @@ "line": 5, "col": 12 }, - "type": "type core = [ `A | `B ]", + "type": "[ `A | `B ]", "tail": "no" }, { From d1cacae010100bacbbb745de8824c78cc05bfa9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 20 Dec 2024 16:26:26 +0100 Subject: [PATCH 5/5] Fix regression in typeclass --- src/ocaml/typing/typeclass.ml | 6 +++--- tests/test-dirs/short-paths.t/run.t | 11 ++++------- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index 755b77e9f4..7106baa525 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -1840,7 +1840,7 @@ let type_classes define_class approx kind env cls = )) cls in - let res, env = + let res, newenv = Ctype.with_local_level_generalize_for_class begin fun () -> let (res, env) = List.fold_left (initial_env define_class approx) ([], env) cls @@ -1852,10 +1852,10 @@ let type_classes define_class approx kind env cls = res, env end in - let res = List.rev_map (final_decl env define_class) res in + let res = List.rev_map (final_decl newenv define_class) res in let decls = List.fold_right extract_type_decls res [] in let decls = - try Typedecl_variance.update_class_decls env decls + try Typedecl_variance.update_class_decls newenv decls with Typedecl_variance.Error(loc, err) -> raise (Typedecl.Error(loc, Typedecl.Variance err)) in diff --git a/tests/test-dirs/short-paths.t/run.t b/tests/test-dirs/short-paths.t/run.t index b861fbddf6..9dd8360970 100644 --- a/tests/test-dirs/short-paths.t/run.t +++ b/tests/test-dirs/short-paths.t/run.t @@ -193,7 +193,7 @@ "sub": [], "valid": true, "message": "Some type variables are unbound in this type: class b : 'a -> a - The method x has type 'c where 'c is unbound" + The method x has type 'b where 'b is unbound" }, { "start": { @@ -309,7 +309,7 @@ "type": "typer", "sub": [], "valid": true, - "message": "The value x has type t but an expression was expected of type unit" + "message": "The value x has type N.O.t but an expression was expected of type unit" }, { "start": { @@ -325,10 +325,7 @@ "valid": true, "message": "Modules do not match: sig type t = int val foo : 'a -> string end is not included in S - Values do not match: - val foo : 'a -> string - is not included in - val foo : int -> t + Values do not match: val foo : 'a -> string is not included in val foo : t -> t The type t -> string is not compatible with the type t -> t Type string is not compatible with type t File \"test.ml\", line 72, characters 2-20: Expected declaration @@ -346,7 +343,7 @@ "type": "typer", "sub": [], "valid": true, - "message": "The constant 5 has type int but an expression was expected of type Dep.M.t" + "message": "The constant 5 has type int but an expression was expected of type Dep.t" } ], "notifications": []