Lift deprecated and alerts attributes into odoc tags

src/document/comment.ml

@@ -226,8 +226,8 @@ and nestable_block_element_list elements =
 
 let tag : Comment.tag -> Description.one =
  fun t ->
+  let sp = inline (Text " ") in
   let item ?value ~tag definition =
-    let sp = inline (Text " ") in
     let tag_name = inline ~attr:[ "at-tag" ] (Text tag) in
     let tag_value =
       match value with
@@ -238,6 +238,11 @@ let tag : Comment.tag -> Description.one =
     { Description.attr = [ tag ]; key; definition }
   in
   let text_def s = [ block (Block.Inline [ inline @@ Text s ]) ] in
+  let content_to_inline ?(prefix = []) content =
+    match content with
+    | None -> []
+    | Some content -> prefix @ [ inline @@ Text content ]
+  in
   match t with
   | `Author s -> item ~tag:"author" (text_def s)
   | `Deprecated content ->
@@ -262,6 +267,13 @@ let tag : Comment.tag -> Description.one =
       let value = Inline.Text version in
       item ~tag:"before" ~value (nestable_block_element_list content)
   | `Version s -> item ~tag:"version" (text_def s)
+  | `Alert ("deprecated", content) ->
+      let content = content_to_inline content in
+      item ~tag:"deprecated" [ block (Block.Inline content) ]
+  | `Alert (tag, content) ->
+      let content = content_to_inline ~prefix:[ sp ] content in
+      item ~tag:"alert"
+        [ block (Block.Inline ([ inline @@ Text tag ] @ content)) ]
 
 let attached_block_element : Comment.attached_block_element -> Block.t =
   function

src/loader/cmi.ml

@@ -1069,14 +1069,3 @@ let read_interface root name intf =
   let id = `Root (root, Odoc_model.Names.ModuleName.make_std name) in
   let items = read_signature Env.empty id intf in
   (id, items)
-
-let point_of_pos { Lexing.pos_lnum; pos_bol; pos_cnum; _ } =
-  let column = pos_cnum - pos_bol in
-  { Odoc_model.Location_.line = pos_lnum; column }
-
-let read_location { Location.loc_start; loc_end; _ } =
-  {
-    Odoc_model.Location_.file = loc_start.pos_fname;
-    start = point_of_pos loc_start;
-    end_ = point_of_pos loc_end;
-  }

src/loader/cmi.mli

@@ -69,7 +69,7 @@ val read_signature_noenv : Ident_env.t ->
                        Paths.Identifier.Signature.t ->
                        Odoc_model.Compat.signature ->
                        (Odoc_model.Lang.Signature.t * Odoc_model.Lang.Include.shadowed)
-  
+
 val read_signature : Ident_env.t ->
                      Paths.Identifier.Signature.t ->
                      Odoc_model.Compat.signature -> Odoc_model.Lang.Signature.t
@@ -83,5 +83,3 @@ val read_extension_constructor : Ident_env.t ->
 val read_exception : Ident_env.t ->
   Paths.Identifier.Signature.t -> Ident.t ->
   Types.extension_constructor -> Odoc_model.Lang.Exception.t
-
-val read_location : Location.t -> Odoc_model.Location_.span

src/loader/cmt.ml

@@ -534,7 +534,7 @@ and read_structure_item env parent item =
 
 and read_include env parent incl =
   let open Include in
-  let loc = Cmi.read_location incl.incl_loc 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 Odoc_model.Semantics.Expect_status container incl.incl_attributes in
   let decl_modty =

src/loader/cmti.ml

@@ -738,7 +738,7 @@ and read_module_type_substitution env parent mtd =
 
 and read_include env parent incl =
   let open Include in
-  let loc = Cmi.read_location incl.incl_loc 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 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

src/loader/doc_attr.ml

@@ -18,70 +18,127 @@ open Odoc_model
 
 module Paths = Odoc_model.Paths
 
+let point_of_pos { Lexing.pos_lnum; pos_bol; pos_cnum; _ } =
+  let column = pos_cnum - pos_bol in
+  { Odoc_model.Location_.line = pos_lnum; column }
+
+let read_location { Location.loc_start; loc_end; _ } =
+  {
+    Odoc_model.Location_.file = loc_start.pos_fname;
+    start = point_of_pos loc_start;
+    end_ = point_of_pos loc_end;
+  }
 
 let empty_body = []
 
 let empty : Odoc_model.Comment.docs = empty_body
 
-
-
-let load_payload : Parsetree.payload -> string * Location.t = function
-  | PStr [{pstr_desc =
-      Pstr_eval ({pexp_desc =
+let load_constant_string = function
+  | {Parsetree.pexp_desc =
 #if OCAML_VERSION < (4,3,0)
-        Pexp_constant (Const_string (text, _))
+     Pexp_constant (Const_string (text, _))
 #elif OCAML_VERSION < (4,11,0)
-        Pexp_constant (Pconst_string (text, _))
+     Pexp_constant (Pconst_string (text, _))
 #else
-        Pexp_constant (Pconst_string (text, _, _))
+     Pexp_constant (Pconst_string (text, _, _))
 #endif
-   ; pexp_loc = loc; _}, _); _}] ->
-     (text, loc)
-  | _ -> assert false
+   ; pexp_loc = loc; _} ->
+       Some (text , loc)
+  | _ -> None
+
+let load_payload = function
+  | Parsetree.PStr [ { pstr_desc = Pstr_eval (constant_string, _); _ } ] ->
+      load_constant_string constant_string
+  | _ -> None
+
+let load_alert_name name = (Longident.last name.Location.txt)
 
+let load_alert_name_and_payload = function
+  | Parsetree.PStr
+      [ { pstr_desc = Pstr_eval ({ pexp_desc = expression; _ }, _); _ } ] -> (
+      match expression with
+      | Pexp_apply ({ pexp_desc = Pexp_ident name; _ }, [ (_, payload) ]) ->
+          Some (load_alert_name name, load_constant_string payload)
+      | Pexp_ident name -> Some (load_alert_name name, None)
+      | _ -> None)
+  | _ -> None
 
-let parse_attribute : Parsetree.attribute -> (string * Location.t) option = function
 #if OCAML_VERSION >= (4,8,0)
-  | { attr_name = { Location.txt =
-      ("text" | "ocaml.text"); loc = _loc}; attr_payload; _ } -> begin
+let attribute_unpack = function
+  | { Parsetree.attr_name = { Location.txt = name; _ }; attr_payload; attr_loc } ->
+      (name, attr_payload, attr_loc)
 #else
-  | ({Location.txt =
-      ("text" | "ocaml.text"); loc = _loc}, attr_payload) -> begin
+let attribute_unpack = function
+  | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc)
 #endif
-  Some (load_payload attr_payload)
-    end
+
+type payload = string * Location.t
+
+type parsed_attribute =
+  [ `Text of payload  (** Standalone comment. *)
+  | `Doc of payload  (** Attached comment. *)
+  | `Stop of Location.t  (** [(**/**)]. *)
+  | `Alert of  string * payload option * Location.t
+    (** [`Alert (name, payload, loc)] is for [\[@@alert name "payload"\]] attributes. *) ]
+
+(** Recognize an attribute. *)
+let parse_attribute : Parsetree.attribute -> parsed_attribute option =
+ fun attr ->
+  let name, attr_payload, attr_loc = attribute_unpack attr in
+  match name with
+  | "text" | "ocaml.text" -> (
+      match load_payload attr_payload with
+      | Some ("/*", _) -> Some (`Stop attr_loc)
+      | Some p -> Some (`Text p)
+      | None -> None)
+  | "doc" | "ocaml.doc" -> (
+      match load_payload attr_payload with
+      | Some p -> Some (`Doc p)
+      | None -> None)
+  | "deprecated" | "ocaml.deprecated" ->
+      Some (`Alert ("deprecated", (load_payload attr_payload), attr_loc))
+  | "alert" | "ocaml.alert" ->
+      (match load_alert_name_and_payload attr_payload with
+        Some (name, payload) ->
+      Some (`Alert (name, payload, attr_loc))
+      | None -> None)
   | _ -> None
 
+let is_stop_comment attr =
+  match parse_attribute attr with Some (`Stop _) -> true | _ -> false
+
 let pad_loc loc =
   { loc.Location.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3 }
 
-let ast_to_comment ~internal_tags parent ast_docs =
+let ast_to_comment ~internal_tags parent ast_docs alerts =
   Odoc_model.Semantics.ast_to_comment ~internal_tags ~sections_allowed:`All
-    ~parent_of_sections:parent ast_docs
+    ~parent_of_sections:parent ast_docs alerts
   |> Error.raise_warnings
 
+let mk_alert_payload ~loc name p =
+  let p = match p with Some (p, _) -> Some p | None -> None in
+  let elt = `Tag (`Alert (name, p)) in
+  let span = read_location loc in
+  Location_.at span elt
+
 let attached internal_tags parent attrs =
-  let rec loop acc =
-    function
-#if OCAML_VERSION >= (4,8,0)
-    | {Parsetree.attr_name = { Location.txt =
-          ("doc" | "ocaml.doc"); loc = _loc}; attr_payload; _ } :: rest -> begin
-#else
-    | ({Location.txt =
-          ("doc" | "ocaml.doc"); loc = _loc}, attr_payload) :: rest -> begin
-#endif
-        let str, loc = load_payload attr_payload in
-        let ast_docs =
-          Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
-          |> Error.raise_parser_warnings
-        in
-        loop (List.rev_append ast_docs acc) rest
-      end
-    | _ :: rest -> loop acc rest
-    | [] -> List.rev acc
+  let rec loop acc_docs acc_alerts = function
+    | attr :: rest -> (
+        match parse_attribute attr with
+        | Some (`Doc (str, loc)) ->
+            let ast_docs =
+              Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
+              |> Error.raise_parser_warnings
+            in
+            loop (List.rev_append ast_docs acc_docs) acc_alerts rest
+        | Some (`Alert (name, p, loc)) ->
+            let elt = mk_alert_payload ~loc name p in
+            loop acc_docs (elt :: acc_alerts) rest
+        | Some (`Text _ | `Stop _) | None -> loop acc_docs acc_alerts rest)
+    | [] -> (List.rev acc_docs, List.rev acc_alerts)
   in
-  let ast_docs = loop [] attrs in
-  ast_to_comment ~internal_tags parent ast_docs
+  let ast_docs, alerts = loop [] [] attrs in
+  ast_to_comment ~internal_tags parent ast_docs alerts
 
 let attached_no_tag parent attrs =
   let x, () = attached Semantics.Expect_none parent attrs in
@@ -109,10 +166,18 @@ let page parent loc str =
 let standalone parent (attr : Parsetree.attribute) :
     Odoc_model.Comment.docs_or_stop option =
   match parse_attribute attr with
-  | Some ("/*", _loc) -> Some `Stop
-  | Some (str, loc) ->
+  | Some (`Stop _loc) -> Some `Stop
+  | Some (`Text (str, loc)) ->
       let doc, () = read_string_comment Semantics.Expect_none parent loc str in
       Some (`Docs doc)
+  | Some (`Doc _) -> None
+  | Some (`Alert (name, _, attr_loc)) ->
+      let w =
+        Error.make "Alert %s not expected here." name
+          (read_location attr_loc)
+      in
+      Error.raise_warning w;
+      None
   | _ -> None
 
 let standalone_multiple parent attrs =
@@ -136,31 +201,54 @@ let split_docs docs =
   inner [] docs
 
 let extract_top_comment internal_tags ~classify parent items =
-  let rec extract ~classify = function
+  let classify x =
+    match classify x with
+    | Some (`Attribute attr) -> (
+        match parse_attribute attr with
+        | Some (`Text _ as p) -> p
+        | Some (`Doc _) -> `Skip (* Unexpected, silently ignore *)
+        | Some (`Alert (name, p, attr_loc)) ->
+            let p = match p with Some (p, _) -> Some p | None -> None in
+            let attr_loc = read_location attr_loc in
+            `Alert (Location_.at attr_loc (`Tag (`Alert (name, p))))
+        | Some (`Stop _) | None -> `Skip)
+    | Some `Open -> `Skip
+    | None -> `Return
+  in
+  let rec extract_tail_alerts acc = function
+    (* Accumulate the alerts after the top-comment. Stop at the next comment. *)
+    | hd :: tl as items -> (
+        match classify hd with
+        | `Text _ | `Return -> (items, acc)
+        | `Alert alert -> extract_tail_alerts (alert :: acc) tl
+        | `Skip -> extract_tail_alerts acc tl)
+    | [] -> ([], acc)
+  and extract = function
+    (* Extract the first comment and accumulate the alerts before and after
+       it. *)
     | hd :: tl as items -> (
         match classify hd with
-        | Some (`Attribute attr) -> (
-            match parse_attribute attr with
-            | Some (text, loc) ->
-                let ast_docs =
-                  Odoc_parser.parse_comment ~location:(pad_loc loc) ~text
-                  |> Error.raise_parser_warnings
-                in
-                (tl, ast_docs)
-            | None ->
-                let items, ast_docs = extract ~classify tl in
-                (hd :: items, ast_docs))
-        | Some `Open ->
-            let items, ast_docs = extract ~classify tl in
-            (hd :: items, ast_docs)
-        | None -> (items, []))
-    | [] -> ([], [])
+        | `Text (text, loc) ->
+            let ast_docs =
+              Odoc_parser.parse_comment ~location:(pad_loc loc) ~text
+              |> Error.raise_parser_warnings
+            in
+            let items, alerts = extract_tail_alerts [] tl in
+            (items, ast_docs, alerts)
+        | `Alert alert ->
+            let items, ast_docs, alerts = extract tl in
+            (items, ast_docs, alert :: alerts)
+        | `Skip ->
+            let items, ast_docs, alerts = extract tl in
+            (hd :: items, ast_docs, alerts)
+        | `Return -> (items, [], []))
+    | [] -> ([], [], [])
   in
-  let items, ast_docs = extract ~classify items in
+  let items, ast_docs, alerts = extract items in
   let docs, tags =
     ast_to_comment ~internal_tags
       (parent : Paths.Identifier.Signature.t :> Paths.Identifier.LabelParent.t)
-      ast_docs
+      ast_docs alerts
   in
   (items, split_docs docs, tags)
 

src/loader/doc_attr.mli

@@ -19,7 +19,7 @@ module Paths = Odoc_model.Paths
 
 val empty : Odoc_model.Comment.docs
 
-val parse_attribute : Parsetree.attribute -> (string * Location.t) option
+val is_stop_comment : Parsetree.attribute -> bool
 
 val attached :
   'tags Semantics.handle_internal_tags ->
@@ -68,3 +68,5 @@ val extract_top_comment_class :
   Lang.ClassSignature.item list ->
   Lang.ClassSignature.item list * (Comment.docs * Comment.docs)
 (** Extract the first comment of a class signature. Returns the remaining items. *)
+
+val read_location : Location.t -> Odoc_model.Location_.span

src/loader/ident_env.cppo.ml

@@ -192,11 +192,9 @@ let rec extract_signature_tree_items hide_item items =
       [`ModuleType (mtd.mtd_id, hide_item)] @ extract_signature_tree_items hide_item rest
   | {sig_desc = Tsig_include incl; _ } :: rest ->
       [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest
-  | {sig_desc = Tsig_attribute attr; _ } :: rest -> begin
-      match Doc_attr.parse_attribute attr with
-      | Some ("/*", _) -> extract_signature_tree_items (not hide_item) rest 
-      | _ -> extract_signature_tree_items hide_item rest
-    end
+  | {sig_desc = Tsig_attribute attr; _ } :: rest ->
+      let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in
+      extract_signature_tree_items hide_item rest
   | {sig_desc = Tsig_class cls; _} :: rest ->
       List.map
         (fun cld ->
@@ -301,12 +299,9 @@ let rec extract_structure_tree_items hide_item items =
         [`ModuleType (mtd.mtd_id, hide_item)] @ extract_structure_tree_items hide_item rest
     | { str_desc = Tstr_include incl; _ } :: rest ->
         [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_structure_tree_items hide_item rest
-
-    | { str_desc = Tstr_attribute attr; _} :: rest -> begin
-        match Doc_attr.parse_attribute attr with
-        | Some ("/*", _) -> extract_structure_tree_items (not hide_item) rest
-        | _ -> extract_structure_tree_items hide_item rest
-      end
+    | { str_desc = Tstr_attribute attr; _} :: rest ->
+        let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in
+        extract_structure_tree_items hide_item rest
     | { str_desc = Tstr_class cls; _ } :: rest ->
         List.map
 #if OCAML_VERSION < (4,3,0)