Merge pull request ocaml#1876 from voodoos/503-preview

Re-apply changes to Printtyp and fix a regression in short paths

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

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;

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

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

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

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 =

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)

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

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 =
@@ -145,7 +148,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
@@ -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