jon.recoil.org
this repo has no description
Parser: reorganize error handling and locations
+640
-588
+2
-2
src/loader/attrs.ml
+2
-2
src/loader/attrs.ml
···
69
69
end
70
70
in
71
71
loop true 0 empty_body attrs
72
-
|> Model.Error.convey_by_exception
72
+
|> Model.Error.to_exception
73
73
74
74
let read_string parent loc str : Model.Comment.docs_or_stop =
75
75
let start_pos = loc.Location.loc_start in
···
81
81
~location:start_pos
82
82
~text:str
83
83
|> Model.Error.shed_warnings
84
-
|> Model.Error.convey_by_exception
84
+
|> Model.Error.to_exception
85
85
in
86
86
`Docs doc
87
87
+4
-4
src/loader/loader.ml
+4
-4
src/loader/loader.ml
···
1
1
let read_string parent_definition location text =
2
-
Model.Error.catch_conveyed_by_exception (fun () ->
2
+
Model.Error.catch (fun () ->
3
3
Attrs.read_string parent_definition location text)
4
4
5
5
···
33
33
begin match cmt_info.cmt_interface_digest with
34
34
| None -> corrupted filename
35
35
| Some digest ->
36
-
Model.Error.catch_conveyed_by_exception begin fun () ->
36
+
Model.Error.catch begin fun () ->
37
37
let name = cmt_info.cmt_modname in
38
38
let root = make_root ~module_name:name ~digest in
39
39
let (id, doc, items) = Cmti.read_interface root name intf in
···
114
114
source; interface; hidden; content; expansion = None}
115
115
116
116
| Implementation impl ->
117
-
Model.Error.catch_conveyed_by_exception begin fun () ->
117
+
Model.Error.catch begin fun () ->
118
118
let name = cmt_info.cmt_modname in
119
119
let interface, digest =
120
120
match cmt_info.cmt_interface_digest with
···
159
159
| cmi_info ->
160
160
match cmi_info.cmi_crcs with
161
161
| (name, Some digest) :: imports when name = cmi_info.cmi_name ->
162
-
Model.Error.catch_conveyed_by_exception begin fun () ->
162
+
Model.Error.catch begin fun () ->
163
163
let root = make_root ~module_name:name ~digest:digest in
164
164
let (id, doc, items) = Cmi.read_interface root name cmi_info.cmi_sign in
165
165
let imports =
+13
-4
src/model/error.ml
+13
-4
src/model/error.ml
···
18
18
warnings : t list;
19
19
}
20
20
21
+
let make : string -> Location_.span -> t = fun message location ->
22
+
`With_full_location {location; error = message}
23
+
24
+
let makef = fun format ->
25
+
(Printf.ksprintf make) format
26
+
21
27
let to_string : t -> string = function
22
28
| `With_full_location {location; error} ->
23
29
let location_string =
···
40
46
41
47
exception Conveyed_by_exception of t
42
48
43
-
let convey_by_exception : ('a, t) result -> 'a = function
49
+
let raise_exception : t -> _ = fun error ->
50
+
raise (Conveyed_by_exception error)
51
+
52
+
let to_exception : ('a, t) result -> 'a = function
44
53
| Ok v -> v
45
-
| Error e -> raise (Conveyed_by_exception e)
54
+
| Error error -> raise_exception error
46
55
47
-
let catch_conveyed_by_exception : (unit -> 'a) -> ('a, t) result = fun f ->
56
+
let catch : (unit -> 'a) -> ('a, t) result = fun f ->
48
57
try Ok (f ())
49
-
with Conveyed_by_exception e -> Error e
58
+
with Conveyed_by_exception error -> Error error
50
59
51
60
(* TODO This is a temporary measure until odoc is ported to handle warnings
52
61
throughout. *)
+26
-1
src/model/location_.ml
+26
-1
src/model/location_.ml
···
4
4
}
5
5
6
6
type span = {
7
+
file : string;
7
8
start : point;
8
9
end_ : point;
9
-
file : string;
10
10
}
11
11
12
12
type 'a with_location = {
···
17
17
let at : span -> 'a -> 'a with_location = fun location value ->
18
18
{location; value}
19
19
20
+
let location : 'a with_location -> span = fun {location; _} ->
21
+
location
22
+
20
23
let value : 'a with_location -> 'a = fun {value; _} ->
21
24
value
22
25
···
26
29
27
30
let same : _ with_location -> 'b -> 'b with_location = fun annotated value ->
28
31
{annotated with value}
32
+
33
+
let span : span list -> span = fun spans ->
34
+
match spans with
35
+
| [] ->
36
+
{
37
+
file = "_none_";
38
+
start = {
39
+
line = 1;
40
+
column = 0;
41
+
};
42
+
end_ = {
43
+
line = 1;
44
+
column = 0;
45
+
};
46
+
}
47
+
| first::spans ->
48
+
let last = List.fold_left (fun _ span -> span) first spans in
49
+
{
50
+
file = first.file;
51
+
start = first.start;
52
+
end_ = last.end_;
53
+
}
+2
-56
src/parser/helpers.ml
+2
-56
src/parser/helpers.ml
···
1
-
(* This file contains mostly functions from the former [model/attrs.ml], and
2
-
also some helpers for error handling. It should be reorganized in the
3
-
future. *)
4
-
5
-
type raw_parse_error = {
6
-
start_offset : int;
7
-
end_offset : int;
8
-
text : string;
9
-
}
10
-
11
-
exception Parse_error of raw_parse_error
12
-
13
-
let not_allowed ?suggestion (start_offset, end_offset) ~what ~in_what =
14
-
let text = Printf.sprintf "%s is not allowed in %s" what in_what in
15
-
let text =
16
-
match suggestion with
17
-
| None -> text
18
-
| Some suggestion ->
19
-
Printf.sprintf "%s\nSuggestion: %s" text suggestion
20
-
in
21
-
raise_notrace (Parse_error {start_offset; end_offset; text})
22
-
23
-
let must_be_followed_by_whitespace (start_offset, end_offset) ~what =
24
-
let text =
25
-
Printf.sprintf "%s must be followed by space, a tab, or a new line" what in
26
-
raise_notrace (Parse_error {start_offset; end_offset; text})
27
-
28
-
let cannot_be_empty (start_offset, end_offset) ~what =
29
-
raise_notrace
30
-
(Parse_error {
31
-
start_offset;
32
-
end_offset;
33
-
text = Printf.sprintf "%s cannot be empty" what
34
-
})
35
-
36
-
let no_leading_whitespace_in_verbatim start_offset =
37
-
raise_notrace
38
-
(Parse_error {
39
-
start_offset;
40
-
end_offset = start_offset + 2;
41
-
text = "'{v' must be followed by whitespace"
42
-
})
43
-
44
-
let no_trailing_whitespace_in_verbatim end_offset =
45
-
raise_notrace
46
-
(Parse_error {
47
-
start_offset = end_offset - 2;
48
-
end_offset = end_offset;
49
-
text = "'v}' must be preceded by whitespace"
50
-
})
51
-
52
-
let must_begin_on_its_own_line (start_offset, end_offset) ~what =
53
-
let text = Printf.sprintf "%s must begin on its own line" what in
54
-
raise_notrace (Parse_error {start_offset; end_offset; text})
55
-
56
-
1
+
(* This file contains mostly functions from the former [model/attrs.ml]. It
2
+
should be reorganized in the future. *)
57
3
58
4
module Paths = Model.Paths
59
5
+7
src/parser/lexer.mli
+7
src/parser/lexer.mli
+188
-178
src/parser/lexer.mll
+188
-178
src/parser/lexer.mll
···
41
41
in
42
42
String.sub s 0 trim_from
43
43
44
-
let trim_leading_space_or_accept_whitespace t lexbuf =
45
-
match t.[0] with
46
-
| ' ' -> String.sub t 1 (String.length t - 1)
47
-
| '\t' | '\r' | '\n' -> t
48
-
| _ -> Helpers.no_leading_whitespace_in_verbatim (Lexing.lexeme_start lexbuf)
49
-
| exception Invalid_argument _ -> ""
50
44
51
-
let trim_trailing_space_or_accept_whitespace t lexbuf =
52
-
match t.[String.length t - 1] with
53
-
| ' ' -> String.sub t 0 (String.length t - 1)
54
-
| '\t' | '\r' | '\n' -> t
55
-
| _ -> Helpers.no_trailing_whitespace_in_verbatim (Lexing.lexeme_end lexbuf)
56
-
| exception Invalid_argument _ -> ""
45
+
46
+
module Location = Model.Location_
47
+
module Error = Model.Error
48
+
57
49
58
50
51
+
let reference_token target = function
52
+
| "{!" -> `Simple_reference target
53
+
| "{{!" -> `Begin_reference_with_replacement_text target
54
+
| "{{:" -> `Begin_link_with_replacement_text target
55
+
| _ -> assert false
59
56
60
-
let emit ?start_offset ?adjust_start_by ?adjust_end_by lexbuf token =
57
+
(* Assuming an ASCII-compatible input encoding here. *)
58
+
let heading_level level =
59
+
Char.code level - Char.code '0'
60
+
61
+
62
+
63
+
type input = {
64
+
file : string;
65
+
offset_to_location : int -> Location.point;
66
+
lexbuf : Lexing.lexbuf;
67
+
}
68
+
69
+
let offset_span_to_location
70
+
?start_offset ?adjust_start_by ?end_offset ?adjust_end_by input =
61
71
let start =
62
-
match adjust_start_by with
63
-
| None -> Lexing.lexeme_start lexbuf
64
-
| Some s -> Lexing.lexeme_start lexbuf + String.length s
72
+
match start_offset with
73
+
| None -> Lexing.lexeme_start input.lexbuf
74
+
| Some s -> s
65
75
in
66
76
let start =
67
-
match start_offset with
77
+
match adjust_start_by with
68
78
| None -> start
69
-
| Some s -> s
79
+
| Some s -> start + String.length s
80
+
in
81
+
let end_ =
82
+
match end_offset with
83
+
| None -> Lexing.lexeme_end input.lexbuf
84
+
| Some e -> e
70
85
in
71
86
let end_ =
72
87
match adjust_end_by with
73
-
| None -> Lexing.lexeme_end lexbuf
74
-
| Some s -> Lexing.lexeme_end lexbuf - String.length s
88
+
| None -> end_
89
+
| Some s -> end_ - String.length s
75
90
in
76
-
((start, end_), token)
91
+
{
92
+
Model.Location_.file = input.file;
93
+
start = input.offset_to_location start;
94
+
end_ = input.offset_to_location end_;
95
+
}
77
96
78
-
let reference_token target = function
79
-
| "{!" -> `Simple_reference target
80
-
| "{{!" -> `Begin_reference_with_replacement_text target
81
-
| "{{:" -> `Begin_link_with_replacement_text target
82
-
| _ -> assert false
97
+
let emit input ?start_offset ?adjust_start_by ?adjust_end_by token =
98
+
let location =
99
+
offset_span_to_location
100
+
?start_offset ?adjust_start_by ?adjust_end_by input
101
+
in
102
+
Location.at location token
103
+
104
+
let raise_error
105
+
input ?start_offset ?adjust_start_by ?end_offset ?adjust_end_by error =
106
+
let location =
107
+
offset_span_to_location
108
+
?start_offset ?adjust_start_by ?end_offset ?adjust_end_by input
109
+
in
110
+
Error.raise_exception (error location)
111
+
112
+
113
+
114
+
let trim_leading_space_or_accept_whitespace input text =
115
+
match text.[0] with
116
+
| ' ' -> String.sub text 1 (String.length text - 1)
117
+
| '\t' | '\r' | '\n' -> text
118
+
| exception Invalid_argument _ -> ""
119
+
| _ ->
120
+
raise_error
121
+
input
122
+
~end_offset:(Lexing.lexeme_start input.lexbuf + 2)
123
+
Parse_error.no_leading_whitespace_in_verbatim
83
124
84
-
(* Assuming an ASCII-compatible input encoding here. *)
85
-
let heading_level level =
86
-
Char.code level - Char.code '0'
125
+
let trim_trailing_space_or_accept_whitespace input text =
126
+
match text.[String.length text - 1] with
127
+
| ' ' -> String.sub text 0 (String.length text - 1)
128
+
| '\t' | '\r' | '\n' -> text
129
+
| exception Invalid_argument _ -> ""
130
+
| _ ->
131
+
raise_error
132
+
input
133
+
~start_offset:(Lexing.lexeme_end input.lexbuf - 2)
134
+
Parse_error.no_trailing_whitespace_in_verbatim
87
135
88
136
}
89
137
···
121
169
122
170
123
171
124
-
rule token = parse
172
+
rule token input = parse
125
173
| horizontal_space* eof
126
-
{ emit lexbuf `End }
174
+
{ emit input `End }
127
175
128
176
| (horizontal_space* newline as prefix)
129
177
horizontal_space* ((newline horizontal_space*)+ as suffix)
130
-
{ emit lexbuf `Blank_line ~adjust_start_by:prefix ~adjust_end_by:suffix }
178
+
{ emit input `Blank_line ~adjust_start_by:prefix ~adjust_end_by:suffix }
131
179
132
180
| horizontal_space* newline horizontal_space*
133
-
{ emit lexbuf `Single_newline }
181
+
{ emit input `Single_newline }
134
182
135
183
| horizontal_space+
136
-
{ emit lexbuf `Space }
184
+
{ emit input `Space }
137
185
138
186
| (horizontal_space* (newline horizontal_space*)? as p) '}'
139
-
{ emit lexbuf `Right_brace ~adjust_start_by:p }
187
+
{ emit input `Right_brace ~adjust_start_by:p }
140
188
141
189
| word_char+ as w
142
-
{ emit lexbuf (`Word w) }
190
+
{ emit input (`Word w) }
143
191
144
192
| '\\' (markup_char as c)
145
-
{ emit lexbuf (`Word (String.make 1 c)) }
193
+
{ emit input (`Word (String.make 1 c)) }
146
194
147
195
| '\\'
148
-
{ emit lexbuf (`Word "\\") }
196
+
{ emit input (`Word "\\") }
149
197
150
198
| '['
151
-
{ code_span (Buffer.create 1024) 0 (Lexing.lexeme_start lexbuf) lexbuf }
199
+
{ code_span
200
+
(Buffer.create 1024) 0 (Lexing.lexeme_start lexbuf) input lexbuf }
152
201
153
202
| '-'
154
-
{ emit lexbuf `Minus }
203
+
{ emit input `Minus }
155
204
156
205
| '+'
157
-
{ emit lexbuf `Plus }
206
+
{ emit input `Plus }
158
207
159
208
| "{b"
160
-
{ emit lexbuf (`Begin_style `Bold) }
209
+
{ emit input (`Begin_style `Bold) }
161
210
162
211
| "{i"
163
-
{ emit lexbuf (`Begin_style `Italic) }
212
+
{ emit input (`Begin_style `Italic) }
164
213
165
214
| "{e"
166
-
{ emit lexbuf (`Begin_style `Emphasis) }
215
+
{ emit input (`Begin_style `Emphasis) }
167
216
168
217
| "{^"
169
-
{ emit lexbuf (`Begin_style `Superscript) }
218
+
{ emit input (`Begin_style `Superscript) }
170
219
171
220
| "{_"
172
-
{ emit lexbuf (`Begin_style `Subscript) }
221
+
{ emit input (`Begin_style `Subscript) }
173
222
174
223
| "{!modules:" ([^ '}']* as modules) '}'
175
-
{ emit lexbuf (`Modules modules) }
224
+
{ emit input (`Modules modules) }
176
225
177
226
| (reference_start as start)
178
227
space_char* (no_brace+ as target) space_char* '}'
179
-
{ emit lexbuf (reference_token target start) }
228
+
{ emit input (reference_token target start) }
180
229
181
230
| "{[" (code_block_text as c) "]}"
182
231
{ let c = trim_leading_blank_lines c in
183
232
let c = trim_trailing_blank_lines c in
184
-
emit lexbuf (`Code_block c) }
233
+
emit input (`Code_block c) }
185
234
186
235
| "{v" (verbatim_text as t) "v}"
187
-
{ let t = trim_leading_space_or_accept_whitespace t lexbuf in
188
-
let t = trim_trailing_space_or_accept_whitespace t lexbuf in
236
+
{ let t = trim_leading_space_or_accept_whitespace input t in
237
+
let t = trim_trailing_space_or_accept_whitespace input t in
189
238
let t = trim_leading_blank_lines t in
190
239
let t = trim_trailing_blank_lines t in
191
-
emit lexbuf (`Verbatim t) }
240
+
emit input (`Verbatim t) }
192
241
193
242
| "{ul"
194
-
{ emit lexbuf (`Begin_list `Unordered) }
243
+
{ emit input (`Begin_list `Unordered) }
195
244
196
245
| "{ol"
197
-
{ emit lexbuf (`Begin_list `Ordered) }
246
+
{ emit input (`Begin_list `Ordered) }
198
247
199
248
| "{li"
200
-
{ emit lexbuf (`Begin_list_item `Li) }
249
+
{ emit input (`Begin_list_item `Li) }
201
250
202
251
| "{-"
203
-
{ emit lexbuf (`Begin_list_item `Dash) }
252
+
{ emit input (`Begin_list_item `Dash) }
204
253
205
254
| '{' (['0'-'9'] as level) ':' (no_brace+ as label)
206
-
{ emit lexbuf (`Begin_section_heading (heading_level level, Some label)) }
255
+
{ emit input (`Begin_section_heading (heading_level level, Some label)) }
207
256
208
257
| '{' (['0'-'9'] as level)
209
-
{ emit lexbuf (`Begin_section_heading (heading_level level, None)) }
258
+
{ emit input (`Begin_section_heading (heading_level level, None)) }
210
259
211
260
| "@author" horizontal_space+ ([^ '\r' '\n']* as author)
212
-
{ emit lexbuf (`Tag (`Author author)) }
261
+
{ emit input (`Tag (`Author author)) }
213
262
214
263
| "@deprecated"
215
-
{ emit lexbuf (`Tag `Deprecated) }
264
+
{ emit input (`Tag `Deprecated) }
216
265
217
266
| "@param" horizontal_space+ ((_ # space_char)+ as name)
218
-
{ emit lexbuf (`Tag (`Param name)) }
267
+
{ emit input (`Tag (`Param name)) }
219
268
220
269
| "@raise" horizontal_space+ ((_ # space_char)+ as name)
221
-
{ emit lexbuf (`Tag (`Raise name)) }
270
+
{ emit input (`Tag (`Raise name)) }
222
271
223
272
| "@return"
224
-
{ emit lexbuf (`Tag `Return) }
273
+
{ emit input (`Tag `Return) }
225
274
226
275
| "@see" horizontal_space* '<' ([^ '>']* as url) '>'
227
-
{ emit lexbuf (`Tag (`See (`Url, url))) }
276
+
{ emit input (`Tag (`See (`Url, url))) }
228
277
229
278
| "@see" horizontal_space* '\'' ([^ '>']* as filename) '\''
230
-
{ emit lexbuf (`Tag (`See (`File, filename))) }
279
+
{ emit input (`Tag (`See (`File, filename))) }
231
280
232
281
| "@see" horizontal_space* '"' ([^ '>']* as name) '"'
233
-
{ emit lexbuf (`Tag (`See (`Document, name))) }
282
+
{ emit input (`Tag (`See (`Document, name))) }
234
283
235
284
| "@since" horizontal_space+ ([^ '\r' '\n']* as version)
236
-
{ emit lexbuf (`Tag (`Since version)) }
285
+
{ emit input (`Tag (`Since version)) }
237
286
238
287
| "@before" horizontal_space+ ((_ # space_char)+ as version)
239
-
{ emit lexbuf (`Tag (`Before version)) }
288
+
{ emit input (`Tag (`Before version)) }
240
289
241
290
| "@version" horizontal_space+ ([^ '\r' '\n']* as version)
242
-
{ emit lexbuf (`Tag (`Version version)) }
291
+
{ emit input (`Tag (`Version version)) }
243
292
244
293
| "@canonical" horizontal_space+ ([^ '\r' '\n']* as identifier)
245
-
{ emit lexbuf (`Tag (`Canonical identifier)) }
294
+
{ emit input (`Tag (`Canonical identifier)) }
246
295
247
296
248
297
249
298
| '{' (['0'-'9'] ['0'-'9']+ as level)
250
-
{ raise_notrace
251
-
(Helpers.Parse_error {
252
-
start_offset = Lexing.lexeme_start lexbuf;
253
-
end_offset = Lexing.lexeme_end lexbuf;
254
-
text = Printf.sprintf "'%s': bad section level (2-4 allowed)" level;
255
-
}) }
299
+
{ raise_error input (Parse_error.bad_section_level level) }
256
300
257
-
| '{' ['0'-'9'] ':'
258
-
{ Helpers.cannot_be_empty
259
-
(Lexing.lexeme_start lexbuf + 2, Lexing.lexeme_end lexbuf)
260
-
~what:"heading label" }
301
+
| ('{' ['0'-'9'] as prefix) ':'
302
+
{ raise_error
303
+
input
304
+
~adjust_start_by:prefix
305
+
(Parse_error.cannot_be_empty ~what:"heading label") }
261
306
262
-
| '{' _?
263
-
{ raise_notrace
264
-
(Helpers.Parse_error {
265
-
start_offset = Lexing.lexeme_start lexbuf;
266
-
end_offset = Lexing.lexeme_end lexbuf;
267
-
text = Printf.sprintf "'%s': bad markup" (Lexing.lexeme lexbuf);
268
-
}) }
307
+
| '{' _? as markup
308
+
{ raise_error input (Parse_error.bad_markup markup) }
269
309
270
310
| ']'
271
-
{ raise_notrace
272
-
(Helpers.Parse_error {
273
-
start_offset = Lexing.lexeme_start lexbuf;
274
-
end_offset = Lexing.lexeme_end lexbuf;
275
-
text = "unpaired ']' (end of code)"
276
-
}) }
311
+
{ raise_error input Parse_error.unpaired_right_bracket }
277
312
278
313
| '@' ("author" | "since" | "version" | "canonical")
279
-
{ Helpers.cannot_be_empty
280
-
(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)
281
-
~what:(Printf.sprintf "'%s'" (Lexing.lexeme lexbuf)) }
314
+
{ raise_error
315
+
input
316
+
(Parse_error.cannot_be_empty
317
+
~what:(Printf.sprintf "'%s'" (Lexing.lexeme lexbuf))) }
282
318
283
319
| "@param"
284
-
{ raise_notrace
285
-
(Helpers.Parse_error {
286
-
start_offset = Lexing.lexeme_start lexbuf;
287
-
end_offset = Lexing.lexeme_end lexbuf;
288
-
text = "'@param' expects parameter name on the same line";
289
-
}) }
320
+
{ raise_error input Parse_error.truncated_param }
290
321
291
322
| "@raise"
292
-
{ raise_notrace
293
-
(Helpers.Parse_error {
294
-
start_offset = Lexing.lexeme_start lexbuf;
295
-
end_offset = Lexing.lexeme_end lexbuf;
296
-
text = "'@raise' expects exception constructor on the same line";
297
-
}) }
323
+
{ raise_error input Parse_error.truncated_raise }
298
324
299
325
| "@before"
300
-
{ raise_notrace
301
-
(Helpers.Parse_error {
302
-
start_offset = Lexing.lexeme_start lexbuf;
303
-
end_offset = Lexing.lexeme_end lexbuf;
304
-
text = "'@before' expects version number on the same line";
305
-
}) }
326
+
{ raise_error input Parse_error.truncated_before }
306
327
307
328
| "@see"
308
-
{ raise_notrace
309
-
(Helpers.Parse_error {
310
-
start_offset = Lexing.lexeme_start lexbuf;
311
-
end_offset = Lexing.lexeme_end lexbuf;
312
-
text =
313
-
"'@see' must be followed by <url>, 'file', or \"document title\""
314
-
}) }
329
+
{ raise_error input Parse_error.truncated_see }
315
330
316
-
| '@' ['a'-'z' 'A'-'Z']+
317
-
{ raise_notrace
318
-
(Helpers.Parse_error {
319
-
start_offset = Lexing.lexeme_start lexbuf;
320
-
end_offset = Lexing.lexeme_end lexbuf;
321
-
text = Printf.sprintf "unknown tag '%s'" (Lexing.lexeme lexbuf);
322
-
}) }
331
+
| '@' ['a'-'z' 'A'-'Z']+ as tag
332
+
{ raise_error input (Parse_error.unknown_tag tag) }
323
333
324
334
| '@'
325
-
{ raise_notrace
326
-
(Helpers.Parse_error {
327
-
start_offset = Lexing.lexeme_start lexbuf;
328
-
end_offset = Lexing.lexeme_end lexbuf;
329
-
text = "stray '@'";
330
-
}) }
335
+
{ raise_error input Parse_error.stray_at }
331
336
332
337
| '\r'
333
-
{ raise_notrace
334
-
(Helpers.Parse_error {
335
-
start_offset = Lexing.lexeme_start lexbuf;
336
-
end_offset = Lexing.lexeme_end lexbuf;
337
-
text = "stray '\\r' (carriage return character)";
338
-
}) }
338
+
{ raise_error input Parse_error.stray_cr }
339
339
340
340
| reference_start space_char* "}"
341
-
{ Helpers.cannot_be_empty
342
-
(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)
343
-
~what:"reference target" }
341
+
{ raise_error input (Parse_error.cannot_be_empty ~what:"reference target") }
344
342
345
343
| ((reference_start as start) space_char* no_brace+) as prefix
346
344
space_char+ no_brace
347
-
{ Helpers.not_allowed
348
-
(Lexing.lexeme_start lexbuf + String.length prefix,
349
-
Lexing.lexeme_end lexbuf - 1)
350
-
~what:"internal whitespace"
351
-
~in_what:(Token.describe (reference_token "" start)) }
345
+
{ raise_error
346
+
input
347
+
~adjust_start_by:prefix
348
+
~adjust_end_by:" "
349
+
(Parse_error.not_allowed
350
+
~what:"internal whitespace"
351
+
~in_what:(Token.describe (reference_token "" start))) }
352
352
353
353
| "{!modules:" [^ '}']* eof
354
-
{ Helpers.not_allowed
355
-
(Lexing.lexeme_end lexbuf, Lexing.lexeme_end lexbuf)
356
-
~what:(Token.describe `End)
357
-
~in_what:(Token.describe (`Modules "")) }
354
+
{ raise_error
355
+
input
356
+
~start_offset:(Lexing.lexeme_end lexbuf)
357
+
(Parse_error.not_allowed
358
+
~what:(Token.describe `End)
359
+
~in_what:(Token.describe (`Modules ""))) }
358
360
359
361
| (reference_start as start) [^ '}']* eof
360
-
{ Helpers.not_allowed
361
-
(Lexing.lexeme_end lexbuf, Lexing.lexeme_end lexbuf)
362
-
~what:(Token.describe `End)
363
-
~in_what:(Token.describe (reference_token "" start)) }
362
+
{ raise_error
363
+
input
364
+
~start_offset:(Lexing.lexeme_end lexbuf)
365
+
(Parse_error.not_allowed
366
+
~what:(Token.describe `End)
367
+
~in_what:(Token.describe (reference_token "" start))) }
364
368
365
369
| "{[" code_block_text eof
366
-
{ Helpers.not_allowed
367
-
(Lexing.lexeme_end lexbuf, Lexing.lexeme_end lexbuf)
368
-
~what:(Token.describe `End)
369
-
~in_what:(Token.describe (`Code_block "")) }
370
+
{ raise_error
371
+
input
372
+
~start_offset:(Lexing.lexeme_end lexbuf)
373
+
(Parse_error.not_allowed
374
+
~what:(Token.describe `End)
375
+
~in_what:(Token.describe (`Code_block ""))) }
370
376
371
377
| "{v" verbatim_text eof
372
-
{ Helpers.not_allowed
373
-
(Lexing.lexeme_end lexbuf, Lexing.lexeme_end lexbuf)
374
-
~what:(Token.describe `End)
375
-
~in_what:(Token.describe (`Verbatim "")) }
378
+
{ raise_error
379
+
input
380
+
~start_offset:(Lexing.lexeme_end lexbuf)
381
+
(Parse_error.not_allowed
382
+
~what:(Token.describe `End)
383
+
~in_what:(Token.describe (`Verbatim ""))) }
376
384
377
385
378
386
379
-
and code_span buffer nesting_level start_offset = parse
387
+
and code_span buffer nesting_level start_offset input = parse
380
388
| ']'
381
389
{ if nesting_level = 0 then
382
-
emit lexbuf (`Code_span (Buffer.contents buffer)) ~start_offset
390
+
emit input (`Code_span (Buffer.contents buffer)) ~start_offset
383
391
else begin
384
392
Buffer.add_char buffer ']';
385
-
code_span buffer (nesting_level - 1) start_offset lexbuf
393
+
code_span buffer (nesting_level - 1) start_offset input lexbuf
386
394
end }
387
395
388
396
| '['
389
397
{ Buffer.add_char buffer '[';
390
-
code_span buffer (nesting_level + 1) start_offset lexbuf }
398
+
code_span buffer (nesting_level + 1) start_offset input lexbuf }
391
399
392
400
| "\\]"
393
401
{ Buffer.add_char buffer ']';
394
-
code_span buffer nesting_level start_offset lexbuf }
402
+
code_span buffer nesting_level start_offset input lexbuf }
395
403
396
404
| newline
397
-
{ Helpers.not_allowed
398
-
(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)
399
-
~what:(Token.describe `Single_newline)
400
-
~in_what:(Token.describe (`Code_span "")) }
405
+
{ raise_error
406
+
input
407
+
(Parse_error.not_allowed
408
+
~what:(Token.describe `Single_newline)
409
+
~in_what:(Token.describe (`Code_span ""))) }
401
410
402
411
| eof
403
-
{ Helpers.not_allowed
404
-
(Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)
405
-
~what:(Token.describe `End)
406
-
~in_what:(Token.describe (`Code_span "")) }
412
+
{ raise_error
413
+
input
414
+
(Parse_error.not_allowed
415
+
~what:(Token.describe `End)
416
+
~in_what:(Token.describe (`Code_span ""))) }
407
417
408
418
| _ as c
409
419
{ Buffer.add_char buffer c;
410
-
code_span buffer nesting_level start_offset lexbuf }
420
+
code_span buffer nesting_level start_offset input lexbuf }
+66
src/parser/parse_error.ml
+66
src/parser/parse_error.ml
···
1
+
module Location = Model.Location_
2
+
module Error = Model.Error
3
+
4
+
5
+
6
+
let bad_markup : string -> Location.span -> Error.t =
7
+
Error.makef "'%s': bad markup"
8
+
9
+
let bad_section_level : string -> Location.span -> Error.t =
10
+
Error.makef "'%s': bad section level (2-4 allowed)"
11
+
12
+
let cannot_be_empty : what:string -> Location.span -> Error.t = fun ~what ->
13
+
Error.makef "%s cannot be empty" what
14
+
15
+
let must_begin_on_its_own_line : what:string -> Location.span -> Error.t =
16
+
fun ~what ->
17
+
Error.makef "%s must begin on its own line" what
18
+
19
+
let must_be_followed_by_whitespace : what:string -> Location.span -> Error.t =
20
+
fun ~what ->
21
+
Error.makef "%s must be followed by space, a tab, or a new line" what
22
+
23
+
let not_allowed
24
+
: ?suggestion:string -> what:string -> in_what:string -> Location.span ->
25
+
Error.t =
26
+
fun ?suggestion ~what ~in_what location ->
27
+
let message = Printf.sprintf "%s is not allowed in %s" what in_what in
28
+
let message =
29
+
match suggestion with
30
+
| None -> message
31
+
| Some suggestion -> Printf.sprintf "%s\nSuggestion: %s" message suggestion
32
+
in
33
+
Error.make message location
34
+
35
+
let no_leading_whitespace_in_verbatim : Location.span -> Error.t =
36
+
Error.make "'{v' must be followed by whitespace"
37
+
38
+
let no_trailing_whitespace_in_verbatim : Location.span -> Error.t =
39
+
Error.make "'v}' must be preceded by whitespace"
40
+
41
+
let stray_at : Location.span -> Error.t =
42
+
Error.make "stray '@'"
43
+
44
+
let stray_cr : Location.span -> Error.t =
45
+
Error.make "stray '\\r' (carriage return character)"
46
+
47
+
let truncated_before : Location.span -> Error.t =
48
+
Error.make "'@before' expects version number on the same line"
49
+
50
+
let truncated_param : Location.span -> Error.t =
51
+
Error.make "'@param' expects parameter name on the same line"
52
+
53
+
let truncated_raise : Location.span -> Error.t =
54
+
Error.make "'@raise' expects exception constructor on the same line"
55
+
56
+
let truncated_see : Location.span -> Error.t =
57
+
Error.make "'@see' must be followed by <url>, 'file', or \"document title\""
58
+
59
+
let unknown_tag : string -> Location.span -> Error.t =
60
+
Error.makef "unknown tag '%s'"
61
+
62
+
let unpaired_right_brace : Location.span -> Error.t =
63
+
Error.make "unpaired '}' (end of markup)"
64
+
65
+
let unpaired_right_bracket : Location.span -> Error.t =
66
+
Error.make "unpaired ']' (end of code)"
+14
-31
src/parser/parser_.ml
+14
-31
src/parser/parser_.ml
···
68
68
offset_to_location_relative_to_start_of_file
69
69
in
70
70
71
-
(* The parser signals errors by raising exceptions. These carry byte offsets
72
-
into the comment for the start and end of the offending text, and a
73
-
description. We need to convert the offsets to locations relative to the
74
-
file containing the comment, add the filename, and package the result in
75
-
the type of error accepted by the rest of odoc. *)
76
-
let convert_parsing_error_to_odoc_error
77
-
: Helpers.raw_parse_error -> Model.Error.t = fun error ->
78
-
79
-
`With_full_location {
80
-
location = {
81
-
file = location.Lexing.pos_fname;
82
-
start = offset_to_location error.start_offset;
83
-
end_ = offset_to_location error.end_offset;
84
-
};
85
-
error = error.text;
86
-
}
87
-
in
88
-
89
71
let token_stream =
90
72
let lexbuf = Lexing.from_string text in
91
-
Stream.from (fun _token_index -> Some (Lexer.token lexbuf))
73
+
let input : Lexer.input =
74
+
{
75
+
file = location.Lexing.pos_fname;
76
+
offset_to_location;
77
+
lexbuf;
78
+
}
79
+
in
80
+
Stream.from (fun _token_index -> Some (Lexer.token input lexbuf))
92
81
in
93
82
94
-
try
95
-
Syntax.parse
96
-
~file:location.Lexing.pos_fname
97
-
~offset_to_location
98
-
~token_stream
99
-
|> Semantics.ast_to_comment
83
+
match Syntax.parse token_stream with
84
+
| Error error ->
85
+
{Model.Error.result = Error error; warnings = []}
86
+
| Ok ast ->
87
+
Semantics.ast_to_comment
100
88
~permissive
101
89
~sections_allowed
102
90
~parent_of_sections:containing_definition
103
-
104
-
with Helpers.Parse_error error ->
105
-
{
106
-
Model.Error.result = Error (convert_parsing_error_to_odoc_error error);
107
-
warnings = [];
108
-
}
91
+
ast
109
92
110
93
111
94
+3
-7
src/parser/semantics.ml
+3
-7
src/parser/semantics.ml
···
17
17
if status.permissive then
18
18
status.warnings <- message::status.warnings
19
19
else
20
-
raise_notrace (Error.Conveyed_by_exception message)
20
+
Error.raise_exception message
21
21
22
22
23
23
···
56
56
error = "only one title-level heading is allowed";
57
57
}
58
58
in
59
-
raise_notrace (Error.Conveyed_by_exception message)
59
+
Error.raise_exception message
60
60
end;
61
61
let element = `Heading (`Title, label, content) in
62
62
let element = Location.at location element in
···
127
127
}
128
128
in
129
129
130
-
let result =
131
-
Error.catch_conveyed_by_exception (fun () ->
132
-
top_level_block_elements status ast)
133
-
in
134
-
130
+
let result = Error.catch (fun () -> top_level_block_elements status ast) in
135
131
let warnings = List.rev status.warnings in
136
132
137
133
{Error.result; warnings}
+313
-301
src/parser/syntax.ml
+313
-301
src/parser/syntax.ml
···
16
16
is not explicitly delimited with curly braces.
17
17
- [block_element_list] parses a sequence of block elements. A comment is a
18
18
sequence of block elements, so [block_element_list] is the top-level
19
-
parser. It is also used for list item and tag content.
19
+
parser. It is also used for list item and tag content. *)
20
20
21
-
The parser raises exceptions with constructor [Helpers.Parse_error]. These
22
-
contain raw byte offsets as locations. These are caught in module [Parser_],
23
-
and translated to line/column locations. *)
24
21
25
22
23
+
module Location = Model.Location_
24
+
module Error = Model.Error
25
+
module Comment = Model.Comment
26
26
27
-
(* {2 Input} *)
27
+
type 'a with_location = 'a Location.with_location
28
28
29
-
(* Tokens paired with their start and end byte offsets.
30
29
31
-
This type constructor is mainly used as [Token.t stream_head]. However, in
32
-
places where only a subset of tokens is allowed, it is used with more
33
-
restrictive types, such as [[ `Space | `Single_newline ] stream_head]. *)
34
-
type 'token stream_head = (int * int) * 'token
35
30
36
-
(* What the parser needs from the outside world. A value of type [input] is
37
-
passed around between all the parsing functions.
31
+
(* {2 Input} *)
38
32
39
-
- [file] is the name of the file containing the comment being parsed. It is
40
-
needed to construct locations.
41
-
- [offset_to_location] converts byte indexes relative to the start of the
42
-
comment to line, column pairs relative to the start of the file containing
43
-
the comment.
44
-
- [token_stream] is the stream of tokens emitted by the lexer.
33
+
type input = (Token.t Location.with_location) Stream.t
45
34
46
-
In addition to a value of type [input], some parsing functions also take a
47
-
value of type ['a stream_head], for some ['a] that is narrower than [Token.t].
48
-
This is done when the stream head has already been examined by the caller, and
49
-
it allows a precise and limited set of cases in the function. *)
50
-
type input = {
51
-
file : string;
52
-
offset_to_location : int -> Model.Location_.point;
53
-
token_stream : (Token.t stream_head) Stream.t;
54
-
}
55
-
56
-
let junk input =
57
-
Stream.junk input.token_stream
35
+
let junk = Stream.junk
58
36
59
37
let peek input =
60
-
match Stream.peek input.token_stream with
38
+
match Stream.peek input with
61
39
| Some token -> token
62
40
| None -> assert false
63
41
(* The last token in the stream is always [`End], and it is never consumed by
64
42
the parser, so the [None] case is impossible. *)
65
43
66
-
let npeek n input =
67
-
Stream.npeek n input.token_stream
68
-
69
-
type 'a with_location = 'a Model.Location_.with_location
70
-
71
-
let at_token input (start_offset, end_offset) value : _ with_location =
72
-
{
73
-
location = {
74
-
file = input.file;
75
-
start = input.offset_to_location start_offset;
76
-
end_ = input.offset_to_location end_offset;
77
-
};
78
-
value;
79
-
}
80
-
81
-
let token_span input (start_offset, _) (_, end_offset) value : _ with_location =
82
-
{
83
-
location = {
84
-
file = input.file;
85
-
start = input.offset_to_location start_offset;
86
-
end_ = input.offset_to_location end_offset;
87
-
};
88
-
value;
89
-
}
90
-
91
-
let child_span input (start_offset, end_offset) children value
92
-
: _ with_location =
93
-
let nested_end_location =
94
-
List.fold_left (fun _acc child ->
95
-
Some child.Model.Location_.location)
96
-
None children
97
-
in
98
-
match nested_end_location with
99
-
| None ->
100
-
{
101
-
location = {
102
-
file = input.file;
103
-
start = input.offset_to_location start_offset;
104
-
end_ = input.offset_to_location end_offset;
105
-
};
106
-
value;
107
-
}
108
-
| Some nested_end_location ->
109
-
{
110
-
location = {
111
-
file = input.file;
112
-
start = input.offset_to_location start_offset;
113
-
end_ = nested_end_location.end_;
114
-
};
115
-
value;
116
-
}
117
-
118
-
119
-
120
-
module Comment = Model.Comment
121
-
module Raise = Helpers
44
+
let npeek = Stream.npeek
122
45
123
46
124
47
···
144
67
tokens, so "brace \{" becomes [`Word "brace"; `Word "{"].
145
68
146
69
This parser stops on the first non-word token, and does not consume it. *)
147
-
let word
148
-
: input -> (int * int) ->
149
-
Comment.non_link_inline_element with_location =
150
-
fun input start_location ->
151
-
let rec consume_word_tokens end_location acc =
152
-
match peek input with
153
-
| l, `Word w ->
70
+
let word : input -> Comment.non_link_inline_element with_location =
71
+
fun input ->
72
+
let first_token = peek input in
73
+
74
+
let rec consume_word_tokens last_token acc =
75
+
let next_token = peek input in
76
+
match next_token.value with
77
+
| `Word w ->
154
78
junk input;
155
-
consume_word_tokens l (acc ^ w)
79
+
consume_word_tokens next_token (acc ^ w)
156
80
157
-
| l, `Minus ->
81
+
| `Minus ->
158
82
junk input;
159
-
consume_word_tokens l (acc ^ "-")
83
+
consume_word_tokens next_token (acc ^ "-")
160
84
161
-
| l, `Plus ->
85
+
| `Plus ->
162
86
junk input;
163
-
consume_word_tokens l (acc ^ "+")
87
+
consume_word_tokens next_token (acc ^ "+")
164
88
165
89
| _ ->
166
-
token_span input start_location end_location (`Word acc)
90
+
let location =
91
+
Location.span [first_token.location; last_token.location] in
92
+
Location.at location (`Word acc)
167
93
in
168
-
consume_word_tokens start_location ""
94
+
95
+
consume_word_tokens first_token ""
169
96
170
97
(* Consumes tokens that make up a single non-link inline element:
171
98
···
189
116
190
117
This function consumes exactly the tokens that make up the element. *)
191
118
let rec non_link_inline_element
192
-
: [> ] stream_head -> input ->
119
+
: input -> _ with_location ->
193
120
Comment.non_link_inline_element with_location =
194
-
fun stream_head input ->
121
+
fun input next_token ->
195
122
196
-
match stream_head with
197
-
| l, `Space ->
123
+
match next_token.value with
124
+
| `Space ->
198
125
junk input;
199
-
at_token input l `Space
126
+
Location.same next_token `Space
200
127
201
-
| l, `Word _
202
-
| l, `Minus
203
-
| l, `Plus ->
204
-
word input l
128
+
| `Word _
129
+
| `Minus
130
+
| `Plus ->
131
+
word input
205
132
206
-
| l, `Code_span c ->
133
+
| `Code_span c ->
207
134
junk input;
208
-
at_token input l (`Code_span c)
135
+
Location.same next_token (`Code_span c)
209
136
210
-
| l, (`Begin_style s as parent_markup) ->
137
+
| `Begin_style s as parent_markup ->
211
138
junk input;
139
+
212
140
let requires_leading_whitespace =
213
141
match s with
214
142
| `Superscript | `Subscript -> false
215
143
| _ -> true
216
144
in
217
-
let content, end_location =
145
+
let content, brace_location =
218
146
delimited_non_link_inline_element_list
219
147
~parent_markup
220
-
~parent_markup_location:l
148
+
~parent_markup_location:next_token.location
221
149
~requires_leading_whitespace
222
150
input
223
151
in
224
152
if content = [] then
225
-
Raise.cannot_be_empty l ~what:(Token.describe parent_markup);
226
-
token_span input l end_location (`Styled (s, content))
153
+
Parse_error.cannot_be_empty
154
+
~what:(Token.describe parent_markup) next_token.location
155
+
|> Error.raise_exception;
156
+
157
+
(`Styled (s, content))
158
+
|> Location.at (Location.span [next_token.location; brace_location])
227
159
228
160
(* Consumes tokens that make up a sequence of non-link inline elements. See
229
161
function [non_link_inline_element] for a list of what those are.
···
251
183
generating error messages. *)
252
184
and delimited_non_link_inline_element_list
253
185
: parent_markup:[< Token.t ] ->
254
-
parent_markup_location:(int * int) ->
186
+
parent_markup_location:Location.span ->
255
187
requires_leading_whitespace:bool ->
256
188
input ->
257
-
(Comment.non_link_inline_element with_location) list * (int * int) =
189
+
(Comment.non_link_inline_element with_location) list * Location.span =
258
190
fun
259
191
~parent_markup
260
192
~parent_markup_location
···
267
199
let rec consume_non_link_inline_elements
268
200
: at_start_of_line:bool ->
269
201
(Comment.non_link_inline_element with_location) list ->
270
-
(Comment.non_link_inline_element with_location) list * (int * int) =
202
+
(Comment.non_link_inline_element with_location) list * Location.span =
271
203
fun ~at_start_of_line acc ->
272
204
273
205
match peek input with
274
-
| l, `Right_brace ->
206
+
| {value = `Right_brace; location} ->
275
207
junk input;
276
-
List.rev acc, l
208
+
List.rev acc, location
277
209
278
210
(* The [`Space] token is not space at the beginning or end of line, because
279
211
that is combined into [`Single_newline] or [`Blank_line] tokens. It is
···
283
215
because that is combined into the [`Right_brace] token by the lexer. So,
284
216
it is an internal space, and we want to add it to the non-link inline
285
217
element list. *)
286
-
| _, `Space
287
-
| _, `Word _
288
-
| _, `Code_span _
289
-
| _, `Begin_style _ as stream_head ->
290
-
let acc = (non_link_inline_element stream_head input)::acc in
218
+
| {value = `Space; _}
219
+
| {value = `Word _; _}
220
+
| {value = `Code_span _; _}
221
+
| {value = `Begin_style _; _} as next_token ->
222
+
let acc = (non_link_inline_element input next_token)::acc in
291
223
consume_non_link_inline_elements ~at_start_of_line:false acc
292
224
293
-
| l, `Single_newline ->
225
+
| {value = `Single_newline; location} ->
294
226
junk input;
295
-
let element = at_token input l `Space in
227
+
let element = Location.at location `Space in
296
228
consume_non_link_inline_elements ~at_start_of_line:true (element::acc)
297
229
298
-
| l, (`Minus | `Plus as bullet) as stream_head ->
230
+
| {value = `Minus | `Plus as bullet; location} as next_token ->
299
231
if not at_start_of_line then
300
-
let acc = (non_link_inline_element stream_head input)::acc in
232
+
let acc = (non_link_inline_element input next_token)::acc in
301
233
consume_non_link_inline_elements ~at_start_of_line:false acc
302
234
else
303
235
let suggestion =
···
305
237
"move %s so it isn't the first thing on the line"
306
238
(Token.print bullet)
307
239
in
308
-
Raise.not_allowed
309
-
l
240
+
Parse_error.not_allowed
310
241
~what:(Token.describe bullet)
311
242
~in_what:(Token.describe parent_markup)
312
243
~suggestion
244
+
location
245
+
|> Error.raise_exception
313
246
314
-
| l, token ->
315
-
Raise.not_allowed
316
-
l ~what:(Token.describe token) ~in_what:(Token.describe parent_markup)
247
+
| other_token ->
248
+
Parse_error.not_allowed
249
+
~what:(Token.describe other_token.value)
250
+
~in_what:(Token.describe parent_markup)
251
+
other_token.location
252
+
|> Error.raise_exception
317
253
in
318
254
319
-
match peek input with
320
-
| _, `Space ->
255
+
let first_token = peek input in
256
+
match first_token.value with
257
+
| `Space ->
321
258
junk input;
322
259
consume_non_link_inline_elements ~at_start_of_line:false []
323
260
(* [~at_start_of_line] is [false] here because the preceding token was some
324
261
some markup like '{b', and we didn't move to the next line, so the next
325
262
token will not be the first non-whitespace token on its line. *)
326
263
327
-
| _, `Single_newline ->
264
+
| `Single_newline ->
328
265
junk input;
329
266
consume_non_link_inline_elements ~at_start_of_line:true []
330
267
331
-
| l, `Blank_line ->
268
+
| `Blank_line ->
332
269
(* In case the markup is immediately followed by a blank line, the error
333
270
message printed by the catch-all case below can be confusing, as it will
334
271
suggest that the markup must be followed by a newline (which it is). It
335
272
just must not be followed by two newlines. To explain that clearly,
336
273
handle that case specifically. *)
337
-
Raise.not_allowed
338
-
l
274
+
Parse_error.not_allowed
339
275
~what:(Token.describe `Blank_line)
340
276
~in_what:(Token.describe parent_markup)
277
+
first_token.location
278
+
|> Error.raise_exception
341
279
342
-
| l, `Right_brace ->
280
+
| `Right_brace ->
343
281
junk input;
344
-
[], l
282
+
[], first_token.location
345
283
346
284
| _ ->
347
285
if requires_leading_whitespace then
348
-
Raise.must_be_followed_by_whitespace
349
-
parent_markup_location ~what:(Token.print parent_markup)
286
+
Parse_error.must_be_followed_by_whitespace
287
+
~what:(Token.print parent_markup) parent_markup_location
288
+
|> Error.raise_exception
350
289
else
351
290
consume_non_link_inline_elements ~at_start_of_line:false []
352
291
···
384
323
then parses a line of inline elements. Afterwards, it looks ahead to the next
385
324
line. If that line also begins with an inline element, it parses that line,
386
325
and so on. *)
387
-
let paragraph
388
-
: input -> (int * int) -> Comment.nestable_block_element with_location =
389
-
fun input start_offsets ->
326
+
let paragraph : input -> Comment.nestable_block_element with_location =
327
+
fun input ->
390
328
391
329
(* Parses a single line of a paragraph, consisting of inline elements. The
392
330
only valid ways to end a paragraph line are with [`End], [`Single_newline],
···
399
337
(Comment.inline_element with_location) list =
400
338
fun acc ->
401
339
match peek input with
402
-
| _, `Space
403
-
| _, `Minus
404
-
| _, `Plus
405
-
| _, `Word _
406
-
| _, `Code_span _
407
-
| _, `Begin_style _ as stream_head ->
408
-
let element = non_link_inline_element stream_head input in
340
+
| {value = `Space; _}
341
+
| {value = `Minus; _}
342
+
| {value = `Plus; _}
343
+
| {value = `Word _; _}
344
+
| {value = `Code_span _; _}
345
+
| {value = `Begin_style _; _} as next_token ->
346
+
let element = non_link_inline_element input next_token in
409
347
let acc = (element :> Comment.inline_element with_location)::acc in
410
348
paragraph_line acc
411
349
412
-
| l, `Simple_reference r ->
350
+
| {value = `Simple_reference r; location} ->
413
351
junk input;
414
352
let element =
415
-
at_token input l (`Reference (Helpers.read_reference r, [])) in
353
+
Location.at location (`Reference (Helpers.read_reference r, [])) in
416
354
paragraph_line (element::acc)
417
355
418
-
| l, (`Begin_reference_with_replacement_text r as parent_markup) ->
356
+
| {value = `Begin_reference_with_replacement_text r as parent_markup;
357
+
location} ->
419
358
junk input;
420
-
let content, end_location =
359
+
360
+
let content, brace_location =
421
361
delimited_non_link_inline_element_list
422
362
~parent_markup
423
-
~parent_markup_location:l
363
+
~parent_markup_location:location
424
364
~requires_leading_whitespace:false
425
365
input
426
366
in
427
367
if content = [] then
428
-
Raise.cannot_be_empty l ~what:(Token.describe parent_markup);
429
-
let element = `Reference (Helpers.read_reference r, content) in
430
-
let element = token_span input l end_location element in
368
+
Parse_error.cannot_be_empty
369
+
~what:(Token.describe parent_markup) location
370
+
|> Error.raise_exception;
371
+
372
+
let element =
373
+
`Reference (Helpers.read_reference r, content)
374
+
|> Location.at (Location.span [location; brace_location])
375
+
in
431
376
paragraph_line (element::acc)
432
377
433
-
| l, (`Begin_link_with_replacement_text u as parent_markup) ->
378
+
| {value = `Begin_link_with_replacement_text u as parent_markup;
379
+
location} ->
434
380
junk input;
435
-
let content, end_location =
381
+
382
+
let content, brace_location =
436
383
delimited_non_link_inline_element_list
437
384
~parent_markup
438
-
~parent_markup_location:l
385
+
~parent_markup_location:location
439
386
~requires_leading_whitespace:false
440
387
input
441
388
in
442
-
let element = token_span input l end_location (`Link (u, content)) in
389
+
390
+
let element =
391
+
`Link (u, content)
392
+
|> Location.at (Location.span [location; brace_location])
393
+
in
443
394
paragraph_line (element::acc)
444
395
445
396
| _ ->
446
397
acc
447
398
in
448
399
449
-
(* After each row is parsed, decides whether to parse more rows. *)
450
-
let rec additional_rows
400
+
(* After each line is parsed, decides whether to parse more lines. *)
401
+
let rec additional_lines
451
402
: (Comment.inline_element with_location) list ->
452
403
(Comment.inline_element with_location) list =
453
404
fun acc ->
454
405
match npeek 2 input with
455
-
| (l, `Single_newline)::(_, #token_that_begins_a_paragraph_line)::_ ->
406
+
| {value = `Single_newline; location}::
407
+
{value = #token_that_begins_a_paragraph_line; _}::_ ->
456
408
junk input;
457
-
let acc = (at_token input l `Space)::acc in
409
+
let acc = (Location.at location `Space)::acc in
458
410
let acc = paragraph_line acc in
459
-
additional_rows acc
411
+
additional_lines acc
460
412
461
413
| _ ->
462
414
List.rev acc
463
415
in
464
416
465
-
let all_elements = additional_rows (paragraph_line []) in
466
-
child_span input start_offsets all_elements (`Paragraph all_elements)
417
+
let elements = paragraph_line [] |> additional_lines in
418
+
`Paragraph elements
419
+
|> Location.at (Location.span (List.map Location.location elements))
467
420
468
421
469
422
···
600
553
parent_markup:[< Token.t | `Comment ] ->
601
554
input ->
602
555
(block with_location) list *
603
-
stops_at_which_tokens stream_head *
556
+
stops_at_which_tokens with_location *
604
557
where_in_line =
605
558
fun context ~parent_markup input ->
606
559
···
609
562
where_in_line ->
610
563
(block with_location) list ->
611
564
(block with_location) list *
612
-
stops_at_which_tokens stream_head *
565
+
stops_at_which_tokens with_location *
613
566
where_in_line =
614
567
fun ~parsed_a_tag where_in_line acc ->
615
568
···
619
572
| _ -> Token.describe token
620
573
in
621
574
622
-
let raise_if_after_text (l, token) =
575
+
let raise_if_after_text {Location.location; value = token} =
623
576
if where_in_line = `After_text then
624
-
Raise.must_begin_on_its_own_line l ~what:(describe token)
577
+
Parse_error.must_begin_on_its_own_line ~what:(describe token) location
578
+
|> Error.raise_exception
625
579
in
626
580
627
-
let raise_if_after_tags (l, token) =
581
+
let raise_if_after_tags {Location.location; value = token} =
628
582
if parsed_a_tag then
629
583
let suggestion =
630
584
Printf.sprintf
631
585
"move %s before any tags" (Token.describe token)
632
586
in
633
-
Raise.not_allowed
634
-
l ~what:(describe token) ~in_what:"the tags section" ~suggestion
587
+
Parse_error.not_allowed
588
+
~what:(describe token)
589
+
~in_what:"the tags section"
590
+
~suggestion
591
+
location
592
+
|> Error.raise_exception
635
593
in
636
594
637
-
let raise_because_not_at_top_level (l, token) =
595
+
let raise_because_not_at_top_level {Location.location; value = token} =
638
596
let suggestion =
639
597
Printf.sprintf
640
598
"move %s outside of any other markup" (Token.print token)
641
599
in
642
-
Raise.not_allowed
643
-
l
600
+
Parse_error.not_allowed
644
601
~what:(Token.describe token)
645
602
~in_what:(Token.describe parent_markup)
646
603
~suggestion
604
+
location
605
+
|> Error.raise_exception
647
606
in
648
607
649
608
650
609
651
610
match peek input with
652
611
(* Terminators: the two tokens that terminate anything. *)
653
-
| _, `End
654
-
| _, `Right_brace as stream_head ->
612
+
| {value = `End; _}
613
+
| {value = `Right_brace; _} as next_token ->
655
614
(* This little absurdity is needed to satisfy the type system. Without it,
656
615
OCaml is unable to prove that [stream_head] has the right type for all
657
616
possible values of [context]. *)
658
617
begin match context with
659
618
| Top_level ->
660
-
List.rev acc, stream_head, where_in_line
619
+
List.rev acc, next_token, where_in_line
661
620
| In_shorthand_list ->
662
-
List.rev acc, stream_head, where_in_line
621
+
List.rev acc, next_token, where_in_line
663
622
| In_explicit_list ->
664
-
List.rev acc, stream_head, where_in_line
623
+
List.rev acc, next_token, where_in_line
665
624
| In_tag ->
666
-
List.rev acc, stream_head, where_in_line
625
+
List.rev acc, next_token, where_in_line
667
626
end
668
627
669
628
···
671
630
(* Whitespace. This can terminate some kinds of block elements. It is also
672
631
necessary to track it to interpret [`Minus] and [`Plus] correctly, as
673
632
well as to ensure that all block elements begin on their own line. *)
674
-
| _, `Space ->
633
+
| {value = `Space; _} ->
675
634
junk input;
676
635
consume_block_elements ~parsed_a_tag where_in_line acc
677
636
678
-
| _, `Single_newline ->
637
+
| {value = `Single_newline; _} ->
679
638
junk input;
680
639
consume_block_elements ~parsed_a_tag `At_start_of_line acc
681
640
682
-
| _, `Blank_line as stream_head ->
641
+
| {value = `Blank_line; _} as next_token ->
683
642
begin match context with
684
643
(* Blank lines terminate shorthand lists ([- foo]). They also terminate
685
644
paragraphs, but the paragraph parser is aware of that internally. *)
686
645
| In_shorthand_list ->
687
-
List.rev acc, stream_head, where_in_line
646
+
List.rev acc, next_token, where_in_line
688
647
(* Otherwise, blank lines are pretty much like single newlines. *)
689
648
| _ ->
690
649
junk input;
···
696
655
(* Explicit list items ([{li ...}] and [{- ...}]) can never appear directly
697
656
in block content. They can only appear inside [{ul ...}] and [{ol ...}].
698
657
So, catch those. *)
699
-
| l, (`Begin_list_item _ as token) ->
658
+
| {value = `Begin_list_item _ as token; location} ->
700
659
let suggestion =
701
660
Printf.sprintf
702
661
"move %s into %s, or use %s"
···
704
663
(Token.describe (`Begin_list `Unordered))
705
664
(Token.describe (`Minus))
706
665
in
707
-
Raise.not_allowed
708
-
l
666
+
Parse_error.not_allowed
709
667
~what:(Token.describe token)
710
668
~in_what:(Token.describe parent_markup)
711
669
~suggestion
670
+
location
671
+
|> Error.raise_exception
712
672
713
673
714
674
715
675
(* Tags. These can appear at the top level only. Also, once one tag is seen,
716
676
the only top-level elements allowed are more tags. *)
717
-
| l, (`Tag tag as token) as stream_head ->
677
+
| {value = `Tag tag as token; location} as next_token ->
718
678
begin match context with
719
679
(* Tags cannot make sense in an explicit list ([{ul {li ...}}]). *)
720
680
| In_explicit_list ->
721
-
raise_because_not_at_top_level stream_head
681
+
raise_because_not_at_top_level next_token
722
682
(* If a tag starts at the beginning of a line, it terminates the preceding
723
683
tag and/or the current shorthand list. In this case, return to the
724
684
caller, and let the caller decide how to interpret the tag token. *)
725
685
| In_shorthand_list ->
726
686
if where_in_line = `At_start_of_line then
727
-
List.rev acc, stream_head, where_in_line
687
+
List.rev acc, next_token, where_in_line
728
688
else
729
-
raise_because_not_at_top_level stream_head
689
+
raise_because_not_at_top_level next_token
730
690
| In_tag ->
731
691
if where_in_line = `At_start_of_line then
732
-
List.rev acc, stream_head, where_in_line
692
+
List.rev acc, next_token, where_in_line
733
693
else
734
-
raise_because_not_at_top_level stream_head
694
+
raise_because_not_at_top_level next_token
735
695
736
696
(* If this is the top-level call to [block_element_list], parse the
737
697
tag. *)
738
698
| Top_level ->
739
699
if where_in_line <> `At_start_of_line then
740
-
Raise.must_begin_on_its_own_line l ~what:(Token.describe token);
700
+
Parse_error.must_begin_on_its_own_line
701
+
~what:(Token.describe token) location
702
+
|> Error.raise_exception;
703
+
741
704
junk input;
742
705
743
706
begin match tag with
744
707
| `Author s | `Since s | `Version s | `Canonical s as tag ->
745
708
let s = String.trim s in
746
709
if s = "" then
747
-
Raise.cannot_be_empty l ~what:(Token.describe token);
710
+
Parse_error.cannot_be_empty ~what:(Token.describe token) location
711
+
|> Error.raise_exception;
748
712
let tag =
749
713
match tag with
750
714
| `Author _ -> `Author s
···
755
719
let module_ = Helpers.read_mod_longident s in
756
720
`Canonical (path, module_)
757
721
in
758
-
let tag = at_token input l (`Tag tag) in
722
+
let tag = Location.at location (`Tag tag) in
759
723
consume_block_elements ~parsed_a_tag:true `After_text (tag::acc)
760
724
761
725
| `Deprecated | `Return as tag ->
···
766
730
| `Deprecated -> `Deprecated content
767
731
| `Return -> `Return content
768
732
in
769
-
let tag = child_span input l content (`Tag tag) in
733
+
let location =
734
+
location::(List.map Location.location content)
735
+
|> Location.span
736
+
in
737
+
let tag = Location.at location (`Tag tag) in
770
738
consume_block_elements ~parsed_a_tag:true where_in_line (tag::acc)
771
739
772
740
| `Param _ | `Raise _ | `Before _ as tag ->
···
778
746
| `Raise s -> `Raise (s, content)
779
747
| `Before s -> `Before (s, content)
780
748
in
781
-
let tag = child_span input l content (`Tag tag) in
749
+
let location =
750
+
location::(List.map Location.location content)
751
+
|> Location.span
752
+
in
753
+
let tag = Location.at location (`Tag tag) in
782
754
consume_block_elements ~parsed_a_tag:true where_in_line (tag::acc)
783
755
784
756
| `See (kind, target) ->
785
-
let content, _stream_head, where_in_line =
757
+
let content, _next_token, where_in_line =
786
758
block_element_list In_tag ~parent_markup:token input in
759
+
let location =
760
+
location::(List.map Location.location content)
761
+
|> Location.span
762
+
in
787
763
let tag = `Tag (`See (kind, target, content)) in
788
-
let tag = child_span input l content tag in
764
+
let tag = Location.at location tag in
789
765
consume_block_elements ~parsed_a_tag:true where_in_line (tag::acc)
790
766
end
791
767
end
792
768
793
769
794
770
795
-
| l, #token_that_begins_a_paragraph_line as stream_head ->
796
-
raise_if_after_tags stream_head;
797
-
raise_if_after_text stream_head;
798
-
let block = paragraph input l in
771
+
| {value = #token_that_begins_a_paragraph_line; _} as next_token ->
772
+
raise_if_after_tags next_token;
773
+
raise_if_after_text next_token;
774
+
775
+
let block = paragraph input in
799
776
let block =
800
777
Model.Location_.map (accepted_in_all_contexts context) block in
801
778
let acc = block::acc in
802
779
consume_block_elements ~parsed_a_tag `After_text acc
803
780
804
-
| l, ((`Code_block s | `Verbatim s) as token) as stream_head ->
805
-
raise_if_after_tags stream_head;
806
-
raise_if_after_text stream_head;
781
+
| {value = `Code_block s | `Verbatim s as token; location} as next_token ->
782
+
raise_if_after_tags next_token;
783
+
raise_if_after_text next_token;
807
784
if s = "" then
808
-
Raise.cannot_be_empty l ~what:(Token.describe token);
785
+
Parse_error.cannot_be_empty ~what:(Token.describe token) location
786
+
|> Error.raise_exception;
787
+
809
788
junk input;
810
789
let block =
811
790
match token with
···
813
792
| `Verbatim _ -> `Verbatim s
814
793
in
815
794
let block = accepted_in_all_contexts context block in
816
-
let block = at_token input l block in
795
+
let block = Location.at location block in
817
796
let acc = block::acc in
818
797
consume_block_elements ~parsed_a_tag `After_text acc
819
798
820
-
| l, (`Modules s as token) as stream_head ->
821
-
raise_if_after_tags stream_head;
822
-
raise_if_after_text stream_head;
799
+
| {value = `Modules s as token; location} as next_token ->
800
+
raise_if_after_tags next_token;
801
+
raise_if_after_text next_token;
823
802
824
803
junk input;
825
804
···
857
836
in
858
837
859
838
if modules = [] then
860
-
Raise.cannot_be_empty l ~what:(Token.describe token);
839
+
Parse_error.cannot_be_empty ~what:(Token.describe token) location
840
+
|> Error.raise_exception;
861
841
862
842
let block = accepted_in_all_contexts context (`Modules modules) in
863
-
let block = at_token input l block in
843
+
let block = Location.at location block in
864
844
let acc = block::acc in
865
845
consume_block_elements ~parsed_a_tag `After_text acc
866
846
867
847
868
848
869
-
| l, (`Begin_list kind as token) as stream_head ->
870
-
raise_if_after_tags stream_head;
871
-
raise_if_after_text stream_head;
849
+
| {value = `Begin_list kind as token; location} as next_token ->
850
+
raise_if_after_tags next_token;
851
+
raise_if_after_text next_token;
852
+
872
853
junk input;
873
-
let items, right_brace_offsets =
854
+
855
+
let items, brace_location =
874
856
explicit_list_items ~parent_markup:token input in
875
857
if items = [] then
876
-
Raise.cannot_be_empty l ~what:(Token.describe token);
858
+
Parse_error.cannot_be_empty ~what:(Token.describe token) location
859
+
|> Error.raise_exception;
860
+
861
+
let location = Location.span [location; brace_location] in
877
862
let block = `List (kind, items) in
878
863
let block = accepted_in_all_contexts context block in
879
-
let block = token_span input l right_brace_offsets block in
864
+
let block = Location.at location block in
880
865
let acc = block::acc in
881
866
consume_block_elements ~parsed_a_tag `After_text acc
882
867
883
868
884
869
885
-
| l, (`Minus | `Plus as token) as stream_head ->
886
-
raise_if_after_tags stream_head;
870
+
| {value = `Minus | `Plus as token; location} as next_token ->
871
+
raise_if_after_tags next_token;
887
872
begin match where_in_line with
888
873
| `After_text | `After_shorthand_bullet ->
889
-
Raise.must_begin_on_its_own_line l ~what:(Token.describe token);
874
+
Parse_error.must_begin_on_its_own_line
875
+
~what:(Token.describe token) location
876
+
|> Error.raise_exception
890
877
| _ ->
891
878
()
892
879
end;
880
+
893
881
begin match context with
894
882
| In_shorthand_list ->
895
-
List.rev acc, stream_head, where_in_line
883
+
List.rev acc, next_token, where_in_line
896
884
| _ ->
897
885
let items, where_in_line =
898
-
shorthand_list_items stream_head where_in_line input in
886
+
shorthand_list_items next_token where_in_line input in
899
887
let kind =
900
888
match token with
901
889
| `Minus -> `Unordered
902
890
| `Plus -> `Ordered
903
891
in
892
+
let location =
893
+
location::(List.map Location.location (List.flatten items))
894
+
|> Location.span
895
+
in
904
896
let block = `List (kind, items) in
905
897
let block = accepted_in_all_contexts context block in
906
-
let block = child_span input l (List.flatten items) block in
898
+
let block = Location.at location block in
907
899
let acc = block::acc in
908
900
consume_block_elements ~parsed_a_tag where_in_line acc
909
901
end
910
902
911
903
912
904
913
-
| l, (`Begin_section_heading (level, label) as token) as stream_head ->
914
-
raise_if_after_tags stream_head;
905
+
| {value = `Begin_section_heading (level, label) as token; location}
906
+
as next_token ->
907
+
908
+
raise_if_after_tags next_token;
915
909
916
910
begin match context with
917
911
| In_shorthand_list ->
918
912
if where_in_line = `At_start_of_line then
919
-
List.rev acc, stream_head, where_in_line
913
+
List.rev acc, next_token, where_in_line
920
914
else
921
-
raise_because_not_at_top_level stream_head
915
+
raise_because_not_at_top_level next_token
922
916
| In_explicit_list ->
923
-
raise_because_not_at_top_level stream_head
917
+
raise_because_not_at_top_level next_token
924
918
| In_tag ->
925
-
raise_because_not_at_top_level stream_head
919
+
raise_because_not_at_top_level next_token
926
920
927
921
| Top_level ->
928
922
if where_in_line <> `At_start_of_line then
929
-
Raise.must_begin_on_its_own_line l ~what:(Token.describe token);
923
+
Parse_error.must_begin_on_its_own_line
924
+
~what:(Token.describe token) location
925
+
|> Error.raise_exception;
926
+
930
927
junk input;
931
928
932
-
let content, right_brace_offsets =
929
+
let content, brace_location =
933
930
delimited_non_link_inline_element_list
934
931
~parent_markup:token
935
-
~parent_markup_location:l
932
+
~parent_markup_location:location
936
933
~requires_leading_whitespace:true
937
934
input
938
935
in
939
936
if content = [] then
940
-
Raise.cannot_be_empty l ~what:(Token.describe token);
937
+
Parse_error.cannot_be_empty ~what:(Token.describe token) location
938
+
|> Error.raise_exception;
941
939
940
+
let location = Location.span [location; brace_location] in
942
941
let heading = `Heading (level, label, content) in
943
-
let heading = token_span input l right_brace_offsets heading in
942
+
let heading = Location.at location heading in
944
943
let acc = heading::acc in
945
944
consume_block_elements ~parsed_a_tag `After_text acc
946
945
end
···
969
968
above). That parser returns to [implicit_list_items] only on [`Blank_line],
970
969
[`End], [`Minus] or [`Plus] at the start of a line, or [`Right_brace]. *)
971
970
and shorthand_list_items
972
-
: [ `Minus | `Plus ] stream_head ->
971
+
: [ `Minus | `Plus ] with_location ->
973
972
where_in_line ->
974
973
input ->
975
974
((Comment.nestable_block_element with_location) list) list *
976
975
where_in_line =
977
-
fun ((_, bullet_token) as stream_head) where_in_line input ->
976
+
fun first_token where_in_line input ->
977
+
978
+
let bullet_token = first_token.value in
978
979
979
980
let rec consume_list_items
980
-
: [> ] stream_head ->
981
+
: [> ] with_location ->
981
982
where_in_line ->
982
983
((Comment.nestable_block_element with_location) list) list ->
983
984
((Comment.nestable_block_element with_location) list) list *
984
985
where_in_line =
985
-
fun stream_head where_in_line acc ->
986
+
fun next_token where_in_line acc ->
986
987
987
-
match stream_head with
988
-
| _, `End
989
-
| _, `Right_brace
990
-
| _, `Blank_line
991
-
| _, `Tag _
992
-
| _, `Begin_section_heading _ ->
988
+
match next_token.value with
989
+
| `End
990
+
| `Right_brace
991
+
| `Blank_line
992
+
| `Tag _
993
+
| `Begin_section_heading _ ->
993
994
List.rev acc, where_in_line
994
995
995
-
| l, (`Minus | `Plus as bullet) ->
996
+
| `Minus
997
+
| `Plus as bullet ->
996
998
if bullet = bullet_token then begin
997
999
junk input;
998
1000
999
1001
let content, stream_head, where_in_line =
1000
1002
block_element_list In_shorthand_list ~parent_markup:bullet input in
1001
1003
if content = [] then
1002
-
Raise.cannot_be_empty l ~what:(Token.describe bullet);
1004
+
Parse_error.cannot_be_empty
1005
+
~what:(Token.describe bullet) next_token.location
1006
+
|> Error.raise_exception;
1003
1007
1004
1008
let acc = content::acc in
1005
1009
consume_list_items stream_head where_in_line acc
···
1009
1013
in
1010
1014
1011
1015
consume_list_items
1012
-
(stream_head :> stopped_implicitly stream_head) where_in_line []
1016
+
(first_token :> stopped_implicitly with_location) where_in_line []
1013
1017
1014
1018
(* Consumes a sequence of explicit list items (starting with '{li ...}' and
1015
1019
'{-...}', which are represented by [`Begin_list_item _] tokens).
···
1025
1029
: parent_markup:[< Token.t ] ->
1026
1030
input ->
1027
1031
((Comment.nestable_block_element with_location) list) list *
1028
-
(int * int) =
1032
+
Location.span =
1029
1033
fun ~parent_markup input ->
1030
1034
1031
1035
let rec consume_list_items
1032
1036
: ((Comment.nestable_block_element with_location) list) list ->
1033
1037
((Comment.nestable_block_element with_location) list) list *
1034
-
(int * int) =
1038
+
Location.span =
1035
1039
fun acc ->
1036
1040
1037
-
match peek input with
1038
-
| l, `End ->
1039
-
Raise.not_allowed
1040
-
l ~what:(Token.describe `End) ~in_what:(Token.describe parent_markup)
1041
+
let next_token = peek input in
1042
+
match next_token.value with
1043
+
| `End ->
1044
+
Parse_error.not_allowed
1045
+
next_token.location
1046
+
~what:(Token.describe `End)
1047
+
~in_what:(Token.describe parent_markup)
1048
+
|> Error.raise_exception
1041
1049
1042
-
| l, `Right_brace ->
1050
+
| `Right_brace ->
1043
1051
junk input;
1044
-
List.rev acc, l
1052
+
List.rev acc, next_token.location
1045
1053
1046
-
| _, `Space
1047
-
| _, `Single_newline
1048
-
| _, `Blank_line ->
1054
+
| `Space
1055
+
| `Single_newline
1056
+
| `Blank_line ->
1049
1057
junk input;
1050
1058
consume_list_items acc
1051
1059
1052
-
| l, (`Begin_list_item kind as token) ->
1060
+
| `Begin_list_item kind as token ->
1053
1061
junk input;
1054
1062
1055
1063
(* '{li', represented by [`Begin_list_item `Li], must be followed by
1056
1064
whitespace. *)
1057
1065
if kind = `Li then begin
1058
-
match peek input with
1059
-
| _, (`Space | `Single_newline | `Blank_line | `Right_brace) ->
1066
+
match (peek input).value with
1067
+
| `Space | `Single_newline | `Blank_line | `Right_brace ->
1060
1068
()
1061
1069
(* The presence of [`Right_brace] above requires some explanation:
1062
1070
···
1071
1079
it is not represented as [`Space], [`Single_newline], or
1072
1080
[`Blank_line]. *)
1073
1081
| _ ->
1074
-
Raise.must_be_followed_by_whitespace l ~what:(Token.print token)
1082
+
Parse_error.must_be_followed_by_whitespace
1083
+
next_token.location ~what:(Token.print token)
1084
+
|> Error.raise_exception
1075
1085
end;
1076
1086
1077
-
let content, stream_head, _where_in_line =
1087
+
let content, token_after_list_item, _where_in_line =
1078
1088
block_element_list In_explicit_list ~parent_markup:token input in
1079
1089
1080
1090
if content = [] then
1081
-
Raise.cannot_be_empty l ~what:(Token.describe token);
1091
+
Parse_error.cannot_be_empty
1092
+
next_token.location ~what:(Token.describe token)
1093
+
|> Error.raise_exception;
1082
1094
1083
-
begin match stream_head with
1084
-
| _, `Right_brace ->
1095
+
begin match token_after_list_item.value with
1096
+
| `Right_brace ->
1085
1097
junk input
1086
-
| l', `End ->
1087
-
Raise.not_allowed
1088
-
l' ~what:(Token.describe `End) ~in_what:(Token.describe token)
1098
+
| `End ->
1099
+
Parse_error.not_allowed
1100
+
token_after_list_item.location
1101
+
~what:(Token.describe `End)
1102
+
~in_what:(Token.describe token)
1103
+
|> Error.raise_exception
1089
1104
end;
1090
1105
1091
1106
let acc = content::acc in
1092
1107
consume_list_items acc
1093
1108
1094
-
| l, token ->
1109
+
| token ->
1095
1110
let suggestion =
1096
1111
match token with
1097
1112
| `Begin_section_heading _ | `Tag _ ->
···
1103
1118
(Token.print (`Begin_list_item `Li))
1104
1119
(Token.print (`Begin_list_item `Dash))
1105
1120
in
1106
-
Raise.not_allowed
1107
-
l
1121
+
Parse_error.not_allowed
1122
+
next_token.location
1108
1123
~what:(Token.describe token)
1109
1124
~in_what:(Token.describe parent_markup)
1110
1125
~suggestion
1126
+
|> Error.raise_exception
1111
1127
in
1112
1128
1113
1129
consume_list_items []
···
1116
1132
1117
1133
(* {2 Entry point} *)
1118
1134
1119
-
let parse ~file ~offset_to_location ~token_stream =
1120
-
let input = {file; offset_to_location; token_stream} in
1121
-
1122
-
let elements, stream_head, _where_in_line =
1123
-
block_element_list Top_level ~parent_markup:`Comment input in
1124
-
1125
-
match stream_head with
1126
-
| _, `End ->
1127
-
elements
1135
+
let parse token_stream =
1136
+
Error.catch begin fun () ->
1137
+
let elements, last_token, _where_in_line =
1138
+
block_element_list Top_level ~parent_markup:`Comment token_stream in
1128
1139
1129
-
| l, `Right_brace ->
1130
-
raise_notrace (Helpers.Parse_error {
1131
-
start_offset = fst l;
1132
-
end_offset = snd l;
1133
-
text = "unpaired '}' (end of markup)"
1134
-
})
1140
+
match last_token.value with
1141
+
| `End ->
1142
+
elements
1143
+
| `Right_brace ->
1144
+
Parse_error.unpaired_right_brace last_token.location
1145
+
|> Error.raise_exception
1146
+
end