Merge 036d9cf into 8ad7cd5

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;
   }
@@ -579,8 +580,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
@@ -676,12 +677,18 @@ module Fmt = struct
     | Some x -> Format.fprintf ppf "= %a" type_expr x
     | None -> ()
 
-  and type_equation ppf t =
-    match t.TypeDecl.Equation.manifest with
-    | None -> ()
-    | Some m -> Format.fprintf ppf " = %a" type_expr m
+  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_equation2 ppf t =
+  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 +707,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

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 ->

src/xref2/subst.ml

@@ -1,8 +1,17 @@
-exception TypeReplacement of Component.TypeExpr.t
+open Component
 
 exception Invalidated
+
 exception MTOInvalidated
 
+type 'a or_replaced =
+  | Not_replaced of 'a
+  | Replaced of (TypeExpr.t * TypeDecl.Equation.t)
+
+let map_replaced f = function
+  | Not_replaced p -> Not_replaced (f p)
+  | Replaced _ as r -> r
+
 open Component
 open Substitution
 
@@ -76,9 +85,8 @@ let add_class_type :
         t.class_type;
   }
 
-let add_type_replacement : Ident.path_type -> Component.TypeExpr.t -> t -> t =
- fun id texp t ->
-  { t with type_replacement = PathTypeMap.add id texp t.type_replacement }
+let add_type_replacement id texp equation t =
+  { t with type_replacement = PathTypeMap.add id (texp, equation) t.type_replacement }
 
 let add_module_substitution : Ident.path_module -> t -> t =
  fun id t ->
@@ -108,6 +116,44 @@ let rename_class_type : Ident.path_class_type -> Ident.path_class_type -> t -> t
     class_type = PathClassTypeMap.add id (`Renamed id') t.class_type;
     type_ = PathTypeMap.add (id :> Ident.path_type) (`Renamed (id' :> Ident.path_type)) t.type_ }
 
+let rec substitute_vars vars t =
+  let open TypeExpr in
+  match t with
+  | Var s -> List.assoc s vars
+  | Any -> Any
+  | Alias (t, str) -> Alias (substitute_vars vars t, str)
+  | Arrow (lbl, t1, t2) -> Arrow (lbl, substitute_vars vars t1, substitute_vars vars t2)
+  | Tuple ts -> Tuple (List.map (substitute_vars vars) ts)
+  | Constr (p, ts) -> Constr (p, List.map (substitute_vars vars) ts)
+  | Polymorphic_variant v -> Polymorphic_variant (substitute_vars_poly_variant vars v)
+  | Object o -> Object (substitute_vars_type_object vars o)
+  | Class (p, ts) -> Class (p, List.map (substitute_vars vars) ts)
+  | Poly (strs, ts) -> Poly (strs, substitute_vars vars ts)
+  | Package p -> Package (substitute_vars_package vars p)
+
+and substitute_vars_package vars p =
+  let open TypeExpr.Package in
+  let subst_subst (p, t) = p, substitute_vars vars t in
+  { p with substitutions = List.map subst_subst p.substitutions }
+
+and substitute_vars_type_object vars o =
+  let open TypeExpr.Object in
+  let subst_field = function
+    | Method m -> Method { m with type_ = substitute_vars vars m.type_ }
+    | Inherit t -> Inherit (substitute_vars vars t)
+  in
+  { o with fields = List.map subst_field o.fields }
+
+and substitute_vars_poly_variant vars v =
+  let open TypeExpr.Polymorphic_variant in
+  let subst_element = function
+    | Type t -> Type (substitute_vars vars t)
+    | Constructor c ->
+      let arguments = List.map (substitute_vars vars) c.Constructor.arguments in
+      Constructor { c with arguments}
+  in
+  { v with elements = List.map subst_element v.elements }
+
 let rec resolved_module_path :
     t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ =
  fun s p ->
@@ -201,43 +247,51 @@ and module_type_path : t -> Cpath.module_type -> Cpath.module_type =
   | `Dot (p, n) -> `Dot (module_path s p, n)
   | `ModuleType (p', str) -> `ModuleType (resolved_parent_path s p', str)
 
-and resolved_type_path : t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ =
+and resolved_type_path :
+    t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ or_replaced =
  fun s p ->
   match p with
   | `Local id -> (
       if PathTypeMap.mem id s.type_replacement then
-        raise (TypeReplacement (PathTypeMap.find id s.type_replacement));
-      match try Some (PathTypeMap.find id s.type_) with Not_found -> None with
-      | Some (`Prefixed (_p, rp)) -> rp
-      | Some (`Renamed x) -> `Local x
-      | None -> `Local id )
-  | `Identifier _ -> p
-  | `Substituted p -> `Substituted (resolved_type_path s p)
-  | `Type (p, n) -> `Type (resolved_parent_path s p, n)
-  | `ClassType (p, n) -> `ClassType (resolved_parent_path s p, n)
-  | `Class (p, n) -> `Class (resolved_parent_path s p, n)
-
-and type_path : t -> Cpath.type_ -> Cpath.type_ =
+        Replaced (PathTypeMap.find id s.type_replacement)
+      else
+        match
+          try Some (PathTypeMap.find id s.type_) with Not_found -> None
+        with
+        | Some (`Prefixed (_p, rp)) -> Not_replaced rp
+        | Some (`Renamed x) -> Not_replaced (`Local x)
+        | None -> Not_replaced (`Local id) )
+  | `Identifier _ -> Not_replaced p
+  | `Substituted p ->
+      resolved_type_path s p |> map_replaced (fun p -> `Substituted p)
+  | `Type (p, n) -> Not_replaced (`Type (resolved_parent_path s p, n))
+  | `ClassType (p, n) -> Not_replaced (`ClassType (resolved_parent_path s p, n))
+  | `Class (p, n) -> Not_replaced (`Class (resolved_parent_path s p, n))
+
+and type_path : t -> Cpath.type_ -> Cpath.type_ or_replaced =
  fun s p ->
   match p with
   | `Resolved r -> (
-      try `Resolved (resolved_type_path s r)
+      try resolved_type_path s r |> map_replaced (fun r -> `Resolved r)
       with Invalidated ->
         let path' = Cpath.unresolve_resolved_type_path r in
         type_path s (`Substituted path') )
-  | `Substituted p -> `Substituted (type_path s p)
+  | `Substituted p -> type_path s p |> map_replaced (fun r -> `Substituted r)
   | `Local (id, b) -> (
       if PathTypeMap.mem id s.type_replacement then
-        raise (TypeReplacement (PathTypeMap.find id s.type_replacement));
-      match try Some (PathTypeMap.find id s.type_) with Not_found -> None with
-      | Some (`Prefixed (p, _rp)) -> p
-      | Some (`Renamed x) -> `Local (x, b)
-      | None -> `Local (id, b) )
-  | `Identifier _ -> p
-  | `Dot (p, n) -> `Dot (module_path s p, n)
-  | `Type (p, n) -> `Type (resolved_parent_path s p, n)
-  | `Class (p, n) -> `Class (resolved_parent_path s p, n)
-  | `ClassType (p, n) -> `ClassType (resolved_parent_path s p, n)
+        Replaced (PathTypeMap.find id s.type_replacement)
+      else
+        match
+          try Some (PathTypeMap.find id s.type_) with Not_found -> None
+        with
+        | Some (`Prefixed (p, _rp)) -> Not_replaced p
+        | Some (`Renamed x) -> Not_replaced (`Local (x, b))
+        | None -> Not_replaced (`Local (id, b)) )
+  | `Identifier _ -> Not_replaced p
+  | `Dot (p, n) -> Not_replaced (`Dot (module_path s p, n))
+  | `Type (p, n) -> Not_replaced (`Type (resolved_parent_path s p, n))
+  | `Class (p, n) -> Not_replaced (`Class (resolved_parent_path s p, n))
+  | `ClassType (p, n) -> Not_replaced (`ClassType (resolved_parent_path s p, n))
 
 and resolved_class_type_path :
     t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type =
@@ -387,27 +441,38 @@ and type_package s p =
 
 and type_expr s t =
   let open Component.TypeExpr in
-  try
-    match t with
-    | Var s -> Var s
-    | Any -> Any
-    | Alias (t, str) -> Alias (type_expr s t, str)
-    | Arrow (lbl, t1, t2) -> Arrow (lbl, type_expr s t1, type_expr s t2)
-    | Tuple ts -> Tuple (List.map (type_expr s) ts)
-    | Constr (p, ts) -> Constr (type_path s p, List.map (type_expr s) ts)
-    | Polymorphic_variant v -> Polymorphic_variant (type_poly_var s v)
-    | Object o -> Object (type_object s o)
-    | Class (p, ts) -> Class (class_type_path s p, List.map (type_expr s) ts)
-    | Poly (strs, ts) -> Poly (strs, type_expr s ts)
-    | Package p -> Package (type_package s p)
-  with TypeReplacement y -> y
-
-and simple_expansion : t -> Component.ModuleType.simple_expansion -> Component.ModuleType.simple_expansion = fun s t ->
+  match t with
+  | Var s -> Var s
+  | Any -> Any
+  | Alias (t, str) -> Alias (type_expr s t, str)
+  | Arrow (lbl, t1, t2) -> Arrow (lbl, type_expr s t1, type_expr s t2)
+  | Tuple ts -> Tuple (List.map (type_expr s) ts)
+  | Constr (p, ts) -> (
+      match type_path s p with
+      | Replaced (t, eq) ->
+          let mk_var acc pexpr param =
+            match param.Odoc_model.Lang.TypeDecl.desc with
+            | Any -> acc
+            | Var n -> (n, type_expr s pexpr) :: acc
+          in
+          let vars = List.fold_left2 mk_var [] ts eq.params in
+          substitute_vars vars t
+      | Not_replaced p -> Constr (p, List.map (type_expr s) ts) )
+  | Polymorphic_variant v -> Polymorphic_variant (type_poly_var s v)
+  | Object o -> Object (type_object s o)
+  | Class (p, ts) -> Class (class_type_path s p, List.map (type_expr s) ts)
+  | Poly (strs, ts) -> Poly (strs, type_expr s ts)
+  | Package p -> Package (type_package s p)
+
+and simple_expansion :
+    t ->
+    Component.ModuleType.simple_expansion ->
+    Component.ModuleType.simple_expansion =
+ fun s t ->
   let open Component.ModuleType in
   match t with
   | Signature sg -> Signature (signature s sg)
-  | Functor (arg, sg) ->
-      Functor (functor_parameter s arg, simple_expansion s sg)
+  | Functor (arg, sg) -> Functor (functor_parameter s arg, simple_expansion s sg)
 
 and module_type s t =
   let open Component.ModuleType in
@@ -571,11 +636,13 @@ and extension_constructor s c =
 
 and extension s e =
   let open Component.Extension in
-  {
-    e with
-    type_path = type_path s e.type_path;
-    constructors = List.map (extension_constructor s) e.constructors;
-  }
+  let type_path =
+    match type_path s e.type_path with
+    | Not_replaced p -> p
+    | Replaced (TypeExpr.Constr (p, _), _) -> p
+    | Replaced _ -> (* What else is possible ? *) assert false
+  and constructors = List.map (extension_constructor s) e.constructors in
+  { e with type_path; constructors }
 
 and external_ s e =
   let open Component.External in
@@ -724,11 +791,9 @@ and rename_bound_idents s sg =
   | Value (id, v) :: rest ->
       let id' = Ident.Rename.value id in
       rename_bound_idents s (Value (id', v) :: sg) rest
-  | External (id, e) :: rest -> (
-      try
+  | External (id, e) :: rest ->
         let id' = Ident.Rename.value id in
         rename_bound_idents s (External (id', e) :: sg) rest
-      with TypeReplacement _ -> rename_bound_idents s sg rest )
   | Class (id, r, c) :: rest ->
       let id' = new_class_id id in
       rename_bound_idents
@@ -818,11 +883,7 @@ and apply_sig_map s items removed =
     | Exception (id, e) :: rest ->
         inner rest (Exception (id, exception_ s e) :: acc)
     | TypExt e :: rest ->
-        inner rest
-          ( try
-              let e' = extension s e in
-              TypExt e' :: acc
-            with TypeReplacement _ -> acc )
+        inner rest ( TypExt (extension s e) :: acc)
     | Value (id, v) :: rest ->
         inner rest
           ( Value