lexer_generator.ml 21.7 KB
Newer Older
1
2
3
4
open Batteries
open BatList
open Symbols
open Utils
Wilke Pierre's avatar
Wilke Pierre committed
5
open E_regexp
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

type 'a set = 'a Set.t

(* Non-deterministic Finite Automata (NFA) *)

(* Les états d'un NFA [nfa_state] sont des entiers.

   Un NFA est modélisé sous la forme d'un record, avec les quatre champs
   suivants:
   - [nfa_states] contient la liste des états de l'automate.
   - [nfa_initial] contient la liste des états initiaux de l'automate.
   - [nfa_final] contient la liste des états finaux de l'automate sous la
     forme (q, t), où q est un état de l'automate, et t, de type
     [string -> token option] est une fonction qui construit un token
     à partir d'une chaîne de caractères.
   - [nfa_step q] donne la liste des transitions depuis l'état [q] sous la
     forme d'une liste [(charset, q')]. [charset] est l'ensemble des caractères
     qui permettent de prendre la transition vers l'état [q']. [charset] peut
     éventuellement être [None], ce qui indique une epsilon-transition. 
*)

type nfa_state = int

type nfa =
  {
    nfa_states: nfa_state list;
    nfa_initial: nfa_state list;
    nfa_final: (nfa_state * (string -> token option)) list;
    nfa_step: nfa_state -> (char set option * nfa_state) list
  }

(* [empty_nfa] est un NFA vide. *)
let empty_nfa =
  {
    nfa_states = [];
    nfa_initial = [];
    nfa_final = [];
    nfa_step = fun q -> [];
  }
Armillon Damien's avatar
Armillon Damien committed
45
  let print_set = fun s -> Set.iter (Printf.printf "%d ") s; Printf.printf("\n")
46
47
48

(* Concaténation de NFAs.  *)
let cat_nfa n1 n2 =
Armillon Damien's avatar
Armillon Damien committed
49
50
  let n1_final_state = List.map (fst) n1.nfa_final in
  let new_nfa_step = fun q ->
Armillon Damien's avatar
Armillon Damien committed
51
52
    if List.mem q n1_final_state then List.map (fun q' -> (None,q')) n2.nfa_initial @ n1.nfa_step q
    else if List.mem q n2.nfa_states  then n2.nfa_step q
Armillon Damien's avatar
Armillon Damien committed
53
54
    else n1.nfa_step q in
    {
Armillon Damien's avatar
Armillon Damien committed
55
56
      nfa_states = n1.nfa_states @ n2.nfa_states(*(List.filter (fun state -> not (List.mem state n2.nfa_initial)) n2.nfa_states)*);
      nfa_initial =  n1.nfa_initial;
Armillon Damien's avatar
Armillon Damien committed
57
58
59
      nfa_final = n2.nfa_final;
      nfa_step = new_nfa_step;
    }
60

Wilke Pierre's avatar
Wilke Pierre committed
61
(* Alternatives de NFAs *)
62
let alt_nfa n1 n2 =
Armillon Damien's avatar
Armillon Damien committed
63
64
65
66
67
68
69
70
   {
      nfa_states = n1.nfa_states @ n2.nfa_states;
      nfa_initial = n1.nfa_initial @ n2.nfa_initial;
      nfa_final = n1.nfa_final @ n2.nfa_final;
      nfa_step = fun q ->
         if List.mem q n1.nfa_states then n1.nfa_step q
         else n2.nfa_step q
   }
71

Wilke Pierre's avatar
Wilke Pierre committed
72
73
(* Répétition de NFAs *)
(* t est de type [string -> token option] *)
74
let star_nfa n t =
Armillon Damien's avatar
Armillon Damien committed
75
76
77
   let final_states = List.map (fst) n.nfa_final in
   {
      nfa_states = n.nfa_states;
Armillon Damien's avatar
Armillon Damien committed
78
79
      nfa_initial = final_states;
      nfa_final = List.map (fun q -> (q,t)) final_states ;
Armillon Damien's avatar
Armillon Damien committed
80
81
82
83
      nfa_step = fun q -> if List.mem q final_states
         then List.map (fun q' -> (None,q')) n.nfa_initial @ n.nfa_step q
         else n.nfa_step q;
   }
84
85


Wilke Pierre's avatar
Wilke Pierre committed
86
(* [nfa_of_regexp r freshstate t] construit un NFA qui reconnaît le même langage
87
   que l'expression régulière [r].
Wilke Pierre's avatar
Wilke Pierre committed
88
   [freshstate] correspond à un entier pour lequel il n'y a pas encore d'état dans 
Wilke Pierre's avatar
Wilke Pierre committed
89
   le nfa. Il suffit d'incrémenter [freshstate] pour obtenir de nouveaux états non utilisés.
90
   [t] est une fonction du type [string -> token option] utile pour les états finaux.
91
*)
Wilke Pierre's avatar
Wilke Pierre committed
92
let rec nfa_of_regexp r freshstate t =
93
  match r with
Wilke Pierre's avatar
Wilke Pierre committed
94
95
96
97
98
99
100
101
102
  | Eps -> { nfa_states = [freshstate];
             nfa_initial = [freshstate];
             nfa_final = [(freshstate,t)];
             nfa_step = fun q -> []}, freshstate + 1
  | Charset c -> { nfa_states = [freshstate; freshstate + 1];
                nfa_initial = [freshstate];
                nfa_final = [freshstate + 1, t];
                nfa_step = fun q -> if q = freshstate then [(Some c, freshstate + 1)] else []
              }, freshstate + 2
Armillon Damien's avatar
Armillon Damien committed
103
104
105
106
107
108
109
110
   | Alt (r1, r2) -> let (nfa1, freshstate1) = nfa_of_regexp r1 freshstate t in
      let (nfa2, freshstate2) = nfa_of_regexp r2 freshstate1 t in
      (alt_nfa nfa1 nfa2, freshstate2)
   | Cat (r1, r2) -> let (nfa1, freshstate1) = nfa_of_regexp r1 freshstate t in
      let (nfa2, freshstate2) = nfa_of_regexp r2 freshstate1 t in
      (cat_nfa nfa1 nfa2, freshstate2)
   | Star r -> let (nfa1, freshstate1) = nfa_of_regexp r freshstate t in
      (star_nfa nfa1 t , freshstate1)
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

(* Deterministic Finite Automaton (DFA) *)

(* Les états d'un DFA [dfa_state] sont des ensembles d'entiers.

   Similairement aux NFA, un DFA est modélisé sous la forme d'un record, avec
   les quatre champs suivants:

   - [dfa_states] contient la liste des états de l'automate.
   - [dfa_initial] contient l'état initial de l'automate.
   - [dfa_final] contient la liste des états finaux de l'automate sous la
     forme (q, t), où q est un état de l'automate, et t, de type
     [string -> token option] est une fonction qui construit un token
     à partir d'une chaîne de caractères.
   - [dfa_step q c] donne l'état [q'] accessible après avoir lu le caractère
     [c], depuis l'état [q]. [charset] peut éventuellement être [None], ce qui
     indique qu'aucune transition n'est possible depuis cet état, et avec ce
     caractère.
*)

type dfa_state = int set

type dfa =
  {
    dfa_states: dfa_state list;
    dfa_initial: dfa_state;
    dfa_final: (dfa_state * (string -> token option)) list;
    dfa_step: dfa_state -> char -> dfa_state option
  }

(* On va maintenant déterminiser notre NFA pour en faire un DFA. *)


(* [epsilon_closure] calcule la epsilon-fermeture d'un état [s] dans un NFA [n],
   c'est-à-dire l'ensemble des états accessibles depuis [s] en ne prenant que
   des epsilon-transitions. *)
let epsilon_closure (n: nfa) (s: nfa_state) : nfa_state set =
  (* La fonction [traversal visited s] effectue un parcours de l'automate en
     partant de l'état [s], et en suivant uniquement les epsilon-transitions. *)
  let rec traversal (visited: nfa_state set) (s: nfa_state) : nfa_state set =
Armillon Damien's avatar
Armillon Damien committed
151
152
153
154
155
156
157
         let new_visited = Set.add s visited in
         let eps_transition = List.filter_map (
            fun (step, state) ->  if (step = None && not (Set.mem state visited)) then Some state else None
            ) (n.nfa_step s) in
         List.fold_left (
            fun accumulator  transition -> Set.union accumulator (traversal accumulator transition)
            ) new_visited eps_transition 
158
159
160
161
162
163
  in
  traversal Set.empty s

(* [epsilon_closure_set n ls] calcule l'union des epsilon-fermeture de chacun
   des états du NFA [n] dans l'ensemble [ls]. *)
let epsilon_closure_set (n: nfa) (ls: nfa_state set) : nfa_state set =
Armillon Damien's avatar
Armillon Damien committed
164
   Set.fold (fun state acc-> Set.union acc (epsilon_closure n state)) ls Set.empty
165
166
167

(* [dfa_initial_state n] calcule l'état initial de l'automate déterminisé. *)
let dfa_initial_state (n: nfa) : dfa_state =
Armillon Damien's avatar
Armillon Damien committed
168
   epsilon_closure_set n (Set.of_list n.nfa_initial)
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

(* Construction de la table de transitions de l'automate DFA. *)

(* Comme vu en cours, pour construire la table de l'automate DFA à partir de
   l'automate NFA [n], on part d'un état [q] de l'automate (initialement, l'état
   initial, que l'on vient de calculer ci-dessus).

   On calcule l'ensemble [t] des transitions dans [n] de chacun des états de
   [q]. Cet ensemble est de type [(char set option * nfa_state) list].

   On transforme cet ensemble [t] de la manière suivante :
   - on jette les epsilon-transitions : [assoc_throw_none]
   - on transforme chaque transition ({c1,c2,..,cn}, q) en une liste de
     transitions [(c1,q); (c2,q); ...; (cn,q)] : [assoc_distribute_key]
   - on fusionne les transitions qui consomment le même caractère:
     [(c1,q1);(c1,q2);...;(c1,qn);(c2,q'1);...(c2,q'm)] ->
     [(c1,{q1,q2,...,qn});(c2,{q'1,...,q'm})] : [assoc_merge_vals]
   - on applique la epsilon-fermeture sur tous les états:
Wilke Pierre's avatar
Wilke Pierre committed
187
     [(c1,{q1,q2,...,qn});...;(cn,{qn}])] -> [(c1, eps({q1,q2,...,qn})); ...; (cn, eps({qn}))] :
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
     [epsilon_closure_set]

   On obtient alors l'ensemble des transitions depuis l'état [q] dans
   l'automate DFA.

   On réitère ce processus pour tous les nouveaux états que l'on atteint.
*)

let assoc_throw_none (l : ('a option * 'b) list) : ('a * 'b) list =
  List.filter_map (fun (o,n) ->
      match o with
        None -> None
      | Some x -> Some (x,n)
    ) l

Wilke Pierre's avatar
Wilke Pierre committed
203
204
205
206
207
let assoc_distribute_key (l : ('a set * 'b) list) : ('a * 'b) list =
  List.fold_left (fun (acc : ('a * 'b) list) (k, v) ->
      Set.fold (fun c acc -> (c, v)::acc) k acc)
    [] l

208
209
210
211
212
213
214
215
216
217
218
219
220
let assoc_merge_vals (l : ('a * 'b) list) : ('a * 'b set) list =
  List.fold_left (fun (acc : ('a * 'b set) list) (k, v) ->
      match List.assoc_opt k acc with
      | None -> (k, Set.singleton v)::acc
      | Some vl -> (k, Set.add v vl)::List.remove_assoc k acc
    ) [] l

let rec build_dfa_table (table: (dfa_state, (char * dfa_state) list) Hashtbl.t)
    (n: nfa)
    (ds: dfa_state) : unit =
  match Hashtbl.find_option table ds with
  | Some _ -> ()
  | None ->
Wilke Pierre's avatar
Wilke Pierre committed
221
222
    (* [transitions] contient les transitions du DFA construites
     * à partir des transitions du NFA comme décrit auparavant *)
223
    let transitions : (char * dfa_state) list =
Armillon Damien's avatar
Armillon Damien committed
224
225
226
227
228
229
230
231
         let nfa_transitions =  List.flatten (
            Set.elements (
               Set.map (n.nfa_step) ds
         )) in
         let non_eps_transitions = assoc_throw_none nfa_transitions in
         let distributed_transitions = assoc_distribute_key non_eps_transitions in
         let merged_transitions = assoc_merge_vals distributed_transitions in
         List.map (fun (c,states) -> (c,epsilon_closure_set n states)) merged_transitions
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
      in
    Hashtbl.replace table ds transitions;
    List.iter (build_dfa_table table n) (List.map snd transitions)

(* Calcul des états finaux de l'automate DFA *)

(* Comme vu en cours, un état [q] du DFA est final si et seulement si il existe
   un état [q'] dans [q] qui soit un état final dans le NFA.

   Il nous faut de plus calculer le token qui sera reconnu par chaque état
   final.

   Supposons que l'on ait deux états finaux [q1, fun s -> SYM_IDENTIFIER s] et
   [q2, fun s -> SYM_WHILE] dans notre NFA.
   L'état [q = {q1,q2}] est final, mais comment choisir le token à reconnaître ?

   Dans ce cas précis, on souhaite reconnaître le mot-clé 'while' plutôt qu'un
   identifiant quelconque.

   Pour résoudre ce problème plus généralement, on introduit une fonction de
   priorité pour départager les tokens. La fonction [priority : token -> int]
   donne une valeur plus petite aux tokens les plus prioritaires.

*)

let priority t =
  match t with
  | SYM_EOF -> 100
  | SYM_IDENTIFIER _ -> 50
  | _ -> 0

(* [min_priority l] renvoie le token de [l] qui a la plus petite priorité, ou
   [None] si la liste [l] est vide. *)
let min_priority (l: token list) : token option =
Armillon Damien's avatar
Armillon Damien committed
266
267
268
269
270
   match l with
   | [] -> None
   | q1::r -> Some (List.fold_left 
      (fun current_best current -> if priority current > priority current_best then current_best else current)
      q1 r)
271

Armillon Damien's avatar
Armillon Damien committed
272
   (* [dfa_final_states n dfa_states] renvoie la liste des états finaux du DFA,
273
274
275
   accompagnés du token qu'ils reconnaissent. *)
let dfa_final_states (n: nfa) (dfa_states: dfa_state list) :
  (dfa_state * (string -> token option)) list  =
Armillon Damien's avatar
Armillon Damien committed
276
      List.filter_map (fun state_set ->
Armillon Damien's avatar
Armillon Damien committed
277
278
279
280
      let final_states =
         Set.filter_map (
            fun state -> List.find_opt (fun nfa_final -> fst nfa_final = state) n.nfa_final
         ) state_set in
Armillon Damien's avatar
Armillon Damien committed
281
      if not (Set.is_empty final_states) then
Armillon Damien's avatar
Armillon Damien committed
282
283
284
285
      let (final_sates_names,final_sates_functions) = Set.fold (
         fun (name,f) (acc_name,acc_fun) -> (Set.union (Set.singleton name) acc_name ,f::acc_fun)
         ) final_states (Set.empty,[]) in 
      let return_function = fun s -> min_priority (List.filter_map (fun f -> f s) final_sates_functions) in
Armillon Damien's avatar
Armillon Damien committed
286
287
      Some (state_set,return_function)
      else None
Armillon Damien's avatar
Armillon Damien committed
288
289
      ) dfa_states

290
291
292

(* Construction de la relation de transition du DFA. *)

Armillon Damien's avatar
Armillon Damien committed
293
294
let (let*) = Option.bind

295
296
297
(* [make_dfa_step table] construit la fonction de transition du DFA, où [table]
   est la table générée par [build_dfa_table], définie ci-dessus. *)
let make_dfa_step (table: (dfa_state, (char * dfa_state) list) Hashtbl.t) =
Armillon Damien's avatar
Armillon Damien committed
298
299
300
301
   fun (q: dfa_state) (a: char) ->
      let* possible_steps = Hashtbl.find_option table q in
      let* (_,next_step) = List.find_opt (fun step -> fst step = a) possible_steps in
      Some next_step
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

(* Finalement, on assemble tous ces morceaux pour construire l'automate. La
   fonction [dfa_of_nfa n] vous est grâcieusement offerte. *)
let dfa_of_nfa (n: nfa) : dfa =
  let table : (dfa_state, (char * dfa_state) list) Hashtbl.t =
    Hashtbl.create (List.length n.nfa_states) in
  let dfa_initial = dfa_initial_state n in
  build_dfa_table table n dfa_initial;
  let dfa_states = Hashtbl.keys table |> List.of_enum in
  let dfa_final = dfa_final_states n dfa_states in
  let dfa_step = make_dfa_step table in
  {
    dfa_states  ;
    dfa_initial ;
    dfa_final   ;
    dfa_step    ;
  }

(* Analyse lexicale *)

(* Maintenant que tout est en place, on va pouvoir écrire un analyseur lexical,
   qui va découper notre programme source en une liste de tokens. *)

(* La fonction [tokenize_one d w] tente de reconnaître le plus grand préfixe
   possible de [w]. Elle renvoie un couple [(res,w')], où [res] est le résultat
   de l'analyse lexicale d'un mot et [w'] est le reste du programme à analyser.

   Le résultat est de type [lexer_result], défini ci-dessous:
   - [LRToken tok] indique que l'automate a reconnu le token [tok]
   - [LRskip] indique que l'automate a reconnu un mot qui ne génère pas de token
     (c'est le cas par exemple des espaces, tabulations, retours à la ligne et
     commentaires)
   - [LRerror] indique que l'automate n'a rien reconnu du tout : il s'agit donc
     d'une erreur.

*)

type lexer_result =
  | LRtoken of token
  | LRskip
  | LRerror

(* La fonction [tokenize_one] utilise une fonction interne [recognize q w
   current_word last_accepted] qui essaie de lire le plus grand préfixe de [w]
   reconnu par l'automate.

   - [q] est l'état courant de l'automate.
   - [w] est le reste du programme source à analyser.
   - [current_word] est le mot reconnu depuis l'état initial de l'automate.
   - [last_accepted] est de type [lexer_result * char list]. La première
     composante est le dernier résultat valable de l'analyseur : celui vers
     lequel on se rabattra lorsque l'on sera bloqué dans un état non final de
     l'automate. La deuxième composante est le reste du programme à analyser,
     après ce dernier token reconnu.

   La fonction recognize est lancée avec [q = d.dfa_initial], l'état initial du
   DFA, le programme à analyser [w], un mot courant vide, et un dernier état
   accepté dénotant une erreur (si on ne passe par aucun état final, il s'agit
   bien d'une erreur lexicale).

*)
Armillon Damien's avatar
Armillon Damien committed
363
let to_lexer_result (d:dfa) (q: dfa_state) (w: char list): lexer_result =
Armillon Damien's avatar
Armillon Damien committed
364
365
366
367
368
369
370
  let result = List.find_opt (fun (state,_) -> Set.equal q state) d.dfa_final in
  match result with
  | None ->  LRerror
  | Some (_,f) -> match f (string_of_char_list w) with
     | None -> LRskip
     | Some token -> LRtoken token

371

Armillon Damien's avatar
Armillon Damien committed
372

373
374
let tokenize_one (d : dfa) (w: char list) : lexer_result * char list =
  let rec recognize (q: dfa_state) (w: char list)
Armillon Damien's avatar
Armillon Damien committed
375
      (current_word: char list) (last_accepted: lexer_result * char list)
376
    : lexer_result * char list =
Armillon Damien's avatar
Armillon Damien committed
377
         let last_accepted' = (to_lexer_result d q current_word, w) in
Armillon Damien's avatar
Armillon Damien committed
378
         match w with
Armillon Damien's avatar
Armillon Damien committed
379
         | [] -> last_accepted'
Armillon Damien's avatar
Armillon Damien committed
380
381
         | lettre::r ->
            match d.dfa_step q lettre with
Armillon Damien's avatar
Armillon Damien committed
382
            | None -> last_accepted'
Armillon Damien's avatar
Armillon Damien committed
383
            | Some q' -> let new_current_word = current_word @ [lettre] in match to_lexer_result d q' new_current_word with
Armillon Damien's avatar
Armillon Damien committed
384
               | LRerror -> recognize q' r (new_current_word) last_accepted'
Armillon Damien's avatar
Armillon Damien committed
385
               | lr -> recognize q' r (new_current_word) last_accepted'
386
  in
Armillon Damien's avatar
Armillon Damien committed
387
  recognize d.dfa_initial w [] (LRerror, w)
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

(* La fonction [tokenize_all d w] répète l'application de [tokenize_one] tant qu'on
   n'est pas arrivé à la fin du fichier (token [SYM_EOF]). Encore une fois,
   cette fonction vous est offerte. *)
let rec tokenize_all (d: dfa) (w: char list) : (token list * char list) =
  match tokenize_one d w with
  | LRerror, w -> [], w
  | LRskip, w -> tokenize_all d w
  | LRtoken token, w ->
    let (tokens, w) =
      if token = SYM_EOF
      then ([], w)
      else tokenize_all d w in
    (token :: tokens, w)



(* Fonctions d'affichage - Utile pour déboguer *)

407
408
409
410
411
412

let char_list_to_char_ranges s =
  let rec recognize_range (cl: int list) l opt_c n =
    match cl with
    | [] -> (match opt_c with
          None -> l
413
        | Some c -> (c,n)::l
414
415
416
417
418
419
420
421
422
423
      )
    | c::r -> (match opt_c with
        | None -> recognize_range r l (Some c) 0
        | Some c' ->
          if c' + n + 1 = c
          then recognize_range r l (Some c') (n + 1)
          else recognize_range r ((c',n)::l) (Some c) 0
      )
  in
  let l = recognize_range (List.sort Stdlib.compare (List.map Char.code s)) [] None 0 in
Wilke Pierre's avatar
Wilke Pierre committed
424
  let escape_char c =
425
426
427
428
429
430
    if c = '"' then "\\\""
    else if c = '\\' then "\\\\"
    else if c = '\x00' then "\\\\0"
    else if c = '\t' then "\\\\t"
    else if c = '\n' then "\\\\n"
    else Printf.sprintf "%c" c in
431
  List.fold_left (fun acc (c,n) ->
432
433
434
435
      match n with
      | 0 -> Printf.sprintf "%s%s" (escape_char (Char.chr c)) acc
      | 1 -> Printf.sprintf "%s%s%s" (escape_char (Char.chr c)) (c + 1 |> Char.chr |> escape_char) acc
      | _ -> Printf.sprintf "%s-%s%s" (escape_char (Char.chr c))
Wilke Pierre's avatar
Wilke Pierre committed
436
          (escape_char (Char.chr (c + n))) acc
437
438
439
    ) "" l


440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
(* Affichage d'un NFA *)
let nfa_to_string (n : nfa) : string =
  Printf.sprintf "===== NFA\nStates : %s\nInitial states : %s\nFinal states : %s\n%s"
    (String.concat " " (List.map (fun q -> string_of_int q) n.nfa_states))
    (String.concat " " (List.map (fun q -> string_of_int q) n.nfa_initial))
    (String.concat " " (List.map (fun (q,_) -> string_of_int q) n.nfa_final)) 
    (String.concat ""
       (List.map (fun q ->
            let l = n.nfa_step q in
            String.concat ""
              (List.map (fun (oa, q') ->
                   Printf.sprintf "step(%d, %s) = [%d]\n" q (match oa with Some a -> Printf.sprintf "[%s]" (string_of_char_set a) | _ -> "eps")
                     q'
                 ) l)
          ) n.nfa_states))

456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
let nfa_to_dot oc (n : nfa) : unit =
  Printf.fprintf oc "digraph {\n";
  List.iter (fun n -> Printf.fprintf oc "N%d [shape=\"house\" color=\"red\"]\n" n) (n.nfa_initial);
  List.iter (fun (q,t) ->
      Printf.fprintf oc "N%d [shape=\"rectangle\", label=\"%s\"]\n"
        q (match t "0" with | Some s -> string_of_symbol s | None -> "" )) n.nfa_final;
  List.iter (fun q ->
      List.iter (fun (cso, q') ->
          match cso with
          | None ->
            Printf.fprintf oc "N%d -> N%d [label=\"[epsilon]\"]\n" q q'
          | Some cs ->
            Printf.fprintf oc "N%d -> N%d [label=\"[%s]\"]\n" q q' (char_list_to_char_ranges (Set.to_list cs))
        ) (n.nfa_step q);
    ) n.nfa_states;
  Printf.fprintf oc "}\n"


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
(* Affichage d'un DFA *)
let dfa_to_string (n : dfa) (alphabet: char list): string =
  Printf.sprintf "===== DFA\nStates : %s\nInitial state : %s\nFinal states : [%s]\n%s"
    (String.concat " " (List.map (fun q -> string_of_int_set q) n.dfa_states))
    (string_of_int_set n.dfa_initial)
    (String.concat " " (List.map (fun (q,_) -> string_of_int_set q) n.dfa_final))
    (String.concat "" (List.map (fun q ->
         String.concat "" (List.map (fun a ->
             let l = n.dfa_step q a in
             match l with
             | None -> ""
             | Some q' ->
               if not (Set.is_empty q') then
                 Printf.sprintf "step(%s, %c) = %s\n"
                   (string_of_int_set q)
                   a (string_of_int_set q')
               else ""
           ) alphabet);
       ) n.dfa_states))

(* Affichage graphique d'un DFA. Génère un fichier .dot que vous pouvez ensuite
   convertir en pdf avec la commande 'dot fichier.dot -Tsvg -o fichier.svg' ou
   bien en copiant le code DOT dans un convertisseur en ligne (par exemple :
   http://proto.informatics.jax.org/prototypes/dot2svg/). *)

let dfa_to_dot oc (n : dfa) (cl: char list): unit =
  Printf.fprintf oc "digraph {\n";
  Printf.fprintf oc "N%s [shape=\"house\" color=\"red\"]\n" (string_of_int_set n.dfa_initial);
  List.iter (fun (q,t) ->
      Printf.fprintf oc "N%s [shape=\"rectangle\", label=\"%s\"]\n"
        (string_of_int_set q) (match t "0" with | Some s -> string_of_symbol s | None -> "" )) n.dfa_final;
  List.iter (fun q ->
      let l = List.fold_left (fun l a ->
          match n.dfa_step q a with
            None -> l
          | Some q' ->
            match List.assoc_opt q' l with
            | None -> (q', [a])::l
            | Some ql -> (q', a::ql)::List.remove_assoc q' l
        ) [] cl in
      List.iter (fun (q', cl) ->
          Printf.fprintf oc "N%s -> N%s [label=\"[%s]\"]\n"
            (string_of_int_set q)
            (string_of_int_set q') (char_list_to_char_ranges cl)
        ) l;
    ) n.dfa_states;
  Printf.fprintf oc "}\n"

let nfa_of_list_regexp l =
  let (n, fs) = List.fold_left (fun (nfa, fs) (r,t) ->
      let n,fs = nfa_of_regexp r fs t in
      (alt_nfa nfa n, fs)
    ) ({ nfa_states = []; nfa_initial = []; nfa_final = []; nfa_step = fun _ -> [] },1)
      l in n

let dfa_of_list_regexp l =
  let n = nfa_of_list_regexp l in
Armillon Damien's avatar
Armillon Damien committed
531
532
533
  let oc = open_out "/tmp/nfa.dot" in
  nfa_to_dot oc n;
  close_out oc;
534
535
536
537
  dfa_of_nfa n

let tokenize_list_regexp l s =
  let d = dfa_of_list_regexp l in
Armillon Damien's avatar
Armillon Damien committed
538
539
540
  let oc = open_out "/tmp/dfa.dot" in
  dfa_to_dot oc d alphabet;
  close_out oc;
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
  let tokens, leftover = tokenize_all d (char_list_of_string s) in
  if leftover <> []
  then Error (Printf.sprintf "Lexer failed to recognize string starting with '%s'\n"
                   (string_of_char_list (take 20 leftover))
                )
  else OK tokens

let file_contents file =
  let ic = open_in file in
  let rec aux s () =
    try
      let line = input_line ic in  (* read line from in_channel and discard \n *)
      aux (s ^ line ^ "\n") ()   (* close the input channel *)
    with e ->                      (* some unexpected exception occurs *)
      close_in_noerr ic;           (* emergency closing *)
      s in
  aux "" ()


let tokenize_file f =
  tokenize_list_regexp list_regexp (file_contents f)