include functor support for OxCaml

CHANGES.md

@@ -4,6 +4,8 @@
 - Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #1422, #1444)
 - Remove requirement for ppx_expect in tests (@jonludlam, #1445)
 - Support for OxCaml modalities (@art-w, #1420)
+- Display items included via `include functor` as included via the functor
+  (@Leonidas-from-XIV, #1452)
 
 # 3.2.1
 

src/document/generator.ml

@@ -1916,23 +1916,27 @@ 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 (Path p) -> Paths.Path.(is_hidden (p :> t))
+        | ModuleType mty | Functor (ModuleType mty) -> umty_hidden mty
       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_decl =
+          let include_kw, include_decl =
             match t.decl with
             | Odoc_model.Lang.Include.Alias mod_path ->
-                Link.from_path (mod_path :> Paths.Path.t)
-            | ModuleType mt -> umty mt
+                (O.keyword "include", Link.from_path (mod_path :> Paths.Path.t))
+            | Functor (Path mod_path) ->
+                ( O.keyword "include functor",
+                  Link.from_path (mod_path :> Paths.Path.t) )
+            | Functor (ModuleType mt) -> (O.keyword "include functor", umty mt)
+            | ModuleType mt -> (O.keyword "include", 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/cmt.ml

@@ -613,26 +613,29 @@ and read_include env parent incl =
   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_functor _ | Tincl_gen_functor _) -> (
+      let p = Env.Path.read_module env.ident_env p in
+      Some (`Functor p))
     | 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))
+      Some (`Module_type (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)))
     | _ ->
       let mty = read_module_expr env parent container incl.incl_mod in
-      umty_of_mty mty
+      umty_of_mty mty |> Option.map (fun m -> `Module_type m)
   in
   let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
   let expansion = { content; shadowed; } in
   match decl_modty with
-  | Some m ->
+  | Some `Module_type m ->
     let decl = ModuleType m in
     [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
+  | Some `Functor p ->
+    let decl = Include.Functor (Path p) in
+    [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
   | _ ->
     content.items
 

src/loader/cmti.ml

@@ -965,8 +965,16 @@ and read_include env parent incl =
 #endif
     let decl = Include.ModuleType uexpr in
     [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
+#if defined OXCAML
+  | Some uexpr, (Tincl_functor _ | Tincl_gen_functor _) ->
+    let decl = match uexpr with
+      | TypeOf (ModPath p, _) -> Include.Functor (Path p)
+      | Path p -> Include.Functor (ModuleType uexpr)
+      | _ -> failwith "We expected TypeOf or Path but got something else"
+    in
+    [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
+#endif
   | _ ->
-    (* TODO: Handle [include functor] *)
     content.items
 
 and read_open env parent o =

src/model/lang.ml

@@ -195,8 +195,13 @@ and Include : sig
 
   type expansion = { shadowed : shadowed; content : Signature.t }
 
+  type functor' = Path of Path.Module.t | ModuleType of ModuleType.U.expr
+
   (* 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'
 
   type t = {
     loc : Location_.span;
@@ -632,7 +637,9 @@ 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 = Alias p; _ } | { decl = Functor (Path p); _ } ->
+        Paths.Path.is_hidden (p :> Path.t)
+    | { decl = Functor (ModuleType expr); _ } -> uexpr_considered_hidden expr
     | { decl = ModuleType expr; _ } -> uexpr_considered_hidden expr
   in
   match (s.doc, s.items) with

src/model_desc/lang_desc.ml

@@ -293,6 +293,8 @@ and include_decl =
   Variant
     (function
     | Alias p -> C ("Alias", (p :> Paths.Path.t), path)
+    | Functor (Path p) -> C ("Functor", (p :> Paths.Path.t), path)
+    | Functor (ModuleType e) -> C ("Functor", e, moduletype_u_expr)
     | ModuleType e -> C ("ModuleType", e, moduletype_u_expr))
 
 and include_expansion =

src/xref2/compile.ml

@@ -389,6 +389,10 @@ and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
   | ModuleType expr ->
       if is_elidable_with_module_type_u expr then ModuleType expr
       else ModuleType (u_module_type_expr env id expr)
+  | Functor (Path p) -> Functor (Path (module_path env p))
+  | Functor (ModuleType expr) ->
+      if is_elidable_with_module_type_u expr then ModuleType expr
+      else Functor (ModuleType (u_module_type_expr env id expr))
   | Alias p -> Alias (module_path env p)
 
 and module_type : Env.t -> ModuleType.t -> ModuleType.t =
@@ -410,10 +414,16 @@ and include_ : Env.t -> Include.t -> Include.t * Env.t =
     match
       let open Odoc_utils.ResultMonad in
       match decl with
+      | Functor (Path p) ->
+          Tools.expansion_of_module_path env ~strengthen:true p >>= fun exp ->
+          Tools.assert_functor exp
+      | Functor (ModuleType mty) ->
+          Tools.signature_of_u_module_type_expr env mty ~allow_functor:true
       | Alias p ->
           Tools.expansion_of_module_path env ~strengthen:true p >>= fun exp ->
           Tools.assert_not_functor exp
-      | ModuleType mty -> Tools.signature_of_u_module_type_expr env mty
+      | ModuleType mty ->
+          Tools.signature_of_u_module_type_expr env mty ~allow_functor:false
     with
     | Error e ->
         Errors.report ~what:(`Include decl) ~tools_error:e `Expand;
@@ -639,7 +649,9 @@ and module_type_map_subs env id cexpr subs =
   match find_parent cexpr with
   | None -> None
   | Some parent -> (
-      match Tools.signature_of_u_module_type_expr env cexpr with
+      match
+        Tools.signature_of_u_module_type_expr env cexpr ~allow_functor:false
+      with
       | Error e ->
           Errors.report ~what:(`Module_type id) ~tools_error:e `Lookup;
           None

src/xref2/component.ml

@@ -364,7 +364,11 @@ end =
   Open
 
 and Include : sig
-  type decl = Alias of Cpath.module_ | ModuleType of ModuleType.U.expr
+  type functor' = Path of Cpath.module_ | ModuleType of ModuleType.U.expr
+  type decl =
+    | Alias of Cpath.module_
+    | ModuleType of ModuleType.U.expr
+    | Functor of functor'
 
   type t = {
     parent : Odoc_model.Paths.Identifier.Signature.t;
@@ -924,6 +928,9 @@ module Fmt = struct
     let open Include in
     function
     | Alias p -> Format.fprintf ppf "%a" (module_path c) p
+    | Functor (Path p) -> Format.fprintf ppf "functor %a" (module_path c) p
+    | Functor (ModuleType mt) ->
+        Format.fprintf ppf "functor %a" (u_module_type_expr c) mt
     | ModuleType mt -> Format.fprintf ppf "%a" (u_module_type_expr c) mt
 
   and value c ppf v =
@@ -2410,6 +2417,9 @@ module Of_Lang = struct
   and include_decl ident_map m =
     match m with
     | Odoc_model.Lang.Include.Alias p -> Include.Alias (module_path ident_map p)
+    | Functor (Path p) -> Functor (Path (module_path ident_map p))
+    | Functor (ModuleType s) ->
+        Functor (ModuleType (u_module_type_expr ident_map s))
     | ModuleType s -> ModuleType (u_module_type_expr ident_map s)
 
   and simple_expansion ident_map

src/xref2/component.mli

@@ -336,7 +336,11 @@ and Open : sig
 end
 
 and Include : sig
-  type decl = Alias of Cpath.module_ | ModuleType of ModuleType.U.expr
+  type functor' = Path of Cpath.module_ | ModuleType of ModuleType.U.expr
+  type decl =
+    | Alias of Cpath.module_
+    | ModuleType of ModuleType.U.expr
+    | Functor of functor'
 
   type t = {
     parent : Odoc_model.Paths.Identifier.Signature.t;

src/xref2/lang_of.ml

@@ -651,6 +651,10 @@ and include_decl :
   (* Don't start shadowing within any signatures *)
   match d with
   | Alias p -> Alias (Path.module_ map p)
+  | Functor (Path p) -> Functor (Path (Path.module_ map p))
+  | Functor (ModuleType mty) ->
+      let include_parent = Identifier.fresh_include_parent identifier in
+      Functor (ModuleType (u_module_type_expr map include_parent mty))
   | ModuleType mty ->
       let include_parent = Identifier.fresh_include_parent identifier in
       ModuleType (u_module_type_expr map include_parent mty)

src/xref2/link.ml

@@ -707,6 +707,9 @@ and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
   match decl with
   | ModuleType expr when is_elidable_with_module_type_u expr -> ModuleType expr
   | ModuleType expr -> ModuleType (u_module_type_expr env id expr)
+  | Functor (Path p) -> Functor (Path (module_path env p))
+  | Functor (ModuleType expr) ->
+      Functor (ModuleType (u_module_type_expr env id expr))
   | Alias p -> Alias (module_path env p)
 
 and module_type : Env.t -> ModuleType.t -> ModuleType.t =
@@ -898,7 +901,9 @@ and u_module_type_expr :
   | Path p -> Path (module_type_path env p)
   | With (subs, expr) as unresolved -> (
       let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) expr) in
-      match Tools.signature_of_u_module_type_expr env cexpr with
+      match
+        Tools.signature_of_u_module_type_expr env cexpr ~allow_functor:false
+      with
       | Ok sg ->
           With (handle_fragments env id sg subs, u_module_type_expr env id expr)
       | Error e ->
@@ -945,7 +950,9 @@ and module_type_expr :
       Path { p_path; p_expansion = do_expn p_expansion (Some p_path) }
   | With { w_substitutions; w_expansion; w_expr } as unresolved -> (
       let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) w_expr) in
-      match Tools.signature_of_u_module_type_expr env cexpr with
+      match
+        Tools.signature_of_u_module_type_expr env cexpr ~allow_functor:false
+      with
       | Ok sg ->
           With
             {

src/xref2/subst.ml

@@ -759,6 +759,8 @@ and module_decl s t =
 and include_decl s t =
   match t with
   | Include.Alias p -> Include.Alias (module_path s p)
+  | Functor (Path p) -> Functor (Path (module_path s p))
+  | Functor (ModuleType t) -> ModuleType (u_module_type_expr s t)
   | ModuleType t -> ModuleType (u_module_type_expr s t)
 
 and module_ s t =

src/xref2/tools.ml

@@ -1586,6 +1586,12 @@ and assert_not_functor : type err.
   | Signature sg -> Ok sg
   | _ -> assert false
 
+and assert_functor : type err. expansion -> (Component.Signature.t, err) result
+    = function
+  | Functor (_, mty) -> (
+      match mty with Signature s -> Ok s | _ -> assert false)
+  | _ -> assert false
+
 and unresolve_subs subs =
   List.map
     (function
@@ -1621,22 +1627,28 @@ and signature_of_module_type_of :
 and signature_of_u_module_type_expr :
     Env.t ->
     Component.ModuleType.U.expr ->
+    allow_functor:bool ->
     (Component.Signature.t, expansion_of_module_error) result =
- fun env m ->
+ fun env m ~allow_functor ->
   match m with
   | Component.ModuleType.U.Path p -> (
       match resolve_module_type env p with
-      | Ok (_, mt) -> expansion_of_module_type env mt >>= assert_not_functor
+      | Ok (_, mt) -> (
+          expansion_of_module_type env mt
+          >>=
+          match allow_functor with
+          | true -> assert_functor
+          | false -> assert_not_functor)
       | Error e -> Error (`UnresolvedPath (`ModuleType (p, e))))
   | Signature s -> Ok s
   | With (subs, s) ->
-      signature_of_u_module_type_expr env s >>= fun sg ->
+      signature_of_u_module_type_expr env s ~allow_functor >>= fun sg ->
       let subs = unresolve_subs subs in
       handle_signature_with_subs env sg subs
   | TypeOf (desc, original_path) ->
       signature_of_module_type_of env desc ~original_path >>= assert_not_functor
   | Strengthen (expr, path, _aliasable) ->
-      signature_of_u_module_type_expr env expr >>= fun sg ->
+      signature_of_u_module_type_expr env expr ~allow_functor >>= fun sg ->
       Ok (Strengthen.signature path sg)
 
 and expansion_of_simple_expansion :
@@ -1667,7 +1679,8 @@ and expansion_of_module_type_expr :
   | Component.ModuleType.With { w_expansion = Some e; _ } ->
       Ok (expansion_of_simple_expansion e)
   | Component.ModuleType.With { w_substitutions; w_expr; _ } ->
-      signature_of_u_module_type_expr env w_expr >>= fun sg ->
+      signature_of_u_module_type_expr env w_expr ~allow_functor:false
+      >>= fun sg ->
       let subs = unresolve_subs w_substitutions in
       handle_signature_with_subs env sg subs >>= fun sg -> Ok (Signature sg)
   | Component.ModuleType.Functor (arg, expr) -> Ok (Functor (arg, expr))
@@ -1681,7 +1694,8 @@ and expansion_of_module_type_expr :
       in
       expansion_of_module_path env ~strengthen p
   | Component.ModuleType.Strengthen { s_expr; s_path; _ } ->
-      signature_of_u_module_type_expr env s_expr >>= fun sg ->
+      signature_of_u_module_type_expr env s_expr ~allow_functor:false
+      >>= fun sg ->
       let sg = Strengthen.signature s_path sg in
       Ok (Signature sg)
 
@@ -1812,7 +1826,12 @@ and fragmap :
         expansion_of_module_path env ~strengthen:true p >>= assert_not_functor
         >>= fun sg ->
         fragmap env subst sg >>= fun sg -> Ok (ModuleType (Signature sg))
-    | ModuleType mty' -> Ok (ModuleType (With ([ subst ], mty')))
+    | Functor (Path p) ->
+        expansion_of_module_path env ~strengthen:true p >>= assert_functor
+        >>= fun sg ->
+        fragmap env subst sg >>= fun sg -> Ok (ModuleType (Signature sg))
+    | Functor (ModuleType mty') | ModuleType mty' ->
+        Ok (ModuleType (With ([ subst ], mty')))
   in
   let map_module m new_subst =
     let open Component.Module in

src/xref2/tools.mli

@@ -201,6 +201,8 @@ val prefix_signature :
 
 val assert_not_functor : expansion -> (Component.Signature.t, 'err) result
 
+val assert_functor : expansion -> (Component.Signature.t, 'err) result
+
 val expansion_of_module_path :
   Env.t ->
   strengthen:bool ->
@@ -240,6 +242,7 @@ val expansion_of_module_type_expr :
 val signature_of_u_module_type_expr :
   Env.t ->
   Component.ModuleType.U.expr ->
+  allow_functor:bool ->
   (Component.Signature.t, expansion_of_module_error) result
 (** The following functions are use for the resolution of
     {{!type:Odoc_model.Paths.Fragment.t}Fragments} Whilst resolving fragments it

test/generators/cases/oxcaml.mli

@@ -280,3 +280,31 @@ module M3 : sig @@ contended
 end
 (** [contended] modality applied to all definitions in the module, except the
     ones which have already specified this axis. *)
+
+(** {1 Include functor on signatures} *)
+
+module No_include_functor : sig
+(** Module without any [include functor] features, this is how things are done
+    in plain OCaml at the moment. *)
+  module Make (T : sig type t end) : sig type included end
+  module T : sig
+    type t
+  end
+
+  include module type of T
+  include module type of Make(T)
+end
+
+module Include_functor : sig
+(** Module which defines a functor and includes it via [module type of] *)
+  module Make (T : sig type t end) : sig type included end
+  type t
+  include functor module type of Make
+end
+
+module Include_functor_named_type : sig
+(** This is a Module where the type is named and then included. *)
+  module type Make = (_ : sig type t end) -> sig type included end
+  type t
+  include functor Make
+end