From e653b1eb0c07d73edeca41c895ebd57a782339a8 Mon Sep 17 00:00:00 2001 From: Florian Angeletti Date: Wed, 25 Jan 2023 14:35:16 +0100 Subject: use Shape component kinds in printtyp --- typing/printtyp.ml | 125 +++++++++++++++++++++++++++------------------------- typing/printtyp.mli | 11 ++--- typing/typecore.ml | 2 +- 3 files changed, 68 insertions(+), 70 deletions(-) (limited to 'typing') diff --git a/typing/printtyp.ml b/typing/printtyp.ml index a6f8ca92cc..93ff03362a 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -26,6 +26,7 @@ open Btype open Outcometree module String = Misc.Stdlib.String +module Sig_component_kind = Shape.Sig_component_kind (* Print a long identifier *) @@ -54,14 +55,15 @@ let printing_env = ref Env.empty cmi present on the file system *) let in_printing_env f = Env.without_cmis f !printing_env + type namespace = Sig_component_kind.t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type -type namespace = - | Type - | Module - | Module_type - | Class - | Class_type - | Other (** Other bypasses the unique name identifier mechanism *) module Namespace = struct @@ -71,20 +73,14 @@ module Namespace = struct | Module_type -> 2 | Class -> 3 | Class_type -> 4 - | Other -> 5 + | Extension_constructor | Value -> 5 + (* we do not handle those component *) - let size = 1 + id Other + let size = 1 + id Value - let show = - function - | Type -> "type" - | Module -> "module" - | Module_type -> "module type" - | Class -> "class" - | Class_type -> "class type" - | Other -> "" - let pp ppf x = Format.pp_print_string ppf (show x) + let pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x) (** The two functions below should never access the filesystem, and thus use {!in_printing_env} rather than directly @@ -92,32 +88,32 @@ module Namespace = struct let lookup = let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in function - | Type -> to_lookup Env.find_type_by_name - | Module -> to_lookup Env.find_module_by_name - | Module_type -> to_lookup Env.find_modtype_by_name - | Class -> to_lookup Env.find_class_by_name - | Class_type -> to_lookup Env.find_cltype_by_name - | Other -> fun _ -> raise Not_found + | 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) -> fun _ -> raise Not_found let location namespace id = let path = Path.Pident id in try Some ( match namespace with - | Type -> (in_printing_env @@ Env.find_type path).type_loc - | Module -> (in_printing_env @@ Env.find_module path).md_loc - | Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc - | Class -> (in_printing_env @@ Env.find_class path).cty_loc - | Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Other -> Location.none + | 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) | None -> Location.none ) with Not_found -> None let best_class_namespace = function - | Papply _ | Pdot _ -> Module + | Papply _ | Pdot _ -> Some Module | Pextra_ty _ -> assert false (* Only in type path *) | Pident c -> - match location Class c with - | Some _ -> Class - | None -> Class_type + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type end @@ -134,7 +130,7 @@ module Conflicts = struct let explanations = ref M.empty let add namespace name id = - match Namespace.location namespace id with + match Namespace.location (Some namespace) id with | None -> () | Some location -> let explanation = @@ -154,14 +150,14 @@ module Conflicts = struct (* lookup the identifier in scope with name [root_name] and add it too *) - match Namespace.lookup namespace root_name with + 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 %s@]" - Location.print_loc r.location (Namespace.show r.kind) r.name + Location.print_loc r.location (Sig_component_kind.to_string r.kind) r.name let print_located_explanations ppf l = Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l @@ -288,7 +284,7 @@ let indexed_name namespace id = | Module_type -> Env.find_modtype_index id env | Class -> Env.find_class_index id env | Class_type-> Env.find_cltype_index id env - | Other -> None + | Value | Extension_constructor -> None in let index = match M.find_opt (Ident.name id) !bound_in_recursion with @@ -318,17 +314,23 @@ let indexed_name namespace id = human_id id index let ident_name namespace id = - if not !enabled || 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 + 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 Other id)) + (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 *) @@ -400,26 +402,26 @@ let 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 Other 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 Module p, s) + Oide_dot (tree_of_path (Some Module) p, s) | Papply(p1, p2) -> - let t1 = tree_of_path Module p1 in - let t2 = tree_of_path Module p2 in + 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 Type p, s) + Oide_dot (tree_of_path (Some Type) p, s) | Pext_ty -> - tree_of_path Other p + tree_of_path None p end let tree_of_path ?disambiguation namespace p = @@ -427,7 +429,7 @@ let tree_of_path ?disambiguation namespace p = (rewrite_double_underscore_paths !printing_env p) let path ppf p = - !Oprint.out_ident ppf (tree_of_path Other p) + !Oprint.out_ident ppf (tree_of_path None p) let string_of_path p = Format.asprintf "%a" path p @@ -767,8 +769,8 @@ let best_type_path p = 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 Type p' - else tree_of_path ~disambiguation:false Other 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 *) @@ -1186,7 +1188,7 @@ let rec tree_of_typexp mode ty = String.concat "." (Longident.flatten li), tree_of_typexp mode ty )) fl in - Otyp_module (tree_of_path Module_type p, fl) + Otyp_module (tree_of_path (Some Module_type) p, fl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; if is_aliased_proxy px && aliasable ty then begin @@ -1907,7 +1909,7 @@ let add_sigitem env x = let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> - Omty_ident (tree_of_path Module_type p) + Omty_ident (tree_of_path (Some Module_type) p) | Mty_signature sg -> Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) @@ -1918,7 +1920,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 -> - Omty_alias (tree_of_path Module p) + Omty_alias (tree_of_path (Some Module) p) and tree_of_functor_parameter = function | Unit -> @@ -2113,8 +2115,8 @@ 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 Type tp) else - Diff(tree_of_path Type tp, tree_of_path Type 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 -> !Oprint.out_ident ppf p @@ -2211,7 +2213,8 @@ let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = reserve_names ty; Errortrace.{ty; expanded = ty} | _ -> prepare_expansion ty_exp -let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path Type p) +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) let print_tag ppf = fprintf ppf "`%s" @@ -2600,7 +2603,7 @@ let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = txt3 type_path_expansion tp0) (* Adapt functions to exposed interface *) -let tree_of_path = tree_of_path Other +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) diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 01c982abd4..eaa3599183 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -21,6 +21,7 @@ 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 @@ -34,13 +35,7 @@ module Out_name: sig val print: out_name -> string end -type namespace = - | Type - | Module - | Module_type - | Class - | Class_type - | Other (** Other bypasses the unique name for identifier mechanism *) +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 @@ -69,7 +64,7 @@ module Conflicts: sig an identifier to avoid a name collision *) type explanation = - { kind: namespace; + { kind: Shape.Sig_component_kind.t; name:string; root_name:string; location:Location.t diff --git a/typing/typecore.ml b/typing/typecore.ml index d5f88241f6..e92dec8f17 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -966,7 +966,7 @@ end) = struct [_] -> [] | _ -> let open Printtyp in wrap_printing_env ~error:true env (fun () -> - reset(); strings_of_paths Type tpaths) + reset(); strings_of_paths (Some Type) tpaths) let disambiguate_by_type env tpath lbls = match lbls with -- cgit v1.2.1