include functor support for OxCaml

CHANGES.md

@@ -7,6 +7,8 @@
 - Support OxCaml 5.2.0minus39 (@jonludlam, #1469)
 - Support for OxCaml modes (@art-w, #1454)
 - Fix OxCaml with-bounds for arbitrary types (@art-w, #1466)
+- Display items included via `include functor` as included via the functor
+  (@Leonidas-from-XIV, #1452)
 
 ### Fixed
 - Remove requirement for ppx_expect in tests (@jonludlam, #1445)

src/document/generator.ml

@@ -1912,23 +1912,33 @@ module Make (Syntax : SYNTAX) = struct
     and include_ (t : Odoc_model.Lang.Include.t) =
       let decl_hidden =
         match t.decl with
-        | Alias p -> Paths.Path.(is_hidden (p :> t))
-        | ModuleType mty -> umty_hidden mty
+        | Alias p | Functor { original_ref = Path p; _ } ->
+            Paths.Path.(is_hidden (p :> t))
+        | Functor { original_ref = ModuleType mty; _ } -> mty_hidden mty
+        | ModuleType umty -> umty_hidden umty
       in
       let status = if decl_hidden then `Inline else t.status in
 
       let _, content = signature t.expansion.content in
       let summary =
         if decl_hidden then O.render (O.keyword "include" ++ O.txt " ...")
         else
+          let include_kw =
+            match t.decl with
+            | Odoc_model.Lang.Include.Alias _ | ModuleType _ ->
+                O.keyword "include"
+            | Functor _ -> O.keyword "include functor"
+          in
           let include_decl =
             match t.decl with
-            | Odoc_model.Lang.Include.Alias mod_path ->
+            | Odoc_model.Lang.Include.Alias mod_path
+            | Functor { original_ref = Path mod_path; _ } ->
                 Link.from_path (mod_path :> Paths.Path.t)
+            | Functor { original_ref = ModuleType mt; _ } -> mty mt
             | ModuleType mt -> umty mt
           in
           O.render
-            (O.keyword "include" ++ O.txt " " ++ include_decl
+            (include_kw ++ O.txt " " ++ include_decl
             ++ if Syntax.Mod.include_semicolon then O.keyword ";" else O.noop)
       in
       let content = { Include.content; status; summary } in

src/loader/cmi.ml

@@ -1638,3 +1638,90 @@ let read_interface root name ~warnings_tag intf =
       id intf
   in
   (id, items)
+
+let generate_wrapper_module =
+  let wrapper_counter = ref 0 in
+  fun parent ~prefix ~hidden ->
+    incr wrapper_counter;
+    let dummy_id =
+      let dummy_name =
+        let sep = match hidden with | true -> "__" | false -> "_" in
+        let name = Printf.sprintf "%s%s%d" prefix sep !wrapper_counter in
+        match hidden with
+        | false -> Odoc_model.Names.ModuleName.make_std name
+        | true -> Odoc_model.Names.ModuleName.hidden_of_string name
+      in
+      Identifier.Mk.module_ (parent, dummy_name)
+    in
+    let dummy_path = `Identifier (dummy_id, hidden) in
+    (dummy_id, dummy_path)
+
+let no_doc : Odoc_model.Comment.docs = { elements = []; warnings_tag = None }
+
+(* [include functor F] is modelled as the application of [F] to a synthetic,
+   hidden module holding the items that precede the include.
+
+   That module's items are *aliases* of the real ones rather than copies: the
+   expansion of [F(BODY__n)] refers to the functor argument, so a copy would
+   leave the expansion mentioning [BODY__n.t], a hidden path, which the
+   generator renders as an abstract [type t].  With an alias, [BODY__n.t]
+   reduces to the enclosing signature's own [t] and is rendered, and linked, as
+   such. *)
+let wrapper_items dummy_id items =
+  let module Id = Identifier in
+  let name id = Id.name id in
+  let parent = (dummy_id : Id.Module.t :> Id.Signature.t) in
+  (* Anonymous parameters ([_]) have to be named so that the alias can pass
+     them on to the item it aliases. *)
+  let alias_params params =
+    List.split
+      (List.mapi
+         (fun i (p : TypeDecl.param) ->
+           let v = match p.desc with Var v -> v | Any -> Printf.sprintf "a%d" i in
+           ({ p with TypeDecl.desc = TypeDecl.Var v }, TypeExpr.Var v))
+         params)
+  in
+  let rec wrapper_item item acc =
+    match (item : Signature.item) with
+    | Type (rec_, td) ->
+      let params, args = alias_params td.equation.params in
+      let manifest =
+        Some (TypeExpr.Constr (`Identifier ((td.id :> Id.Path.Type.t), false), args))
+      in
+      let equation =
+        { td.equation with TypeDecl.Equation.params; manifest; constraints = []; private_ = false }
+      in
+      let id = Id.Mk.type_ (parent, Odoc_model.Names.TypeName.make_std (name td.id)) in
+      Signature.Type (rec_, { td with TypeDecl.id; equation; representation = None; canonical = None; source_loc = None }) :: acc
+    | Module (rec_, m) ->
+      let id = Id.Mk.module_ (parent, Odoc_model.Names.ModuleName.make_std (name m.id)) in
+      let type_ = Module.Alias (`Identifier ((m.id :> Id.Path.Module.t), false), None) in
+      Signature.Module (rec_, { m with Module.id; type_; canonical = None; hidden = false; source_loc = None }) :: acc
+    | ModuleType mt ->
+      let id = Id.Mk.module_type (parent, Odoc_model.Names.ModuleTypeName.make_std (name mt.id)) in
+      let expr =
+        Some (ModuleType.Path { p_path = `Identifier ((mt.id :> Id.Path.ModuleType.t), false); p_expansion = None })
+      in
+      Signature.ModuleType { mt with ModuleType.id; expr; canonical = None; source_loc = None } :: acc
+    | Include incl ->
+      (* The items an [include] brings in are visible to the functor too. *)
+      List.fold_left (fun acc item -> wrapper_item item acc) acc incl.Include.expansion.content.items
+    | Value _ | ModuleSubstitution _ | ModuleTypeSubstitution _ | Open _
+    | TypeSubstitution _ | TypExt _ | Exception _ | Comment _ ->
+      (* Nothing in the expansion of [F(BODY__n)] can refer to these. *)
+      acc
+    | Class _ | ClassType _ ->
+      (* A class type of the argument can be referred to from the expansion,
+         but odoc does not chase class type aliases the way it chases type
+         manifests, so aliasing them here would not help: such a reference is
+         left printing the (hidden) name of the synthetic module. *)
+      acc
+  in
+  List.rev (List.fold_left (fun acc item -> wrapper_item item acc) [] items)
+
+let wrapper_module (dummy_id, _dummy_path) ~hidden items =
+  let items = wrapper_items dummy_id items in
+  let sig_ : Signature.t = { items; compiled = true; removed = []; doc = no_doc } in
+  let type_ : Module.decl = ModuleType (Signature sig_) in
+  let module_ : Module.t = {id=dummy_id; source_loc=None; doc=no_doc; type_; canonical=None; hidden} in
+  Signature.Module (Ordinary, module_)

src/loader/cmi.mli

@@ -128,3 +128,16 @@ val read_value_descr_modalities :
 val read_label_modalities :
   Types.label_declaration ->
   Odoc_model.Lang.Modalities.t
+
+val generate_wrapper_module : Paths.Identifier.Signature.t -> prefix:string -> hidden:bool -> Paths.Identifier.Module.t * Paths.Path.Module.t
+
+val wrapper_module :
+  Paths.Identifier.Module.t * Paths.Path.Module.t ->
+  hidden:bool ->
+  Odoc_model.Lang.Signature.item list ->
+  Odoc_model.Lang.Signature.item
+(** [wrapper_module w ~hidden items] is the synthetic module an
+    [include functor] applies its functor to.  Its items are aliases of
+    [items], the items that precede the include, so that whatever the functor's
+    expansion inherits from its argument resolves back to them rather than to
+    the (hidden) name of the wrapper. *)

src/loader/cmt.ml

@@ -22,6 +22,7 @@ module OCamlPath = Path
 
 open Odoc_model.Paths
 open Odoc_model.Lang
+module Names = Odoc_model.Names
 
 module Env = Ident_env
 
@@ -579,16 +580,8 @@ and read_include env parent incl =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
   let decl_modty =
-#if defined OXCAML
-    match unwrap_module_expr_desc incl.incl_mod.mod_desc, incl.incl_kind with
-    | _, (Tincl_functor _ | Tincl_gen_functor _) ->
-      (* TODO: Handle [include functor] *)
-      None
-    | Tmod_ident(p, _), Tincl_structure ->
-#else
     match unwrap_module_expr_desc incl.incl_mod.mod_desc with
     | Tmod_ident(p, _) ->
-#endif
       let p = Env.Path.read_module env.ident_env p in
       Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p))
     | _ ->
@@ -601,16 +594,60 @@ and read_include env parent incl =
   | Some m ->
     let decl = ModuleType m in
     [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
-  | _ ->
+  | None ->
     content.items
 
+#if defined OXCAML
+(* [include functor F] applies [F] to [wrapper], a synthetic module holding
+   everything defined before the include.  [F] itself need not be a path -- it
+   can be an anonymous functor -- in which case it is bound to a module so that
+   there is something to apply. *)
+and read_include_functor env parent wrapper incl =
+  let open Include in
+  let loc = Doc_attr.read_location incl.incl_loc in
+  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
+  let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
+  let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
+  let expansion = { content; shadowed; } in
+  let bound, functor_path, original_ref =
+    match unwrap_module_expr_desc incl.incl_mod.mod_desc with
+    | Tmod_ident (p, _) ->
+      let p = Env.Path.read_module env.ident_env p in
+      ([], p, Path p)
+    | _ ->
+      let mty = read_module_expr env parent container incl.incl_mod in
+      let hidden = true in
+      let id, path = Cmi.generate_wrapper_module parent ~prefix:"INCLUDE" ~hidden in
+      let m : Module.t = {id; source_loc=None; doc; type_=ModuleType mty; canonical=None; hidden} in
+      ([Signature.Module (Ordinary, m)], path, ModuleType mty)
+  in
+  let decl = Functor {target = Path (`Apply (functor_path, wrapper)); original_ref} in
+  bound @ [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
+#endif
+
 and read_open env parent o =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container o.open_attributes in
   let signature = o.open_bound_items in
   let expansion, _ = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature signature) in
   Open.{expansion; doc}
 
+and read_items env parent items =
+  List.fold_left
+    (fun acc item ->
+      match item.str_desc with
+#if defined OXCAML
+      | Tstr_include ({ incl_kind = (Tincl_functor _ | Tincl_gen_functor _); _ } as incl) ->
+        let hidden = true in
+        let wrapper = Cmi.generate_wrapper_module parent ~prefix:"BODY" ~hidden in
+        let wrapper_module = Cmi.wrapper_module wrapper ~hidden (List.rev acc) in
+        let items = read_include_functor env parent (snd wrapper) incl in
+        List.rev_append items (wrapper_module :: acc)
+#endif
+      | _ -> List.rev_append (read_structure_item env parent item) acc)
+    [] items
+  |> List.rev
+
 and read_structure :
       'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
       _ * 'tags =
@@ -626,13 +663,7 @@ and read_structure :
     in
     Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent str.str_items
   in
-  let items =
-    List.fold_left
-      (fun items item ->
-        List.rev_append (read_structure_item env parent item) items)
-      [] items
-    |> List.rev
-  in
+  let items = read_items env parent items in
   match doc_post with
   | { elements = [] ; _} ->
     ({ Signature.items; compiled = false; removed = []; doc }, tags)

src/loader/cmti.ml

@@ -907,28 +907,60 @@ and read_include env parent incl =
   let include_parent = Identifier.fresh_include_parent parent in
   let include_container = (include_parent :> Identifier.LabelParent.t) in
   let expr = read_module_type env include_parent include_container incl.incl_mod in
-  let umty = Odoc_model.Lang.umty_of_mty expr in 
   let expansion = { content; shadowed; } in
-#if defined OXCAML
-  match umty, incl.incl_kind with
-  | Some uexpr, Tincl_structure ->
-#else
-  match umty with
+  match Odoc_model.Lang.umty_of_mty expr with
   | Some uexpr ->
-#endif
     let decl = Include.ModuleType uexpr in
     [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
-  | _ ->
-    (* TODO: Handle [include functor] *)
+  | None ->
     content.items
 
+#if defined OXCAML
+(* [include functor F] applies [F] to [wrapper], a synthetic module holding
+   everything defined before the include.  A signature never has a path to [F]
+   -- only its module type -- so [F] is bound to a module to obtain one. *)
+and read_include_functor env parent wrapper incl =
+  let open Include in
+  let loc = Doc_attr.read_location incl.incl_loc in
+  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
+  let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
+  let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
+  let include_parent = Identifier.fresh_include_parent parent in
+  let include_container = (include_parent :> Identifier.LabelParent.t) in
+  let expr = read_module_type env include_parent include_container incl.incl_mod in
+  let expansion = { content; shadowed; } in
+  let hidden = true in
+  let id, functor_path = Cmi.generate_wrapper_module parent ~prefix:"INCLUDE" ~hidden in
+  let functor_ : Module.t = {id; source_loc=None; doc; type_=ModuleType expr; canonical=None; hidden} in
+  let decl = Functor {target = Path (`Apply (functor_path, wrapper)); original_ref = ModuleType expr} in
+  [ Signature.Module (Ordinary, functor_);
+    Include {parent; doc; decl; expansion; status; strengthened=None; loc } ]
+#endif
+
 and read_open env parent o =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag o.open_attributes in
   let signature = o.open_bound_items in
   let expansion, _ = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature signature) in
   { expansion; doc }
 
+and read_items env parent items =
+  List.fold_left
+    (fun acc item ->
+      match item.sig_desc with
+#if defined OXCAML
+      | Tsig_include ({ incl_kind = (Tincl_functor _ | Tincl_gen_functor _);
+                        incl_mod = { mty_desc = (Tmty_typeof _ | Tmty_ident _); _ }; _ } as incl, _) ->
+        let hidden = true in
+        let wrapper = Cmi.generate_wrapper_module parent ~prefix:"BODY" ~hidden in
+        let wrapper_module = Cmi.wrapper_module wrapper ~hidden (List.rev acc) in
+        let items = read_include_functor env parent (snd wrapper) incl in
+        List.rev_append items (wrapper_module :: acc)
+#endif
+      | _ -> List.rev_append (read_signature_item env parent item) acc)
+    [] items
+  |> List.rev
+
 and read_signature :
       'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
       _ * 'tags =
@@ -944,13 +976,7 @@ and read_signature :
     in
     Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent sg.sig_items
   in
-  let items =
-    List.fold_left
-      (fun items item ->
-        List.rev_append (read_signature_item env parent item) items)
-      [] items
-    |> List.rev
-  in
+  let items = read_items env parent items in
   match doc_post with
   | {elements=[]; _} ->
     ({ Signature.items; compiled = false; removed = []; doc }, tags)

src/model/lang.ml

@@ -195,8 +195,15 @@ and Include : sig
 
   type expansion = { shadowed : shadowed; content : Signature.t }
 
+  type functor_ref = Path of Path.Module.t | ModuleType of ModuleType.expr
+
+  type functor_t = { target : functor_ref; original_ref : functor_ref }
+
   (* Explicitly unexpanded decl *)
-  type decl = Alias of Path.Module.t | ModuleType of ModuleType.U.expr
+  type decl =
+    | Alias of Path.Module.t
+    | ModuleType of ModuleType.U.expr
+    | Functor of functor_t
 
   type t = {
     loc : Location_.span;
@@ -639,7 +646,12 @@ let extract_signature_doc (s : Signature.t) =
     (* A signature that starts with an include may inherits the
        top-comment from the expansion. *)
     | { Include.status = `Inline; _ } -> true
-    | { decl = Alias p; _ } -> Paths.Path.is_hidden (p :> Path.t)
+    | { decl = Functor { original_ref = Path p }; _ } | { decl = Alias p; _ } ->
+        Paths.Path.is_hidden (p :> Path.t)
+    | { decl = Functor { original_ref = ModuleType _ }; _ } ->
+        (* [include functor module type of ...]: nothing to be hidden behind,
+           so the enclosing signature does not inherit the top comment. *)
+        false
     | { decl = ModuleType expr; _ } -> uexpr_considered_hidden expr
   in
   match (s.doc, s.items) with