Fix a bug in subst noticed in uwt

Two fixes and a test:
1. Slightly more recursion needed when expanding `module type of`
   expressions before compilation
2. In the presence of `module type of` expressions and `includes`,
   we can get in the situation when we try to rename elements that
   have been prefixed. This is not an error, though it is unusual.
   we end up labelling the items with different idents, but that's
   fine because all expressions referencing them are using the
   prefixed path anyway.

The test is a much cut-down version of `uwt` that was originally
demonstrating the problem, manifesting as an internal `Failure`
begin raised

Author: jonludlam

src/xref2/subst.ml

@@ -905,20 +905,26 @@ and rename_bound_idents s sg =
     try
       match PathModuleMap.find (id :> Ident.path_module) s.module_ with
       | `Renamed (`LModule _ as x) -> x
+      | `Prefixed (_, _) ->
+          (* This is unusual but can happen when we have TypeOf expressions. It means
+             we're already prefixing this module path, hence we can essentially rename
+             it to whatever we like because it's never going to be referred to. *)
+          Ident.Rename.module_ id
       | _ -> failwith "Error"
     with Not_found -> Ident.Rename.module_ id
   in
   let new_module_type_id id =
     try
       match ModuleTypeMap.find id s.module_type with
       | `Renamed x -> x
-      | _ -> failwith "Error"
+      | `Prefixed (_, _) -> Ident.Rename.module_type id
     with Not_found -> Ident.Rename.module_type id
   in
   let new_type_id id =
     try
       match PathTypeMap.find (id :> Ident.path_type) s.type_ with
       | `Renamed (`LType _ as x) -> x
+      | `Prefixed (_, _) -> Ident.Rename.type_ id
       | _ -> failwith "Error"
     with Not_found -> Ident.Rename.type_ id
   in
@@ -928,6 +934,7 @@ and rename_bound_idents s sg =
         PathClassTypeMap.find (id :> Ident.path_class_type) s.class_type
       with
       | `Renamed (`LClass _ as x) -> x
+      | `Prefixed (_, _) -> Ident.Rename.class_ id
       | _ -> failwith "Error"
     with Not_found -> Ident.Rename.class_ id
   in
@@ -937,6 +944,7 @@ and rename_bound_idents s sg =
         PathClassTypeMap.find (id :> Ident.path_class_type) s.class_type
       with
       | `Renamed (`LClassType _ as x) -> x
+      | `Prefixed (_, _) -> Ident.Rename.class_type id
       | _ -> failwith "Error!"
     with Not_found -> Ident.Rename.class_type id
   in

src/xref2/type_of.ml

@@ -69,8 +69,8 @@ and module_type_expr env (id : Id.Signature.t) expr =
   | TypeOf t -> (
       match module_type_expr_typeof env id t with
       | Ok e ->
-          TypeOf
-            { t with t_expansion = Some Lang_of.(simple_expansion empty id e) }
+          let se = Lang_of.(simple_expansion empty id e) in
+          TypeOf { t with t_expansion = Some (simple_expansion env se) }
       | Error e
         when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any)
         ->
@@ -86,8 +86,8 @@ and u_module_type_expr env id expr =
   | TypeOf t -> (
       match module_type_expr_typeof env id t with
       | Ok e ->
-          TypeOf
-            { t with t_expansion = Some Lang_of.(simple_expansion empty id e) }
+          let se = Lang_of.(simple_expansion empty id e) in
+          TypeOf { t with t_expansion = Some (simple_expansion env se) }
       | Error e
         when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any)
         ->
@@ -98,6 +98,14 @@ and u_module_type_expr env id expr =
 and functor_parameter env p =
   { p with expr = module_type_expr env (p.id :> Id.Signature.t) p.expr }
 
+and simple_expansion :
+    Env.t -> ModuleType.simple_expansion -> ModuleType.simple_expansion =
+ fun env -> function
+  | Signature sg -> Signature (signature env sg)
+  | Functor (Named n, sg) ->
+      Functor (Named (functor_parameter env n), simple_expansion env sg)
+  | Functor (Unit, sg) -> Functor (Unit, simple_expansion env sg)
+
 and include_ env i =
   let decl =
     match i.decl with

test/xref2/include_module_type_of.t/run.t

@@ -0,0 +1,41 @@
+Repro of problem from uwt (https://github.com/ocaml/odoc/issues/691)
+
+  $ cat uwt_base.mli
+  (* This file is part of uwt, released under the MIT license. See LICENSE.md for
+     details, or visit https://github.com/fdopen/uwt/blob/master/LICENSE.md. *)
+  module Base : sig
+    type 'a uv_result = 'a
+  
+  module Fs_types : sig
+    type uv_open_flag =
+      | O_RDONLY (** Open for reading *)
+    (** Flags for {!Fs_functions.openfile}
+  
+        [O_CLOEXEC] doesn't exist, because this flag is unconditionally
+        added by libuv. [O_SHARE_DELETE], [O_SHARE_WRITE], [O_SHARE_READ]
+        are always added on Windows, unless [O_EXLOCK] is specified. *)
+  
+  end
+  
+  module type Fs_functions = sig
+    include module type of Fs_types
+    with type uv_open_flag = Fs_types.uv_open_flag
+  
+    type 'a t
+  
+    val openfile : ?perm:int -> mode:uv_open_flag list -> string -> int t
+    (** Equivalent to open(2). perm defaults are 0o644 *)
+  end
+  end
+  
+  include module type of Base
+    with type Fs_types.uv_open_flag = Base.Fs_types.uv_open_flag
+  
+
+What used to happen is that the `odoc link` command would cause an internal
+error. If it doesn't here, that particular issue is fixed!
+
+  $ ocamlc -c -bin-annot uwt_base.mli
+  $ odoc compile uwt_base.cmti
+  $ odoc link uwt_base.odoc
+

test/xref2/include_module_type_of.t/uwt_base.mli

@@ -0,0 +1,30 @@
+(* This file is part of uwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/fdopen/uwt/blob/master/LICENSE.md. *)
+module Base : sig
+  type 'a uv_result = 'a
+
+module Fs_types : sig
+  type uv_open_flag =
+    | O_RDONLY (** Open for reading *)
+  (** Flags for {!Fs_functions.openfile}
+
+      [O_CLOEXEC] doesn't exist, because this flag is unconditionally
+      added by libuv. [O_SHARE_DELETE], [O_SHARE_WRITE], [O_SHARE_READ]
+      are always added on Windows, unless [O_EXLOCK] is specified. *)
+
+end
+
+module type Fs_functions = sig
+  include module type of Fs_types
+  with type uv_open_flag = Fs_types.uv_open_flag
+
+  type 'a t
+
+  val openfile : ?perm:int -> mode:uv_open_flag list -> string -> int t
+  (** Equivalent to open(2). perm defaults are 0o644 *)
+end
+end
+
+include module type of Base
+  with type Fs_types.uv_open_flag = Base.Fs_types.uv_open_flag
+