Separate handling of internal tags

src/document/comment.ml

@@ -255,7 +255,7 @@ and nestable_block_element_list elements =
   |> List.map Odoc_model.Location_.value
   |> List.map nestable_block_element
 
-let tag : Comment.tag -> Description.one option =
+let tag : Comment.tag -> Description.one =
  fun t ->
   let item ?value ~tag definition =
     let sp = inline (Text " ") in
@@ -266,7 +266,7 @@ let tag : Comment.tag -> Description.one option =
       | Some t -> [ sp; inline ~attr:[ "value" ] t ]
     in
     let key = tag_name :: tag_value in
-    Some { Description.attr = [ tag ]; key; definition }
+    { Description.attr = [ tag ]; key; definition }
   in
   let text_def s = [ block (Block.Inline [ inline @@ Text s ]) ] in
   match t with
@@ -293,15 +293,11 @@ let tag : Comment.tag -> Description.one option =
       let value = Inline.Text version in
       item ~tag:"before" ~value (nestable_block_element_list content)
   | `Version s -> item ~tag:"version" (text_def s)
-  | `Canonical _ | `Inline | `Open | `Closed -> None
 
 let attached_block_element : Comment.attached_block_element -> Block.t =
   function
   | #Comment.nestable_block_element as e -> [ nestable_block_element e ]
-  | `Tag t -> (
-      match tag t with
-      | None -> []
-      | Some t -> [ block ~attr:[ "at-tags" ] @@ Description [ t ] ])
+  | `Tag t -> [ block ~attr:[ "at-tags" ] @@ Description [ tag t ] ]
 
 (* TODO collaesce tags *)
 

src/document/generator.ml

@@ -1516,18 +1516,7 @@ module Make (Syntax : SYNTAX) = struct
         | Alias p -> Paths.Path.(is_hidden (p :> t))
         | ModuleType mty -> umty_hidden mty
       in
-      let status =
-        let is_open_tag element =
-          element.Odoc_model.Location_.value = `Tag `Open
-        in
-        let is_closed_tag element =
-          element.Odoc_model.Location_.value = `Tag `Closed
-        in
-        if t.inline || decl_hidden then `Inline
-        else if List.exists is_open_tag t.doc then `Open
-        else if List.exists is_closed_tag t.doc then `Closed
-        else `Default
-      in
+      let status = if decl_hidden then `Inline else t.status in
 
       let include_decl =
         match t.decl with

src/loader/cmi.ml

@@ -332,13 +332,6 @@ let mark_class_declaration cld =
   List.iter mark_type_parameter cld.cty_params;
   mark_class_type cld.cty_params cld.cty_type
 
-let canonical doc : [`Dot of Path.Module.t * string] option =
-  let doc = List.map Odoc_model.Location_.value doc in
-  match List.find (function `Tag (`Canonical _) -> true | _ -> false) doc with
-  | exception Not_found -> None
-  | `Tag (`Canonical (`Dot (p, n))) -> Some (`Dot (p, n) )
-  | _ -> None
-
 let rec read_type_expr env typ =
   let open TypeExpr in
   let typ = Btype.repr typ in
@@ -512,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_no_tag container vd.val_attributes in
     mark_value_description vd;
     let type_ = read_type_expr env vd.val_type in
     match vd.val_kind with
@@ -534,7 +527,7 @@ let read_label_declaration env parent ld =
   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
+    Doc_attr.attached_no_tag
       (parent :> Identifier.LabelParent.t) ld.ld_attributes
   in
   let mutable_ = (ld.ld_mutable = Mutable) in
@@ -560,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_no_tag container cd.cd_attributes in
   let args =
     read_constructor_declaration_arguments env
       (parent :> Identifier.Parent.t) cd.cd_args
@@ -621,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 = Doc_attr.attached container decl.type_attributes in
-  let canonical = (canonical doc :> 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
@@ -651,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_no_tag container ext.ext_attributes in
   let args =
     read_constructor_declaration_arguments env
       (parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
@@ -684,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_no_tag container ext.ext_attributes in
     mark_exception ext;
     let args =
       read_constructor_declaration_arguments env
@@ -782,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_no_tag container cltd.clty_attributes in
     mark_class_type_declaration cltd;
     let params =
       List.map2
@@ -817,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_no_tag container cld.cty_attributes in
     mark_class_declaration cld;
     let params =
       List.map2
@@ -856,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 = Doc_attr.attached container mtd.mtd_attributes in
-  let canonical = (canonical doc :> 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 = Doc_attr.attached container md.md_attributes in
-  let canonical = (canonical doc :> 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,8 +25,6 @@ val read_interface :
   Odoc_model.Compat.signature ->
   Paths.Identifier.RootModule.t * Odoc_model.Lang.Signature.t
 
-val canonical : Odoc_model.Comment.docs -> [ `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_no_tag 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_no_tag 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_no_tag 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_no_tag 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_no_tag 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 (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,14 +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 = Doc_attr.attached container mb.mb_attributes in
-  let canonical =
-    let doc = List.map Odoc_model.Location_.value doc in
-    match List.find (function `Tag (`Canonical _) -> true | _ -> false) doc with
-    | exception Not_found -> None
-    | `Tag (`Canonical p) -> Some (p :> Path.Module.t)
-    | _ -> None
-  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)
@@ -510,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 = 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, _) ->
@@ -530,7 +526,7 @@ and read_include env parent incl =
   | Some m when not (contains_signature m) ->
     let decl = ModuleType m in
     let expansion = { content; shadowed; } in
-    [Include {parent; doc; decl; expansion; inline=false }]
+    [Include {parent; doc; decl; expansion; status }]
   | Some (ModuleType.U.Signature { items; _ }) ->
     items
   | _ ->
@@ -542,21 +538,34 @@ 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, 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 internal_tags ~classify parent str.str_items
+  in
   let items =
     List.fold_left
       (fun items item ->
         List.rev_append (read_structure_item env parent item) items)
-      [] str.str_items
+      [] items
     |> List.rev
   in
-  let items, doc = Doc_attr.extract_top_comment items in
-  { items; compiled = false; doc }
+  ({ 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 = read_structure Env.empty id impl in
-  (id, sg)
+  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

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