use Shape component kinds in printtyp

3 files changed, 68 insertions, 70 deletions

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 "@[<v 2>%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 "@[<v>%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