grew_grs.ml 33.7 KB
Newer Older
bguillaum's avatar
bguillaum committed
1
2
3
4
5
6
7
8
9
10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
12
13
open Printf
open Log

14
open Grew_fs
bguillaum's avatar
bguillaum committed
15
open Grew_base
16
open Grew_types
bguillaum's avatar
bguillaum committed
17
open Grew_ast
18
open Grew_domain
19
open Grew_edge
bguillaum's avatar
bguillaum committed
20
21
22
open Grew_command
open Grew_graph
open Grew_rule
bguillaum's avatar
bguillaum committed
23
open Grew_loader
pj2m's avatar
pj2m committed
24

bguillaum's avatar
bguillaum committed
25
(* ================================================================================ *)
pj2m's avatar
pj2m committed
26
27
module Rewrite_history = struct
  type t = {
28
29
30
31
    instance: Instance.t;
    module_name: string;
    good_nf: t list;
  }
pj2m's avatar
pj2m committed
32

33
  let rec get_graphs = function
Bruno Guillaume's avatar
Bruno Guillaume committed
34
    | { good_nf = []; instance } -> [instance.Instance.graph]
35
36
    | { good_nf = l} -> List_.flat_map get_graphs l

37
  let rec is_empty t =
bguillaum's avatar
bguillaum committed
38
    (t.instance.Instance.rules = []) && List.for_all is_empty t.good_nf
bguillaum's avatar
bguillaum committed
39
40

  let rec num_sol = function
Bruno Guillaume's avatar
Bruno Guillaume committed
41
    | { good_nf = [] } -> 1
bguillaum's avatar
bguillaum committed
42
    | { good_nf = l} -> List.fold_left (fun acc t -> acc + (num_sol t)) 0 l
43

bguillaum's avatar
bguillaum committed
44
  let save_nfs ?domain ?filter ?main_feat ~dot base_name t =
45
    let rec loop file_name rules t =
Bruno Guillaume's avatar
Bruno Guillaume committed
46
47
48
49
      match t.good_nf with
        | [] when dot -> Instance.save_dot_png ?domain ?filter ?main_feat file_name t.instance; [rules, file_name]
        | [] -> ignore (Instance.save_dep_png ?domain ?filter ?main_feat file_name t.instance); [rules, file_name]
        | l ->
50
          List_.foldi_left
51
            (fun i acc son ->
52
              (* Instance.save_dep_png ?main_feat (sprintf "%s_%d" file_name i) son.instance; *)
53
54
55
56
              let nfs = loop
                (sprintf "%s_%d" file_name i)
                (rules @ [t.module_name, son.instance.Instance.rules])
                son in
57
58
              nfs @ acc
            )
bguillaum's avatar
bguillaum committed
59
60
            [] l in
    loop base_name [] t
61

bguillaum's avatar
bguillaum committed
62
  let save_gr ?domain base t =
63
    let rec loop file_name t =
Bruno Guillaume's avatar
Bruno Guillaume committed
64
65
66
      match t.good_nf with
        | [] -> File.write (Instance.to_gr ?domain t.instance) (file_name^".gr")
        | l -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
67
68
    in loop base t

bguillaum's avatar
bguillaum committed
69
  let save_conll ?domain base t =
bguillaum's avatar
bguillaum committed
70
    let rec loop file_name t =
Bruno Guillaume's avatar
Bruno Guillaume committed
71
72
73
      match t.good_nf with
        | [] -> File.write (Instance.to_conll_string ?domain t.instance) (file_name^".conll")
        | l -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
bguillaum's avatar
bguillaum committed
74
75
    in loop base t

bguillaum's avatar
bguillaum committed
76
  let save_full_conll ?domain base t =
77
78
    let cpt = ref 0 in
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
79
80
      match t.good_nf with
        | [] ->
bguillaum's avatar
bguillaum committed
81
          File.write (Instance.to_conll_string ?domain t.instance) (sprintf "%s__%d.conll" base !cpt);
82
          incr cpt
Bruno Guillaume's avatar
Bruno Guillaume committed
83
        | l -> List.iter loop l
84
    in loop t; !cpt
85

86
  (* suppose that all modules are deterministic and produced exacly one normal form *)
bguillaum's avatar
bguillaum committed
87
  let save_det_gr ?domain base t =
88
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
89
90
91
      match t.good_nf with
        | [] -> File.write (Instance.to_gr ?domain t.instance) (base^".gr")
        | [one] -> loop one
92
        | _ -> Error.run "[save_det_gr] Not a single rewriting"
93
    in loop t
bguillaum's avatar
bguillaum committed
94

bguillaum's avatar
bguillaum committed
95
  let save_det_conll ?domain ?header base t =
bguillaum's avatar
bguillaum committed
96
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
97
98
      match t.good_nf with
        | [] ->
99
100
          let output =
            match header with
bguillaum's avatar
bguillaum committed
101
102
              | Some h -> sprintf "%% %s\n%s" h (Instance.to_conll_string ?domain t.instance)
              | None -> Instance.to_conll_string ?domain t.instance in
103
          File.write output (base^".conll")
Bruno Guillaume's avatar
Bruno Guillaume committed
104
        | [one] -> loop one
105
        | _ -> Error.run "[save_det_conll] Not a single rewriting"
bguillaum's avatar
bguillaum committed
106
107
    in loop t

bguillaum's avatar
bguillaum committed
108
  let det_dep_string ?domain t =
bguillaum's avatar
bguillaum committed
109
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
110
111
      match t.good_nf with
        | [] ->
bguillaum's avatar
bguillaum committed
112
          let graph = t.instance.Instance.graph in
bguillaum's avatar
bguillaum committed
113
          Some (G_graph.to_dep ?domain graph)
Bruno Guillaume's avatar
Bruno Guillaume committed
114
        | [one] -> loop one
bguillaum's avatar
bguillaum committed
115
        | _ -> None
bguillaum's avatar
bguillaum committed
116
    in loop t
bguillaum's avatar
bguillaum committed
117

bguillaum's avatar
bguillaum committed
118
  let conll_dep_string ?domain ?(keep_empty_rh=false) t =
bguillaum's avatar
bguillaum committed
119
120
121
122
    if (not keep_empty_rh) && is_empty t
    then None
    else
      let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
123
124
        match t.good_nf with
          | [] ->
bguillaum's avatar
bguillaum committed
125
            let graph = t.instance.Instance.graph in
bguillaum's avatar
bguillaum committed
126
            Some (G_graph.to_conll_string ?domain graph)
Bruno Guillaume's avatar
Bruno Guillaume committed
127
          | [one] -> loop one
bguillaum's avatar
bguillaum committed
128
129
          | _ -> None
      in loop t
130
end (* module Rewrite_history *)
pj2m's avatar
pj2m committed
131

bguillaum's avatar
bguillaum committed
132
(* ================================================================================ *)
pj2m's avatar
pj2m committed
133
134
module Modul = struct
  type t = {
135
136
    name: string;
    rules: Rule.t list;
137
    deterministic: bool;
138
139
    loc: Loc.t;
  }
pj2m's avatar
pj2m committed
140

Bruno Guillaume's avatar
Bruno Guillaume committed
141
142
143
  let to_json ?domain t =
    `Assoc [
      ("module_name", `String t.name);
144
      ("deterministic", `Bool t.deterministic);
Bruno Guillaume's avatar
Bruno Guillaume committed
145
146
147
      ("rules", `List (List.map (Rule.to_json ?domain) t.rules));
    ]

148
149
150
151
  let check t =
    (* check for duplicate rules *)
    let rec loop already_defined = function
      | [] -> ()
152
153
      | r::_ when List.mem (Rule.get_name r) already_defined ->
        Error.build ~loc:(Rule.get_loc r) "Rule '%s' is defined twice in the same module" (Rule.get_name r)
154
155
      | r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
    loop [] t.rules
pj2m's avatar
pj2m committed
156

bguillaum's avatar
bguillaum committed
157
  let build ?domain ast_module =
Bruno Guillaume's avatar
Bruno Guillaume committed
158
    let rules = List.map (Rule.build ?domain ast_module.Ast.mod_dir) ast_module.Ast.rules in
159
    let modul =
160
      {
161
        name = ast_module.Ast.module_id;
162
        rules;
163
        deterministic = ast_module.Ast.deterministic;
164
165
        loc = ast_module.Ast.mod_loc;
      } in
166
    check modul; modul
167
end (* module Modul *)
168

bguillaum's avatar
bguillaum committed
169
(* ================================================================================ *)
pj2m's avatar
pj2m committed
170
module Grs = struct
171

pj2m's avatar
pj2m committed
172
  type t = {
bguillaum's avatar
bguillaum committed
173
    domain: Domain.t option;
174
    modules: Modul.t list;       (* the ordered list of modules used from rewriting *)
175
    strategies: Ast.strategy list;
bguillaum's avatar
bguillaum committed
176
177
    filename: string;
    ast: Ast.grs;
178
179
  }

180
  let to_json t = `List (List.map (Modul.to_json ?domain:t.domain) t.modules)
Bruno Guillaume's avatar
Bruno Guillaume committed
181

bguillaum's avatar
bguillaum committed
182
  let get_modules t = t.modules
bguillaum's avatar
bguillaum committed
183
184
  let get_ast t = t.ast
  let get_filename t = t.filename
bguillaum's avatar
bguillaum committed
185

186
  let get_domain t = t.domain
187

188
  let sequence_names t = List.map (fun s -> s.Ast.strat_name) t.strategies
bguillaum's avatar
bguillaum committed
189
190

  let empty = {domain=None; modules=[]; strategies=[]; ast=Ast.empty_grs; filename=""; }
pj2m's avatar
pj2m committed
191

Bruno Guillaume's avatar
Bruno Guillaume committed
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
  let check_strategy strat t =
    let rec loop = function
    | Ast.Ref name ->
      (if not (List.exists (fun m -> name = m.Modul.name) t.modules)
      then Error.build ~loc:strat.Ast.strat_loc "In sequence '%s' definition, module '%s' undefined" strat.Ast.strat_name name)
    | Ast.Seq sd_list -> List.iter loop sd_list
    | Ast.Star sd -> loop sd
    | Ast.Pick sd -> loop sd
    | Ast.Sequence name_list ->
      List.iter (fun name ->
        if not (List.exists (fun m -> name = m.Modul.name) t.modules)
        then Error.build ~loc:strat.Ast.strat_loc "In sequence '%s' definition, module '%s' undefined" strat.Ast.strat_name name
      ) name_list
    in loop strat.Ast.strat_def

207
208
209
210
  let check t =
    (* check for duplicate modules *)
    let rec loop already_defined = function
      | [] -> ()
211
212
      | m::_ when List.mem m.Modul.name already_defined ->
        Error.build ~loc:m.Modul.loc "Module '%s' is defined twice" m.Modul.name
213
214
215
      | m::tail -> loop (m.Modul.name :: already_defined) tail in
    loop [] t.modules;

bguillaum's avatar
bguillaum committed
216
    (* check for duplicate strategies *)
217
218
    let rec loop already_defined = function
      | [] -> ()
219
220
221
      | s::_ when List.mem s.Ast.strat_name already_defined ->
        Error.build ~loc:s.Ast.strat_loc "Sequence '%s' is defined twice" s.Ast.strat_name
      | s::tail -> loop (s.Ast.strat_name :: already_defined) tail in
Bruno Guillaume's avatar
Bruno Guillaume committed
222
223
224
225
226
227
228
    loop [] t.strategies;

    (* check for undefined module or strategy *)
    List.iter (fun strat ->
      check_strategy strat t
    ) t.strategies

bguillaum's avatar
bguillaum committed
229
230
  let domain_build ast_domain =
    Domain.build
231
232
233
      (Label_domain.build ast_domain.Ast.label_domain)
      (Feature_domain.build ast_domain.Ast.feature_domain)

bguillaum's avatar
bguillaum committed
234
  let build filename =
bguillaum's avatar
bguillaum committed
235
    let ast = Loader.grs filename in
bguillaum's avatar
bguillaum committed
236
    let domain = match ast.Ast.domain with None -> None | Some ast_dom -> Some (domain_build ast_dom) in
bguillaum's avatar
bguillaum committed
237
    let modules = List.map (Modul.build ?domain) ast.Ast.modules in
bguillaum's avatar
bguillaum committed
238
    let grs = {domain; strategies = ast.Ast.strategies; modules; ast; filename} in
239
240
    check grs;
    grs
pj2m's avatar
pj2m committed
241

242
243
  (* ---------------------------------------------------------------------------------------------------- *)
  let rewrite grs strategy_name graph =
244
245
246
247
248
249
    let strategy =
      try List.find (fun s -> s.Ast.strat_name = strategy_name) grs.strategies
      with Not_found ->
        Error.run "[rewrite] Undefined stategy \"%s\"\nAvailable stategies: %s"
        strategy_name
        (String.concat "; " (List.map (fun s -> s.Ast.strat_name) grs.strategies)) in
bguillaum's avatar
bguillaum committed
250

251
    let rec old_loop instance module_list =
252
      match module_list with
Bruno Guillaume's avatar
Bruno Guillaume committed
253
      | [] -> {Rewrite_history.instance = instance; module_name = ""; good_nf = []; }
254
255
256
257
      | module_name :: tail ->
         let next =
           try List.find (fun m -> m.Modul.name=module_name) grs.modules
           with Not_found -> Log.fcritical "No module named '%s'" module_name in
Bruno Guillaume's avatar
Bruno Guillaume committed
258
        let good_set =
259
          Rule.normalize
bguillaum's avatar
bguillaum committed
260
            ?domain: grs.domain
261
            next.Modul.name
262
            ~deterministic: next.Modul.deterministic
263
            next.Modul.rules
264
            (Instance.refresh instance) in
Bruno Guillaume's avatar
Bruno Guillaume committed
265
        let good_list = Instance_set.elements good_set in
266
267
268
        {
          Rewrite_history.instance = instance;
          module_name = next.Modul.name;
269
          good_nf = List.map (fun i -> old_loop i tail) good_list;
270
271
        } in

272
273
274
    let loop instance def =
      match def with

275
      | Ast.Sequence module_list -> old_loop instance module_list
276
277
      | _ -> failwith "Not yet implemented" in

278
    loop (Instance.from_graph graph) (strategy.Ast.strat_def)
279

280
  (* [new_style grs module_list] return an equivalent strategy expressed with Seq, Pick and Star *)
281
  let new_style grs module_list =
282
    Ast.Seq
283
284
285
286
      (List.map
        (fun module_name ->
           let modul =
           try List.find (fun m -> m.Modul.name=module_name) grs.modules
287
           with Not_found -> Error.build "No module named '%s'" module_name in
288
           if modul.Modul.deterministic
289
           then Ast.Pick (Ast.Star (Ast.Ref module_name))
290
           else Ast.Star (Ast.Ref module_name)
291
292
293
294
295
296
297
        ) module_list
      )

  (* [one_rewrite grs strat inst] tries to rewrite deterministically [inst] with [strat] defined in [grs] *)
  let one_rewrite grs strat inst =
    let rec loop inst = function
    (* name can refer to another strategy def or to a module *)
298
    | Ast.Ref name ->
299
300
      begin
        try
301
302
          let sub_strat = List.find (fun s -> s.Ast.strat_name = name) grs.strategies in
          loop inst sub_strat.Ast.strat_def
303
304
305
        with Not_found ->
          let modul =
            try List.find (fun m -> m.Modul.name=name) grs.modules
306
            with Not_found -> Error.build "No module or strategy named '%s'" name in
Bruno Guillaume's avatar
Bruno Guillaume committed
307
          Rule.conf_one_step ?domain: grs.domain inst modul.Modul.rules
308
309
      end
    (* Sequence of strategies *)
310
311
312
    | Ast.Seq [] -> Log.fcritical "Empty sequence in strategy definition"
    | Ast.Seq [one] -> loop inst one
    | Ast.Seq (head::tail) ->
313
314
      begin
        match loop inst head with
315
        | Some new_inst -> loop new_inst (Ast.Seq tail)
316
317
318
        | None -> None
      end
    (* Interation of a strategy *)
319
    | Ast.Star sub_strat ->
320
321
322
      begin
        match loop inst sub_strat with
        | None -> Some inst
323
        | Some new_inst -> loop new_inst (Ast.Star sub_strat)
324
      end
325
326
    (* Pick *)
    | Ast.Pick sub_strat -> loop inst sub_strat
327
    (* Old style seq definition *)
328
    | Ast.Sequence module_list -> loop inst (new_style grs module_list) in
329
330
    loop inst strat

331
  let simple_rewrite grs strat_desc graph = failwith "OBSOLETE [Grs.simple_rewrite]"
332

333
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
334
  (* construction of the rew_display *)
335
336
337
338
339
340
  let rec pick = function
    | Libgrew_types.Node (_, _, []) -> Log.bug "Empty node"; exit 12
    | Libgrew_types.Node (graph, name, (bs,rd)::_) -> Libgrew_types.Node (graph, "pick(" ^ name^")", [(bs, pick rd)])
    | x -> x

  let rec try_ = function
bguillaum's avatar
bguillaum committed
341
    | Libgrew_types.Node (_, _, []) -> Log.bug "Empty node"; exit 12
342
    | Libgrew_types.Node (graph, name, (bs,rd)::_) -> Libgrew_types.Node (graph, "try(" ^ name^")", [(bs, pick rd)])
bguillaum's avatar
bguillaum committed
343
344
    | x -> x

345
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
  let rec clean = function
    | Libgrew_types.Empty -> Libgrew_types.Empty
    | Libgrew_types.Leaf graph -> Libgrew_types.Leaf graph
    | Libgrew_types.Local_normal_form (graph, name, Libgrew_types.Empty) -> Libgrew_types.Empty
    | Libgrew_types.Local_normal_form (graph, name, rd) -> Libgrew_types.Local_normal_form (graph, name, clean rd)
    | Libgrew_types.Node (graph, name, bs_rd_list) ->
        match
          List.fold_left (fun acc (bs,rd) ->
            match clean rd with
              | Libgrew_types.Empty -> acc
              | crd -> (bs, crd) :: acc
          ) [] bs_rd_list
        with
        | [] -> Libgrew_types.Empty
        | new_bs_rd_list -> Libgrew_types.Node (graph, name, new_bs_rd_list)

pj2m's avatar
pj2m committed
362

363
364
  (* ---------------------------------------------------------------------------------------------------- *)
  let build_rew_display grs strategy_name graph =
365
    let strategy = List.find (fun s -> s.Ast.strat_name = strategy_name) grs.strategies in
366
367
368

    let instance = Instance.from_graph graph in
    let rec old_loop instance module_list =
369
      match module_list with
bguillaum's avatar
bguillaum committed
370
      | [] -> Libgrew_types.Leaf instance.Instance.graph
371
372
373
374
      | next_name :: tail ->
         let next =
           try List.find (fun m -> m.Modul.name=next_name) grs.modules
           with Not_found -> Log.fcritical "No module named '%s'" next_name in
Bruno Guillaume's avatar
Bruno Guillaume committed
375
        let good_set =
376
          Rule.normalize
bguillaum's avatar
bguillaum committed
377
            ?domain: grs.domain
378
            next.Modul.name
379
            ~deterministic: next.Modul.deterministic
380
            next.Modul.rules
381
            (Instance.refresh instance) in
Bruno Guillaume's avatar
Bruno Guillaume committed
382
        let inst_list = Instance_set.elements good_set in
pj2m's avatar
pj2m committed
383

384
        match inst_list with
385
          | [{Instance.big_step = None}] ->
386
            Libgrew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, old_loop instance tail)
bguillaum's avatar
bguillaum committed
387
          | _ -> Libgrew_types.Node
388
389
390
391
392
393
            (
              instance.Instance.graph,
              next.Modul.name,
              List.map
                (fun inst ->
                  match inst.Instance.big_step with
394
395
396
                    | None -> Error.bug "Cannot have no big_steps and more than one reducts at the same time"
                    | Some bs -> (bs, old_loop inst tail)
                ) inst_list
Bruno Guillaume's avatar
Bruno Guillaume committed
397
            ) in
bguillaum's avatar
bguillaum committed
398

399
    let indent = ref 10 in
bguillaum's avatar
bguillaum committed
400

401
    let rec apply_leaf strat_def = function
bguillaum's avatar
bguillaum committed
402
      | Libgrew_types.Empty -> Libgrew_types.Empty
403
404
405
      | Libgrew_types.Leaf graph -> loop (Instance.from_graph graph) strat_def
      | Libgrew_types.Local_normal_form (graph, name, rd) -> Libgrew_types.Local_normal_form (graph, name, apply_leaf strat_def rd)
      | Libgrew_types.Node (graph, name, bs_rd_list) -> Libgrew_types.Node (graph, name, List.map (fun (bs,rd) -> (bs, apply_leaf strat_def rd)) bs_rd_list)
bguillaum's avatar
bguillaum committed
406

407
408
    and loop instance strat_def =
      printf "%s===> loop  strat_def=%s\n%!"
bguillaum's avatar
bguillaum committed
409
        (String.make (2 * (max 0 !indent)) ' ')
410
        (Ast.strat_def_to_string strat_def);
bguillaum's avatar
bguillaum committed
411
412
      incr indent;

413
414
      match strat_def with

415
      | Ast.Sequence module_list -> old_loop instance module_list
bguillaum's avatar
bguillaum committed
416
417

      (* ========> reference to a module or to another strategy <========= *)
418
      | Ast.Ref name ->
bguillaum's avatar
bguillaum committed
419
420
        begin
          try
421
422
            let strategy = List.find (fun s -> s.Ast.strat_name = name) grs.strategies in
            loop instance strategy.Ast.strat_def
bguillaum's avatar
bguillaum committed
423
424
425
426
427
          with Not_found ->
            let modul =
              try List.find (fun m -> m.Modul.name=name) grs.modules
              with Not_found -> Log.fcritical "No [strategy or] module named '%s'" name in
            begin
bguillaum's avatar
bguillaum committed
428
              printf "%s one_step (module=%s)...%!" (String.make (2 * (max 0 !indent)) ' ') modul.Modul.name;
bguillaum's avatar
bguillaum committed
429
              let domain = get_domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
430
              match Instance_set.elements (Rule.one_step ?domain instance modul.Modul.rules) with
bguillaum's avatar
bguillaum committed
431
432
433
434
435
436
437
              | [] -> printf "0\n%!"; let res = Libgrew_types.Empty in decr indent; res
              | instance_list -> printf "%d\n%!" (List.length instance_list);
                Libgrew_types.Node
                (instance.Instance.graph,
                  name,
                  List.map
                    (fun inst -> match inst.Instance.big_step with
438
                    | None -> Error.bug "Cannot have no big_steps and more than one reducts at the same time"
bguillaum's avatar
bguillaum committed
439
440
441
442
443
444
445
                    | Some bs -> let res = (bs, Libgrew_types.Leaf inst.Instance.graph) in decr indent; res
                    ) instance_list
                )
            end
        end

      (* ========> Strat defined as a sequence of sub-strategies <========= *)
446
447
448
      | Ast.Seq [] -> Log.bug "[Grs.build_rew_display] Empty sequence!"; exit 2
      | Ast.Seq [one] -> let res = loop instance one in decr indent; res
      | Ast.Seq (head_strat :: tail_strat) ->
bguillaum's avatar
bguillaum committed
449
        let one_step = loop instance head_strat in decr indent;
450
        apply_leaf (Ast.Seq tail_strat) one_step
bguillaum's avatar
bguillaum committed
451

452
      | Ast.Pick strat -> pick (loop instance strat)
bguillaum's avatar
bguillaum committed
453

454
      | Ast.Star strat ->
bguillaum's avatar
bguillaum committed
455
456
457
458
        begin
          match clean (loop instance strat) with
          | Libgrew_types.Empty -> Libgrew_types.Leaf instance.Instance.graph
          | Libgrew_types.Local_normal_form _ -> Log.bug "dont know if 'Local_normal_form' in star should happen or not ???"; exit 1
459
          | rd -> apply_leaf (Ast.Star strat) rd
bguillaum's avatar
bguillaum committed
460
461
462
        end
      in

463
    loop instance (strategy.Ast.strat_def)
bguillaum's avatar
bguillaum committed
464

465
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
466
467
468
  let rule_iter fct grs =
    List.iter
      (fun modul ->
bguillaum's avatar
bguillaum committed
469
470
        List.iter (fun rule -> fct modul.Modul.name rule) modul.Modul.rules
      ) grs.modules
471
end (* module Grs *)
472
473
474
475
476

module New_grs = struct

  type decl =
  | Rule of Rule.t
477
  | Strategy of string * New_ast.strat
478
479
480
481
482
483
484
485
486
  | Package of string * decl list

  type t = {
    filename: string;
    domain: Domain.t option;
    decls: decl list;
    ast: New_ast.grs;
  }

487
488
  let get_strat_list grs = Grew_ast.New_ast.strat_list grs.ast

489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
  let rec dump_decl indent = function
    | Rule r -> printf "%srule %s\n" (String.make indent ' ') (Rule.get_name r)
    | Strategy (name, def) -> printf "%sstrat %s\n" (String.make indent ' ') name
    | Package (name, decl_list) ->
      printf "%spackage %s:\n" (String.make indent ' ') name;
      List.iter (dump_decl (indent + 2)) decl_list

  let dump t =
    printf "================ New_grs ================\n";
    Domain.dump t.domain;
    printf "-----------------------\n";
    List.iter (dump_decl 0) t.decls;
    printf "================ New_grs ================\n%!";
    ()


  let rec build_decl ?domain = function
506
  | New_ast.Package (loc, name, decl_list) -> Package (name, List.map (build_decl ?domain) decl_list)
507
  | New_ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO: remove this arg (old grs)" ast_rule)
508
  | New_ast.Strategy (loc, name, ast_strat) -> Strategy (name, ast_strat)
509
510
511
512
  | _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"

  let domain t = t.domain

513
  let from_ast filename ast =
514

515
516
    let feature_domains = List_.opt_map
      (fun x -> match x with
517
        | New_ast.Features desc -> Some desc
518
519
        | _ -> None
      ) ast in
520
521
    let feature_domain = match feature_domains with
    | [] -> None
522
    | h::t -> Some (Feature_domain.build (List.fold_left Feature_domain.merge h t)) in
523
524
525

    let label_domains = List_.opt_map
      (fun x -> match x with
526
        | New_ast.Labels desc -> Some desc
527
528
529
530
        | _ -> None
      ) ast in
    let label_domain = match label_domains with
    | [] -> None
531
    | h::t -> Some (Label_domain.build (List.fold_left Label_domain.merge h t)) in
532
533
534
535
536
537
538

    let domain = match (label_domain, feature_domain) with
    | (None, None) -> None
    | (Some ld, None) -> Some (Domain.build_labels_only ld)
    | (None, Some fd) -> Some (Domain.build_features_only fd)
    | (Some ld, Some fd) -> Some (Domain.build ld fd) in

539
540
541
542
543
544
545
546
547
    let decls = List_.opt_map
      (fun x -> match x with
        | New_ast.Features _ -> None
        | New_ast.Labels _ -> None
        | New_ast.Import _ -> Error.bug "[load] Import: inconsistent ast for new_grs"
        | New_ast.Include _ -> Error.bug "[load] Inlcude: inconsistent ast for new_grs"
        | x -> Some (build_decl ?domain x)
      ) ast in

548
549
    { filename;
      ast;
550
      domain;
551
      decls;
552
    }
Bruno Guillaume's avatar
Bruno Guillaume committed
553

554
555
  let load filename = from_ast filename (Loader.new_grs filename)

Bruno Guillaume's avatar
Bruno Guillaume committed
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
  (* The type [pointed] is a zipper style data structure for resolving names x.y.z *)
  type pointed =
  | Top of decl list
  | Pack of (decl list * pointed)  (* (content, mother package) *)





  let top grs = Top grs.decls

  let decl_list = function
  | Top dl -> dl
  | Pack (dl, _) -> dl

  let down pointed name =
    let rec loop = function
    | [] -> None
    | Package (n,dl) :: _ when n=name -> Some (Pack (dl, pointed))
    | _::t -> loop t in
    loop (decl_list pointed)


  (* search for a decl named [name] defined in the working directory [wd] in [grs] *)
  let rec search_at pointed path = match path with
    | [] -> None
    | [one] ->
      (
        try
          let item = List.find (* ?? rule and strategy with the same name ?? *)
            (function
              | Strategy (s,_) when s=one -> true
              | Rule r when Rule.get_name r = one -> true
              | Package (p,_) when p=one -> true
              | _ -> false
            ) (decl_list pointed) in
          Some (item, pointed)
        with Not_found -> None
      )
    | head::tail ->
      match down pointed head with
      | None -> None
      | Some new_p -> search_at new_p tail

  (* search for the path in current location and recursively on mother structure *)
  let rec search_from pointed path =
    match search_at pointed path with
      | Some r_or_s -> Some r_or_s
      | None ->
      (match pointed with
        | Top _ -> None
        | Pack (_,mother) -> search_from mother path
      )

610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
  (* det apply a package to an instance = apply only top level rules in the package *)
  let det_pack_rewrite ?domain decl_list instance =
    let rec loop = function
      | [] -> None
      | Rule r :: tail_decl ->
        (match Rule.det_apply ?domain r instance with
        | Some x -> Some x
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

  (* apply a package to an instance = apply only top level rules in the package *)
  let pack_rewrite ?domain decl_list instance =
    List.fold_left
      (fun acc decl -> match decl with
        | Rule r -> Instance_set.union acc (Rule.apply ?domain r instance)
        | _ -> acc
      ) Instance_set.empty decl_list

  (* deterministic case *)
  let rec det_intern_simple_rewrite ?domain pointed strat_name instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
632
633
634
    let path = Str.split (Str.regexp "\\.") strat_name in
    match search_from pointed path with
    | None -> Error.build "Simple rewrite, cannot find strat %s" strat_name
635
636
    | Some (Rule r,_) -> Rule.det_apply ?domain r instance
    | Some (Package (_, decl_list), _) -> det_pack_rewrite ?domain decl_list instance
Bruno Guillaume's avatar
Bruno Guillaume committed
637
    | Some (Strategy (_,ast_strat), new_pointed) ->
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
      det_strat_simple_rewrite new_pointed ast_strat instance

  and det_strat_simple_rewrite ?domain pointed strat instance =
    match strat with
    | New_ast.Ref subname -> det_intern_simple_rewrite ?domain pointed subname instance
    | New_ast.Pick strat -> det_strat_simple_rewrite ?domain pointed strat instance

    | New_ast.Alt [] -> None
    | New_ast.Alt strat_list ->
      let rec loop = function
        | [] -> None
        | head_strat :: tail_strat ->
          match det_strat_simple_rewrite ?domain pointed head_strat instance with
          | None -> loop tail_strat
          | Some x -> Some x in
        loop strat_list
Bruno Guillaume's avatar
Bruno Guillaume committed
654

655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
    | New_ast.Seq [] -> Some instance
    | New_ast.Seq (head_strat :: tail_strat) ->
      begin
        match det_strat_simple_rewrite ?domain pointed head_strat instance with
        | None -> None
        | Some inst -> det_strat_simple_rewrite ?domain pointed (New_ast.Seq tail_strat) inst
      end

    | New_ast.Iter strat ->
      begin
        match det_strat_simple_rewrite ?domain pointed strat instance with
        | None -> Some instance
        | Some inst -> det_strat_simple_rewrite ?domain pointed (New_ast.Iter strat) inst
        end

    | New_ast.Try strat ->
        begin
          match det_strat_simple_rewrite ?domain pointed strat instance with
          | None -> Some instance
          | Some i -> Some i
        end

    | New_ast.If (s, s1, s2) ->
      begin
        match det_strat_simple_rewrite ?domain pointed s instance with
        | None -> det_strat_simple_rewrite ?domain pointed s1 instance
        | Some _ -> det_strat_simple_rewrite ?domain pointed s2 instance
      end

  (* non deterministic case *)
  let rec intern_simple_rewrite ?domain pointed strat_name instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
686
687
688
    let path = Str.split (Str.regexp "\\.") strat_name in
    match search_from pointed path with
    | None -> Error.build "Simple rewrite, cannot find strat %s" strat_name
689
690
    | Some (Rule r,_) -> Rule.apply r instance
    | Some (Package (_, decl_list), _) -> pack_rewrite decl_list instance
Bruno Guillaume's avatar
Bruno Guillaume committed
691
    | Some (Strategy (_,ast_strat), new_pointed) ->
692
      strat_simple_rewrite ?domain new_pointed ast_strat instance
Bruno Guillaume's avatar
Bruno Guillaume committed
693

694
  and strat_simple_rewrite ?domain pointed strat instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
695
    match strat with
696
    | New_ast.Ref subname -> intern_simple_rewrite ?domain pointed subname instance
Bruno Guillaume's avatar
Bruno Guillaume committed
697
698
    | New_ast.Pick strat ->
      begin
699
        match det_strat_simple_rewrite ?domain pointed strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
700
701
702
703
704
705
        | None -> Grew_rule.Instance_set.empty
        | Some x -> Instance_set.singleton x
      end

    | New_ast.Alt [] -> Grew_rule.Instance_set.empty
    | New_ast.Alt strat_list -> List.fold_left
706
      (fun acc strat -> Instance_set.union acc (strat_simple_rewrite ?domain pointed strat instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
707
708
709
710
      ) Instance_set.empty strat_list

    | New_ast.Seq [] -> Instance_set.singleton instance
    | New_ast.Seq (head_strat :: tail_strat) ->
711
      let first_strat = strat_simple_rewrite ?domain pointed head_strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
712
      Instance_set.fold
713
        (fun instance acc -> Instance_set.union acc (strat_simple_rewrite ?domain pointed (New_ast.Seq tail_strat) instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
714
715
716
        ) first_strat Instance_set.empty

    | New_ast.Iter strat ->
717
      let one_step = strat_simple_rewrite ?domain pointed strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
718
719
720
      if Instance_set.is_empty one_step
      then Instance_set.singleton instance
      else Instance_set.fold
721
        (fun instance acc -> Instance_set.union acc (strat_simple_rewrite ?domain pointed (New_ast.Iter strat) instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
722
723
724
725
        ) one_step Instance_set.empty

    | New_ast.Try strat ->
      begin
726
        let one_step = strat_simple_rewrite ?domain pointed strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
727
728
729
730
731
732
733
        if Instance_set.is_empty one_step
        then Instance_set.singleton instance
        else one_step
      end

    | New_ast.If (s, s1, s2) ->
      begin
734
735
736
        match det_strat_simple_rewrite ?domain pointed s instance with
        | None -> strat_simple_rewrite ?domain pointed s1 instance
        | Some _ -> strat_simple_rewrite ?domain pointed s2 instance
Bruno Guillaume's avatar
Bruno Guillaume committed
737
738
      end

739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

  let simple_rewrite grs strat graph =
    let domain = domain grs in
    let instance = Instance.from_graph graph in
    let set = strat_simple_rewrite ?domain (top grs) (Parser.strategy strat) instance in
    List.map
      (fun inst -> inst.Instance.graph)
      (Instance_set.elements set)





  let det_pack_one ?domain decl_list instance =
    let rec loop = function
      | [] -> None
      | Rule r :: tail_decl ->
        (match Rule.det_apply ?domain r instance with
        | Some x -> Some (x, Rule.get_name r)
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list



  let det_iter_pack ?domain decl_list instance = (* return a (big step, inst) *)
Bruno Guillaume's avatar
Bruno Guillaume committed
766
    match det_pack_one ?domain decl_list instance with
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
    | None -> None
    | Some (x, rule_name) ->
      let first = {Libgrew_types.rule_name; up=G_deco.empty; down=G_deco.empty} in
      let rec loop inst =
        match det_pack_one ?domain decl_list inst with
        | None -> ([], inst)
        | Some (next, rule_name) ->
            let (tail, final) = loop next in
            (
              (inst.Instance.graph, {Libgrew_types.rule_name; up=G_deco.empty; down=G_deco.empty} ) :: tail,
              final
            ) in
      let (small_step, final) = loop x in
      Some ({ Libgrew_types.first; small_step }, final)

  let rec det_rew_display_tmp ?domain pointed strat instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
783
    match strat with
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
    | New_ast.Ref subname ->
      let path = Str.split (Str.regexp "\\.") subname in
      begin
        match search_from pointed path with
        | None -> Error.build "Simple rewrite, cannot find strat %s" subname
        | Some (Rule r,_) ->
          begin
            match Rule.det_apply ?domain r instance with
            | None -> None
            | Some inst -> Some [(
                Rule.get_name r,
                { Libgrew_types.first = {Libgrew_types.rule_name=Rule.get_name r; up=G_deco.empty; down=G_deco.empty}; small_step = [] },
                inst
              )]
          end
        | Some (Package (_, decl_list), _) ->
            begin
              match det_pack_one ?domain decl_list instance with
              | None -> None
              | Some (inst,rule_name) -> Some [(
                  rule_name,
                  { Libgrew_types.first = {Libgrew_types.rule_name=rule_name; up=G_deco.empty; down=G_deco.empty}; small_step = [] },
                  inst
                )]
            end
        | Some (Strategy (_,ast_strat), new_pointed) ->
            det_rew_display_tmp ?domain new_pointed ast_strat instance
      end

    | New_ast.Pick strat -> det_rew_display_tmp ?domain pointed strat instance
Bruno Guillaume's avatar
Bruno Guillaume committed
814
815
816
817
818
819

    | New_ast.Alt [] -> None
    | New_ast.Alt strat_list ->
      let rec loop = function
        | [] -> None
        | head_strat :: tail_strat ->
820
          match det_rew_display_tmp ?domain pointed head_strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
821
822
823
824
          | None -> loop tail_strat
          | Some x -> Some x in
        loop strat_list

825
    | New_ast.Seq [] -> Some []
Bruno Guillaume's avatar
Bruno Guillaume committed
826
827
    | New_ast.Seq (head_strat :: tail_strat) ->
      begin
828
        match det_rew_display_tmp ?domain pointed head_strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
829
        | None -> None
830
831
832
833
834
835
836
        | Some [] -> det_rew_display_tmp ?domain pointed (New_ast.Seq tail_strat) instance
        | Some (((_,_,inst) :: _) as l) ->
          begin
            match det_rew_display_tmp ?domain pointed (New_ast.Seq tail_strat) inst with
            | None -> None
            | Some l2 -> Some (l2 @ l)
          end
Bruno Guillaume's avatar
Bruno Guillaume committed
837
838
      end

839
840
841
842
843
844
845
    | New_ast.Iter (New_ast.Ref subname) ->
      let path = Str.split (Str.regexp "\\.") subname in
        begin
          match search_from pointed path with
          | None -> Error.build "Simple rewrite, cannot find strat %s" subname
          | Some (Rule r,_) ->
            begin
Bruno Guillaume's avatar
Bruno Guillaume committed
846
              match det_iter_pack ?domain [Rule r] instance with
847
848
849
850
851
              | Some (big_step, final) -> Some [(Rule.get_name r, big_step, final)]
              | None -> Some []
            end
          | Some (Package (pack_name, decl_list), _) ->
            begin
Bruno Guillaume's avatar
Bruno Guillaume committed
852
              match det_iter_pack ?domain decl_list instance with
853
854
855
856
857
858
859
              | Some (big_step, final) -> Some [(pack_name, big_step, final)]
              | None -> Some []
            end
          | Some (Strategy (_,ast_strat), new_pointed) ->
              det_rew_display_tmp ?domain new_pointed ast_strat instance
        end

Bruno Guillaume's avatar
Bruno Guillaume committed
860
861
    | New_ast.Iter strat ->
      begin
862
863
864
865
866
867
868
869
870
871
        match det_rew_display_tmp ?domain pointed strat instance with
        | None -> Some []
        | Some [] -> Some []
        | Some (((_,_,inst) :: _) as l) ->
          begin
            match det_rew_display_tmp ?domain pointed (New_ast.Iter strat) inst with
            | None -> Some l
            | Some l2 -> Some (l2 @ l)
          end
      end
Bruno Guillaume's avatar
Bruno Guillaume committed
872
873
874

    | New_ast.Try strat ->
        begin
875
876
          match det_rew_display_tmp ?domain pointed strat instance with
          | None -> Some []
Bruno Guillaume's avatar
Bruno Guillaume committed
877
878
879
880
881
          | Some i -> Some i
        end

    | New_ast.If (s, s1, s2) ->
      begin
882
883
884
        match det_strat_simple_rewrite ?domain pointed s instance with
        | None -> det_rew_display_tmp ?domain pointed s1 instance
        | Some _ -> det_rew_display_tmp ?domain pointed s2 instance
Bruno Guillaume's avatar
Bruno Guillaume committed
885
886
      end

887
888
  let det_rew_display grs strat graph =
    let domain = domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
889
    let instance = Instance.from_graph graph in
890
891
892
893
894
895
896
897
898
    let rec loop (s,b,rd) = function
    | [] -> Libgrew_types.Node (instance.Instance.graph, s, [b, rd])
    | (s2, b2, i2) :: tail -> loop (s2, b2, Libgrew_types.Node (i2.Instance.graph,s,[b,rd])) tail in

    match det_rew_display_tmp ?domain (top grs) (Parser.strategy strat) instance with
    | None -> Libgrew_types.Empty
    | Some [] -> Libgrew_types.Leaf instance.Instance.graph
    | Some ((s1,b1,i1) :: tail) -> loop (s1,b1,Libgrew_types.Leaf i1.Instance.graph) tail

899
end
900

901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
module Univ_grs = struct
  let load file =
    let new_ast =
    try
      let ast = Loader.new_grs file in
      Log.finfo "[Univ_grs.load] SUCCEED to load file \"%s\" with NEW syntax" file;
      ast
    with exc_new ->
      Log.finfo "[Univ_grs.load] FAILED to load file \"%s\" with NEW syntax: exc=\"%s\"" file (Printexc.to_string exc_new);
      try
        let ast = New_ast.convert (Loader.grs file) in
        Log.finfo "[Univ_grs.load] SUCCEED to load file \"%s\" with OLD syntax" file;
        ast
      with exc_old ->
        Log.finfo "[Univ_grs.load] FAILED to load file \"%s\" with OLD syntax: exc=\"%s\"" file (Printexc.to_string exc_old);
        raise exc_new in
  New_grs.from_ast file new_ast
end