grew_grs.ml 48.6 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
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

44
  let save_gr base t =
45
    let rec loop file_name t =
Bruno Guillaume's avatar
Bruno Guillaume committed
46
      match t.good_nf with
47
        | [] -> File.write (Instance.to_gr t.instance) (file_name^".gr")
Bruno Guillaume's avatar
Bruno Guillaume committed
48
        | l -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
49 50
    in loop base t

51
  let save_conll base t =
bguillaum's avatar
bguillaum committed
52
    let rec loop file_name t =
Bruno Guillaume's avatar
Bruno Guillaume committed
53
      match t.good_nf with
54
        | [] -> File.write (Instance.to_conll_string t.instance) (file_name^".conll")
Bruno Guillaume's avatar
Bruno Guillaume committed
55
        | l -> List.iteri (fun i son -> loop (sprintf "%s_%d" file_name i) son) l
bguillaum's avatar
bguillaum committed
56 57
    in loop base t

58
  let save_full_conll base t =
59 60
    let cpt = ref 0 in
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
61 62
      match t.good_nf with
        | [] ->
63
          File.write (Instance.to_conll_string t.instance) (sprintf "%s__%d.conll" base !cpt);
64
          incr cpt
Bruno Guillaume's avatar
Bruno Guillaume committed
65
        | l -> List.iter loop l
66
    in loop t; !cpt
67

68
  (* suppose that all modules are deterministic and produced exacly one normal form *)
69
  let save_det_gr base t =
70
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
71
      match t.good_nf with
72
        | [] -> File.write (Instance.to_gr t.instance) (base^".gr")
Bruno Guillaume's avatar
Bruno Guillaume committed
73
        | [one] -> loop one
74
        | _ -> Error.run "[save_det_gr] Not a single rewriting"
75
    in loop t
bguillaum's avatar
bguillaum committed
76

77
  let save_det_conll ?header base t =
bguillaum's avatar
bguillaum committed
78
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
79 80
      match t.good_nf with
        | [] ->
81 82
          let output =
            match header with
83 84
              | Some h -> sprintf "%% %s\n%s" h (Instance.to_conll_string t.instance)
              | None -> Instance.to_conll_string t.instance in
85
          File.write output (base^".conll")
Bruno Guillaume's avatar
Bruno Guillaume committed
86
        | [one] -> loop one
87
        | _ -> Error.run "[save_det_conll] Not a single rewriting"
bguillaum's avatar
bguillaum committed
88 89
    in loop t

90
  let det_dep_string t =
bguillaum's avatar
bguillaum committed
91
    let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
92 93
      match t.good_nf with
        | [] ->
bguillaum's avatar
bguillaum committed
94
          let graph = t.instance.Instance.graph in
95
          Some (G_graph.to_dep graph)
Bruno Guillaume's avatar
Bruno Guillaume committed
96
        | [one] -> loop one
bguillaum's avatar
bguillaum committed
97
        | _ -> None
bguillaum's avatar
bguillaum committed
98
    in loop t
bguillaum's avatar
bguillaum committed
99

100
  let conll_dep_string ?(keep_empty_rh=false) t =
bguillaum's avatar
bguillaum committed
101 102 103 104
    if (not keep_empty_rh) && is_empty t
    then None
    else
      let rec loop t =
Bruno Guillaume's avatar
Bruno Guillaume committed
105 106
        match t.good_nf with
          | [] ->
bguillaum's avatar
bguillaum committed
107
            let graph = t.instance.Instance.graph in
108
            Some (G_graph.to_conll_string graph)
Bruno Guillaume's avatar
Bruno Guillaume committed
109
          | [one] -> loop one
bguillaum's avatar
bguillaum committed
110 111
          | _ -> None
      in loop t
112
end (* module Rewrite_history *)
pj2m's avatar
pj2m committed
113

bguillaum's avatar
bguillaum committed
114
(* ================================================================================ *)
pj2m's avatar
pj2m committed
115 116
module Modul = struct
  type t = {
117 118
    name: string;
    rules: Rule.t list;
119
    deterministic: bool;
120 121
    loc: Loc.t;
  }
pj2m's avatar
pj2m committed
122

123 124 125
  let to_json ?domain t =
    `Assoc [
      ("module_name", `String t.name);
126
      ("deterministic", `Bool t.deterministic);
127 128 129
      ("rules", `List (List.map (Rule.to_json ?domain) t.rules));
    ]

130 131 132 133
  let check t =
    (* check for duplicate rules *)
    let rec loop already_defined = function
      | [] -> ()
134 135
      | 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)
136 137
      | r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
    loop [] t.rules
pj2m's avatar
pj2m committed
138

bguillaum's avatar
bguillaum committed
139
  let build ?domain ast_module =
Bruno Guillaume's avatar
Bruno Guillaume committed
140
    let rules = List.map (Rule.build ?domain ast_module.Ast.mod_dir) ast_module.Ast.rules in
141
    let modul =
142
      {
143
        name = ast_module.Ast.module_id;
144
        rules;
145
        deterministic = ast_module.Ast.deterministic;
146 147
        loc = ast_module.Ast.mod_loc;
      } in
148
    check modul; modul
149
end (* module Modul *)
150

bguillaum's avatar
bguillaum committed
151
(* ================================================================================ *)
152
module Old_grs = struct
153

pj2m's avatar
pj2m committed
154
  type t = {
bguillaum's avatar
bguillaum committed
155
    domain: Domain.t option;
156
    modules: Modul.t list;       (* the ordered list of modules used from rewriting *)
157
    strategies: Ast.strategy list;
158 159
    filename: string;
    ast: Ast.grs;
160 161
  }

162
  let to_json t = `List (List.map (Modul.to_json ?domain:t.domain) t.modules)
163

bguillaum's avatar
bguillaum committed
164
  let get_modules t = t.modules
165 166
  let get_ast t = t.ast
  let get_filename t = t.filename
bguillaum's avatar
bguillaum committed
167

168
  let get_domain t = t.domain
169

170
  let sequence_names t = List.map (fun s -> s.Ast.strat_name) t.strategies
bguillaum's avatar
bguillaum committed
171 172

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

Bruno Guillaume's avatar
Bruno Guillaume committed
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
  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

189 190 191 192
  let check t =
    (* check for duplicate modules *)
    let rec loop already_defined = function
      | [] -> ()
193 194
      | m::_ when List.mem m.Modul.name already_defined ->
        Error.build ~loc:m.Modul.loc "Module '%s' is defined twice" m.Modul.name
195 196 197
      | m::tail -> loop (m.Modul.name :: already_defined) tail in
    loop [] t.modules;

bguillaum's avatar
bguillaum committed
198
    (* check for duplicate strategies *)
199 200
    let rec loop already_defined = function
      | [] -> ()
201 202 203
      | 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
204 205 206 207 208 209 210
    loop [] t.strategies;

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

bguillaum's avatar
bguillaum committed
211
  let domain_build ast_domain =
Bruno Guillaume's avatar
Bruno Guillaume committed
212 213 214 215 216 217

    let conll_fields = match ast_domain.Ast.conll_fields with
      | Some [c2;c3;c4;c5] -> Some (c2,c3,c4,c5)
      | Some _ -> Error.build "conll_fields declaration does not contains exactly 4 values"
      | _ -> None in

bguillaum's avatar
bguillaum committed
218
    Domain.build
219
      (Label_domain.build ast_domain.Ast.label_domain)
Bruno Guillaume's avatar
Bruno Guillaume committed
220
      (Feature_domain.build ?conll_fields ast_domain.Ast.feature_domain)
221

222
  let build filename =
bguillaum's avatar
bguillaum committed
223
    let ast = Loader.grs filename in
bguillaum's avatar
bguillaum committed
224
    let domain = match ast.Ast.domain with None -> None | Some ast_dom -> Some (domain_build ast_dom) in
bguillaum's avatar
bguillaum committed
225
    let modules = List.map (Modul.build ?domain) ast.Ast.modules in
bguillaum's avatar
bguillaum committed
226
    let grs = {domain; strategies = ast.Ast.strategies; modules; ast; filename} in
227 228
    check grs;
    grs
pj2m's avatar
pj2m committed
229

230 231
  (* ---------------------------------------------------------------------------------------------------- *)
  let rewrite grs strategy_name graph =
232 233 234 235 236 237
    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
238

239
    let rec old_loop instance module_list =
240
      match module_list with
Bruno Guillaume's avatar
Bruno Guillaume committed
241
      | [] -> {Rewrite_history.instance = instance; module_name = ""; good_nf = []; }
242 243 244 245
      | 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
246
        let good_set =
247
          Rule.normalize
bguillaum's avatar
bguillaum committed
248
            ?domain: grs.domain
249
            next.Modul.name
250
            ~deterministic: next.Modul.deterministic
251
            next.Modul.rules
252
            (Instance.refresh instance) in
Bruno Guillaume's avatar
Bruno Guillaume committed
253
        let good_list = Instance_set.elements good_set in
254 255 256
        {
          Rewrite_history.instance = instance;
          module_name = next.Modul.name;
257
          good_nf = List.map (fun i -> old_loop i tail) good_list;
258 259
        } in

260 261 262
    let loop instance def =
      match def with

263
      | Ast.Sequence module_list -> old_loop instance module_list
264 265
      | _ -> failwith "Not yet implemented" in

266
    loop (Instance.from_graph graph) (strategy.Ast.strat_def)
267

268
  (* [new_style grs module_list] return an equivalent strategy expressed with Seq, Pick and Star *)
269
  let new_style grs module_list =
270
    Ast.Seq
271 272 273 274
      (List.map
        (fun module_name ->
           let modul =
           try List.find (fun m -> m.Modul.name=module_name) grs.modules
275
           with Not_found -> Error.build "No module named '%s'" module_name in
276
           if modul.Modul.deterministic
277
           then Ast.Pick (Ast.Star (Ast.Ref module_name))
278
           else Ast.Star (Ast.Ref module_name)
279 280 281 282 283 284 285
        ) 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 *)
286
    | Ast.Ref name ->
287 288
      begin
        try
289 290
          let sub_strat = List.find (fun s -> s.Ast.strat_name = name) grs.strategies in
          loop inst sub_strat.Ast.strat_def
291 292 293
        with Not_found ->
          let modul =
            try List.find (fun m -> m.Modul.name=name) grs.modules
294
            with Not_found -> Error.build "No module or strategy named '%s'" name in
Bruno Guillaume's avatar
Bruno Guillaume committed
295
          Rule.conf_one_step ?domain: grs.domain inst modul.Modul.rules
296 297
      end
    (* Sequence of strategies *)
298 299 300
    | Ast.Seq [] -> Log.fcritical "Empty sequence in strategy definition"
    | Ast.Seq [one] -> loop inst one
    | Ast.Seq (head::tail) ->
301 302
      begin
        match loop inst head with
303
        | Some new_inst -> loop new_inst (Ast.Seq tail)
304 305 306
        | None -> None
      end
    (* Interation of a strategy *)
307
    | Ast.Star sub_strat ->
308 309 310
      begin
        match loop inst sub_strat with
        | None -> Some inst
311
        | Some new_inst -> loop new_inst (Ast.Star sub_strat)
312
      end
313 314
    (* Pick *)
    | Ast.Pick sub_strat -> loop inst sub_strat
315
    (* Old style seq definition *)
316
    | Ast.Sequence module_list -> loop inst (new_style grs module_list) in
317 318
    loop inst strat

319
  let simple_rewrite grs strat_desc graph = failwith "OBSOLETE [Grs.simple_rewrite]"
320

321
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
322
  (* construction of the rew_display *)
323 324 325 326 327 328
  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
329
    | Libgrew_types.Node (_, _, []) -> Log.bug "Empty node"; exit 12
330
    | Libgrew_types.Node (graph, name, (bs,rd)::_) -> Libgrew_types.Node (graph, "try(" ^ name^")", [(bs, pick rd)])
bguillaum's avatar
bguillaum committed
331 332
    | x -> x

333
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
  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
350

351 352
  (* ---------------------------------------------------------------------------------------------------- *)
  let build_rew_display grs strategy_name graph =
353
    let strategy = List.find (fun s -> s.Ast.strat_name = strategy_name) grs.strategies in
354 355 356

    let instance = Instance.from_graph graph in
    let rec old_loop instance module_list =
357
      match module_list with
358
      | [] -> Libgrew_types.Leaf instance.Instance.graph
359 360 361 362
      | 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
363
        let good_set =
364
          Rule.normalize
bguillaum's avatar
bguillaum committed
365
            ?domain: grs.domain
366
            next.Modul.name
367
            ~deterministic: next.Modul.deterministic
368
            next.Modul.rules
369
            (Instance.refresh instance) in
Bruno Guillaume's avatar
Bruno Guillaume committed
370
        let inst_list = Instance_set.elements good_set in
pj2m's avatar
pj2m committed
371

372
        match inst_list with
373
          | [{Instance.big_step = None}] ->
374
            Libgrew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, old_loop instance tail)
375
          | _ -> Libgrew_types.Node
376 377 378 379 380 381
            (
              instance.Instance.graph,
              next.Modul.name,
              List.map
                (fun inst ->
                  match inst.Instance.big_step with
382 383 384
                    | 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
385
            ) in
bguillaum's avatar
bguillaum committed
386

387
    let indent = ref 10 in
bguillaum's avatar
bguillaum committed
388

389
    let rec apply_leaf strat_def = function
bguillaum's avatar
bguillaum committed
390
      | Libgrew_types.Empty -> Libgrew_types.Empty
391 392 393
      | 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
394

395 396
    and loop instance strat_def =
      printf "%s===> loop  strat_def=%s\n%!"
bguillaum's avatar
bguillaum committed
397
        (String.make (2 * (max 0 !indent)) ' ')
398
        (Ast.strat_def_to_string strat_def);
bguillaum's avatar
bguillaum committed
399 400
      incr indent;

401 402
      match strat_def with

403
      | Ast.Sequence module_list -> old_loop instance module_list
bguillaum's avatar
bguillaum committed
404 405

      (* ========> reference to a module or to another strategy <========= *)
406
      | Ast.Ref name ->
bguillaum's avatar
bguillaum committed
407 408
        begin
          try
409 410
            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
411 412 413 414 415
          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
416
              printf "%s one_step (module=%s)...%!" (String.make (2 * (max 0 !indent)) ' ') modul.Modul.name;
bguillaum's avatar
bguillaum committed
417
              let domain = get_domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
418
              match Instance_set.elements (Rule.one_step ?domain instance modul.Modul.rules) with
bguillaum's avatar
bguillaum committed
419 420 421 422 423 424 425
              | [] -> 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
426
                    | None -> Error.bug "Cannot have no big_steps and more than one reducts at the same time"
bguillaum's avatar
bguillaum committed
427 428 429 430 431 432 433
                    | 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 <========= *)
434 435 436
      | 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
437
        let one_step = loop instance head_strat in decr indent;
438
        apply_leaf (Ast.Seq tail_strat) one_step
bguillaum's avatar
bguillaum committed
439

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

442
      | Ast.Star strat ->
bguillaum's avatar
bguillaum committed
443 444 445 446
        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
447
          | rd -> apply_leaf (Ast.Star strat) rd
bguillaum's avatar
bguillaum committed
448 449 450
        end
      in

451
    loop instance (strategy.Ast.strat_def)
bguillaum's avatar
bguillaum committed
452

453
  (* ---------------------------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
454 455 456
  let rule_iter fct grs =
    List.iter
      (fun modul ->
457 458
        List.iter (fun rule -> fct modul.Modul.name rule) modul.Modul.rules
      ) grs.modules
459
end (* module Old_grs *)
460

461 462 463



464
module Grs = struct
465 466 467

  type decl =
  | Rule of Rule.t
468
  | Strategy of string * New_ast.strat
469 470 471 472 473 474 475 476 477
  | Package of string * decl list

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

478 479
  let rec decl_to_json ?domain = function
    | Rule r -> Rule.to_json ?domain r
Bruno Guillaume's avatar
Bruno Guillaume committed
480
    | Strategy (name, strat) -> `Assoc [("strat_name", `String name); ("strat_def", New_ast.strat_to_json strat)]
481
    | Package (name, decl_list) -> `Assoc [("package_name", `String name); "decls", `List (List.map (decl_to_json ?domain) decl_list)]
Bruno Guillaume's avatar
Bruno Guillaume committed
482 483 484 485 486 487 488 489 490 491

  let to_json t =
    match t.domain with
    | None -> `Assoc [
      "filename", `String t.filename;
      "decls", `List (List.map decl_to_json t.decls)
    ]
    | Some dom -> `Assoc [
      "domain", Domain.to_json dom;
      "filename", `String t.filename;
492
      "decls", `List (List.map (decl_to_json ~domain:dom) t.decls)
Bruno Guillaume's avatar
Bruno Guillaume committed
493 494 495
    ]


496 497
  let get_strat_list grs = Grew_ast.New_ast.strat_list grs.ast

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 =
506
    printf "================ Grs ================\n";
507 508 509
    Domain.dump t.domain;
    printf "-----------------------\n";
    List.iter (dump_decl 0) t.decls;
510
    printf "================ Grs ================\n%!";
511 512 513 514
    ()


  let rec build_decl ?domain = function
515
  | New_ast.Package (loc, name, decl_list) -> Package (name, List.map (build_decl ?domain) decl_list)
516
  | New_ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO: remove this arg (old grs)" ast_rule)
517
  | New_ast.Strategy (loc, name, ast_strat) -> Strategy (name, ast_strat)
518 519 520 521
  | _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"

  let domain t = t.domain

522
  let from_ast filename ast =
523 524 525 526 527 528 529 530 531 532
    let conll_fields = match List_.opt_map
      (fun x -> match x with
        | New_ast.Conll_fields desc -> Some desc
        | _ -> None
      ) ast with
      | [] -> None
      | [[c2;c3;c4;c5]] -> Some (c2,c3,c4,c5)
      | [_] -> Error.build "conll_fields declaration does not contains exactly 4 values"
      | _ :: _ :: _ -> Error.build "Several conll_fields declaration" in

533 534
    let feature_domains = List_.opt_map
      (fun x -> match x with
535
        | New_ast.Features desc -> Some desc
536 537
        | _ -> None
      ) ast in
538

539 540
    let feature_domain = match feature_domains with
    | [] -> None
541
    | h::t -> Some (Feature_domain.build ?conll_fields (List.fold_left Feature_domain.merge h t)) in
542 543 544

    let label_domains = List_.opt_map
      (fun x -> match x with
545
        | New_ast.Labels desc -> Some desc
546 547 548 549
        | _ -> None
      ) ast in
    let label_domain = match label_domains with
    | [] -> None
550
    | h::t -> Some (Label_domain.build (List.fold_left Label_domain.merge h t)) in
551 552 553 554 555 556 557

    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

558 559 560 561
    let decls = List_.opt_map
      (fun x -> match x with
        | New_ast.Features _ -> None
        | New_ast.Labels _ -> None
562
        | New_ast.Conll_fields _ -> None
563
        | New_ast.Import _ -> Error.bug "[load] Import: inconsistent ast for new_grs"
564
        | New_ast.Include _ -> Error.bug "[load] Include: inconsistent ast for new_grs"
565 566 567
        | x -> Some (build_decl ?domain x)
      ) ast in

568 569
    { filename;
      ast;
570
      domain;
571
      decls;
572
    }
Bruno Guillaume's avatar
Bruno Guillaume committed
573

574
  let load filename = from_ast filename (Loader.new_grs filename)
Bruno Guillaume's avatar
Bruno Guillaume committed
575
  let load_old filename = from_ast filename (New_ast.convert (Loader.grs filename))
576

Bruno Guillaume's avatar
Bruno Guillaume committed
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 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630
  (* 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
      )

631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652
  (* 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
653 654 655
    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
656 657
    | 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
658
    | Some (Strategy (_,ast_strat), new_pointed) ->
659 660 661 662
      det_strat_simple_rewrite new_pointed ast_strat instance

  and det_strat_simple_rewrite ?domain pointed strat instance =
    match strat with
Bruno Guillaume's avatar
Bruno Guillaume committed
663
    | New_ast.Onf s -> det_strat_simple_rewrite ?domain pointed (New_ast.Pick (New_ast.Iter s)) instance
664 665 666 667 668 669 670 671 672 673 674 675
    | 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
676

677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707
    | 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
708 709 710
    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
711 712
    | Some (Rule r,_) -> Rule.apply r instance
    | Some (Package (_, decl_list), _) -> pack_rewrite decl_list instance
Bruno Guillaume's avatar
Bruno Guillaume committed
713
    | Some (Strategy (_,ast_strat), new_pointed) ->
714
      strat_simple_rewrite ?domain new_pointed ast_strat instance
Bruno Guillaume's avatar
Bruno Guillaume committed
715

716
  and strat_simple_rewrite ?domain pointed strat instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
717
    match strat with
Bruno Guillaume's avatar
Bruno Guillaume committed
718
    | New_ast.Onf s -> strat_simple_rewrite ?domain pointed (New_ast.Pick (New_ast.Iter s)) instance
719
    | New_ast.Ref subname -> intern_simple_rewrite ?domain pointed subname instance
Bruno Guillaume's avatar
Bruno Guillaume committed
720 721
    | New_ast.Pick strat ->
      begin
722
        match det_strat_simple_rewrite ?domain pointed strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
723 724 725 726 727 728
        | 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
729
      (fun acc strat -> Instance_set.union acc (strat_simple_rewrite ?domain pointed strat instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
730 731 732 733
      ) Instance_set.empty strat_list

    | New_ast.Seq [] -> Instance_set.singleton instance
    | New_ast.Seq (head_strat :: tail_strat) ->
734
      let first_strat = strat_simple_rewrite ?domain pointed head_strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
735
      Instance_set.fold
736
        (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
737 738 739
        ) first_strat Instance_set.empty

    | New_ast.Iter strat ->
740
      let one_step = strat_simple_rewrite ?domain pointed strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
741 742 743
      if Instance_set.is_empty one_step
      then Instance_set.singleton instance
      else Instance_set.fold
744
        (fun instance acc -> Instance_set.union acc (strat_simple_rewrite ?domain pointed (New_ast.Iter strat) instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
745 746 747 748
        ) one_step Instance_set.empty

    | New_ast.Try strat ->
      begin
749
        let one_step = strat_simple_rewrite ?domain pointed strat instance in
Bruno Guillaume's avatar
Bruno Guillaume committed
750 751 752 753 754 755 756
        if Instance_set.is_empty one_step
        then Instance_set.singleton instance
        else one_step
      end

    | New_ast.If (s, s1, s2) ->
      begin
757 758 759
        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
760 761
      end

762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779

  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
Bruno Guillaume's avatar
Bruno Guillaume committed
780
        | Some x -> Some x
781 782 783 784 785
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

Bruno Guillaume's avatar
Bruno Guillaume committed
786
  let det_iter_pack ?domain decl_list instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
787
    match det_pack_one ?domain decl_list instance with
788
    | None -> None
Bruno Guillaume's avatar
Bruno Guillaume committed
789
    | Some x ->
790 791
      let rec loop inst =
        match det_pack_one ?domain decl_list inst with
Bruno Guillaume's avatar
Bruno Guillaume committed
792 793 794
        | None -> Some (Instance.swap inst)
        | Some next -> loop next
      in loop x
795 796

  let rec det_rew_display_tmp ?domain pointed strat instance =
Bruno Guillaume's avatar
Bruno Guillaume committed
797
    match strat with
Bruno Guillaume's avatar
Bruno Guillaume committed
798
    | New_ast.Onf s -> det_rew_display_tmp ?domain pointed (New_ast.Pick (New_ast.Iter s)) instance
799 800 801 802 803 804 805
    | 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
806
            match Rule.det_apply ?domain r (Instance.refresh instance) with
807
            | None -> None
Bruno Guillaume's avatar
Bruno Guillaume committed
808
            | Some inst -> Some [(Rule.get_name r, inst)]
809
          end
Bruno Guillaume's avatar
Bruno Guillaume committed
810
        | Some (Package (pack_name, decl_list), _) ->
811
            begin
Bruno Guillaume's avatar
Bruno Guillaume committed
812
              match det_pack_one ?domain decl_list (Instance.refresh instance) with
813
              | None -> None
Bruno Guillaume's avatar
Bruno Guillaume committed
814
              | Some inst -> Some [( pack_name, inst )]
815 816 817 818 819 820
            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
821 822 823 824 825 826

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

832
    | New_ast.Seq [] -> Some []
Bruno Guillaume's avatar
Bruno Guillaume committed
833 834
    | New_ast.Seq (head_strat :: tail_strat) ->
      begin
835
        match det_rew_display_tmp ?domain pointed head_strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
836
        | None -> None
837
        | Some [] -> det_rew_display_tmp ?domain pointed (New_ast.Seq tail_strat) instance
Bruno Guillaume's avatar
Bruno Guillaume committed
838
        | Some (((_,inst) :: _) as l) ->
839 840 841 842 843
          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
844 845
      end

846 847 848 849 850 851 852
    | 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
853 854
              match det_iter_pack ?domain [Rule r] (Instance.refresh instance) with
              | Some final -> Some [(Rule.get_name r, final)]
855 856 857 858
              | None -> Some []
            end
          | Some (Package (pack_name, decl_list), _) ->
            begin
Bruno Guillaume's avatar
Bruno Guillaume committed
859 860
              match det_iter_pack ?domain decl_list (Instance.refresh instance) with
              | Some final -> Some [(pack_name, final)]
861 862 863 864 865 866
              | 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
867 868
    | New_ast.Iter strat ->
      begin
869 870 871
        match det_rew_display_tmp ?domain pointed strat instance with
        | None -> Some []
        | Some [] -> Some []
Bruno Guillaume's avatar
Bruno Guillaume committed
872
        | Some (((_,inst) :: _) as l) ->
873 874 875 876 877 878
          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
879 880 881

    | New_ast.Try strat ->
        begin
882 883
          match det_rew_display_tmp ?domain pointed strat instance with
          | None -> Some []
Bruno Guillaume's avatar
Bruno Guillaume committed
884 885 886 887 888
          | Some i -> Some i
        end

    | New_ast.If (s, s1, s2) ->
      begin
889 890 891
        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
892 893
      end

894 895
  let det_rew_display grs strat graph =
    let domain = domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
896
    let instance = Instance.from_graph graph in
897

Bruno Guillaume's avatar
Bruno Guillaume committed
898 899 900 901 902 903 904 905 906 907
    let rec loop inst = function
    | [] -> Libgrew_types.Leaf inst.Instance.graph
    | (s2, i2) :: tail ->
      begin
        match i2.Instance.big_step with
        | Some bs2 -> Libgrew_types.Node (inst.Instance.graph, s2, [bs2, loop i2 tail])
        | _ -> failwith "missing BS"
      end in

    match CCOpt.map List.rev (det_rew_display_tmp ?domain (top grs) (Parser.strategy strat) instance) with
908 909
    | None -> Libgrew_types.Empty
    | Some [] -> Libgrew_types.Leaf instance.Instance.graph
Bruno Guillaume's avatar
Bruno Guillaume committed
910 911 912 913 914
    | Some ((s1,i1) :: tail) ->
      match i1.Instance.big_step with
      | Some bs -> Libgrew_types.Node (instance.Instance.graph, s1, [bs, loop i1 tail])
      (* Libgrew_types.Node (i2.Instance.graph,s2,[bs,rd])) tail *)
    | _ -> failwith "missing BS2"
915

916 917 918 919 920 921 922 923 924 925 926 927 928 929
  (* return true if strat always return at least one graph *)
  let at_least_one grs strat =
    let rec loop pointed strat =
      match strat with
      | New_ast.Ref strat_name ->
        begin
          let path = Str.split (Str.regexp "\\.") strat_name in
          match search_from pointed path with
          | None -> Error.build "cannot find strat %s" strat_name
          | Some (Rule _,_)
          | Some (Package _, _) -> false
          | Some (Strategy (_,ast_strat), new_pointed) -> loop new_pointed ast_strat
        end
      | New_ast.Pick s -> loop pointed s
Bruno Guillaume's avatar
Bruno Guillaume committed
930
      | New_ast.Onf s -> true
931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951
      | New_ast.Alt l -> List.exists (fun s -> loop pointed s) l
      | New_ast.Seq l -> List.for_all (fun s -> loop pointed s) l
      | New_ast.Iter _ -> true
      | New_ast.If (_,s1, s2) -> (loop pointed s1) && (loop pointed s2)
      | New_ast.Try (s) -> loop pointed s in
    loop (top grs) (Parser.strategy strat)

  (* return true if strat always return at most one graph *)
  let at_most_one grs strat =
    let rec loop pointed strat =
      match strat with
      | New_ast.Ref strat_name ->
        begin
          let path = Str.split (Str.regexp "\\.") strat_name in
          match search_from pointed path with
          | None -> Error.build "cannot find strat %s" strat_name
          | Some (Rule _,_)
          | Some (Package _, _) -> false
          | Some (Strategy (_,ast_strat), new_pointed) -> loop new_pointed ast_strat
        end
      | New_ast.Pick s -> true
Bruno Guillaume's avatar
Bruno Guillaume committed
952
      | New_ast.Onf s -> true
953 954 955 956 957 958 959
      | New_ast.Alt [one] -> loop pointed one
      | New_ast.Alt _ -> false
      | New_ast.Seq l -> List.for_all (fun s -> loop pointed s) l
      | New_ast.Iter s -> loop pointed s
      | New_ast.If (_,s1, s2) -> (loop pointed s1) || (loop pointed s2)
      | New_ast.Try (s) -> loop pointed s in
    loop (top grs) (Parser.strategy strat)
Bruno Guillaume's avatar
Bruno Guillaume committed
960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975


(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)
(* ============================================================================================= *)

976 977 978 979 980 981 982 983



  (* ============================================================================================= *)
  (* Rewriting in the deterministic case with graph type *)
  (* ============================================================================================= *)

  (* apply a package to an instance = apply only top level rules in the package *)
Bruno Guillaume's avatar
Bruno Guillaume committed
984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047
  let onf_pack_rewrite ?domain decl_list graph =
    let rec loop = function
      | [] -> None
      | Rule r :: tail_decl ->
        (match Rule.onf_apply ?domain r graph with
        | Some x -> Some x
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

  let rec onf_intern_simple_rewrite ?domain pointed strat_name graph =
    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
    | Some (Rule r,_) -> Rule.onf_apply ?domain r graph
    | Some (Package (_, decl_list), _) -> onf_pack_rewrite ?domain decl_list graph
    | Some (Strategy (_,ast_strat), new_pointed) ->
      onf_strat_simple_rewrite ?domain new_pointed ast_strat graph

  and onf_strat_simple_rewrite ?domain pointed strat graph =
    match strat with
    | New_ast.Ref subname -> onf_intern_simple_rewrite ?domain pointed subname graph
    | New_ast.Pick strat -> onf_strat_simple_rewrite ?domain pointed strat graph

    | New_ast.Alt [] -> None
    | New_ast.Alt strat_list ->
      let rec loop = function
        | [] -> None
        | head_strat :: tail_strat ->
          match onf_strat_simple_rewrite ?domain pointed head_strat graph with
          | None -> loop tail_strat
          | Some x -> Some x in
        loop strat_list

    | New_ast.Seq [] -> Some graph
    | New_ast.Seq (head_strat :: tail_strat) ->
      begin
        match onf_strat_simple_rewrite ?domain pointed head_strat graph with
        | None -> None
        | Some inst -> onf_strat_simple_rewrite ?domain pointed (New_ast.Seq tail_strat) inst
      end

    | New_ast.Iter sub_strat ->
      begin
        match onf_strat_simple_rewrite ?domain pointed sub_strat graph with
        | None -> Some graph
        | Some inst -> onf_strat_simple_rewrite ?domain pointed strat inst
        end

    | New_ast.Try sub_strat ->
        begin
          match onf_strat_simple_rewrite ?domain pointed sub_strat graph with
          | None -> Some graph
          | Some i -> Some i
        end

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

1048
    | New_ast.Onf (s) -> onf_strat_simple_rewrite ?domain pointed s graph (* TODO check Onf (P) == 1 rule app ? *)
Bruno Guillaume's avatar
Bruno Guillaume committed
1049

1050 1051 1052
  (* ============================================================================================= *)
  (* Rewriting in the non-deterministic case with Graph_with_history.t type *)
  (* ============================================================================================= *)
Bruno Guillaume's avatar
Bruno Guillaume committed
1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102