-
Notifications
You must be signed in to change notification settings - Fork 125
/
trx_runtime.ml
308 lines (266 loc) · 8.77 KB
/
trx_runtime.ml
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
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(**
Runtime for generated files by trx.
TODO:(Adam) documentation of this module
@author Adam Koprowski
*)
let pr = Printf.sprintf
type pos = int
(* =========================================================================================================== *)
(* ============================================= Error handling ============================================== *)
(* =========================================================================================================== *)
exception SyntaxError of pos * string
type errorDesc =
| Expected of string
type parseError =
{ errorPos : pos
; expected : errorDesc list
; mainConstruct : (pos * errorDesc) option
}
type 'a result =
| Ok of 'a * parseError
| Fail of parseError
let rec errorDescList2str = function
| [Expected e] -> e
| Expected e::es -> pr "%s or %s" e (errorDescList2str es)
| _ -> "[???]"
let joinErrors e1 e2 =
let rec joinExp = function
| [], e -> e
| e, [] -> e
| x::xs, y::ys when x = y -> joinExp (x::xs, ys)
| x::xs, y::ys when x < y -> x::joinExp (xs, y::ys)
| x::xs, y::ys -> y::joinExp (x::xs, ys)
in
let joinMC = function
| None, e -> e
| e, None -> e
| (Some (e1p, e1d) as e1), (Some (e2p, e2d) as e2) ->
if e1p > e2p then
e1
else if e2p > e1p then
e2
else if e1d = e2d then
e1
else
None
in
if e1.errorPos > e2.errorPos || e2.expected = [] then
e1
else if e2.errorPos > e1.errorPos || e1.expected = [] then
e2
else
{ errorPos = e1.errorPos
; expected = joinExp (e1.expected, e2.expected)
; mainConstruct = joinMC (e1.mainConstruct, e2.mainConstruct)
}
let res_err_fun f = function
| Ok (res, e) -> Ok (res, f e)
| Fail e -> Fail (f e)
let decorateConstruct res pos err =
let fix e =
if e.errorPos > pos then
e
else
{ e with errorPos = pos; expected = err }
in
res_err_fun fix res
let emptyError pos =
{ errorPos = pos
; expected = []
; mainConstruct = None
}
let option_to_res_err opt pos err =
let res =
match opt with
| Some res -> Ok (res, emptyError pos)
| None -> Fail (emptyError pos)
in
decorateConstruct res pos err
let option_to_res_msg opt pos msg =
option_to_res_err opt pos [Expected msg]
let addErrorInfo err = res_err_fun (joinErrors err)
let setMainConstruct res pos err =
let setMC e =
let newMC =
match e.mainConstruct with
| None -> Some (pos, err)
| Some (p, _) when pos > p -> Some (pos, err)
| Some (p, d) when pos = p && d = err -> Some (pos, err)
| Some (p, _) when pos < p -> e.mainConstruct
| Some (p, _) when pos = p -> None
| Some _ -> assert false
in
{ e with mainConstruct = newMC }
in
decorateConstruct (res_err_fun setMC res) pos [err]
let error2str pos2loc e =
let extraInfo =
match e.mainConstruct with
| None -> ""
| Some (pos, (Expected msg)) ->
pr "\n(while parsing %s starting at %s)" msg (FilePos.get_pos_string (pos2loc pos))
in
pr "expected %s %s" (errorDescList2str e.expected) extraInfo
let gen_syntax_error pos2loc err =
raise (SyntaxError (err.errorPos, error2str pos2loc err))
exception Final of errorDesc list
let range_to_error r =
let rec aux = function
| [] -> []
| `Any :: _ -> raise (Final [Expected "any character"])
| `One c::cs -> Expected (pr "'%c'" c)::aux cs
| `Range (c1, c2)::cs -> Expected (pr "['%c'-'%c']" c1 c2)::aux cs
in
try
List.sort Pervasives.compare (aux r)
with
Final err -> err
let print_error pos err = pr "At %s: %s" pos err
let show_error_aux pos2loc pos err =
print_error (FilePos.get_pos_string (pos2loc pos)) err
let show_error content pos err =
print_error (FilePos.get_pos_string (FilePos.get_pos_no_cache content pos)) err
let show_parse_error pos2loc err =
show_error_aux pos2loc err.errorPos (error2str pos2loc err)
(* was used by trx_ocaml.ml; temporarily suspended suspending backtrace recording ;)
let suspend_backtrace_recording f arg =
let backtrace_stat = Printexc.backtrace_status () in
Printexc.record_backtrace false;
let result = f arg in
Printexc.record_backtrace backtrace_stat;
result
*)
(* =========================================================================================================== *)
(* ============================================= Parsing support ============================================= *)
(* =========================================================================================================== *)
let process_range _get_char _len pos cl =
if pos < _len then begin
let c = _get_char pos in
let rec aux = function
| [] -> false
| `Any::_ -> true
| `One c'::cs -> c = c' || aux cs
| `Range (c1, c2)::cs -> (c >= c1 && c <= c2) || aux cs
in
if aux cl then
Some (pos + 1, c)
else
None
end else
None
let process_literal _get_char _len pos literal case =
let literal_len = String.length literal in
let equal_insensitive c1 c2 = Char.lowercase c1 = Char.lowercase c2 in
let eq = if case then (=) else equal_insensitive in
let rec aux i =
if i = literal_len then
true
else
eq (_get_char (pos + i)) (String.unsafe_get literal i) && aux (i + 1)
in
if pos + literal_len <= _len && aux 0 then
Some (pos + literal_len, literal)
else
None
let while_primary plus f pos =
let rec aux res parse_errors pos =
match f pos with
| Ok ((pos', r), e) ->
aux (r::res) (e :: parse_errors) pos'
| Fail e ->
let e =
List.fold_left (fun e parse_error -> joinErrors parse_error e)
e parse_errors in
if plus && res = [] then
Fail e
else
Ok ((pos, List.rev res), e)
in
aux [] [] pos
let while_primary_noerr plus f pos =
let rec aux res pos =
match f pos with
| Some (pos', r) -> aux (r::res) pos'
| None ->
if plus && res = [] then
None
else
Some (pos, List.rev res)
in
aux [] pos
(* FIXME This function and the following one are essentially a hack.
They assume that we don't care about the result of parsing so
give an empty list as said result. This has the benefit that we
have the same type as for the above, un-optimized functions
and as long as we don't inspect this result everything is fine.
Of course much better would be to do it in a type-safe way, i.e.
either switch the result to option type or to lazy. But that
has far gone consequences for TRX infrastructure and is difficult
to do without LOTS of changes to it (I already tried and gave up)
and without a small runtime penalty as well. So for now I'm just
leaving this hack. If anyone has a better idea of how to address
it, I'm all ears... Adam *)
let while_primary_nores plus f pos =
let rec aux first parse_errors pos =
match f pos with
| Ok ((pos', _), e) ->
aux false (e :: parse_errors) pos'
| Fail e ->
let e =
List.fold_left (fun e parse_error -> joinErrors parse_error e)
e parse_errors in
if plus && first then
Fail e
else
Ok ((pos, []), e)
in
aux true [] pos
let while_primary_noerr_nores plus f pos =
let rec aux first pos =
match f pos with
| Some (pos', _) -> aux false pos'
| None ->
if plus && first then
None
else
Some (pos, [])
in
aux true pos
let err_stack = ref []
let push_errInfo (err : parseError) =
err_stack := err :: !err_stack
let gatherErrors res =
let rec aux res = function
| [] -> res
| x::xs -> aux (addErrorInfo x res) xs
in
let res = aux res !err_stack in
err_stack := [];
res
(* Needed for Netweb *)
let get_pos :pos->int = fun p -> p
let update_memoization_cache cache update_pos =
(* FIXME, this is a bit ugly/inefficient, but the point is to update [cache]
in place; any ideas how to do it better? *)
Hashtbl.clear cache;
let update_entry (pos, result) =
match update_pos ~pos:pos with
| None -> ()
| Some pos' -> Hashtbl.add cache pos' result
in
let content = Hashtbl.fold (fun k v l -> (k, v)::l) cache [] in
List.iter update_entry content;
cache