1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Leo White *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Location
17
18 (* Docstrings *)
19
20 (* A docstring is "attached" if it has been inserted in the AST. This
21 is used for generating unexpected docstring warnings. *)
22 type ds_attached =
23 | Unattached (* Not yet attached anything.*)
24 | Info (* Attached to a field or constructor. *)
25 | Docs (* Attached to an item or as floating text. *)
26
27 (* A docstring is "associated" with an item if there are no blank lines between
28 them. This is used for generating docstring ambiguity warnings. *)
29 type ds_associated =
30 | Zero (* Not associated with an item *)
31 | One (* Associated with one item *)
32 | Many (* Associated with multiple items (ambiguity) *)
33
34 type docstring =
35 { ds_body: string;
36 ds_loc: Location.t;
37 mutable ds_attached: ds_attached;
38 mutable ds_associated: ds_associated; }
39
40 (* List of docstrings *)
41
42 let docstrings : docstring list ref = ref []
43
44 (* Warn for unused and ambiguous docstrings *)
45
46 let warn_bad_docstrings () =
47 if Warnings.is_active (Warnings.Bad_docstring true) then begin
48 List.iter
49 (fun ds ->
50 match ds.ds_attached with
51 | Info -> ()
52 | Unattached ->
53 prerr_warning ds.ds_loc (Warnings.Bad_docstring true)
54 | Docs ->
55 match ds.ds_associated with
56 | Zero | One -> ()
57 | Many ->
58 prerr_warning ds.ds_loc (Warnings.Bad_docstring false))
59 (List.rev !docstrings)
60 end
61
62 (* Docstring constructors and destructors *)
63
64 let docstring body loc =
65 let ds =
66 { ds_body = body;
67 ds_loc = loc;
68 ds_attached = Unattached;
69 ds_associated = Zero; }
70 in
71 ds
72
73 let register ds =
74 docstrings := ds :: !docstrings
75
76 let docstring_body ds = ds.ds_body
77
78 let docstring_loc ds = ds.ds_loc
79
80 (* Docstrings attached to items *)
81
82 type docs =
83 { docs_pre: docstring option;
84 docs_post: docstring option; }
85
86 let empty_docs = { docs_pre = None; docs_post = None }
87
88 let doc_loc = {txt = "ocaml.doc"; loc = Location.none}
89
90 let docs_attr ds =
91 let open Parsetree in
92 let exp =
93 { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
94 pexp_loc = ds.ds_loc;
95 pexp_loc_stack = [];
96 pexp_attributes = []; }
97 in
98 let item =
99 { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
100 in
101 { attr_name = doc_loc;
102 attr_payload = PStr [item];
103 attr_loc = Location.none }
104
105 let add_docs_attrs docs attrs =
106 let attrs =
107 match docs.docs_pre with
108 | None | Some { ds_body=""; _ } -> attrs
109 | Some ds -> docs_attr ds :: attrs
110 in
111 let attrs =
112 match docs.docs_post with
113 | None | Some { ds_body=""; _ } -> attrs
114 | Some ds -> attrs @ [docs_attr ds]
115 in
116 attrs
117
118 (* Docstrings attached to constructors or fields *)
119
120 type info = docstring option
121
122 let empty_info = None
123
124 let info_attr = docs_attr
125
126 let add_info_attrs info attrs =
127 match info with
128 | None | Some {ds_body=""; _} -> attrs
129 | Some ds -> attrs @ [info_attr ds]
130
131 (* Docstrings not attached to a specific item *)
132
133 type text = docstring list
134
135 let empty_text = []
136 let empty_text_lazy = lazy []
137
138 let text_loc = {txt = "ocaml.text"; loc = Location.none}
139
140 let text_attr ds =
141 let open Parsetree in
142 let exp =
143 { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None));
144 pexp_loc = ds.ds_loc;
145 pexp_loc_stack = [];
146 pexp_attributes = []; }
147 in
148 let item =
149 { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc }
150 in
151 { attr_name = text_loc;
152 attr_payload = PStr [item];
153 attr_loc = Location.none }
154
155 let add_text_attrs dsl attrs =
156 let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
157 (List.map text_attr fdsl) @ attrs
158
159 (* Find the first non-info docstring in a list, attach it and return it *)
160 let get_docstring ~info dsl =
161 let rec loop = function
162 | [] -> None
163 | {ds_attached = Info; _} :: rest -> loop rest
164 | ds :: _ ->
165 ds.ds_attached <- if info then Info else Docs;
166 Some ds
167 in
168 loop dsl
169
170 (* Find all the non-info docstrings in a list, attach them and return them *)
171 let get_docstrings dsl =
172 let rec loop acc = function
173 | [] -> List.rev acc
174 | {ds_attached = Info; _} :: rest -> loop acc rest
175 | ds :: rest ->
176 ds.ds_attached <- Docs;
177 loop (ds :: acc) rest
178 in
179 loop [] dsl
180
181 (* "Associate" all the docstrings in a list *)
182 let associate_docstrings dsl =
183 List.iter
184 (fun ds ->
185 match ds.ds_associated with
186 | Zero -> ds.ds_associated <- One
187 | (One | Many) -> ds.ds_associated <- Many)
188 dsl
189
190 (* Map from positions to pre docstrings *)
191
192 let pre_table : (Lexing.position, docstring list) Hashtbl.t =
193 Hashtbl.create 50
194
195 let set_pre_docstrings pos dsl =
196 if dsl <> [] then Hashtbl.add pre_table pos dsl
197
198 let get_pre_docs pos =
199 try
200 let dsl = Hashtbl.find pre_table pos in
201 associate_docstrings dsl;
202 get_docstring ~info:false dsl
203 with Not_found -> None
204
205 let mark_pre_docs pos =
206 try
207 let dsl = Hashtbl.find pre_table pos in
208 associate_docstrings dsl
209 with Not_found -> ()
210
211 (* Map from positions to post docstrings *)
212
213 let post_table : (Lexing.position, docstring list) Hashtbl.t =
214 Hashtbl.create 50
215
216 let set_post_docstrings pos dsl =
217 if dsl <> [] then Hashtbl.add post_table pos dsl
218
219 let get_post_docs pos =
220 try
221 let dsl = Hashtbl.find post_table pos in
222 associate_docstrings dsl;
223 get_docstring ~info:false dsl
224 with Not_found -> None
225
226 let mark_post_docs pos =
227 try
228 let dsl = Hashtbl.find post_table pos in
229 associate_docstrings dsl
230 with Not_found -> ()
231
232 let get_info pos =
233 try
234 let dsl = Hashtbl.find post_table pos in
235 get_docstring ~info:true dsl
236 with Not_found -> None
237
238 (* Map from positions to floating docstrings *)
239
240 let floating_table : (Lexing.position, docstring list) Hashtbl.t =
241 Hashtbl.create 50
242
243 let set_floating_docstrings pos dsl =
244 if dsl <> [] then Hashtbl.add floating_table pos dsl
245
246 let get_text pos =
247 try
248 let dsl = Hashtbl.find floating_table pos in
249 get_docstrings dsl
250 with Not_found -> []
251
252 let get_post_text pos =
253 try
254 let dsl = Hashtbl.find post_table pos in
255 get_docstrings dsl
256 with Not_found -> []
257
258 (* Maps from positions to extra docstrings *)
259
260 let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t =
261 Hashtbl.create 50
262
263 let set_pre_extra_docstrings pos dsl =
264 if dsl <> [] then Hashtbl.add pre_extra_table pos dsl
265
266 let get_pre_extra_text pos =
267 try
268 let dsl = Hashtbl.find pre_extra_table pos in
269 get_docstrings dsl
270 with Not_found -> []
271
272 let post_extra_table : (Lexing.position, docstring list) Hashtbl.t =
273 Hashtbl.create 50
274
275 let set_post_extra_docstrings pos dsl =
276 if dsl <> [] then Hashtbl.add post_extra_table pos dsl
277
278 let get_post_extra_text pos =
279 try
280 let dsl = Hashtbl.find post_extra_table pos in
281 get_docstrings dsl
282 with Not_found -> []
283
284 (* Docstrings from parser actions *)
285 module WithParsing = struct
286 let symbol_docs () =
287 { docs_pre = get_pre_docs (Parsing.symbol_start_pos ());
288 docs_post = get_post_docs (Parsing.symbol_end_pos ()); }
289
290 let symbol_docs_lazy () =
291 let p1 = Parsing.symbol_start_pos () in
292 let p2 = Parsing.symbol_end_pos () in
293 lazy { docs_pre = get_pre_docs p1;
294 docs_post = get_post_docs p2; }
295
296 let rhs_docs pos1 pos2 =
297 { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1);
298 docs_post = get_post_docs (Parsing.rhs_end_pos pos2); }
299
300 let rhs_docs_lazy pos1 pos2 =
301 let p1 = Parsing.rhs_start_pos pos1 in
302 let p2 = Parsing.rhs_end_pos pos2 in
303 lazy { docs_pre = get_pre_docs p1;
304 docs_post = get_post_docs p2; }
305
306 let mark_symbol_docs () =
307 mark_pre_docs (Parsing.symbol_start_pos ());
308 mark_post_docs (Parsing.symbol_end_pos ())
309
310 let mark_rhs_docs pos1 pos2 =
311 mark_pre_docs (Parsing.rhs_start_pos pos1);
312 mark_post_docs (Parsing.rhs_end_pos pos2)
313
314 let symbol_info () =
315 get_info (Parsing.symbol_end_pos ())
316
317 let rhs_info pos =
318 get_info (Parsing.rhs_end_pos pos)
319
320 let symbol_text () =
321 get_text (Parsing.symbol_start_pos ())
322
323 let symbol_text_lazy () =
324 let pos = Parsing.symbol_start_pos () in
325 lazy (get_text pos)
326
327 let rhs_text pos =
328 get_text (Parsing.rhs_start_pos pos)
329
330 let rhs_post_text pos =
331 get_post_text (Parsing.rhs_end_pos pos)
332
333 let rhs_text_lazy pos =
334 let pos = Parsing.rhs_start_pos pos in
335 lazy (get_text pos)
336
337 let symbol_pre_extra_text () =
338 get_pre_extra_text (Parsing.symbol_start_pos ())
339
340 let symbol_post_extra_text () =
341 get_post_extra_text (Parsing.symbol_end_pos ())
342
343 let rhs_pre_extra_text pos =
344 get_pre_extra_text (Parsing.rhs_start_pos pos)
345
346 let rhs_post_extra_text pos =
347 get_post_extra_text (Parsing.rhs_end_pos pos)
348 end
349
350 include WithParsing
351
352 module WithMenhir = struct
353 let symbol_docs (startpos, endpos) =
354 { docs_pre = get_pre_docs startpos;
355 docs_post = get_post_docs endpos; }
356
357 let symbol_docs_lazy (p1, p2) =
358 lazy { docs_pre = get_pre_docs p1;
359 docs_post = get_post_docs p2; }
360
361 let rhs_docs pos1 pos2 =
362 { docs_pre = get_pre_docs pos1;
363 docs_post = get_post_docs pos2; }
364
365 let rhs_docs_lazy p1 p2 =
366 lazy { docs_pre = get_pre_docs p1;
367 docs_post = get_post_docs p2; }
368
369 let mark_symbol_docs (startpos, endpos) =
370 mark_pre_docs startpos;
371 mark_post_docs endpos;
372 ()
373
374 let mark_rhs_docs pos1 pos2 =
375 mark_pre_docs pos1;
376 mark_post_docs pos2;
377 ()
378
379 let symbol_info endpos =
380 get_info endpos
381
382 let rhs_info endpos =
383 get_info endpos
384
385 let symbol_text startpos =
386 get_text startpos
387
388 let symbol_text_lazy startpos =
389 lazy (get_text startpos)
390
391 let rhs_text pos =
392 get_text pos
393
394 let rhs_post_text pos =
395 get_post_text pos
396
397 let rhs_text_lazy pos =
398 lazy (get_text pos)
399
400 let symbol_pre_extra_text startpos =
401 get_pre_extra_text startpos
402
403 let symbol_post_extra_text endpos =
404 get_post_extra_text endpos
405
406 let rhs_pre_extra_text pos =
407 get_pre_extra_text pos
408
409 let rhs_post_extra_text pos =
410 get_post_extra_text pos
411 end
412
413 (* (Re)Initialise all comment state *)
414
415 let init () =
416 docstrings := [];
417 Hashtbl.reset pre_table;
418 Hashtbl.reset post_table;
419 Hashtbl.reset floating_table;
420 Hashtbl.reset pre_extra_table;
421 Hashtbl.reset post_extra_table
422