/
batGenlex.ml
537 lines (467 loc) · 17.1 KB
/
batGenlex.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
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
open BatParserCo
open BatCharParser
open BatStd
open Genlex
type lexer_error =
| IllegalCharacter of char
| NotReallyAChar
| NotReallyAnEscape
| EndOfStream
exception LexerError of lexer_error * int
exception EarlyEndOfStream
type enum =
{
mutable position : int;
content : char BatEnum.t
}
let junk e =
e.position <- e.position + 1;
BatEnum.junk e.content
let peek e =
BatEnum.peek e.content
type t = (string, token) Hashtbl.t
let of_list x =
let kwd_table = Hashtbl.create (List.length x) in
List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) x;
kwd_table
let to_enum_filter kwd_table =
let initial_buffer = String.create 32 in
let buffer = ref initial_buffer in
let bufpos = ref 0 in
let reset_buffer () = buffer := initial_buffer; bufpos := 0 in
let store c =
if !bufpos >= String.length !buffer then
begin
let newbuffer = String.create (2 * !bufpos) in
String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer
end;
String.set !buffer !bufpos c;
incr bufpos in
let get_string () =
let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s
in
let ident_or_keyword id =
try Hashtbl.find kwd_table id with
Not_found -> Ident id
and keyword_or_error c pos =
let s = BatString.of_char c in
try Hashtbl.find kwd_table s with
Not_found -> raise (LexerError (IllegalCharacter c, pos))
in
let rec next_token (enum : enum) =
match peek enum with
Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') ->
junk enum; next_token enum
| Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) ->
junk enum;
let s = enum in reset_buffer (); store c; ident s
| Some
('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' |
'?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
junk enum;
let s = enum in reset_buffer (); store c; ident2 s
| Some ('0'..'9' as c) ->
junk enum;
let s = enum in reset_buffer (); store c; number s
| Some '\'' ->
junk enum;
let c =
try char enum with
EarlyEndOfStream -> raise (LexerError (NotReallyAChar, enum.position))
in
begin match peek enum with
Some '\'' -> junk enum; Some (Char c)
| None -> raise EarlyEndOfStream
| _ -> raise (LexerError (NotReallyAChar, enum.position))
end
| Some '"' ->
junk enum;
let s = enum in reset_buffer (); Some (String (string s))
| Some '-' -> junk enum; neg_number enum
| Some '(' -> junk enum; maybe_comment enum
| Some c -> junk enum; Some (keyword_or_error c enum.position)
| _ -> None
and ident (enum : enum) =
match peek enum with
Some
('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) ->
junk enum; let s = enum in store c; ident s
| _ -> Some (ident_or_keyword (get_string ()))
and ident2 (enum : enum) =
match peek enum with
Some
('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' |
'>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
junk enum; let s = enum in store c; ident2 s
| _ -> Some (ident_or_keyword (get_string ()))
and neg_number (enum : enum) =
match peek enum with
Some ('0'..'9' as c) ->
junk enum;
let s = enum in reset_buffer (); store '-'; store c; number s
| _ -> let s = enum in reset_buffer (); store '-'; ident2 s
and number (enum : enum) =
match peek enum with
Some ('0'..'9' as c) ->
junk enum; let s = enum in store c; number s
| Some '.' ->
junk enum; let s = enum in store '.'; decimal_part s
| Some ('e' | 'E') ->
junk enum; let s = enum in store 'E'; exponent_part s
| _ -> Some (Int (int_of_string (get_string ())))
and decimal_part (enum : enum) =
match peek enum with
Some ('0'..'9' as c) ->
junk enum; let s = enum in store c; decimal_part s
| Some ('e' | 'E') ->
junk enum; let s = enum in store 'E'; exponent_part s
| _ -> Some (Float (float_of_string (get_string ())))
and exponent_part (enum : enum) =
match peek enum with
Some ('+' | '-' as c) ->
junk enum; let s = enum in store c; end_exponent_part s
| _ -> end_exponent_part enum
and end_exponent_part (enum : enum) =
match peek enum with
Some ('0'..'9' as c) ->
junk enum; let s = enum in store c; end_exponent_part s
| _ -> Some (Float (float_of_string (get_string ())))
and string (enum : enum) =
match peek enum with
Some '"' -> junk enum; get_string ()
| Some '\\' ->
junk enum;
let c =
try escape enum with
EarlyEndOfStream -> raise (LexerError (NotReallyAnEscape, enum.position))
in
let s = enum in store c; string s
| Some c -> junk enum; let s = enum in store c; string s
| _ -> raise EarlyEndOfStream
and char (enum : enum) =
match peek enum with
Some '\\' ->
junk enum;
begin try escape enum with
| EarlyEndOfStream -> raise (LexerError(NotReallyAChar, enum.position))
end
| Some c -> junk enum; c
| _ -> raise EarlyEndOfStream
and escape (enum : enum) =
match peek enum with
Some 'n' -> junk enum; '\n'
| Some 'r' -> junk enum; '\r'
| Some 't' -> junk enum; '\t'
| Some ('0'..'9' as c1) ->
junk enum;
begin match peek enum with
Some ('0'..'9' as c2) ->
junk enum;
begin match peek enum with
Some ('0'..'9' as c3) ->
junk enum;
Char.chr
((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 +
(Char.code c3 - 48))
| Some _ -> raise (LexerError(NotReallyAnEscape, enum.position))
| None -> raise EarlyEndOfStream
end
| Some _ -> raise (LexerError(NotReallyAnEscape, enum.position))
| _ -> raise EarlyEndOfStream
end
| Some c -> junk enum; c
| _ -> raise EarlyEndOfStream
and maybe_comment (enum : enum) =
match peek enum with
Some '*' -> junk enum; let s = enum in comment s; next_token s
| _ -> Some (keyword_or_error '(' enum.position)
and comment (enum : enum) =
match peek enum with
Some '(' -> junk enum; maybe_nested_comment enum
| Some '*' -> junk enum; maybe_end_comment enum
| Some c -> junk enum; comment enum
| _ -> raise EarlyEndOfStream
and maybe_nested_comment (enum : enum) =
match peek enum with
Some '*' -> junk enum; let s = enum in comment s; comment s
| Some c -> junk enum; comment enum
| _ -> raise EarlyEndOfStream
and maybe_end_comment (enum : enum) =
match peek enum with
Some ')' -> junk enum; ()
| Some '*' -> junk enum; maybe_end_comment enum
| Some c -> junk enum; comment enum
| _ -> raise EarlyEndOfStream
in
fun input -> BatEnum.from_while (fun count -> next_token {position = 0; content = input})
let to_stream_filter (kwd_table:t) (x:char Stream.t) : token Stream.t =
(BatStream.of_enum (to_enum_filter kwd_table (BatStream.enum x)))
let to_lazy_list_filter kwd_table x =
(BatLazyList.of_enum (to_enum_filter kwd_table (BatLazyList.enum x)))
let ocaml_comment =
string "(*" >>= fun _ ->
let rec content () =
any >>= function
| '(' -> ( any >>= function
| '*' -> content () >>= const (content ())
| _ -> content () )
| '*' -> ( any >>= function
| ')' -> return ()
| _ -> content() )
| _ -> content ()
in content ()
let ocaml_escape = label "OCaml-style escaped character"
(
any >>= function
| 'n' -> return '\n'
| 'r' -> return '\r'
| 't' -> return '\t'
| '\\'-> return '\\'
| 'b' -> return '\b'
| '"' -> return '"'
| 'x' ->
times 2 hex >>= fun t ->
return (Char.chr (BatInt.of_string (BatString.implode ('0'::'x'::t))))
| '0' .. '9' as x ->
times 2 digit >>= fun t ->
return (Char.chr (BatInt.of_string (BatString.implode (x::t))))
| _ -> fail
)
module Languages =
struct
module type Definition =
sig
val comment_delimiters : (string * string) option
val line_comment_start : string option
val nested_comments : bool
val ident_start : (char, char, position) BatParserCo.t
val ident_letter : (char, char, position) BatParserCo.t
val op_start : (char, char, position) BatParserCo.t
val op_letter : (char, char, position) BatParserCo.t
val reserved_names : string list
val case_sensitive : bool
end
module Library =
struct
(**A good approximation of language definition for OCaml's lexer*)
module OCaml =
struct
let comment_delimiters = Some ("(*", "*)")
let line_comment_start = None
let nested_comments = true
let ident_start = either [uppercase; lowercase; one_of ['_'; '`']]
let ident_letter = either [uppercase; lowercase; digit; one_of ['\''; '_']]
let op_start = satisfy (BatChar.is_symbol)
let op_letter = op_start
let reserved_names = ["fun"; "let"; "module"; "begin"; "end"; "sig"; "function";
"{"; "}"; ";"; "|"; ","; ":"; "."; ](*@TODO: Complete*)
let case_sensitive = true
end
(**A good approximation of language definition for C++'s lexer*)
module C =
struct
let comment_delimiters = Some ("/*", "*/")
let line_comment_start = Some "//"
let nested_comments = true
let ident_start = either [uppercase; lowercase; char '_']
let ident_letter = either [ident_start; digit]
let op_start = one_of [';';':';'!';'$';'%';'&';'*';'+';'.';'/';'<';'=';'>';'?';'^';'|';'-';'~']
let op_letter = op_start
let reserved_names = ["continue"; "volatile"; "register"; "unsigned"; "typedef"; "default";
"sizeof"; "switch"; "return"; "extern"; "struct"; "static"; "signed"; "while";
"break"; "union"; "const"; "else"; "case"; "enum";
"auto"; "goto"; "for"; "if"; "do" ]
let case_sensitive = true
end
end
(** Create a lexer based on conventions*)
module Make (M:Definition) =
struct
open M
(** {6 Case management} *)
let char =
if case_sensitive then char
else case_char
let string =
if case_sensitive then string
else case_string
let adapt_case =
if case_sensitive then BatStd.identity
else String.lowercase
let string_compare =
if case_sensitive then String.compare
else BatString.icompare
(** {6 Whitespace management} *)
let line_comment =
match line_comment_start with
| None -> fail
| Some s ->
(*label "Line comment"*)label "" (
string s >>= fun _ ->
ignore_zero_plus (not_char '\n') >>= fun _ ->
newline >>= fun _ ->
return ())
(*Note: we use [string] rather than [CharParser.string], as the line comment
may be introduced by a word rather than a symbol (e.g. Basic's [REM]), hence
may depend on case sensitivity.*)
let multiline_comment =
match comment_delimiters with
| None -> fail
| Some (l, r) ->
(*label "Multi-line comment"*) label "" (
let l0 = String.get l 0
and r0 = String.get r 0
and string_r = string r in
let in_comment () =
if nested_comments then
let not_lr = label ("Neither \""^l^"\" nor ^ \"" ^r^"\"")
(none_of [r0; l0]) in
let rec aux () =
label "aux" (
either [ string r >>= (fun _ -> return ());
string l >>= (fun _ -> aux () >>= fun _ -> aux ()) ;
(ignore_one_plus not_lr) >>= fun _ -> aux () ]
)
in aux ()
else
string l >>>
label "Contents of comments" (
let rec aux () =
maybe string_r >>= function
| Some _ -> return ()
| None -> any >>> aux ()
in aux ()
)
in in_comment ())
let comment = ( line_comment <|> multiline_comment ) >>> return ()
let whitespaces =
ignore_zero_plus (either
[ satisfy BatChar.is_whitespace >>= (fun _ -> return ());
comment ])
let to_symbol p =
p >>= fun r ->
whitespaces >>= fun _ ->
return (BatString.of_list r)
let lexeme p =
p >>= fun r ->
whitespaces >>= fun _ ->
return r
(** {6 Actual content} *)
let identifier_content = either [ident_start >:: zero_plus ident_letter ;
op_start >:: zero_plus op_letter]
let is_reserved s = List.mem s reserved_names
let ident_or_kwd = label "identifier or reserved"
(label ""
( to_symbol identifier_content >>= fun s ->
(* Printf.eprintf "Got something %S\n" s;*)
return (adapt_case s)))
let ident = label "identifier or operator"
(label ""
(ident_or_kwd >>= fun s ->
if is_reserved s then fail
else ((*Printf.eprintf "Got ident %S\n" s;*)return s)))
(* let kwd = label "keyword"
(ident_or_kwd >>= fun s ->
if is_reserved s then (Printf.eprintf "Got reserved %S\n" s; return s)
else fail)*)
let kwd = label "keyword" (ident_or_kwd)
let identifier s = label ("specific identifier \""^s^"\"") (label ""
(ident >>= fun s' ->
if string_compare s s' = 0 then return ()
else fail))
let keyword s = label ("specific keyword \""^s^"\"") (label ""
(kwd >>= fun s' ->
if string_compare s s' = 0 then return ()
else fail))
(* let as_identifier p = p >>= fun s -> if List.mem s reserved_names then fail else return s
let as_operator p = p >>= fun s -> if List.mem s reserved_op_names then fail else return s*)
(* let any_reserved = label "reserved name"
( to_symbol (ident_start >:: zero_plus ident_letter) >>= fun s ->
if List.mem s reserved_names then return s
else fail)
let any_reserved_op = label "reserved operator"
( to_symbol (op_start >:: zero_plus op_letter) >>= fun s ->
if List.mem s reserved_op_names then return s
else fail)*)
let char_literal = label "Character literal"
(BatCharParser.char '\'' >>= fun _ ->
any >>= function
| '\\' -> ocaml_escape
| c -> return c
) >>= fun c ->
BatCharParser.char '\'' >>= fun _ -> return c
let string_literal = label "String Literal"
(lexeme
(BatCharParser.char '"' >>>
let rec content chars =
any >>= function
| '"' ->
return chars
| '\\' ->
ocaml_escape >>= fun e ->
content (e::chars)
| e -> (*Printf.eprintf "Just received char %c\n" e;*)
content (e::chars)
in content [] >>= fun c ->
(*Printf.eprintf "Sending full string %S\n" (String.of_list (List.rev c));*)
return (BatString.of_list (List.rev c))))
let integer =
label "OCaml-style integer" (
lexeme(maybe (BatCharParser.char '-') >>= fun sign ->
one_plus digit >>= fun digits ->
let number = BatInt.of_string (BatString.of_list digits) in
match sign with
| Some _ -> return (~- number)
| None -> return number ))
let float =
label "OCaml-style floating-point number" (
lexeme (maybe (BatCharParser.char '-') >>= fun sign ->
post_map BatString.of_list (zero_plus digit) >>= fun int_part ->
maybe (
BatCharParser.char '.' >>= fun _ ->
post_map BatString.of_list (zero_plus digit) ) >>= fun decimal_part ->
maybe (
BatCharParser.char 'E' >>= fun _ ->
maybe (BatCharParser.char '+' <|> BatCharParser.char '-') >>= fun sign ->
let sign = BatOption.default '+' sign in
one_plus digit >>= fun expo ->
return ("E" ^ (BatString.of_char sign) ^ (BatString.of_list expo)))
>>= fun expo ->
let number = match (decimal_part, expo) with
| Some d, Some e -> Some (int_part ^ "." ^ d ^ e)
| Some d, None -> Some (int_part ^ "." ^ d)
| None, Some e -> Some (int_part ^ e )
| None, None -> None
in match number with
| None -> fail
| Some n -> let absolute = BatFloat.of_string n in
return (
match sign with
| None -> absolute
| Some _ -> ~-. absolute)
))
let number =
( float >>= fun f -> return (`Float f))
<|>( integer >>= fun i -> return (`Integer i) )
(** Getting it all together. *)
let check_reserved =
if case_sensitive then
fun x ->
if is_reserved x then (Kwd x)
else (Ident x)
else
fun x -> let x = String.lowercase x in
if is_reserved x then (Kwd x)
else (Ident x)
let as_parser =
whitespaces >>= fun _ -> either [
ident_or_kwd >>= (fun x -> return (check_reserved x));
float >>= (fun x -> return (Float x) );
integer >>= (fun x -> return (Int x) );
string_literal >>= (fun x -> return (String x) );
char_literal >>= (fun x -> return (Char x) )
]
let feed = source_map as_parser
let start = whitespaces
end
end