Fix substitution of type params

src/xref2/compile.ml

@@ -669,7 +669,9 @@ and type_expression : Env.t -> Id.Parent.t -> _ -> _ =
       | Ok (cp, (`FType _ | `FClass _ | `FClassType _)) ->
           let p = Cpath.resolved_type_path_of_cpath cp in
           Constr (`Resolved p, ts)
-      | Ok (_cp, `FType_removed (_, x)) -> Lang_of.(type_expr empty parent x)
+      | Ok (_cp, `FType_removed (_, x, _eq)) ->
+          (* Substitute type variables ? *)
+          Lang_of.(type_expr empty parent x)
       | Error _ -> Constr (Cpath.type_path_of_cpath cp, ts) )
   | Polymorphic_variant v ->
       Polymorphic_variant (type_expression_polyvar env parent v)

src/xref2/component.ml

@@ -304,7 +304,8 @@ and Signature : sig
        and the path they've been substituted with *)
   type removed_item =
     | RModule of Ident.module_ * Cpath.Resolved.module_
-    | RType of Ident.type_ * TypeExpr.t
+    | RType of Ident.type_ * TypeExpr.t * TypeDecl.Equation.t
+        (** [RType (_, texpr, eq)], [eq.manifest = Some texpr] *)
 
   type t = { items : item list; removed : removed_item list }
 end =
@@ -417,7 +418,7 @@ and Substitution : sig
     module_type : subst_module_type ModuleTypeMap.t;
     type_ : subst_type PathTypeMap.t;
     class_type : subst_class_type PathClassTypeMap.t;
-    type_replacement : TypeExpr.t PathTypeMap.t;
+    type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t;
     path_invalidating_modules : Ident.path_module list;
     module_type_of_invalidating_modules : Ident.path_module list;
   }
@@ -491,6 +492,16 @@ end
 module Fmt = struct
   open Odoc_model.Names
 
+  let fpf = Format.fprintf
+
+  let fpp_opt fmt pp_a ppf = function Some t -> fpf ppf fmt pp_a t | None -> ()
+
+  let fpp_list fmt_sep fmt_outer pp_a ppf t =
+    let pp_sep ppf () = fpf ppf fmt_sep in
+    match t with
+    | [] -> ()
+    | t -> fpf ppf fmt_outer (Format.pp_print_list ~pp_sep pp_a) t
+
   let rec signature ppf sg =
     let open Signature in
     Format.fprintf ppf "@[<v>";
@@ -506,10 +517,10 @@ module Fmt = struct
             Format.fprintf ppf "@[<v 2>module type %a %a@]@," Ident.fmt id
               module_type (Delayed.get mt)
         | Type (id, _, t) ->
-            Format.fprintf ppf "@[<v 2>type %a %a@]@," Ident.fmt id type_decl
+            Format.fprintf ppf "@[<v 2>type %a%a@]@," Ident.fmt id type_decl
               (Delayed.get t)
         | TypeSubstitution (id, t) ->
-            Format.fprintf ppf "@[<v 2>type %a := %a@]@," Ident.fmt id type_decl
+            Format.fprintf ppf "@[<v 2>type %a :=%a@]@," Ident.fmt id type_decl
               t
         | Exception (id, e) ->
             Format.fprintf ppf "@[<v 2>exception %a %a@]@," Ident.fmt id
@@ -579,8 +590,8 @@ module Fmt = struct
     | RModule (id, path) ->
         Format.fprintf ppf "module %a (%a)" Ident.fmt id resolved_module_path
           path
-    | RType (id, texpr) ->
-        Format.fprintf ppf "type %a (%a)" Ident.fmt id type_expr texpr
+    | RType (id, texpr, eq) ->
+        Format.fprintf ppf "type %a %a = (%a)" type_params eq.params Ident.fmt id type_expr texpr
 
   and removed_item_list ppf r =
     match r with
@@ -672,16 +683,55 @@ module Fmt = struct
       module_type_expr x.FunctorParameter.expr
 
   and type_decl ppf t =
-    match TypeDecl.(t.equation.Equation.manifest) with
-    | Some x -> Format.fprintf ppf "= %a" type_expr x
-    | None -> ()
+    let open TypeDecl in
+    match t.representation with
+    | Some repr ->
+        Format.fprintf ppf "%a = %a"
+          (fpp_opt " : %a" type_expr)
+          t.equation.Equation.manifest type_decl_repr repr
+    | None -> (fpp_opt " = %a" type_expr) ppf t.equation.Equation.manifest
+
+  and type_decl_repr ppf =
+    let open TypeDecl.Representation in
+    function
+    | Variant cs -> fpp_list " | " "%a" type_decl_constructor ppf cs
+    | Record fs -> type_decl_fields ppf fs
+    | Extensible -> Format.fprintf ppf ".."
+
+  and type_decl_constructor ppf t =
+    let open TypeDecl.Constructor in
+    match t.res with
+    | Some res ->
+        fpf ppf "%s : %a -> %a" t.name type_decl_constructor_arg t.args type_expr
+          res
+    | None -> fpf ppf "%s of %a" t.name type_decl_constructor_arg t.args
 
-  and type_equation ppf t =
-    match t.TypeDecl.Equation.manifest with
-    | None -> ()
-    | Some m -> Format.fprintf ppf " = %a" type_expr m
+  and type_decl_constructor_arg ppf =
+    let open TypeDecl.Constructor in
+    function
+    | Tuple ts -> type_tuple ppf ts | Record fs -> type_decl_fields ppf fs
+
+  and type_decl_field ppf t =
+    let open TypeDecl.Field in
+    let mutable_ = if t.mutable_ then "mutable " else "" in
+    fpf ppf "%s%s : %a" mutable_ t.name type_expr t.type_
 
-  and type_equation2 ppf t =
+  and type_decl_fields ppf fs = fpp_list "; " "{ %a }" type_decl_field ppf fs
+
+  and type_tuple ppf ts = fpp_list " * " "%a" type_expr ppf ts
+
+  and type_param ppf t =
+    let desc = match t.Odoc_model.Lang.TypeDecl.desc with Any -> "_" | Var n -> n
+    and variance =
+      match t.variance with Some Pos -> "+" | Some Neg -> "-" | None -> ""
+    and injectivity = if t.injectivity then "!" else "" in
+    Format.fprintf ppf "%s%s%s" variance injectivity desc
+
+  and type_params ppf ts =
+    let pp_sep ppf () = Format.fprintf ppf ", " in
+    Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep type_param) ts
+
+  and type_equation ppf t =
     match t.TypeDecl.Equation.manifest with
     | None -> ()
     | Some m -> Format.fprintf ppf " = %a" type_expr m
@@ -700,7 +750,7 @@ module Fmt = struct
     | TypeEq (frag, decl) ->
         Format.fprintf ppf "%a%a" type_fragment frag type_equation decl
     | TypeSubst (frag, decl) ->
-        Format.fprintf ppf "%a%a" type_fragment frag type_equation2 decl
+        Format.fprintf ppf "%a%a" type_fragment frag type_equation decl
 
   and substitution_list ppf l =
     match l with
@@ -729,37 +779,31 @@ module Fmt = struct
   and type_package ppf _p = Format.fprintf ppf "(package)"
 
   and type_expr_polymorphic_variant ppf p =
-    let kind ppf k =
-      let open Odoc_model.Lang.TypeExpr.Polymorphic_variant in
-      match k with
-      | Fixed -> Format.fprintf ppf "Fixed"
-      | Closed xs -> Format.fprintf ppf "Closed [%s]" (String.concat ";" xs)
-      | Open -> Format.fprintf ppf "Open"
-    in
     let open TypeExpr.Polymorphic_variant in
-    let constructor ppf c = Format.fprintf ppf "name=%s" c.Constructor.name in
-    let element ppf k =
-      match k with
-      | Type t -> Format.fprintf ppf "Type (%a)" type_expr t
-      | Constructor c -> Format.fprintf ppf "Constructor (%a)" constructor c
-    in
-    let rec elements ppf k =
-      match k with
-      | [] -> ()
-      | [ x ] -> Format.fprintf ppf "%a" element x
-      | x :: xs -> Format.fprintf ppf "%a; %a" element x elements xs
+    let pp_element ppf = function
+      | Type t -> type_expr ppf t
+      | Constructor c ->
+          fpf ppf "`%s%a" c.Constructor.name
+            (fpp_list " * " " of %a" type_expr)
+            c.arguments
     in
-    Format.fprintf ppf "{ kind=%a; elements=[%a] }" kind p.kind elements
-      p.elements
+    let pp_elements = fpp_list " | " "%a" pp_element in
+    match p.kind with
+    | Fixed -> fpf ppf "[ %a ]" pp_elements p.elements
+    | Closed xs ->
+        fpf ppf "[ %a > %a ]" pp_elements p.elements
+          (fpp_list " " "%a" Format.pp_print_string)
+          xs
+    | Open -> fpf ppf "[> %a ]" pp_elements p.elements
 
   and type_expr ppf e =
     let open TypeExpr 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 x y
-    | Arrow (_l, t1, t2) ->
-        Format.fprintf ppf "%a -> %a" type_expr t1 type_expr t2
+    | Arrow (l, t1, t2) ->
+        Format.fprintf ppf "%a(%a) -> %a" type_expr_label l type_expr t1 type_expr t2
     | Tuple ts -> Format.fprintf ppf "(%a)" type_expr_list ts
     | Constr (p, args) -> (
         match args with
@@ -776,11 +820,11 @@ module Fmt = struct
       =
    fun ppf p ->
     match p with
-    | `Local ident -> Format.fprintf ppf "local(%a)" Ident.fmt ident
+    | `Local ident -> Format.fprintf ppf "%a" Ident.fmt ident
     | `Apply (p1, p2) ->
         Format.fprintf ppf "%a(%a)" resolved_module_path p1 resolved_module_path p2
     | `Identifier p ->
-        Format.fprintf ppf "identifier(%a)" model_identifier
+        Format.fprintf ppf "%a" model_identifier
           (p :> Odoc_model.Paths.Identifier.t)
     | `Substituted p ->
         Format.fprintf ppf "substituted(%a)" resolved_module_path p
@@ -806,7 +850,7 @@ module Fmt = struct
   and module_path : Format.formatter -> Cpath.module_ -> unit =
    fun ppf p ->
     match p with
-    | `Resolved p -> Format.fprintf ppf "resolved(%a)" resolved_module_path p
+    | `Resolved p -> Format.fprintf ppf "r(%a)" resolved_module_path p
     | `Dot (p, str) -> Format.fprintf ppf "%a.%s" module_path p str
     | `Module (p, n) ->
         Format.fprintf ppf "%a.%a" resolved_parent_path p ModuleName.fmt n
@@ -827,7 +871,7 @@ module Fmt = struct
     match p with
     | `Local id -> Format.fprintf ppf "%a" Ident.fmt id
     | `Identifier id ->
-        Format.fprintf ppf "identifier(%a)" model_identifier
+        Format.fprintf ppf "%a" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
     | `Substituted x ->
         Format.fprintf ppf "substituted(%a)" resolved_module_type_path x
@@ -844,7 +888,7 @@ module Fmt = struct
    fun ppf m ->
     match m with
     | `Resolved p ->
-        Format.fprintf ppf "resolved(%a)" resolved_module_type_path p
+        Format.fprintf ppf "r(%a)" resolved_module_type_path p
     | `Identifier (id, b) ->
         Format.fprintf ppf "identifier(%a, %b)" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
@@ -860,7 +904,7 @@ module Fmt = struct
     match p with
     | `Local id -> Format.fprintf ppf "%a" Ident.fmt id
     | `Identifier id ->
-        Format.fprintf ppf "identifier(%a)" model_identifier
+        Format.fprintf ppf "%a" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
     | `Substituted x ->
         Format.fprintf ppf "substituted(%a)" resolved_type_path x
@@ -884,7 +928,7 @@ module Fmt = struct
   and type_path : Format.formatter -> Cpath.type_ -> unit =
    fun ppf p ->
     match p with
-    | `Resolved r -> Format.fprintf ppf "resolved(%a)" resolved_type_path r
+    | `Resolved r -> Format.fprintf ppf "r(%a)" resolved_type_path r
     | `Identifier (id, b) ->
         Format.fprintf ppf "identifier(%a, %b)" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
@@ -940,7 +984,7 @@ module Fmt = struct
   and model_path : Format.formatter -> Odoc_model.Paths.Path.t -> unit =
    fun ppf (p : Odoc_model.Paths.Path.t) ->
     match p with
-    | `Resolved rp -> Format.fprintf ppf "resolved(%a)" model_resolved_path rp
+    | `Resolved rp -> Format.fprintf ppf "r(%a)" model_resolved_path rp
     | `Identifier (id, b) ->
         Format.fprintf ppf "identifier(%a, %b)" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
@@ -961,7 +1005,7 @@ module Fmt = struct
     let open Odoc_model.Paths.Path.Resolved in
     match p with
     | `Identifier id ->
-        Format.fprintf ppf "identifier(%a)" model_identifier
+        Format.fprintf ppf "%a" model_identifier
           (id :> Odoc_model.Paths.Identifier.t)
     | `Module (parent, name) ->
         Format.fprintf ppf "%a.%s" model_resolved_path
@@ -1172,25 +1216,25 @@ module Fmt = struct
   and signature_fragment ppf (f : Cfrag.signature) =
     match f with
     | `Resolved r ->
-        Format.fprintf ppf "resolved(%a)" resolved_signature_fragment r
+        Format.fprintf ppf "r(%a)" resolved_signature_fragment r
     | `Dot (s, n) -> Format.fprintf ppf "%a.%s" signature_fragment s n
     | `Root -> Format.fprintf ppf "root"
 
   and module_fragment ppf (f : Cfrag.module_) =
     match f with
     | `Resolved r ->
-        Format.fprintf ppf "resolved(%a)" resolved_module_fragment r
+        Format.fprintf ppf "r(%a)" resolved_module_fragment r
     | `Dot (s, n) -> Format.fprintf ppf "%a.%s" signature_fragment s n
 
   and type_fragment ppf (f : Cfrag.type_) =
     match f with
-    | `Resolved r -> Format.fprintf ppf "resolved(%a)" resolved_type_fragment r
+    | `Resolved r -> Format.fprintf ppf "r(%a)" resolved_type_fragment r
     | `Dot (s, n) -> Format.fprintf ppf "%a.%s" signature_fragment s n
 
   and model_resolved_reference ppf (r : Odoc_model.Paths.Reference.Resolved.t) =
     let open Odoc_model.Paths.Reference.Resolved in
     match r with
-    | `Identifier id -> Format.fprintf ppf "identifier(%a)" model_identifier id
+    | `Identifier id -> Format.fprintf ppf "%a" model_identifier id
     | `Hidden p ->
         Format.fprintf ppf "hidden(%a)" model_resolved_reference (p :> t)
     | `Module (parent, name) ->
@@ -1260,7 +1304,7 @@ module Fmt = struct
     let open Odoc_model.Paths.Reference in
     match r with
     | `Resolved r' ->
-        Format.fprintf ppf "resolved(%a)" model_resolved_reference r'
+        Format.fprintf ppf "r(%a)" model_resolved_reference r'
     | `Root (name, _) -> Format.fprintf ppf "unresolvedroot(%s)" name
     | `Dot (parent, str) ->
         Format.fprintf ppf "%a.%s" model_reference (parent :> t) str

src/xref2/component.mli

@@ -286,7 +286,7 @@ and Signature : sig
        and the path they've been substituted with *)
   type removed_item =
     | RModule of Ident.module_ * Cpath.Resolved.module_
-    | RType of Ident.type_ * TypeExpr.t
+    | RType of Ident.type_ * TypeExpr.t * TypeDecl.Equation.t
 
   type t = { items : item list; removed : removed_item list }
 end
@@ -391,7 +391,7 @@ and Substitution : sig
     module_type : subst_module_type ModuleTypeMap.t;
     type_ : subst_type PathTypeMap.t;
     class_type : subst_class_type PathClassTypeMap.t;
-    type_replacement : TypeExpr.t PathTypeMap.t;
+    type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t;
     path_invalidating_modules : Ident.path_module list;
     module_type_of_invalidating_modules : Ident.path_module list;
   }
@@ -504,8 +504,6 @@ module Fmt : sig
 
   val type_equation : Format.formatter -> TypeDecl.Equation.t -> unit
 
-  val type_equation2 : Format.formatter -> TypeDecl.Equation.t -> unit
-
   val exception_ : Format.formatter -> Exception.t -> unit
 
   val extension : Format.formatter -> Extension.t -> unit

src/xref2/find.ml

@@ -103,7 +103,7 @@ let class_in_sig sg name =
         Some (`FClassType (N.class_type' id, c))
     | _ -> None)
 
-type removed_type = [ `FType_removed of TypeName.t * TypeExpr.t ]
+type removed_type = [ `FType_removed of TypeName.t * TypeExpr.t * TypeDecl.Equation.t ]
 
 type careful_module = [ module_ | `FModule_removed of Cpath.Resolved.module_ ]
 
@@ -123,8 +123,8 @@ let careful_module_in_sig sg name =
 
 let removed_type_in_sig sg name =
   let removed_type = function
-    | Signature.RType (id, p) when N.type_ id = name ->
-        Some (`FType_removed (N.type' id, p))
+    | Signature.RType (id, p, eq) when N.type_ id = name ->
+        Some (`FType_removed (N.type' id, p, eq))
     | _ -> None
   in
   find_map removed_type sg.Signature.removed

src/xref2/find.mli

@@ -95,7 +95,7 @@ val any_in_class_signature : ClassSignature.t -> string -> any_in_class_sig list
 
 (** Lookup removed items *)
 
-type removed_type = [ `FType_removed of TypeName.t * TypeExpr.t ]
+type removed_type = [ `FType_removed of TypeName.t * TypeExpr.t * TypeDecl.Equation.t ]
 
 type careful_module = [ module_ | `FModule_removed of Cpath.Resolved.module_ ]
 

src/xref2/link.ml

@@ -790,7 +790,8 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ =
         | Ok (cp', (`FClass _ | `FClassType _)) ->
             let p = Cpath.resolved_type_path_of_cpath cp' in
             Constr (`Resolved p, ts)
-        | Ok (_cp, `FType_removed (_, x)) ->
+        | Ok (_cp, `FType_removed (_, x, _eq)) ->
+            (* Type variables ? *)
             Lang_of.(type_expr empty (parent :> Id.Parent.t) x)
         | Error _ -> Constr (Cpath.type_path_of_cpath cp, ts) )
   | Polymorphic_variant v ->