1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }
type lexer = Location | Dynamic
let get_lexer :
Lexbuf.t ->
lexer ->
unit ->
Tokens.token * Lexing.position * Lexing.position =
fun l -> function
| Location -> Lexbuf.tokenize Lexer.main l
| Dynamic -> Lexbuf.tokenize Lexer.dynamics l
(** Run the QSP parser and apply the analyzer over it.
See [syntax/S] *)
let rec parse : type a context.
(module Qsp_syntax.S.Analyzer
with type Location.t = a
and type context = context) ->
lexer ->
Lexbuf.t ->
context ->
(a result, Qsp_syntax.Report.t) Result.t =
fun (module S : Qsp_syntax.S.Analyzer
with type Location.t = a
and type context = context) ->
let module Parser = Parser.Make (S) in
let module IncrementalParser =
Interpreter.Interpreter (Parser.MenhirInterpreter) in
fun lexer_type l context ->
let get_parser :
lexer ->
Lexing.position ->
(context -> a) Parser.MenhirInterpreter.checkpoint = function
| Location -> Parser.Incremental.main
| Dynamic -> Parser.Incremental.dynamics
in
let lexer = get_lexer l lexer_type in
let init = (get_parser lexer_type) (fst (Lexbuf.positions l)) in
(* Firslty, check if we are able to read the whole syntax from the source *)
let evaluation =
try IncrementalParser.of_lexbuf lexer l init with
| Lexer.LexError message ->
let start_pos, end_pos = Lexbuf.positions l in
let err =
IncrementalParser.
{ code = Interpreter.Custom message; start_pos; end_pos }
in
Error err
| Lexer.UnclosedQuote | Lex_state.Out_of_context ->
let start_pos, end_pos = Lexbuf.positions l in
let err =
IncrementalParser.
{
code = Interpreter.Custom "Unclosed string";
start_pos;
end_pos;
}
in
Error err
in
(* Then evaluate the result *)
match (evaluation, Lexbuf.is_recovery l) with
| Ok r, _ ->
(* We have been able to read the syntax, apply the checkers over the
Tree *)
let content = r context in
Ok { content; report = S.Location.v content }
| _, true ->
(* This pattern can occur after recovering from an error. The
application attempt to start from a clean state in the next
location, but may fail to detect the correct position. If so, we
just start again until we hook the next location *)
parse (module S) lexer_type l context
| Error e, _ ->
let message =
match e.IncrementalParser.code with
| Interpreter.UnrecoverableError -> "UnrecoverableError"
| Interpreter.InvalidSyntax -> "Invalid Syntax"
| Interpreter.Custom msg -> msg
| Interpreter.MenhirCode c ->
let message_content =
try Parser_messages.message c
with Not_found ->
String.concat "" [ "(Error code "; string_of_int c; ")" ]
in
String.concat "" [ String.trim message_content ]
in
let report = Qsp_syntax.Report.error (e.start_pos, e.end_pos) message in
(* Rollback the buffer from the latest errror before discarding until
the end of the location. This ensure we will read the marker
for the end location in the case the error was actually in
this line itsef.
Example :
# location
<ERROR HERE>
! ------- a
--- location ---------------------------------
*)
Lexbuf.rollback l;
(* Discard the remaining file to read. The parser is now in a blank
state, it does not make sense to keep feeding it with the new
tokens. *)
let () = try Lexer.discard l with _ -> () in
Error report
|
