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
|
(**
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_lexbuf] which return the error code in
case of invalid syntax.
*)
type error_code = UnrecoverableError | InvalidSyntax | MenhirCode of int
module Interpreter (MI : MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE) =
struct
type error = {
code : error_code;
start_pos : Lexing.position;
end_pos : Lexing.position;
}
module E = MenhirLib.ErrorReports
module L = MenhirLib.LexerUtil
type step = MI.token * Lexing.position * Lexing.position
let range_message (start_pos, end_pos) : error_code -> error =
fun code -> { code; start_pos; end_pos }
let get_parse_error : Lexbuf.t -> 'a MI.env -> error =
fun buffer env ->
match MI.stack env with
| (lazy Nil) ->
(* The parser is in its initial state. We should not get an
error here *)
let positions = Lexbuf.positions buffer in
range_message positions UnrecoverableError
| (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
range_message (start_pos, end_pos) (MenhirCode (MI.number state))
let rec _parse :
Lexbuf.t -> (unit -> step) -> 'a MI.checkpoint -> ('a, error) Result.t =
fun buffer get_token (checkpoint : 'a MI.checkpoint) ->
match checkpoint with
| MI.InputNeeded _env ->
let token, startp, endp = get_token () in
let checkpoint = MI.offer checkpoint (token, startp, endp) in
_parse buffer get_token checkpoint
| MI.Shifting _ | MI.AboutToReduce _ ->
let checkpoint = MI.resume checkpoint in
_parse buffer get_token checkpoint
| MI.HandlingError _env ->
let err = get_parse_error buffer _env in
Error err
| MI.Accepted v -> Ok v
| MI.Rejected ->
let positions = Lexbuf.positions buffer in
let err = range_message positions InvalidSyntax in
Error err
type 'a builder = Lexing.position -> 'a MI.checkpoint
let of_lexbuf :
(unit -> step) -> Lexbuf.t -> 'a MI.checkpoint -> ('a, error) result =
fun lexer buffer init -> _parse buffer lexer init
end
|
