Unified handling of internal tags

Handle tags as soon as possible instead of passing them around.
This ensures that internal tags are always handled.

Author: Julow

src/loader/cmi.ml

@@ -332,26 +332,6 @@ let mark_class_declaration cld =
   List.iter mark_type_parameter cld.cty_params;
   mark_class_type cld.cty_params cld.cty_type
 
-(* Handle internal tags *)
-
-let rec find_tag f = function
-  | [] -> None
-  | hd :: tl -> (
-      match f hd.Odoc_model.Location_.value with Some _ as x -> x | None -> find_tag f tl)
-
-let find_status_tag tags =
-  match
-    find_tag
-      (function (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
-      tags
-  with
-  | Some status -> status
-  | None -> `Default
-
-let find_canonical_tag tags : [ `Dot of Paths.Path.Module.t * string ] option =
-  (* Ignore [`Root _] paths *)
-  find_tag (function `Canonical (`Dot _ as p) -> Some p | _ -> None) tags
-
 let rec read_type_expr env typ =
   let open TypeExpr in
   let typ = Btype.repr typ in
@@ -525,7 +505,7 @@ let read_value_description env parent id vd =
   let open Signature in
   let id = Env.find_value_identifier env id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container vd.val_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container vd.val_attributes in
     mark_value_description vd;
     let type_ = read_type_expr env vd.val_type in
     match vd.val_kind with
@@ -546,8 +526,8 @@ let read_label_declaration env parent ld =
   let open TypeDecl.Field in
   let name = Ident.name ld.ld_id in
   let id = `Field(parent, Odoc_model.Names.FieldName.make_std name) in
-  let doc, _ =
-    Doc_attr.attached
+  let doc, () =
+    Doc_attr.attached Odoc_model.Semantics.Expect_none
       (parent :> Identifier.LabelParent.t) ld.ld_attributes
   in
   let mutable_ = (ld.ld_mutable = Mutable) in
@@ -573,7 +553,7 @@ let read_constructor_declaration env parent cd =
   let name = Ident.name cd.cd_id in
   let id = `Constructor(parent, Odoc_model.Names.ConstructorName.make_std name) in
   let container = (parent : Identifier.DataType.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container cd.cd_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container cd.cd_attributes in
   let args =
     read_constructor_declaration_arguments env
       (parent :> Identifier.Parent.t) cd.cd_args
@@ -634,8 +614,10 @@ let read_type_declaration env parent id decl =
   let open TypeDecl in
   let id = Env.find_type_identifier env id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, internal_tags = Doc_attr.attached container decl.type_attributes in
-  let canonical = (find_canonical_tag internal_tags :> Path.Type.t option) in
+  let doc, canonical =
+    Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.type_attributes
+  in
+  let canonical = (canonical :> Path.Type.t option) in
   let params = mark_type_declaration decl in
   let manifest = opt_map (read_type_expr env) decl.type_manifest in
   let constraints = read_type_constraints env params in
@@ -664,7 +646,7 @@ let read_extension_constructor env parent id ext =
   let name = Ident.name id in
   let id = `Extension(parent, Odoc_model.Names.ExtensionName.make_std name) in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container ext.ext_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container ext.ext_attributes in
   let args =
     read_constructor_declaration_arguments env
       (parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
@@ -697,7 +679,7 @@ let read_exception env parent id ext =
   let name = Ident.name id in
   let id = `Exception(parent, Odoc_model.Names.ExceptionName.make_std name) in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container ext.ext_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container ext.ext_attributes in
     mark_exception ext;
     let args =
       read_constructor_declaration_arguments env
@@ -795,7 +777,7 @@ let read_class_type_declaration env parent id cltd =
   let open ClassType in
   let id = Env.find_class_type_identifier env id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container cltd.clty_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container cltd.clty_attributes in
     mark_class_type_declaration cltd;
     let params =
       List.map2
@@ -830,7 +812,7 @@ let read_class_declaration env parent id cld =
   let open Class in
   let id = Env.find_class_identifier env id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container cld.cty_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container cld.cty_attributes in
     mark_class_declaration cld;
     let params =
       List.map2
@@ -869,17 +851,17 @@ and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_
   let open ModuleType in
   let id = Env.find_module_type env id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, internal_tags = Doc_attr.attached container mtd.mtd_attributes in
-  let canonical = (find_canonical_tag internal_tags :> Path.ModuleType.t option) in
+  let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
+  let canonical = (canonical :> Path.ModuleType.t option) in
   let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in
   {id; doc; canonical; expr }
 
 and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) =
   let open Module in
   let id = (Env.find_module_identifier env ident :> Identifier.Module.t) in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, internal_tags = Doc_attr.attached container md.md_attributes in
-  let canonical = (find_canonical_tag internal_tags :> Path.Module.t option) in
+  let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container md.md_attributes in
+  let canonical = (canonical :> Path.Module.t option) in
   let type_ =
     match md.md_type with
     | Mty_alias p -> Alias (Env.Path.read_module env p, None)

src/loader/cmi.mli

@@ -25,13 +25,6 @@ val read_interface :
   Odoc_model.Compat.signature ->
   Paths.Identifier.RootModule.t * Odoc_model.Lang.Signature.t
 
-val find_status_tag :
-  Odoc_model.Semantics.internal_tags -> [ `Default | `Inline | `Open | `Closed ]
-
-val find_canonical_tag :
-  Odoc_model.Semantics.internal_tags ->
-  [ `Dot of Paths.Path.Module.t * string ] option
-
 #if OCAML_MAJOR = 4 && OCAML_MINOR = 02
 val read_label : Asttypes.label -> Odoc_model.Lang.TypeExpr.label option
 #else

src/loader/cmt.ml

@@ -71,7 +71,7 @@ let rec read_pattern env parent doc pat =
 
 let read_value_binding env parent vb =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container vb.vb_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container vb.vb_attributes in
     read_pattern env parent doc vb.vb_pat
 
 let read_value_bindings env parent vbs =
@@ -93,7 +93,7 @@ let read_type_extension env parent tyext =
   let open Extension in
   let type_path = Env.Path.read_type env tyext.tyext_path in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container tyext.tyext_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container tyext.tyext_attributes in
   let type_params =
     List.map (fun (ctyp, _) -> ctyp.ctyp_type) tyext.tyext_params
   in
@@ -123,7 +123,7 @@ let rec read_class_type_field env parent ctf =
   let open Odoc_model.Names in
 
   let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container ctf.ctf_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container ctf.ctf_attributes in
   match ctf.ctf_desc with
   | Tctf_val(name, mutable_, virtual_, typ) ->
       let open InstanceVariable in
@@ -204,7 +204,7 @@ let rec read_class_field env parent cf =
   let open ClassSignature in
   let open Odoc_model.Names in
   let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container (cf.cf_attributes) in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container (cf.cf_attributes) in
   match cf.cf_desc with
   | Tcf_val({txt = name; _}, mutable_, _, kind, _) ->
       let open InstanceVariable in
@@ -306,7 +306,7 @@ let read_class_declaration env parent cld =
   let open Class in
   let id = Env.find_class_identifier env cld.ci_id_class in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, _ = Doc_attr.attached container cld.ci_attributes in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container cld.ci_attributes in
     Cmi.mark_class_declaration cld.ci_decl;
     let virtual_ = (cld.ci_virt = Virtual) in
     let clparams =
@@ -338,7 +338,9 @@ let rec read_module_expr env parent label_parent mexpr =
     match mexpr.mod_desc with
     | Tmod_ident _ ->
         Cmi.read_module_type env parent (Odoc_model.Compat.module_type mexpr.mod_type)
-    | Tmod_structure str -> Signature (fst (read_structure env parent str))
+    | Tmod_structure str ->
+        let sg, () = read_structure Odoc_model.Semantics.Expect_none env parent str in
+        Signature sg
 #if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
     | Tmod_functor(parameter, res) ->
         let f_parameter, env =
@@ -397,8 +399,8 @@ and read_module_binding env parent mb =
 #endif
   let id = (id :> Identifier.Module.t) in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, internal_tags = Doc_attr.attached container mb.mb_attributes in
-  let canonical = (Cmi.find_canonical_tag internal_tags :> Path.Module.t option) in
+  let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in
+  let canonical = (canonical :> Path.Module.t option) in
   let type_ =
     match unwrap_module_expr_desc mb.mb_expr.mod_desc with
     | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p, None)
@@ -504,7 +506,7 @@ and read_structure_item env parent item =
 and read_include env parent incl =
   let open Include in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
-  let doc, internal_tags = Doc_attr.attached container incl.incl_attributes in
+  let doc, status = Doc_attr.attached Odoc_model.Semantics.Expect_status container incl.incl_attributes in
   let decl_modty =
     match unwrap_module_expr_desc incl.incl_mod.mod_desc with
     | Tmod_ident(p, _) ->
@@ -524,7 +526,6 @@ and read_include env parent incl =
   | Some m when not (contains_signature m) ->
     let decl = ModuleType m in
     let expansion = { content; shadowed; } in
-    let status = Cmi.find_status_tag internal_tags in
     [Include {parent; doc; decl; expansion; status }]
   | Some (ModuleType.U.Signature { items; _ }) ->
     items
@@ -537,16 +538,19 @@ and read_open env parent o =
   Open.{expansion}
 #endif
 
-and read_structure env parent str =
+and read_structure :
+      'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
+      _ * 'tags =
+ fun internal_tags env parent str ->
   let env = Env.add_structure_tree_items parent str env in
-  let items, doc, internal_tags =
+  let items, doc, tags =
     let classify item =
       match item.str_desc with
       | Tstr_open _ -> Some `Open
       | Tstr_attribute attr -> Some (`Attribute attr)
       | _ -> None
     in
-    Doc_attr.extract_top_comment ~classify parent str.str_items
+    Doc_attr.extract_top_comment internal_tags ~classify parent str.str_items
   in
   let items =
     List.fold_left
@@ -555,11 +559,13 @@ and read_structure env parent str =
       [] items
     |> List.rev
   in
-  ({ items; compiled = false; doc }, internal_tags)
+  ({ Signature.items; compiled = false; doc }, tags)
 
 let read_implementation root name impl =
   let id = `Root (root, Odoc_model.Names.ModuleName.make_std name) in
-  let sg, internal_tags = read_structure Env.empty id impl in
-  (id, sg, internal_tags)
+  let sg, canonical =
+    read_structure Odoc_model.Semantics.Expect_canonical Env.empty id impl
+  in
+  (id, sg, (canonical :> Odoc_model.Paths.Path.Module.t option))
 
 let _ = Cmti.read_module_expr := read_module_expr

src/loader/cmt.mli

@@ -20,4 +20,6 @@ val read_implementation :
   Typedtree.structure ->
   Odoc_model.Paths.Identifier.RootModule.t
   * Odoc_model.Lang.Signature.t
-  * Odoc_model.Semantics.internal_tags
+  * Odoc_model.Paths.Path.Module.t option
+(** Returns [id, sg, canonical_path]. [canonical_path] is the path set from the
+    [@canonical] tag. *)