Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 309 lines (266 sloc) 8.985 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (**
20 Runtime for generated files by trx.
21
22 TODO:(Adam) documentation of this module
23 @author Adam Koprowski
24 *)
25
26 let pr = Printf.sprintf
27
28 type pos = int
29
30 (* =========================================================================================================== *)
31 (* ============================================= Error handling ============================================== *)
32 (* =========================================================================================================== *)
33
34 exception SyntaxError of pos * string
35
36 type errorDesc =
37 | Expected of string
38
39 type parseError =
40 { errorPos : pos
41 ; expected : errorDesc list
42 ; mainConstruct : (pos * errorDesc) option
43 }
44
45 type 'a result =
46 | Ok of 'a * parseError
47 | Fail of parseError
48
49 let rec errorDescList2str = function
50 | [Expected e] -> e
51 | Expected e::es -> pr "%s or %s" e (errorDescList2str es)
52 | _ -> "[???]"
53
54 let joinErrors e1 e2 =
55 let rec joinExp = function
56 | [], e -> e
57 | e, [] -> e
58 | x::xs, y::ys when x = y -> joinExp (x::xs, ys)
59 | x::xs, y::ys when x < y -> x::joinExp (xs, y::ys)
60 | x::xs, y::ys -> y::joinExp (x::xs, ys)
61 in
62 let joinMC = function
63 | None, e -> e
64 | e, None -> e
65 | (Some (e1p, e1d) as e1), (Some (e2p, e2d) as e2) ->
66 if e1p > e2p then
67 e1
68 else if e2p > e1p then
69 e2
70 else if e1d = e2d then
71 e1
72 else
73 None
74 in
75 if e1.errorPos > e2.errorPos || e2.expected = [] then
76 e1
77 else if e2.errorPos > e1.errorPos || e1.expected = [] then
78 e2
79 else
80 { errorPos = e1.errorPos
81 ; expected = joinExp (e1.expected, e2.expected)
82 ; mainConstruct = joinMC (e1.mainConstruct, e2.mainConstruct)
83 }
84
85 let res_err_fun f = function
86 | Ok (res, e) -> Ok (res, f e)
87 | Fail e -> Fail (f e)
88
89 let decorateConstruct res pos err =
90 let fix e =
91 if e.errorPos > pos then
92 e
93 else
94 { e with errorPos = pos; expected = err }
95 in
96 res_err_fun fix res
97
98 let emptyError pos =
99 { errorPos = pos
100 ; expected = []
101 ; mainConstruct = None
102 }
103
104 let option_to_res_err opt pos err =
105 let res =
106 match opt with
107 | Some res -> Ok (res, emptyError pos)
108 | None -> Fail (emptyError pos)
109 in
110 decorateConstruct res pos err
111
112 let option_to_res_msg opt pos msg =
113 option_to_res_err opt pos [Expected msg]
114
115 let addErrorInfo err = res_err_fun (joinErrors err)
116
117 let setMainConstruct res pos err =
118 let setMC e =
119 let newMC =
120 match e.mainConstruct with
121 | None -> Some (pos, err)
122 | Some (p, _) when pos > p -> Some (pos, err)
123 | Some (p, d) when pos = p && d = err -> Some (pos, err)
124 | Some (p, _) when pos < p -> e.mainConstruct
125 | Some (p, _) when pos = p -> None
126 | Some _ -> assert false
127 in
128 { e with mainConstruct = newMC }
129 in
130 decorateConstruct (res_err_fun setMC res) pos [err]
131
132 let error2str pos2loc e =
133 let extraInfo =
134 match e.mainConstruct with
135 | None -> ""
136 | Some (pos, (Expected msg)) ->
137 pr "\n(while parsing %s starting at %s)" msg (FilePos.get_pos_string (pos2loc pos))
138 in
139 pr "expected %s %s" (errorDescList2str e.expected) extraInfo
140
141 let gen_syntax_error pos2loc err =
142 raise (SyntaxError (err.errorPos, error2str pos2loc err))
143
144 exception Final of errorDesc list
145 let range_to_error r =
146 let rec aux = function
147 | [] -> []
148 | `Any :: _ -> raise (Final [Expected "any character"])
149 | `One c::cs -> Expected (pr "'%c'" c)::aux cs
150 | `Range (c1, c2)::cs -> Expected (pr "['%c'-'%c']" c1 c2)::aux cs
151 in
152 try
153 List.sort Pervasives.compare (aux r)
154 with
155 Final err -> err
156
157 let print_error pos err = pr "At %s: %s" pos err
158
159 let show_error_aux pos2loc pos err =
160 print_error (FilePos.get_pos_string (pos2loc pos)) err
161
162 let show_error content pos err =
163 print_error (FilePos.get_pos_string (FilePos.get_pos_no_cache content pos)) err
164
165 let show_parse_error pos2loc err =
166 show_error_aux pos2loc err.errorPos (error2str pos2loc err)
167
168 (* was used by trx_ocaml.ml; temporarily suspended suspending backtrace recording ;)
169 let suspend_backtrace_recording f arg =
170 let backtrace_stat = Printexc.backtrace_status () in
171 Printexc.record_backtrace false;
172 let result = f arg in
173 Printexc.record_backtrace backtrace_stat;
174 result
175 *)
176
177 (* =========================================================================================================== *)
178 (* ============================================= Parsing support ============================================= *)
179 (* =========================================================================================================== *)
180
181 let process_range _get_char _len pos cl =
182 if pos < _len then begin
183 let c = _get_char pos in
184 let rec aux = function
185 | [] -> false
186 | `Any::_ -> true
187 | `One c'::cs -> c = c' || aux cs
188 | `Range (c1, c2)::cs -> (c >= c1 && c <= c2) || aux cs
189 in
190 if aux cl then
191 Some (pos + 1, c)
192 else
193 None
194 end else
195 None
196
197 let process_literal _get_char _len pos literal case =
198 let literal_len = String.length literal in
199 let equal_insensitive c1 c2 = Char.lowercase c1 = Char.lowercase c2 in
200 let eq = if case then (=) else equal_insensitive in
201 let rec aux i =
202 if i = literal_len then
203 true
204 else
205 eq (_get_char (pos + i)) (String.unsafe_get literal i) && aux (i + 1)
206 in
207 if pos + literal_len <= _len && aux 0 then
208 Some (pos + literal_len, literal)
209 else
210 None
211
212 let while_primary plus f pos =
213 let rec aux res parse_errors pos =
214 match f pos with
215 | Ok ((pos', r), e) ->
216 aux (r::res) (e :: parse_errors) pos'
217 | Fail e ->
218 let e =
219 List.fold_left (fun e parse_error -> joinErrors parse_error e)
220 e parse_errors in
221 if plus && res = [] then
222 Fail e
223 else
224 Ok ((pos, List.rev res), e)
225 in
226 aux [] [] pos
227
228 let while_primary_noerr plus f pos =
229 let rec aux res pos =
230 match f pos with
231 | Some (pos', r) -> aux (r::res) pos'
232 | None ->
233 if plus && res = [] then
234 None
235 else
236 Some (pos, List.rev res)
237 in
238 aux [] pos
239
240 (* FIXME This function and the following one are essentially a hack.
241 They assume that we don't care about the result of parsing so
242 give an empty list as said result. This has the benefit that we
243 have the same type as for the above, un-optimized functions
244 and as long as we don't inspect this result everything is fine.
245 Of course much better would be to do it in a type-safe way, i.e.
246 either switch the result to option type or to lazy. But that
247 has far gone consequences for TRX infrastructure and is difficult
248 to do without LOTS of changes to it (I already tried and gave up)
249 and without a small runtime penalty as well. So for now I'm just
250 leaving this hack. If anyone has a better idea of how to address
251 it, I'm all ears... Adam *)
252 let while_primary_nores plus f pos =
253 let rec aux first parse_errors pos =
254 match f pos with
255 | Ok ((pos', _), e) ->
256 aux false (e :: parse_errors) pos'
257 | Fail e ->
258 let e =
259 List.fold_left (fun e parse_error -> joinErrors parse_error e)
260 e parse_errors in
261 if plus && first then
262 Fail e
263 else
264 Ok ((pos, []), e)
265 in
266 aux true [] pos
267
268 let while_primary_noerr_nores plus f pos =
269 let rec aux first pos =
270 match f pos with
271 | Some (pos', _) -> aux false pos'
272 | None ->
273 if plus && first then
274 None
275 else
276 Some (pos, [])
277 in
278 aux true pos
279
280 let err_stack = ref []
281
282 let push_errInfo (err : parseError) =
283 err_stack := err :: !err_stack
284
285 let gatherErrors res =
286 let rec aux res = function
287 | [] -> res
288 | x::xs -> aux (addErrorInfo x res) xs
289 in
290 let res = aux res !err_stack in
291 err_stack := [];
292 res
293
294 (* Needed for Netweb *)
295 let get_pos :pos->int = fun p -> p
296
297 let update_memoization_cache cache update_pos =
298 (* FIXME, this is a bit ugly/inefficient, but the point is to update [cache]
299 in place; any ideas how to do it better? *)
300 Hashtbl.clear cache;
301 let update_entry (pos, result) =
302 match update_pos ~pos:pos with
303 | None -> ()
304 | Some pos' -> Hashtbl.add cache pos' result
305 in
306 let content = Hashtbl.fold (fun k v l -> (k, v)::l) cache [] in
307 List.iter update_entry content;
308 cache
Something went wrong with that request. Please try again.