blob: b41d74ed45e24928aa50ee469cffa81f338b3cad (
plain)
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
|
(**
This module provide a way to build the syntax parser with the menhir
incremental engine. This feature allow to see the state of the parser, and
get detailed error message but is not intended to be used directly.
Refer to the menhir manual in order to see the values.
The interresting function here is [of_lexer] which return the error code in
case of invalid syntax.
*)
type error_code = InvalidSyntax | MenhirCode of int
type error = {
code : error_code;
start_pos : Lexing.position;
end_pos : Lexing.position;
}
module Interpreter (MI : MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE) =
struct
module E = MenhirLib.ErrorReports
module L = MenhirLib.LexerUtil
let range_message start_pos end_pos code = { code; start_pos; end_pos }
let get_parse_error default_position env : error =
match MI.stack env with
| (lazy Nil) ->
range_message default_position.Lexing.lex_start_p
default_position.Lexing.lex_curr_p InvalidSyntax
| (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
range_message start_pos end_pos (MenhirCode (MI.number state))
let rec _parse :
(Lexing.lexbuf -> MI.token) ->
Lexing.lexbuf ->
'a MI.checkpoint ->
('a, error) Result.t =
fun get_token (lexbuf : Lexing.lexbuf) (checkpoint : 'a MI.checkpoint) ->
match checkpoint with
| MI.InputNeeded _env ->
let token = get_token lexbuf in
let startp = lexbuf.Lexing.lex_start_p and endp = lexbuf.lex_curr_p in
let checkpoint = MI.offer checkpoint (token, startp, endp) in
_parse get_token lexbuf checkpoint
| MI.Shifting _ | MI.AboutToReduce _ ->
let checkpoint = MI.resume checkpoint in
_parse get_token lexbuf checkpoint
| MI.HandlingError _env ->
let err = get_parse_error lexbuf _env in
Error err
| MI.Accepted v -> Ok v
| MI.Rejected ->
let err =
range_message lexbuf.lex_start_p lexbuf.lex_curr_p InvalidSyntax
in
Error err
type 'a builder = Lexing.position -> 'a MI.checkpoint
let of_lexbuf :
Lexing.lexbuf ->
(Lexing.lexbuf -> MI.token) ->
'a builder ->
('a, error) result =
fun lexbuf lexer f ->
let init = f lexbuf.lex_curr_p in
_parse lexer lexbuf init
end
|
