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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
open! Import
include Parser_intf
module A = Automaton
let kind_to_stack
: type stack.
('state, stack) Automaton_state.Kind.t -> (module Stack with type t = stack)
=
fun (type state) (kind : (state, stack) Automaton_state.Kind.t) ->
match kind with
| Sexp -> (module Automaton_stack : Stack with type t = stack)
| Positions -> (module Automaton_stack.Just_positions : Stack with type t = stack)
| Sexp_with_positions -> (module Automaton_stack : Stack with type t = stack)
| Cst -> (module Automaton_stack.For_cst : Stack with type t = stack)
;;
let make (type stack state parsed_value) kind mode make_value
: (module S
with type parsed_value = parsed_value
and type State.t = (state, stack) Automaton_state.t
and type Stack.t = stack)
=
(module struct
type nonrec parsed_value = parsed_value
module Stack = (val kind_to_stack kind : Stack with type t = stack)
module State = struct
type t = (state, Stack.t) Automaton_state.t
let create ?pos () = A.create ?initial_pos:pos mode kind
let reset = A.reset
let offset = A.offset
let line = A.line
let column = A.column
let position t : Positions.pos =
{ offset = offset t; line = line t; col = column t }
;;
let stop state = A.set_error_state state
end
let feed = A.feed
let feed_eoi state stack = make_value state (A.feed_eoi state stack)
let feed_substring = Automaton.feed_substring
let feed_string = Automaton.feed_string
let feed_subbytes = Automaton.feed_subbytes
let feed_bytes = Automaton.feed_bytes
let parse_string_exn str =
let state = State.create () in
feed_eoi state (feed_string state str Stack.empty)
;;
let parse_string str =
match parse_string_exn str with
| x -> Ok x
| exception Parse_error.Parse_error e -> Error e
;;
end)
;;
let make_eager (type stack state parsed_value) kind make_value
: (module S_eager
with type parsed_value = parsed_value
and type State.t = (state, stack) Automaton_state.t
and type Stack.t = stack)
=
(module struct
type nonrec parsed_value = parsed_value
module Stack = (val kind_to_stack kind : Stack with type t = stack)
module State = struct
module Read_only = struct
type t = (state, Stack.t) Automaton_state.t
let offset = A.offset
let line = A.line
let column = A.column
let position t : Positions.pos =
{ offset = offset t; line = line t; col = column t }
;;
end
include Read_only
let create ?pos ?(no_sexp_is_error = false) f =
let got_sexp state stack =
let parsed_value = make_value state stack in
f state parsed_value;
Stack.empty
in
A.create ?initial_pos:pos (Eager { got_sexp; no_sexp_is_error }) kind
;;
let reset = A.reset
let stop t = A.set_error_state t
let old_parser_cont_state t = Automaton.old_parser_cont_state t
end
let feed = A.feed
let feed_eoi state stack = ignore (A.feed_eoi state stack : Stack.t)
let feed_substring = Automaton.feed_substring
let feed_string = Automaton.feed_string
let feed_subbytes = Automaton.feed_subbytes
let feed_bytes = Automaton.feed_bytes
module Lexbuf_consumer = struct
type t = State.t
exception Got_sexp of parsed_value * Positions.pos
let got_sexp state parsed_value =
raise_notrace (Got_sexp (parsed_value, State.position state))
;;
let create () = State.create got_sexp
let pos_of_lexbuf lexbuf =
let p = lexbuf.Lexing.lex_curr_p in
{ Positions.line = p.pos_lnum; col = p.pos_cnum - p.pos_bol; offset = p.pos_cnum }
;;
let update_lexbuf (lexbuf : Lexing.lexbuf) (pos : Positions.pos) =
let p = pos.offset - lexbuf.lex_abs_pos in
lexbuf.lex_curr_pos <- p;
lexbuf.lex_start_pos <- p;
lexbuf.lex_curr_p
<- { lexbuf.lex_curr_p with
pos_lnum = pos.line
; pos_cnum = pos.offset
; pos_bol = pos.offset - pos.col
}
;;
let rec feed_lexbuf t (lexbuf : Lexing.lexbuf) stack =
let stack =
feed_subbytes
t
lexbuf.lex_buffer
stack
~pos:lexbuf.lex_curr_pos
~len:(lexbuf.lex_buffer_len - lexbuf.lex_curr_pos)
in
lexbuf.lex_curr_pos <- lexbuf.lex_buffer_len;
lexbuf.lex_start_pos <- lexbuf.lex_buffer_len;
if not lexbuf.lex_eof_reached
then (
lexbuf.refill_buff lexbuf;
feed_lexbuf t lexbuf stack)
else feed_eoi t stack
;;
let parse_gen t (lexbuf : Lexing.lexbuf) =
A.reset t ~pos:(pos_of_lexbuf lexbuf);
match feed_lexbuf t lexbuf Stack.empty with
| () ->
update_lexbuf lexbuf (State.position t);
None
| exception Got_sexp (parsed_value, pos) ->
update_lexbuf lexbuf pos;
Some parsed_value
| exception exn ->
update_lexbuf lexbuf (State.position t);
raise exn
;;
let set_no_sexp_is_error t x =
match A.mode t with
| Eager e -> e.no_sexp_is_error <- x
| _ -> assert false
;;
let parse t lexbuf =
set_no_sexp_is_error t true;
match parse_gen t lexbuf with
| Some x -> x
| None -> failwith "Parsexp.parse_gen: None"
;;
let parse_opt t lexbuf =
set_no_sexp_is_error t false;
parse_gen t lexbuf
;;
end
end)
;;