Source file doc_attr.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 =
#if OCAML_VERSION < (4,11,0)
     Pexp_constant (Pconst_string (text, _))
#elif OCAML_VERSION < (5,3,0)
     Pexp_constant (Pconst_string (text, _, _))
#else
     Pexp_constant {pconst_desc= Pconst_string (text, _, _); _}
#endif
   ; 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 attribute_unpack = function
  | { Parsetree.attr_name = { Location.txt = name; _ }; attr_payload; attr_loc } ->
      (name, attr_payload, attr_loc)

#if defined OXCAML
(* the input is a [Zero_alloc.t] which is not present in OCaml, so it can't be
   a no-op *)
let lang_value_attr_of_zero_alloc zero_alloc =
  match Zero_alloc.get zero_alloc with
    | Default_zero_alloc -> None
    | Ignore_assert_all -> None
    | Assume { arity; _} ->
        Some (Lang.Value.Zero_alloc ( Lang.Value.Zero_alloc.{ opt = false; strict = false; arity; custom_error_msg = None }))
    | Check { strict; opt; arity; custom_error_msg } ->
        Some (Lang.Value.Zero_alloc ( Lang.Value.Zero_alloc.{ opt; strict; arity; custom_error_msg }))
#endif

#if defined OXCAML
let attrs_of_value_description (vd : Types.value_description) =
  let zero_alloc = lang_value_attr_of_zero_alloc vd.val_zero_alloc in
  match zero_alloc with
  | Some za -> [za]
  | None -> []
#else
let attrs_of_value_description (vd : Types.value_description) = []
#endif

#if defined OXCAML
let id_attrs_of_value_bindings vbs =
  vbs |> Typedtree.let_bound_idents_with_modes_sorts_and_checks |> List.fold_left (fun tbl (ident, _, zero_alloc) ->
    match lang_value_attr_of_zero_alloc zero_alloc with
    | None -> tbl
    | Some attr -> Ident.add ident [attr] tbl) Ident.empty
#else
let id_attrs_of_value_bindings _vbs = Ident.empty
#endif

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

(* The same doc-comment text is often attached to many definitions (OxCaml's
   ppx_template can produce tens of thousands of copies of one comment), so
   parses are memoized by raw text. The parsed AST bakes in absolute source
   locations, so a cached parse is only reused when it is location-
   insensitive: it produced no warnings and contains no headings, references
   or [{!modules ...}], whose locations feed warnings and ambiguous-heading
   detection during linking. Anything else is re-parsed per occurrence. *)

let rec inline_element_needs_own_location
    (x : Odoc_parser.Ast.inline_element) =
  match x with
  | `Reference _ -> true
  | `Styled (_, xs) ->
      List.exists
        (fun e -> inline_element_needs_own_location (Odoc_parser.Loc.value e))
        xs
  | `Space _ | `Word _ | `Code_span _ | `Raw_markup _ | `Link _
  | `Math_span _ ->
      false

let rec nestable_block_element_needs_own_location
    (x : Odoc_parser.Ast.nestable_block_element) =
  match x with
  | `Paragraph xs ->
      List.exists
        (fun e -> inline_element_needs_own_location (Odoc_parser.Loc.value e))
        xs
  | `Modules _ -> true
  | `Media (_, href, _, _) -> (
      match Odoc_parser.Loc.value href with
      | `Reference _ -> true
      | `Link _ -> false)
  | `List (_, _, yss) ->
      List.exists
        (List.exists (fun e ->
             nestable_block_element_needs_own_location (Odoc_parser.Loc.value e)))
        yss
  | `Table ((grid, _), _) ->
      List.exists
        (List.exists (fun (cell, _) ->
             List.exists
               (fun e ->
                 nestable_block_element_needs_own_location
                   (Odoc_parser.Loc.value e))
               cell))
        grid
  | `Code_block _ | `Verbatim _ | `Math_block _ -> false

let tag_needs_own_location (x : Odoc_parser.Ast.tag) =
  match x with
  | `Deprecated c | `Param (_, c) | `Raise (_, c) | `Return c
  | `See (_, _, c) | `Before (_, c) | `Children_order c | `Toc_status c
  | `Order_category c | `Short_title c | `Custom (_, c) ->
      List.exists
        (fun e ->
          nestable_block_element_needs_own_location (Odoc_parser.Loc.value e))
        c
  | `Author _ | `Since _ | `Version _ | `Canonical _ | `Inline | `Open
  | `Closed | `Hidden ->
      false

let block_element_needs_own_location (x : Odoc_parser.Ast.block_element) =
  match x with
  | `Heading _ -> true
  | `Tag t -> tag_needs_own_location t
  | #Odoc_parser.Ast.nestable_block_element as x ->
      nestable_block_element_needs_own_location x

let ast_needs_own_location (ast : Odoc_parser.Ast.t) =
  List.exists
    (fun e -> block_element_needs_own_location (Odoc_parser.Loc.value e))
    ast

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

let attached ~warnings_tag internal_tags parent attrs =
  let rec loop acc_docs acc_alerts = function
    | attr :: rest -> (
        match parse_attribute attr with
        | Some (`Doc (str, loc)) ->
            let ast_docs =
              match Hashtbl.find_opt doc_cache str with
              | Some cached -> cached
              | None ->
                  let parsed =
                    Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
                  in
                  let ast =
                    Semantics.merge_ast (Error.raise_parser_warnings parsed)
                  in
                  (match Odoc_parser.warnings parsed with
                  | [] when not (ast_needs_own_location ast) ->
                      Hashtbl.replace doc_cache str ast
                  | _ -> ());
                  ast
            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, alerts = loop [] [] attrs in
  let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts 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:false 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