Source file doc_attr.ml

# 1 "doc_attr.cppo.ml"
(*
 * Copyright (c) 2014 Leo White <lpw25@cl.cam.ac.uk>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

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 warnings_tag = { Comment.elements = []; warnings_tag }

let empty warnings_tag : Odoc_model.Comment.docs = empty_body warnings_tag

let load_constant_string = function
  | {Parsetree.pexp_desc =
     
# 43 "doc_attr.cppo.ml"
     Pexp_constant (Pconst_string (text, _, _))
   
# 47 "doc_attr.cppo.ml"
   ; 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

# 69 "doc_attr.cppo.ml"
let attribute_unpack = function
  | { Parsetree.attr_name = { Location.txt = name; _ }; attr_payload; attr_loc } ->
      (name, attr_payload, attr_loc)

# 77 "doc_attr.cppo.ml"
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" -> (
      (* We don't expect a stop-comment here. *)
      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 alerts =
  Odoc_model.Semantics.ast_to_comment ~internal_tags
    ~tags_allowed:true ~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 doc_parse_time = ref 0.0
let doc_parse_count = ref 0
let doc_parse_skipped = ref 0
let skip_doc_parsing = ref false

let tag_docs =
  match Sys.getenv_opt "ODOC_TAG_DOCS" with
  | Some "1" | Some "true" -> true
  | _ -> false

let doc_cache : (string, Odoc_parser.Ast.t) Hashtbl.t = Hashtbl.create 256
let doc_cache_hits = ref 0

(* Cache for the full semantic analysis result (parse + ast_to_comment).
   Keyed on the raw doc string. Returns the processed Comment elements.
   Correct for docs without section headings (which is ~all PPX-duplicated docs). *)
let semantic_cache : (string, Odoc_model.Comment.block_element Odoc_model.Location_.with_location list) Hashtbl.t = Hashtbl.create 256
let semantic_cache_hits = ref 0

let () =
  match Sys.getenv_opt "ODOC_GC_STATS" with
  | None | Some "" | Some "0" -> ()
  | Some _ ->
      at_exit (fun () ->
        Printf.eprintf "ODOC_DOC_PARSE time=%.3f count=%d skipped=%d cache_hits=%d cache_size=%d\n%!"
          !doc_parse_time !doc_parse_count !doc_parse_skipped
          !doc_cache_hits (Hashtbl.length doc_cache))

let attached ~warnings_tag internal_tags parent attrs =
  if !skip_doc_parsing then begin
    incr doc_parse_skipped;
    let empty_tags : type a. a Odoc_model.Semantics.handle_internal_tags -> a = function
      | Odoc_model.Semantics.Expect_none -> ()
      | Odoc_model.Semantics.Expect_canonical -> None
      | Odoc_model.Semantics.Expect_status -> `Default
      | Odoc_model.Semantics.Expect_page_tags -> Odoc_model.Frontmatter.empty
    in
    ({ Comment.elements = []; warnings_tag }, empty_tags internal_tags)
  end else
  let rec loop acc_docs acc_alerts = function
    | attr :: rest -> (
        match parse_attribute attr with
        | Some (`Doc (str, loc)) ->
            begin
              let n = !doc_parse_count in
              let str =
                if tag_docs then begin
                  (match Sys.getenv_opt "ODOC_TAG_MANIFEST" with
                   | Some f ->
                       let oc = open_out_gen [Open_append; Open_creat] 0o644 f in
                       let text_preview =
                         let s = String.trim str in
                         if String.length s > 60 then String.sub s 0 60 ^ "..."
                         else s
                       in
                       Printf.fprintf oc "%d\t%s:%d\t%s\t%s\n"
                         n loc.loc_start.pos_fname loc.loc_start.pos_lnum
                         (if !skip_doc_parsing then "SKIP" else "PARSE")
                         text_preview;
                       close_out oc
                   | None -> ());
                  Printf.sprintf "{b ODOC_TAG/%s/%d} %s"
                    loc.loc_start.pos_fname n str
                end
                else str
              in
              let ast_docs =
                match Hashtbl.find_opt doc_cache str with
                | Some cached ->
                    incr doc_cache_hits;
                    cached
                | None ->
                    let t0 = Sys.time () in
                    let parsed =
                      Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
                      |> Error.raise_parser_warnings
                    in
                    doc_parse_time := !doc_parse_time +. (Sys.time () -. t0);
                    Hashtbl.replace doc_cache str parsed;
                    parsed
              in
              incr doc_parse_count;
              loop (List.rev_append ast_docs acc_docs) acc_alerts rest
            end
        | 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, alerts = loop [] [] attrs in
  (* Build a cache key from the raw doc text. For docs without section
     headings (which is the vast majority of PPX-duplicated docs), the
     semantic analysis result is independent of parent. *)
  let cache_key =
    (* Use first doc string directly as cache key — avoids O(n*len)
       string concatenation. Works because the vast majority of items
       have exactly one doc attribute. *)
    let rec find_first = function
      | [] -> None
      | attr :: rest ->
          match parse_attribute attr with
          | Some (`Doc (str, _)) -> Some str
          | _ -> find_first rest
    in
    find_first attrs
  in
  let elements, warnings =
    match cache_key with
    | None ->
      ast_to_comment ~internal_tags parent ast_docs alerts
    | Some key ->
      match Hashtbl.find_opt semantic_cache key with
      | Some cached ->
          incr semantic_cache_hits;
          let empty_tags : type a. a Odoc_model.Semantics.handle_internal_tags -> a = function
            | Odoc_model.Semantics.Expect_none -> ()
            | Odoc_model.Semantics.Expect_canonical -> None
            | Odoc_model.Semantics.Expect_status -> `Default
            | Odoc_model.Semantics.Expect_page_tags -> Odoc_model.Frontmatter.empty
          in
          (cached, empty_tags internal_tags)
      | None ->
          let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts in
          Hashtbl.replace semantic_cache key elements;
          (elements, warnings)
  in
  { Comment.elements; warnings_tag }, warnings

let attached_no_tag ~warnings_tag parent attrs =
  let x, () = attached ~warnings_tag Semantics.Expect_none parent attrs in
  x

let read_string ~tags_allowed internal_tags parent location str =
  Odoc_model.Semantics.parse_comment
    ~internal_tags
    ~tags_allowed
    ~containing_definition:parent
    ~location
    ~text:str
  |> Odoc_model.Error.raise_warnings

let read_string_comment internal_tags parent loc str =
  read_string ~tags_allowed:true internal_tags parent (pad_loc loc) str

let page parent loc str =
  let elements, tags = read_string ~tags_allowed:true Odoc_model.Semantics.Expect_page_tags parent loc.Location.loc_start
      str
  in
  { Comment.elements; warnings_tag = None }, tags

let standalone parent ~warnings_tag (attr : Parsetree.attribute) :
    Odoc_model.Comment.docs_or_stop option =
  match parse_attribute attr with
  | Some (`Stop _loc) -> Some `Stop
  | Some (`Text (str, loc)) ->
      let elements, () = read_string_comment Semantics.Expect_none parent loc str in
      Some (`Docs { elements; warnings_tag })
  | 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 ~warnings_tag attrs =
  let coms =
    List.fold_left
      (fun acc attr ->
        match standalone parent ~warnings_tag attr  with
         | None -> acc
         | Some com -> com :: acc)
      [] attrs
  in
    List.rev coms

let split_docs docs =
  let rec inner first x =
    match x with
    | { Location_.value = `Heading _; _ } :: _ -> List.rev first, x
    | x :: y -> inner (x::first) y
    | [] -> List.rev first, []
  in
  inner [] docs

let extract_top_comment internal_tags ~warnings_tag ~classify parent items =
  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 _) -> `Return (* Stop at stop-comments. *)
        | None -> `Skip (* Skip unrecognized attributes. *))
    | Some `Open -> `Skip (* Skip open statements *)
    | None -> `Return
  in
  let rec extract_tail_alerts acc = function
    (* Accumulate the alerts after the top-comment. Stop at the next comment.
       [`Skip] items (open statements, unrecognised attributes) are preserved
       in the returned items list — dropping them silently loses [open
       struct ... end] declarations that follow the top docstring. *)
    | hd :: tl as items -> (
        match classify hd with
        | `Text _ | `Return -> (items, acc)
        | `Alert alert -> extract_tail_alerts (alert :: acc) tl
        | `Skip ->
            let items, alerts = extract_tail_alerts acc tl in
            (hd :: items, alerts))
    | [] -> ([], acc)
  and extract = function
    (* Extract the first comment and accumulate the alerts before and after
       it. *)
    | hd :: tl as items -> (
        match classify hd with
        | `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, alerts = extract items in
  let docs, tags =
    ast_to_comment ~internal_tags
      (parent : Paths.Identifier.Signature.t :> Paths.Identifier.LabelParent.t)
      ast_docs alerts
  in
  let d1, d2 = split_docs docs in
  ( items,
    ( { Comment.elements = d1; warnings_tag },
      { Comment.elements = d2; warnings_tag } ),
    tags )

let extract_top_comment_class items =
  let mk elements warnings_tag = { Comment.elements; warnings_tag } in
  match items with
  | Lang.ClassSignature.Comment (`Docs doc) :: tl ->
      let d1, d2 = split_docs doc.elements in
      (tl, (mk d1 doc.warnings_tag, mk d2 doc.warnings_tag))
  | _ -> (items, (mk [] None, mk [] None))

let rec conv_canonical_module : Odoc_model.Reference.path -> Paths.Path.Module.t = function
  | `Dot (parent, name) -> `Dot (conv_canonical_module parent, Names.ModuleName.make_std name)
  | `Root name -> `Root (Names.ModuleName.make_std name)

let conv_canonical_type : Odoc_model.Reference.path -> Paths.Path.Type.t option = function
  | `Dot (parent, name) -> Some (`DotT (conv_canonical_module parent, Names.TypeName.make_std name))
  | _ -> None

let conv_canonical_module_type : Odoc_model.Reference.path -> Paths.Path.ModuleType.t option = function
  | `Dot (parent, name) -> Some (`DotMT (conv_canonical_module parent, Names.ModuleTypeName.make_std name))
  | _ -> None