grew_grs.ml 35 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
(* ================================================================================ *)
170
module Old_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 Old_grs *)
472

473 474 475



476
module Grs = struct
477 478 479

  type decl =
  | Rule of Rule.t
480
  | Strategy of string * New_ast.strat
481 482 483 484 485 486 487 488 489
  | Package of string * decl list

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

490 491
  let rec decl_to_json ?domain = function
    | Rule r -> Rule.to_json ?domain r
Bruno Guillaume's avatar
Bruno Guillaume committed
492
    | Strategy (name, strat) -> `Assoc [("strat_name", `String name); ("strat_def", New_ast.strat_to_json strat)]
493
    | 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
494 495 496 497 498 499 500 501 502 503

  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;
504
      "decls", `List (List.map (decl_to_json ~domain:dom) t.decls)
Bruno Guillaume's avatar
Bruno Guillaume committed
505 506 507
    ]


508 509
  let get_strat_list grs = Grew_ast.New_ast.strat_list grs.ast

510 511 512 513 514 515 516 517
  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 =
518
    printf "================ Grs ================\n";
519 520 521
    Domain.dump t.domain;
    printf "-----------------------\n";
    List.iter (dump_decl 0) t.decls;
522
    printf "================ Grs ================\n%!";
523 524 525 526
    ()


  let rec build_decl ?domain = function
527
  | New_ast.Package (loc, name, decl_list) -> Package (name, List.map (build_decl ?domain) decl_list)
528
  | New_ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO: remove this arg (old grs)" ast_rule)
529
  | New_ast.Strategy (loc, name, ast_strat) -> Strategy (name, ast_strat)
530 531 532 533
  | _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"

  let domain t = t.domain

534
  let from_ast filename ast =
535

536 537
    let feature_domains = List_.opt_map
      (fun x -> match x with
538
        | New_ast.Features desc -> Some desc
539 540
        | _ -> None
      ) ast in
541 542
    let feature_domain = match feature_domains with
    | [] -> None
543
    | h::t -> Some (Feature_domain.build (List.fold_left Feature_domain.merge h t)) in
544 545 546

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

    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

560 561 562 563 564 565 566 567 568
    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

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

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

Bruno Guillaume's avatar
Bruno Guillaume committed
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 631
  (* 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
      )

632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
  (* 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
654 655 656
    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
657 658
    | 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
659
    | Some (Strategy (_,ast_strat), new_pointed) ->
660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675
      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
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
718
    | New_ast.Ref subname -> intern_simple_rewrite ?domain pointed subname instance
Bruno Guillaume's avatar
Bruno Guillaume committed
719 720
    | New_ast.Pick strat ->
      begin
721
        match det_strat_simple_rewrite ?domain pointed strat instance with
Bruno Guillaume's avatar
Bruno Guillaume committed
722 723 724 725 726 727
        | 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
728
      (fun acc strat -> Instance_set.union acc (strat_simple_rewrite ?domain pointed strat instance)
Bruno Guillaume's avatar
Bruno Guillaume committed
729 730 731 732
      ) Instance_set.empty strat_list

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

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

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

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

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

  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
779
        | Some x -> Some x
780 781 782 783 784
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

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

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

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