Improve Component.Fmt

src/xref2/component.ml

@@ -590,6 +590,12 @@ module Fmt = struct
     show_removed : bool;
     show_expansions : bool;
     show_include_expansions : bool;
+    identifier_name_only : bool;
+        (** Print Identifier-wrapped paths using only the leaf name (as the HTML
+            renderer does). When canonical resolution has lifted a path like
+            [Mylib.A] into a single Identifier, this prints just [A]. Has no
+            effect on Module-step paths where the structure inherently requires
+            walking the chain. *)
   }
 
   let default =
@@ -599,6 +605,7 @@ module Fmt = struct
       show_removed = true;
       show_expansions = true;
       show_include_expansions = true;
+      identifier_name_only = false;
     }
 
   type id = Odoc_model.Paths.Identifier.t
@@ -772,8 +779,13 @@ module Fmt = struct
     let ident_fmt = if c.short_paths then Ident.short_fmt else Ident.fmt in
     let sig_item ppf = function
       | Module (id, _, m) ->
-          Format.fprintf ppf "@[<hov 2>module %a %a@]" ident_fmt id (module_ c)
-            (Delayed.get m)
+          let m = Delayed.get m in
+          let hidden_name = ModuleName.is_hidden (Ident.Name.typed_module id) in
+          let lb, rb =
+            if m.hidden || hidden_name then ("[", "]") else ("", "")
+          in
+          Format.fprintf ppf "@[<hov 2>module %s%a%s %a@]" lb ident_fmt id rb
+            (module_ c) m
       | ModuleSubstitution (id, m) ->
           Format.fprintf ppf "@[<v 2>module %a := %a@]" ident_fmt id
             (module_path c) m.ModuleSubstitution.manifest
@@ -939,20 +951,23 @@ module Fmt = struct
 
   and module_ c ppf m =
     let fmt_canonical ppf popt =
-      if c.show_canonical then
-        Format.fprintf ppf "@ (canonical=%a)" (option c model_path) popt
-      else ()
+      match popt with
+      | Some p when c.show_canonical ->
+          Format.fprintf ppf "@ (canonical=%a)" (model_path c) p
+      | _ -> ()
     in
     Format.fprintf ppf "%a%a" (module_decl c) m.type_ fmt_canonical
       (m.canonical :> path option)
 
   and simple_expansion c is_include ppf (m : ModuleType.simple_expansion) =
     if c.show_expansions || (is_include && c.show_include_expansions) then
       match m with
+      | ModuleType.Signature sg when is_empty_sg sg ->
+          Format.fprintf ppf "=> sig end"
       | ModuleType.Signature sg ->
-          Format.fprintf ppf "@[<hv 2>(sig :@ %a@;<1 -1>end@])" (signature c) sg
+          Format.fprintf ppf "@[<hv 2>=> sig@ %a@;<1 -1>end@]" (signature c) sg
       | Functor (arg, sg) ->
-          Format.fprintf ppf "(functor: (%a) -> %a)" (functor_parameter c) arg
+          Format.fprintf ppf "=> functor (%a) -> %a" (functor_parameter c) arg
             (simple_expansion c is_include)
             sg
     else ()
@@ -972,11 +987,15 @@ module Fmt = struct
         Format.fprintf ppf "module type of struct include %a end"
           (module_path c) p
 
+  and is_empty_sg (sg : Signature.t) = sg.items = [] && sg.removed = []
+
   and u_module_type_expr c ppf mt =
     let open ModuleType.U in
     match mt with
     | Path p -> module_type_path c ppf p
-    | Signature sg -> Format.fprintf ppf "sig@,@[<v 2>%a@]end" (signature c) sg
+    | Signature sg when is_empty_sg sg -> Format.fprintf ppf "sig end"
+    | Signature sg ->
+        Format.fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" (signature c) sg
     | With (subs, e) ->
         Format.fprintf ppf "%a with [%a]" (u_module_type_expr c) e
           (substitution_list c) subs
@@ -989,6 +1008,7 @@ module Fmt = struct
     let open ModuleType in
     match mt with
     | Path { p_path; _ } -> module_type_path c ppf p_path
+    | Signature sg when is_empty_sg sg -> Format.fprintf ppf "sig end"
     | Signature sg ->
         Format.fprintf ppf "@,@[<hv 2>sig@ %a@;<1 -2>end@]" (signature c) sg
     | With { w_substitutions = subs; w_expr; _ } ->
@@ -1023,7 +1043,8 @@ module Fmt = struct
     | Named x -> Format.fprintf ppf "%a" (functor_parameter_parameter c) x
 
   and functor_parameter_parameter c ppf x =
-    Format.fprintf ppf "%a : %a" Ident.fmt x.FunctorParameter.id
+    let ident_fmt = if c.short_paths then Ident.short_fmt else Ident.fmt in
+    Format.fprintf ppf "%a : %a" ident_fmt x.FunctorParameter.id
       (module_type_expr c) x.FunctorParameter.expr
 
   and type_decl c ppf t =
@@ -1045,11 +1066,16 @@ module Fmt = struct
 
   and type_decl_constructor c ppf t =
     let open TypeDecl.Constructor in
+    let no_args =
+      match t.args with Tuple [] -> true | Tuple _ | Record _ -> false
+    in
     match t.res with
+    | Some res when no_args -> fpf ppf "%s : %a" t.name (type_expr c) res
     | Some res ->
         fpf ppf "%s : %a -> %a" t.name
           (type_decl_constructor_arg c)
           t.args (type_expr c) res
+    | None when no_args -> fpf ppf "%s" t.name
     | None -> fpf ppf "%s of %a" t.name (type_decl_constructor_arg c) t.args
 
   and type_decl_constructor_arg c ppf =
@@ -1093,19 +1119,20 @@ module Fmt = struct
     let pp_sep ppf () = Format.fprintf ppf ", " in
     Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep type_param) ts
 
-  and type_equation_manifest c ppf t =
+  and type_equation_manifest ?(sep = "=") c ppf t =
     match t.TypeDecl.Equation.manifest with
     | None -> ()
-    | Some m -> Format.fprintf ppf " = %a" (type_expr c) m
+    | Some m -> Format.fprintf ppf " %s %a" sep (type_expr c) m
 
   and type_equation_params _c ppf t =
     match t.TypeDecl.Equation.params with
     | [] -> ()
-    | ps -> Format.fprintf ppf "%a" type_params ps
+    | ps -> Format.fprintf ppf " %a" type_params ps
 
-  and type_equation c ppf t =
-    Format.fprintf ppf "(params %a)%a" (type_equation_params c) t
-      (type_equation_manifest c) t
+  and type_equation ?sep c ppf t =
+    Format.fprintf ppf "%a%a" (type_equation_params c) t
+      (type_equation_manifest ?sep c)
+      t
 
   and exception_ _c _ppf _e = ()
 
@@ -1129,7 +1156,9 @@ module Fmt = struct
     | TypeEq (frag, decl) ->
         Format.fprintf ppf "%a%a" (type_fragment c) frag (type_equation c) decl
     | TypeSubst (frag, decl) ->
-        Format.fprintf ppf "%a%a" (type_fragment c) frag (type_equation c) decl
+        Format.fprintf ppf "%a%a" (type_fragment c) frag
+          (type_equation ~sep:":=" c)
+          decl
 
   and substitution_list c ppf l =
     match l with
@@ -1193,20 +1222,36 @@ module Fmt = struct
 
   and type_expr c ppf e =
     let open TypeExpr in
+    let needs_outer_parens = function
+      (* Things that are looser than the constructor-application slot. *)
+      | Arrow _ | Tuple _ | Unboxed_tuple _ -> true
+      | _ -> false
+    in
+    let pp_atom ppf t =
+      if needs_outer_parens t then Format.fprintf ppf "(%a)" (type_expr c) t
+      else type_expr c ppf t
+    in
     match e with
     | Var x -> Format.fprintf ppf "%s" x
     | Any -> Format.fprintf ppf "_"
     | Alias (x, y) -> Format.fprintf ppf "(alias %a %s)" (type_expr c) x y
-    | Arrow (l, t1, t2) ->
-        Format.fprintf ppf "%a(%a) -> %a" type_expr_label l (type_expr c) t1
-          (type_expr c) t2
+    | Arrow (l, t1, t2) -> (
+        (* -> is right-associative: only wrap LHS when it is itself an arrow. *)
+        match t1 with
+        | Arrow _ ->
+            Format.fprintf ppf "%a(%a) -> %a" type_expr_label l (type_expr c) t1
+              (type_expr c) t2
+        | _ ->
+            Format.fprintf ppf "%a%a -> %a" type_expr_label l (type_expr c) t1
+              (type_expr c) t2)
     | Tuple ts -> Format.fprintf ppf "(%a)" (type_labeled_tuple c) ts
     | Unboxed_tuple ts -> Format.fprintf ppf "#(%a)" (type_labeled_tuple c) ts
     | Constr (p, args) -> (
         match args with
         | [] -> Format.fprintf ppf "%a" (type_path c) p
+        | [ a ] -> Format.fprintf ppf "%a %a" pp_atom a (type_path c) p
         | _ ->
-            Format.fprintf ppf "[%a] %a" (type_expr_list c) args (type_path c) p
+            Format.fprintf ppf "(%a) %a" (type_expr_list c) args (type_path c) p
         )
     | Polymorphic_variant poly ->
         Format.fprintf ppf "(poly_var %a)"
@@ -1244,7 +1289,7 @@ module Fmt = struct
           p2
     | `Hidden p1 -> wrap c "hidden" resolved_module_path ppf p1
     | `Canonical (p1, p2) ->
-        wrap2 c "canonical" resolved_module_path model_path ppf p1 (p2 :> path)
+        wrap2r c "canonical" resolved_module_path model_path ppf p1 (p2 :> path)
     | `OpaqueModule m -> wrap c "opaquemodule" resolved_module_path ppf m
 
   and module_path : config -> Format.formatter -> Cpath.module_ -> unit =
@@ -1275,7 +1320,7 @@ module Fmt = struct
         Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
           (ModuleTypeName.to_string m)
     | `CanonicalModuleType (m1, m2) ->
-        wrap2 c "canonicalt" resolved_module_type_path model_path ppf m1
+        wrap2r c "canonicalt" resolved_module_type_path model_path ppf m1
           (m2 :> path)
     | `OpaqueModuleType m ->
         wrap c "opaquemoduletype" resolved_module_type_path ppf m
@@ -1311,7 +1356,7 @@ module Fmt = struct
     | `Substituted x -> wrap c "substituted" resolved_type_path ppf x
     | `Unbox x -> wrap c "unbox" resolved_type_path ppf x
     | `CanonicalType (t1, t2) ->
-        wrap2 c "canonicaltype" resolved_type_path model_path ppf t1
+        wrap2r c "canonicaltype" resolved_type_path model_path ppf t1
           (t2 :> path)
     | `Class (p, t) ->
         Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
@@ -1416,6 +1461,8 @@ module Fmt = struct
 
     match p with
     | `Resolved rp -> wrap c "resolved" model_resolved_path ppf rp
+    | `Identifier (id, _) when c.identifier_name_only ->
+        Format.fprintf ppf "%s" (Odoc_model.Paths.Identifier.name (id :> id))
     | `Identifier (id, b) ->
         wrap2 c "identifier" model_identifier bool ppf (id :> id) b
     | `Root s -> wrap c "root" str ppf (ModuleName.to_string s)
@@ -1443,6 +1490,8 @@ module Fmt = struct
     let open Odoc_model.Paths.Path.Resolved in
     match p with
     | `CoreType x -> Format.fprintf ppf "%s" (TypeName.to_string x)
+    | `Identifier id when c.identifier_name_only ->
+        Format.fprintf ppf "%s" (Odoc_model.Paths.Identifier.name (id :> id))
     | `Identifier id -> Format.fprintf ppf "%a" (model_identifier c) (id :> id)
     | `Module (parent, name) ->
         Format.fprintf ppf "%a.%s" (model_resolved_path c)
@@ -1477,11 +1526,11 @@ module Fmt = struct
           (t1 :> t)
           (t2 :> t)
     | `CanonicalModuleType (t1, t2) ->
-        wrap2 c "canonicalmoduletype" model_resolved_path model_path ppf
+        wrap2r c "canonicalmoduletype" model_resolved_path model_path ppf
           (t1 :> t)
           (t2 :> path)
     | `CanonicalType (t1, t2) ->
-        wrap2 c "canonicaltype" model_resolved_path model_path ppf
+        wrap2r c "canonicaltype" model_resolved_path model_path ppf
           (t1 :> t)
           (t2 :> path)
     | `Apply (funct, arg) ->
@@ -1490,7 +1539,7 @@ module Fmt = struct
           (model_resolved_path c)
           (arg :> t)
     | `Canonical (p1, p2) ->
-        wrap2 c "canonical" model_resolved_path model_path ppf
+        wrap2r c "canonical" model_resolved_path model_path ppf
           (p1 :> t)
           (p2 :> path)
     | `Hidden p -> wrap c "hidden" model_resolved_path ppf (p :> t)

src/xref2/component.mli

@@ -545,12 +545,113 @@ end
 
 (** Formatting functions for components *)
 module Fmt : sig
+  (** Pretty-printer for the {!Component} representation. {!signature} renders a
+      {!Signature.t}; what it prints is controlled by a {!config}.
+
+      The examples below compile a fragment of [.mli] source into the
+      {!Signature.t} it denotes with [sig_of] (a helper from the
+      [component_fmt_prelude] MDX prelude) and render it with {!signature}.
+      [readable] is {!default} with {!short_paths} enabled.
+
+      {@ocaml[
+        # let example = {|
+            module type S = sig type t end
+            module M : S
+            module F (X : S) : sig end
+            include S
+            module type Tsub = S with type t := int
+          |};;
+        val example : string =
+          "\n    module type S = sig type t end\n    module M : S\n    module F (X : S) : sig end\n    include S\n    module type Tsub = S with type t := int\n  "
+      ]}
+
+      With [readable] the rendering stays close to source syntax: a module's
+      expansion is shown after [=>], and a destructively-removed item is flagged
+      with [(removed=...)]:
+
+      {@ocaml[
+        # Format.printf "@[<v>%a@]@." (Component.Fmt.signature readable) (sig_of example);;
+        module type S = sig type t end
+        module M : S => sig type t end
+        module F : (X : S) -> sig end
+        include S => sig type t end
+        module type Tsub = S with t := int => sig  (removed=type () t = (int)) end
+        - : unit = ()
+      ]}
+
+      Each {!config} field switches one of these off. [short_paths = false] is
+      the raw internal view — unique [name/NN] idents and the
+      [r(...)]/[resolved(...)] wrappers used while resolving paths:
+
+      {@ocaml[
+        # Format.printf "@[<v>%a@]@."
+            (Component.Fmt.signature { readable with short_paths = false })
+            (sig_of example);;
+        module type S/6 = sig type t/7 end
+        module M/4 : r(S/6) => sig type t/8 end
+        module F/3 : (X/9 : r(S/6)) -> sig end
+        include r(S/6) => sig type t/2 end
+        module type Tsub/5 = r(S/6) with resolved(root(S/6).t) := resolved(int)
+          => sig  (removed=type () t = (resolved(int))) end
+        - : unit = ()
+      ]}
+
+      [show_expansions = false] hides the [=> sig ... end] expansions. Includes
+      are governed separately by [show_include_expansions], so the [include]
+      keeps its expansion while [M] loses it:
+
+      {@ocaml[
+        # Format.printf "@[<v>%a@]@."
+            (Component.Fmt.signature { readable with show_expansions = false })
+            (sig_of example);;
+        module type S = sig type t end
+        module M : S
+        module F : (X : S) -> sig end
+        include S => sig type t end
+        module type Tsub = S with t := int
+        - : unit = ()
+      ]}
+
+      [show_removed = false] hides items deleted by destructive substitution
+      (here the [t] removed by [Tsub], leaving an empty expansion):
+
+      {@ocaml[
+        # Format.printf "@[<v>%a@]@."
+            (Component.Fmt.signature { readable with show_removed = false })
+            (sig_of example);;
+        module type S = sig type t end
+        module M : S => sig type t end
+        module F : (X : S) -> sig end
+        include S => sig type t end
+        module type Tsub = S with t := int => sig  end
+        - : unit = ()
+      ]}
+
+      The remaining two fields need inputs this self-contained example does not
+      produce: [show_canonical] toggles the [(canonical=...)] note printed for a
+      module carrying a [@canonical] tag, and [identifier_name_only] shortens
+      paths that resolution has lifted to a single cross-unit
+      {!Odoc_model.Paths.Identifier.t} — which only arises across compilation
+      units, not the in-unit signatures [sig_of] builds. *)
+
   type config = {
     short_paths : bool;
+        (** Render short, source-like names instead of the raw [name/NN] idents
+            and [r(...)]/[resolved(...)] path wrappers. *)
     show_canonical : bool;
+        (** Print the [(canonical=...)] note for a module with a [@canonical]
+            target. *)
     show_removed : bool;
+        (** Print items removed by destructive substitution, flagged
+            [(removed=...)]. *)
     show_expansions : bool;
+        (** Print module and module-type expansions after [=>]. *)
     show_include_expansions : bool;
+        (** Print the expansion of [include]d signatures, even when
+            [show_expansions] is off. *)
+    identifier_name_only : bool;
+        (** Print Identifiers using only the leaf name (as the HTML renderer
+            does). *)
   }
 
   val default : config
@@ -598,7 +699,8 @@ module Fmt : sig
 
   val type_decl : config -> Format.formatter -> TypeDecl.t -> unit
 
-  val type_equation : config -> Format.formatter -> TypeDecl.Equation.t -> unit
+  val type_equation :
+    ?sep:string -> config -> Format.formatter -> TypeDecl.Equation.t -> unit
 
   val exception_ : config -> Format.formatter -> Exception.t -> unit