2059

Committed 05 Jun 2024 09:55AM UTC coverage: 71.774% (+0.1%) from 71.636%

Build # 2059

Build Type

push

github

Committed by

jonludlam

Commit Message

doc adjustement

Run Details

2 of 2 new or added lines in 1 file covered. (100.0%)

112 existing lines in 5 files now uncovered.

9688 of 13498 relevant lines covered (71.77%)

3601.26 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

94.84

/src/model/reference.ml

let expected_err : string -> Location_.span -> Error.t =
  Error.make "Expected %s."

let unknown_reference_qualifier : string -> Location_.span -> Error.t =
  Error.make "Unknown reference qualifier '%s'."

let deprecated_reference_kind : string -> string -> Location_.span -> Error.t =
  Error.make "'%s' is deprecated, use '%s' instead."

let reference_kinds_do_not_match : string -> string -> Location_.span -> Error.t
    =
  Error.make "Old-style reference kind ('%s:') does not match new ('%s-')."

let should_not_be_empty : what:string -> Location_.span -> Error.t =
 fun ~what ->
  Error.make "%s should not be empty." (Astring.String.Ascii.capitalize what)

let not_allowed :
    ?suggestion:string ->
    what:string ->
    in_what:string ->
    Location_.span ->
    Error.t =
 fun ?suggestion ~what ~in_what ->
  Error.make ?suggestion "%s is not allowed in %s."
    (Astring.String.Ascii.capitalize what)
    in_what

let deprecated_reference_kind location kind replacement =
  deprecated_reference_kind kind replacement location |> Error.raise_warning

(* http://caml.inria.fr/pub/docs/manual-ocaml/ocamldoc.html#sec359. *)
let match_ocamldoc_reference_kind (_location as loc) s :
    Paths.Reference.tag_any option =
  let d = deprecated_reference_kind in
  match s with
  | "module" -> Some `TModule
  | "modtype" ->
      d loc "modtype" "module-type";
      Some `TModuleType
  | "class" -> Some `TClass
  | "classtype" ->
      d loc "classtype" "class-type";
      Some `TClassType
  | "val" -> Some `TValue
  | "type" -> Some `TType
  | "exception" -> Some `TException
  | "attribute" -> None
  | "method" -> Some `TMethod
  | "section" -> Some `TLabel
  | "const" ->
      d loc "const" "constructor";
      Some `TConstructor
  | "recfield" ->
      d loc "recfield" "field";
      Some `TField
  | "childpage" -> Some `TChildPage
  | "childmodule" -> Some `TChildModule
  | _ -> None

let match_extra_odoc_reference_kind (_location as loc) s :
    Paths.Reference.tag_any option =
  let d = deprecated_reference_kind in
  match s with
  | "class-type" -> Some `TClassType
  | "constructor" -> Some `TConstructor
  | "exn" ->
      d loc "exn" "exception";
      Some `TException
  | "extension" -> Some `TExtension
  | "extension-decl" -> Some `TExtensionDecl
  | "field" -> Some `TField
  | "instance-variable" -> Some `TInstanceVariable
  | "label" ->
      d loc "label" "section";
      Some `TLabel
  | "module-type" -> Some `TModuleType
  | "page" -> Some `TPage
  | "value" ->
      d loc "value" "val";
      Some `TValue
  | _ -> None

(* Ideally, [tokenize] would call this on every reference kind annotation during
   tokenization, when generating the token list. However, that constrains the
   phantom tag type to be the same for all tokens in the list (because lists are
   homogeneous). So, the parser stores kinds as strings in the token list
   instead, and this function is called on each string at the latest possible
   time to prevent typing issues.

   A secondary reason to delay parsing, and store strings in the token list, is
   that we need the strings for user-friendly error reporting. *)
let match_reference_kind location s : Paths.Reference.tag_any =
  match s with
  | None -> `TUnknown
  | Some s -> (
      let result =
        match match_ocamldoc_reference_kind location s with
        | Some kind -> Some kind
        | None -> match_extra_odoc_reference_kind location s
      in
      match result with
      | Some kind -> kind
      | None -> unknown_reference_qualifier s location |> Error.raise_exception)

type token = {
  kind : string option;
  identifier : string;
  location : Location_.span;
}

(* The string is scanned right-to-left, because we are interested in right-most
   hyphens. The tokens are also returned in right-to-left order, because the
   traversals that consume them prefer to look at the deepest identifier
   first. *)
let tokenize location s : token list =
  let rec scan_identifier started_at open_parenthesis_count index tokens =
    match s.[index] with
    | exception Invalid_argument _ ->
        let identifier, location = identifier_ended started_at index in
        { kind = None; identifier; location } :: tokens
    | '-' when open_parenthesis_count = 0 ->
        let identifier, location = identifier_ended started_at index in
        scan_kind identifier location index (index - 1) tokens
    | '.' when open_parenthesis_count = 0 ->
        let identifier, location = identifier_ended started_at index in
        scan_identifier index 0 (index - 1)
          ({ kind = None; identifier; location } :: tokens)
    | ')' ->
        scan_identifier started_at
          (open_parenthesis_count + 1)
          (index - 1) tokens
    | '(' when open_parenthesis_count > 0 ->
        scan_identifier started_at
          (open_parenthesis_count - 1)
          (index - 1) tokens
    | '"' -> (
        try
          scan_identifier started_at 0
            (String.rindex_from s (index - 1) '"' - 1)
            tokens
        with _ ->
          Error.raise_exception (Error.make "Unmatched quotation!" location))
    | _ -> scan_identifier started_at open_parenthesis_count (index - 1) tokens
  and identifier_ended started_at index =
    let offset = index + 1 in
    let length = started_at - offset in
    let identifier = String.sub s offset length in
    let identifier =
      Astring.String.cuts ~sep:"\"" identifier
      |> List.mapi (fun i s ->
             if i mod 2 = 0 then
               Astring.String.cuts s ~sep:" " |> String.concat ""
             else s)
      |> String.concat ""
    in
    let location = Location_.in_string s ~offset ~length location in

    if identifier = "" then
      should_not_be_empty ~what:"Identifier in reference" location
      |> Error.raise_exception;

    (identifier, location)
  and scan_kind identifier identifier_location started_at index tokens =
    match s.[index] with
    | exception Invalid_argument _ ->
        let kind, location = kind_ended identifier_location started_at index in
        { kind; identifier; location } :: tokens
    | '.' ->
        let kind, location = kind_ended identifier_location started_at index in
        scan_identifier index 0 (index - 1)
          ({ kind; identifier; location } :: tokens)
    | _ ->
        scan_kind identifier identifier_location started_at (index - 1) tokens
  and kind_ended identifier_location started_at index =
    let offset = index + 1 in
    let length = started_at - offset in
    let kind = Some (String.sub s offset length) in
    let location = Location_.in_string s ~offset ~length location in
    let location = Location_.span [ location; identifier_location ] in
    (kind, location)
  in

  scan_identifier (String.length s) 0 (String.length s - 1) [] |> List.rev

let expected allowed location =
  let unqualified = "or an unqualified reference" in
  let allowed =
    match allowed with
    | [ one ] -> Printf.sprintf "'%s-' %s" one unqualified
    | _ ->
        String.concat ", "
          (List.map (Printf.sprintf "'%s-'") allowed @ [ unqualified ])
  in
  expected_err allowed location

let parse whole_reference_location s :
    Paths.Reference.t Error.with_errors_and_warnings =
  let open Paths.Reference in
  let open Names in
  let rec signature { kind; identifier; location } tokens : Signature.t =
    let kind = match_reference_kind location kind in
    match tokens with
    | [] -> (
        match kind with
        | (`TUnknown | `TModule | `TModuleType) as kind ->
            `Root (identifier, kind)
        | _ ->
            expected [ "module"; "module-type" ] location
            |> Error.raise_exception)
    | next_token :: tokens -> (
        match kind with
        | `TUnknown ->
            `Dot ((parent next_token tokens :> LabelParent.t), identifier)
        | `TModule ->
            `Module (signature next_token tokens, ModuleName.make_std identifier)
        | `TModuleType ->
            `ModuleType
              (signature next_token tokens, ModuleTypeName.make_std identifier)
        | _ ->
            expected [ "module"; "module-type" ] location
            |> Error.raise_exception)
  and parent { kind; identifier; location } tokens : FragmentTypeParent.t =
    let kind = match_reference_kind location kind in
    match tokens with
    | [] -> (
        match kind with
        | (`TUnknown | `TModule | `TModuleType | `TType) as kind ->
            `Root (identifier, kind)
        | _ ->
            expected [ "module"; "module-type"; "type" ] location
            |> Error.raise_exception)
    | next_token :: tokens -> (
        match kind with
        | `TUnknown ->
            `Dot ((parent next_token tokens :> LabelParent.t), identifier)
        | `TModule ->
            `Module (signature next_token tokens, ModuleName.make_std identifier)
        | `TModuleType ->
            `ModuleType
              (signature next_token tokens, ModuleTypeName.make_std identifier)
        | `TType ->
            `Type (signature next_token tokens, TypeName.make_std identifier)
        | _ ->
            expected [ "module"; "module-type"; "type" ] location
            |> Error.raise_exception)
  in

  let class_signature { kind; identifier; location } tokens : ClassSignature.t =
    let kind = match_reference_kind location kind in
    match tokens with
    | [] -> (
        match kind with
        | (`TUnknown | `TClass | `TClassType) as kind -> `Root (identifier, kind)
        | _ ->
            expected [ "class"; "class-type" ] location |> Error.raise_exception
        )
    | next_token :: tokens -> (
        match kind with
        | `TUnknown ->
            `Dot ((parent next_token tokens :> LabelParent.t), identifier)
        | `TClass ->
            `Class (signature next_token tokens, ClassName.make_std identifier)
        | `TClassType ->
            `ClassType
              (signature next_token tokens, ClassTypeName.make_std identifier)
        | _ ->
            expected [ "class"; "class-type" ] location |> Error.raise_exception
        )
  in

  let rec label_parent { kind; identifier; location } tokens : LabelParent.t =
    let kind = match_reference_kind location kind in
    match tokens with
    | [] -> (
        match kind with
        | ( `TUnknown | `TModule | `TModuleType | `TType | `TClass | `TClassType
          | `TPage ) as kind ->
            `Root (identifier, kind)
        | _ ->
            expected
              [ "module"; "module-type"; "type"; "class"; "class-type"; "page" ]
              location
            |> Error.raise_exception)
    | next_token :: tokens -> (
        match kind with
        | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
        | `TModule ->
            `Module (signature next_token tokens, ModuleName.make_std identifier)
        | `TModuleType ->
            `ModuleType
              (signature next_token tokens, ModuleTypeName.make_std identifier)
        | `TType ->
            `Type (signature next_token tokens, TypeName.make_std identifier)
        | `TClass ->
            `Class (signature next_token tokens, ClassName.make_std identifier)
        | `TClassType ->
            `ClassType
              (signature next_token tokens, ClassTypeName.make_std identifier)
        | _ ->
            expected
              [ "module"; "module-type"; "type"; "class"; "class-type" ]
              location
            |> Error.raise_exception)
  in

  let start_from_last_component { kind; identifier; location } old_kind tokens =
    let new_kind = match_reference_kind location kind in
    let kind =
      match old_kind with
      | None -> new_kind
      | Some (old_kind_string, old_kind_location) -> (
          let old_kind =
            match_reference_kind old_kind_location (Some old_kind_string)
          in
          match new_kind with
          | `TUnknown -> old_kind
          | _ ->
              (if old_kind <> new_kind then
                 let new_kind_string =
                   match kind with Some s -> s | None -> ""
                 in
                 reference_kinds_do_not_match old_kind_string new_kind_string
                   whole_reference_location
                 |> Error.raise_warning);
              new_kind)
    in

    match tokens with
    | [] -> `Root (identifier, kind)
    | next_token :: tokens -> (
        match kind with
        | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
        | `TModule ->
            `Module (signature next_token tokens, ModuleName.make_std identifier)
        | `TModuleType ->
            `ModuleType
              (signature next_token tokens, ModuleTypeName.make_std identifier)
        | `TType ->
            `Type (signature next_token tokens, TypeName.make_std identifier)
        | `TConstructor ->
            `Constructor
              (parent next_token tokens, ConstructorName.make_std identifier)
        | `TField ->
            `Field (parent next_token tokens, FieldName.make_std identifier)
        | `TExtension ->
            `Extension
              (signature next_token tokens, ExtensionName.make_std identifier)
        | `TExtensionDecl ->
            `ExtensionDecl
              (signature next_token tokens, ExtensionName.make_std identifier)
        | `TException ->
            `Exception
              (signature next_token tokens, ExceptionName.make_std identifier)
        | `TValue ->
            `Value (signature next_token tokens, ValueName.make_std identifier)
        | `TClass ->
            `Class (signature next_token tokens, ClassName.make_std identifier)
        | `TClassType ->
            `ClassType
              (signature next_token tokens, ClassTypeName.make_std identifier)
        | `TMethod ->
            `Method
              (class_signature next_token tokens, MethodName.make_std identifier)
        | `TInstanceVariable ->
            `InstanceVariable
              ( class_signature next_token tokens,
                InstanceVariableName.make_std identifier )
        | `TLabel ->
            `Label
              (label_parent next_token tokens, LabelName.make_std identifier)
        | `TChildPage | `TChildModule ->
            let suggestion =
              Printf.sprintf "'child-%s' should be first." identifier
            in
            not_allowed ~what:"Child label"
              ~in_what:"the last component of a reference path" ~suggestion
              location
            |> Error.raise_exception
        | `TPage ->
            let suggestion =
              Printf.sprintf "'page-%s' should be first." identifier
            in
            not_allowed ~what:"Page label"
              ~in_what:"the last component of a reference path" ~suggestion
              location
            |> Error.raise_exception)
  in

  let old_kind, s, location =
    let rec find_old_reference_kind_separator index =
      if index < 0 then raise Not_found
      else
        match s.[index] with
        | ':' -> index
        | ')' -> (
            match String.rindex_from s index '(' with
            | index -> find_old_reference_kind_separator (index - 1)
            | exception (Not_found as exn) -> raise exn)
        | _ -> find_old_reference_kind_separator (index - 1)
    in
    match find_old_reference_kind_separator (String.length s - 1) with
    | index ->
        let old_kind = String.trim (String.sub s 0 index) in
        let old_kind_location =
          Location_.set_end_as_offset_from_start index whole_reference_location
        in
        let s = String.sub s (index + 1) (String.length s - (index + 1)) in
        let location =
          Location_.nudge_start (index + 1) whole_reference_location
        in
        (Some (old_kind, old_kind_location), s, location)
    | exception Not_found -> (None, s, whole_reference_location)
  in

  Error.catch_errors_and_warnings (fun () ->
      match tokenize location s with
      | last_token :: tokens ->
          start_from_last_component last_token old_kind tokens
      | [] ->
          should_not_be_empty ~what:"Reference target" whole_reference_location
          |> Error.raise_exception)

type path = [ `Root of string | `Dot of Paths.Path.Module.t * string ]

let read_path_longident location s =
  let open Paths.Path in
  let rec loop : string -> int -> path option =
   fun s pos ->
    try
      let idx = String.rindex_from s pos '.' in
      let name = String.sub s (idx + 1) (pos - idx) in
      if String.length name = 0 then None
      else
        match loop s (idx - 1) with
        | None -> None
        | Some parent -> Some (`Dot ((parent :> Module.t), name))
    with Not_found ->
      let name = String.sub s 0 (pos + 1) in
      if String.length name = 0 then None else Some (`Root name)
  in
  Error.catch_warnings (fun () ->
      match loop s (String.length s - 1) with
      | Some r -> Result.Ok (r :> path)
      | None -> Result.Error (expected_err "a valid path" location))

let read_mod_longident location lid =
  Error.catch_warnings (fun () ->
      match Error.raise_warnings (parse location lid) with
      | Error _ as e -> e
      | Ok p -> (
          match p with
          | (`Root (_, (`TUnknown | `TModule)) | `Dot (_, _) | `Module (_, _))
            as r ->
              Result.Ok r
          | _ -> Result.Error (expected_err "a reference to a module" location)))

1	let expected_err : string -> Location_.span -> Error.t =
2	Error.make "Expected %s."	955✔
3
4	let unknown_reference_qualifier : string -> Location_.span -> Error.t =
5	Error.make "Unknown reference qualifier '%s'."	955✔
6
7	let deprecated_reference_kind : string -> string -> Location_.span -> Error.t =
8	Error.make "'%s' is deprecated, use '%s' instead."	955✔
9
10	let reference_kinds_do_not_match : string -> string -> Location_.span -> Error.t
11	=
12	Error.make "Old-style reference kind ('%s:') does not match new ('%s-')."	955✔
13
14	let should_not_be_empty : what:string -> Location_.span -> Error.t =
15	fun ~what ->
16	Error.make "%s should not be empty." (Astring.String.Ascii.capitalize what)	24✔
17
18	let not_allowed :
19	?suggestion:string ->
20	what:string ->
21	in_what:string ->
22	Location_.span ->
23	Error.t =
24	fun ?suggestion ~what ~in_what ->
25	Error.make ?suggestion "%s is not allowed in %s."	1✔
26	(Astring.String.Ascii.capitalize what)	1✔
27	in_what
28
29	let deprecated_reference_kind location kind replacement =
30	deprecated_reference_kind kind replacement location \|> Error.raise_warning	8✔
31
32	(* http://caml.inria.fr/pub/docs/manual-ocaml/ocamldoc.html#sec359. *)
33	let match_ocamldoc_reference_kind (_location as loc) s :
34	Paths.Reference.tag_any option =
35	let d = deprecated_reference_kind in	533✔
36	match s with
37	\| "module" -> Some `TModule	79✔
38	\| "modtype" ->	1✔
39	d loc "modtype" "module-type";
40	Some `TModuleType	1✔
41	\| "class" -> Some `TClass	47✔
42	\| "classtype" ->	1✔
43	d loc "classtype" "class-type";
44	Some `TClassType	1✔
45	\| "val" -> Some `TValue	27✔
46	\| "type" -> Some `TType	35✔
47	\| "exception" -> Some `TException	17✔
48	\| "attribute" -> None	×
49	\| "method" -> Some `TMethod	47✔
50	\| "section" -> Some `TLabel	23✔
51	\| "const" ->	1✔
52	d loc "const" "constructor";
53	Some `TConstructor	1✔
54	\| "recfield" ->	1✔
55	d loc "recfield" "field";
56	Some `TField	1✔
57	\| "childpage" -> Some `TChildPage	3✔
58	\| "childmodule" -> Some `TChildModule	5✔
59	\| _ -> None	246✔
60
61	let match_extra_odoc_reference_kind (_location as loc) s :
62	Paths.Reference.tag_any option =
63	let d = deprecated_reference_kind in	246✔
64	match s with
65	\| "class-type" -> Some `TClassType	19✔
66	\| "constructor" -> Some `TConstructor	50✔
67	\| "exn" ->	1✔
68	d loc "exn" "exception";
69	Some `TException	1✔
70	\| "extension" -> Some `TExtension	19✔
71	\| "extension-decl" -> Some `TExtensionDecl	4✔
72	\| "field" -> Some `TField	55✔
73	\| "instance-variable" -> Some `TInstanceVariable	15✔
74	\| "label" ->	1✔
75	d loc "label" "section";
76	Some `TLabel	1✔
77	\| "module-type" -> Some `TModuleType	33✔
78	\| "page" -> Some `TPage	39✔
79	\| "value" ->	2✔
80	d loc "value" "val";
81	Some `TValue	2✔
82	\| _ -> None	8✔
83
84	(* Ideally, [tokenize] would call this on every reference kind annotation during
85	tokenization, when generating the token list. However, that constrains the
86	phantom tag type to be the same for all tokens in the list (because lists are
87	homogeneous). So, the parser stores kinds as strings in the token list
88	instead, and this function is called on each string at the latest possible
89	time to prevent typing issues.
90
91	A secondary reason to delay parsing, and store strings in the token list, is
92	that we need the strings for user-friendly error reporting. *)
93	let match_reference_kind location s : Paths.Reference.tag_any =
94	match s with	2,002✔
95	\| None -> `TUnknown	1,469✔
96	\| Some s -> (	533✔
97	let result =
98	match match_ocamldoc_reference_kind location s with
99	\| Some kind -> Some kind	287✔
100	\| None -> match_extra_odoc_reference_kind location s	246✔
101	in
102	match result with
103	\| Some kind -> kind	525✔
104	\| None -> unknown_reference_qualifier s location \|> Error.raise_exception)	8✔
105
106	type token = {
107	kind : string option;
108	identifier : string;
109	location : Location_.span;
110	}
111
112	(* The string is scanned right-to-left, because we are interested in right-most
113	hyphens. The tokens are also returned in right-to-left order, because the
114	traversals that consume them prefer to look at the deepest identifier
115	first. *)
116	let tokenize location s : token list =
117	let rec scan_identifier started_at open_parenthesis_count index tokens =	1,580✔
118	match s.[index] with	14,574✔
119	\| exception Invalid_argument _ ->	1,377✔
120	let identifier, location = identifier_ended started_at index in
121	{ kind = None; identifier; location } :: tokens	1,358✔
122	\| '-' when open_parenthesis_count = 0 ->	513✔
123	let identifier, location = identifier_ended started_at index in	512✔
124	scan_kind identifier location index (index - 1) tokens	508✔
125	\| '.' when open_parenthesis_count = 0 ->	173✔
126	let identifier, location = identifier_ended started_at index in	172✔
127	scan_identifier index 0 (index - 1)	171✔
128	({ kind = None; identifier; location } :: tokens)
129	\| ')' ->	9✔
130	scan_identifier started_at
131	(open_parenthesis_count + 1)
132	(index - 1) tokens
133	\| '(' when open_parenthesis_count > 0 ->	9✔
134	scan_identifier started_at	9✔
135	(open_parenthesis_count - 1)
136	(index - 1) tokens
137	\| '"' -> (	17✔
138	try
139	scan_identifier started_at 0	15✔
140	(String.rindex_from s (index - 1) '"' - 1)	16✔
141	tokens
142	with _ ->	2✔
143	Error.raise_exception (Error.make "Unmatched quotation!" location))	2✔
144	\| _ -> scan_identifier started_at open_parenthesis_count (index - 1) tokens	12,478✔
145	and identifier_ended started_at index =
146	let offset = index + 1 in	2,061✔
147	let length = started_at - offset in
148	let identifier = String.sub s offset length in
149	let identifier =	2,061✔
150	Astring.String.cuts ~sep:"\"" identifier
151	\|> List.mapi (fun i s ->	2,061✔
152	if i mod 2 = 0 then	2,091✔
153	Astring.String.cuts s ~sep:" " \|> String.concat ""	2,076✔
154	else s)	15✔
155	\|> String.concat ""	2,061✔
156	in
157	let location = Location_.in_string s ~offset ~length location in	2,061✔
158
159	if identifier = "" then	2,061✔
160	should_not_be_empty ~what:"Identifier in reference" location
UNCOV 161	\|> Error.raise_exception;	×
162
163	(identifier, location)	2,037✔
164	and scan_kind identifier identifier_location started_at index tokens =
165	match s.[index] with	4,051✔
166	\| exception Invalid_argument _ ->	197✔
167	let kind, location = kind_ended identifier_location started_at index in
168	{ kind; identifier; location } :: tokens	197✔
169	\| '.' ->	311✔
170	let kind, location = kind_ended identifier_location started_at index in
171	scan_identifier index 0 (index - 1)	311✔
172	({ kind; identifier; location } :: tokens)
173	\| _ ->	3,543✔
174	scan_kind identifier identifier_location started_at (index - 1) tokens
175	and kind_ended identifier_location started_at index =
176	let offset = index + 1 in	508✔
177	let length = started_at - offset in
178	let kind = Some (String.sub s offset length) in	508✔
179	let location = Location_.in_string s ~offset ~length location in
180	let location = Location_.span [ location; identifier_location ] in	508✔
181	(kind, location)	508✔
182	in
183
184	scan_identifier (String.length s) 0 (String.length s - 1) [] \|> List.rev	1,555✔
185
186	let expected allowed location =
187	let unqualified = "or an unqualified reference" in	148✔
188	let allowed =
189	match allowed with
UNCOV 190	\| [ one ] -> Printf.sprintf "'%s-' %s" one unqualified	×
191	\| _ ->	148✔
192	String.concat ", "	148✔
193	(List.map (Printf.sprintf "'%s-'") allowed @ [ unqualified ])	148✔
194	in
195	expected_err allowed location
196
197	let parse whole_reference_location s :
198	Paths.Reference.t Error.with_errors_and_warnings =
199	let open Paths.Reference in	1,580✔
200	let open Names in
201	let rec signature { kind; identifier; location } tokens : Signature.t =
202	let kind = match_reference_kind location kind in	119✔
203	match tokens with	119✔
204	\| [] -> (	96✔
205	match kind with
206	\| (`TUnknown \| `TModule \| `TModuleType) as kind ->	5✔
207	`Root (identifier, kind)
208	\| _ ->	39✔
209	expected [ "module"; "module-type" ] location
210	\|> Error.raise_exception)	39✔
211	\| next_token :: tokens -> (	23✔
212	match kind with
213	\| `TUnknown ->	3✔
214	`Dot ((parent next_token tokens :> LabelParent.t), identifier)	2✔
215	\| `TModule ->	4✔
216	`Module (signature next_token tokens, ModuleName.make_std identifier)	3✔
217	\| `TModuleType ->	4✔
218	`ModuleType
219	(signature next_token tokens, ModuleTypeName.make_std identifier)	3✔
220	\| _ ->	12✔
221	expected [ "module"; "module-type" ] location
222	\|> Error.raise_exception)	12✔
223	and parent { kind; identifier; location } tokens : FragmentTypeParent.t =
224	let kind = match_reference_kind location kind in	97✔
225	match tokens with	97✔
226	\| [] -> (	48✔
227	match kind with
228	\| (`TUnknown \| `TModule \| `TModuleType \| `TType) as kind ->	2✔
229	`Root (identifier, kind)
230	\| _ ->	27✔
231	expected [ "module"; "module-type"; "type" ] location
232	\|> Error.raise_exception)	27✔
233	\| next_token :: tokens -> (	49✔
234	match kind with
235	\| `TUnknown ->	9✔
236	`Dot ((parent next_token tokens :> LabelParent.t), identifier)	6✔
237	\| `TModule ->	4✔
238	`Module (signature next_token tokens, ModuleName.make_std identifier)	3✔
239	\| `TModuleType ->	4✔
240	`ModuleType
241	(signature next_token tokens, ModuleTypeName.make_std identifier)	3✔
242	\| `TType ->	6✔
243	`Type (signature next_token tokens, TypeName.make_std identifier)	4✔
244	\| _ ->	26✔
245	expected [ "module"; "module-type"; "type" ] location
246	\|> Error.raise_exception)	26✔
247	in
248
249	let class_signature { kind; identifier; location } tokens : ClassSignature.t =
250	let kind = match_reference_kind location kind in	40✔
251	match tokens with	40✔
252	\| [] -> (	19✔
253	match kind with
254	\| (`TUnknown \| `TClass \| `TClassType) as kind -> `Root (identifier, kind)	1✔
255	\| _ ->	14✔
256	expected [ "class"; "class-type" ] location \|> Error.raise_exception	14✔
257	)
258	\| next_token :: tokens -> (	21✔
259	match kind with
260	\| `TUnknown ->	3✔
261	`Dot ((parent next_token tokens :> LabelParent.t), identifier)	2✔
262	\| `TClass ->	3✔
263	`Class (signature next_token tokens, ClassName.make_std identifier)	2✔
264	\| `TClassType ->	3✔
265	`ClassType
266	(signature next_token tokens, ClassTypeName.make_std identifier)	2✔
267	\| _ ->	12✔
268	expected [ "class"; "class-type" ] location \|> Error.raise_exception	12✔
269	)
270	in
271
272	let rec label_parent { kind; identifier; location } tokens : LabelParent.t =
273	let kind = match_reference_kind location kind in	158✔
274	match tokens with	157✔
275	\| [] -> (	105✔
276	match kind with
277	\| ( `TUnknown \| `TModule \| `TModuleType \| `TType \| `TClass \| `TClassType	1✔
278	\| `TPage ) as kind ->	7✔
279	`Root (identifier, kind)
280	\| _ ->	8✔
281	expected
282	[ "module"; "module-type"; "type"; "class"; "class-type"; "page" ]
283	location
284	\|> Error.raise_exception)	8✔
285	\| next_token :: tokens -> (	52✔
286	match kind with
287	\| `TUnknown -> `Dot (label_parent next_token tokens, identifier)	27✔
288	\| `TModule ->	3✔
289	`Module (signature next_token tokens, ModuleName.make_std identifier)	2✔
290	\| `TModuleType ->	3✔
291	`ModuleType
292	(signature next_token tokens, ModuleTypeName.make_std identifier)	2✔
293	\| `TType ->	3✔
294	`Type (signature next_token tokens, TypeName.make_std identifier)	2✔
295	\| `TClass ->	5✔
296	`Class (signature next_token tokens, ClassName.make_std identifier)	3✔
297	\| `TClassType ->	1✔
298	`ClassType
299	(signature next_token tokens, ClassTypeName.make_std identifier)	1✔
300	\| _ ->	10✔
301	expected
302	[ "module"; "module-type"; "type"; "class"; "class-type" ]
303	location
304	\|> Error.raise_exception)	10✔
305	in
306
307	let start_from_last_component { kind; identifier; location } old_kind tokens =
308	let new_kind = match_reference_kind location kind in	1,555✔
309	let kind =	1,552✔
310	match old_kind with
311	\| None -> new_kind	1,519✔
312	\| Some (old_kind_string, old_kind_location) -> (	33✔
313	let old_kind =
314	match_reference_kind old_kind_location (Some old_kind_string)
315	in
316	match new_kind with	29✔
317	\| `TUnknown -> old_kind	26✔
318	\| _ ->	3✔
319	(if old_kind <> new_kind then
320	let new_kind_string =	1✔
UNCOV 321	match kind with Some s -> s \| None -> ""	×
322	in
323	reference_kinds_do_not_match old_kind_string new_kind_string
324	whole_reference_location
325	\|> Error.raise_warning);	1✔
326	new_kind)	3✔
327	in
328
329	match tokens with
330	\| [] -> `Root (identifier, kind)	1,218✔
331	\| next_token :: tokens -> (	330✔
332	match kind with
333	\| `TUnknown -> `Dot (label_parent next_token tokens, identifier)	99✔
334	\| `TModule ->	30✔
335	`Module (signature next_token tokens, ModuleName.make_std identifier)	6✔
336	\| `TModuleType ->	5✔
337	`ModuleType
338	(signature next_token tokens, ModuleTypeName.make_std identifier)	3✔
339	\| `TType ->	16✔
340	`Type (signature next_token tokens, TypeName.make_std identifier)	11✔
341	\| `TConstructor ->	38✔
342	`Constructor
343	(parent next_token tokens, ConstructorName.make_std identifier)	14✔
344	\| `TField ->	44✔
345	`Field (parent next_token tokens, FieldName.make_std identifier)	13✔
346	\| `TExtension ->	6✔
347	`Extension
348	(signature next_token tokens, ExtensionName.make_std identifier)	4✔
349	\| `TExtensionDecl ->	2✔
350	`ExtensionDecl
351	(signature next_token tokens, ExtensionName.make_std identifier)	2✔
352	\| `TException ->	4✔
353	`Exception
354	(signature next_token tokens, ExceptionName.make_std identifier)	2✔
355	\| `TValue ->	4✔
356	`Value (signature next_token tokens, ValueName.make_std identifier)	2✔
357	\| `TClass ->	5✔
358	`Class (signature next_token tokens, ClassName.make_std identifier)	3✔
359	\| `TClassType ->	4✔
360	`ClassType
361	(signature next_token tokens, ClassTypeName.make_std identifier)	2✔
362	\| `TMethod ->	36✔
363	`Method
364	(class_signature next_token tokens, MethodName.make_std identifier)	9✔
365	\| `TInstanceVariable ->	4✔
366	`InstanceVariable
367	( class_signature next_token tokens,	2✔
368	InstanceVariableName.make_std identifier )	4✔
369	\| `TLabel ->	8✔
370	`Label
371	(label_parent next_token tokens, LabelName.make_std identifier)	8✔
UNCOV 372	\| `TChildPage \| `TChildModule ->	×
373	let suggestion =
374	Printf.sprintf "'child-%s' should be first." identifier
375	in
UNCOV 376	not_allowed ~what:"Child label"	×
377	~in_what:"the last component of a reference path" ~suggestion
378	location
UNCOV 379	\|> Error.raise_exception	×
380	\| `TPage ->	1✔
381	let suggestion =
382	Printf.sprintf "'page-%s' should be first." identifier
383	in
384	not_allowed ~what:"Page label"	1✔
385	~in_what:"the last component of a reference path" ~suggestion
386	location
387	\|> Error.raise_exception)	1✔
388	in
389
390	let old_kind, s, location =
391	let rec find_old_reference_kind_separator index =
392	if index < 0 then raise Not_found	1,545✔
393	else
394	match s.[index] with	17,164✔
395	\| ':' -> index	35✔
396	\| ')' -> (	15✔
397	match String.rindex_from s index '(' with
398	\| index -> find_old_reference_kind_separator (index - 1)	15✔
UNCOV 399	\| exception (Not_found as exn) -> raise exn)	×
400	\| _ -> find_old_reference_kind_separator (index - 1)	17,114✔
401	in
402	match find_old_reference_kind_separator (String.length s - 1) with	1,580✔
403	\| index ->	35✔
404	let old_kind = String.trim (String.sub s 0 index) in	35✔
405	let old_kind_location =	35✔
406	Location_.set_end_as_offset_from_start index whole_reference_location
407	in
408	let s = String.sub s (index + 1) (String.length s - (index + 1)) in	35✔
409	let location =	35✔
410	Location_.nudge_start (index + 1) whole_reference_location
411	in
412	(Some (old_kind, old_kind_location), s, location)	35✔
413	\| exception Not_found -> (None, s, whole_reference_location)	1,545✔
414	in
415
416	Error.catch_errors_and_warnings (fun () ->
417	match tokenize location s with	1,580✔
418	\| last_token :: tokens ->	1,555✔
419	start_from_last_component last_token old_kind tokens
UNCOV 420	\| [] ->	×
421	should_not_be_empty ~what:"Reference target" whole_reference_location
UNCOV 422	\|> Error.raise_exception)	×
423
424	type path = [ `Root of string \| `Dot of Paths.Path.Module.t * string ]
425
426	let read_path_longident location s =
427	let open Paths.Path in	160✔
428	let rec loop : string -> int -> path option =
429	fun s pos ->
430	try	335✔
431	let idx = String.rindex_from s pos '.' in
432	let name = String.sub s (idx + 1) (pos - idx) in	176✔
433	if String.length name = 0 then None	1✔
434	else
435	match loop s (idx - 1) with	175✔
436	\| None -> None	1✔
437	\| Some parent -> Some (`Dot ((parent :> Module.t), name))	174✔
438	with Not_found ->	159✔
439	let name = String.sub s 0 (pos + 1) in
440	if String.length name = 0 then None else Some (`Root name)	1✔
441	in
442	Error.catch_warnings (fun () ->
443	match loop s (String.length s - 1) with	160✔
444	\| Some r -> Result.Ok (r :> path)	158✔
445	\| None -> Result.Error (expected_err "a valid path" location))	2✔
446
447	let read_mod_longident location lid =
448	Error.catch_warnings (fun () ->	30✔
449	match Error.raise_warnings (parse location lid) with	30✔
UNCOV 450	\| Error _ as e -> e	×
451	\| Ok p -> (	30✔
452	match p with
UNCOV 453	\| (`Root (_, (`TUnknown \| `TModule)) \| `Dot (_, _) \| `Module (_, _))	×
454	as r ->
455	Result.Ok r
UNCOV 456	\| _ -> Result.Error (expected_err "a reference to a module" location)))	×

ocaml / odoc / 2059

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous