grew_ast.ml 18.4 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                                                   *)
(**********************************************************************************)

bguillaum's avatar
bguillaum committed
11 12
open Printf
open Log
bguillaum's avatar
bguillaum committed
13
open Grew_base
bguillaum's avatar
bguillaum committed
14
open Grew_types
bguillaum's avatar
bguillaum committed
15

16
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
17
module Ast = struct
18

19
  (* general function for checking that an identifier is of the right kind *)
20
  (* allowed is a char list which is a sub set of ['#'; '.'; ':'; '*'] *)
21 22 23 24 25 26 27 28 29 30 31 32 33 34
  let check_special name allowed s =
    let sp = Str.full_split (Str.regexp "#\\|\\.\\|:\\|\\*") s in
    try
      match List.find
      (function
        | Str.Delim d when not (List.mem d allowed) -> true
        | _ -> false
      ) sp
      with
      | Str.Delim wrong_char ->
       Error.build "The identifier '%s' is not a valid %s, the character '%s' is illegal" s name wrong_char
      | Str.Text _ -> Error.bug "[Grew_ast.check_special]"
    with
    | Not_found -> ()
35

36 37 38 39 40 41
  (* ---------------------------------------------------------------------- *)
  (* simple_ident: cat *)
  type simple_ident = Id.name
  let parse_simple_ident s = check_special "simple ident" [] s; s
  let is_simple_ident s = try ignore (parse_simple_ident s); true with _ -> false
  let dump_simple_ident name = name
42

bguillaum's avatar
bguillaum committed
43
  (* ---------------------------------------------------------------------- *)
44 45 46 47
  (* label_ident: D:mod.dis *)
  type label_ident = string
  let parse_label_ident s = check_special "label ident" [":"; "."] s; s
  let dump_label_ident name = name
48

49 50 51 52 53
  (* ---------------------------------------------------------------------- *)
  (* pattern_label_ident: D:mod.* *)
  type pattern_label_ident = string
  let parse_pattern_label_ident s = check_special "label ident" [":"; "."; "*"] s; s
  let dump_pattern_label_ident name = name
54

55 56 57 58 59 60
  (* ---------------------------------------------------------------------- *)
  (* node_ident: W0.5 *)
  type node_ident = string
  let parse_node_ident s = check_special "node ident" ["."] s; s
  let dump_node_ident name = name

bguillaum's avatar
bguillaum committed
61
  (* ---------------------------------------------------------------------- *)
62 63
  (* feature_ident: V.cat *)
  type feature_ident = Id.name * feature_name
64 65
  let dump_feature_ident (name, feat_name) = sprintf "%s.%s" name feat_name

66 67 68 69 70
  let parse_feature_ident s =
    check_special "feature ident" ["."] s;
    match Str.full_split (Str.regexp "\\.") s with
    | [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, fn)
    | _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
71

bguillaum's avatar
bguillaum committed
72 73 74 75 76 77
  (* ---------------------------------------------------------------------- *)
  (* simple_or_feature_ident: union of simple_ident and feature_ident *)
  (* Note: used for parsing of "X < Y" and "X.feat < Y.feat" without conflicts *)
  type simple_or_feature_ident = Id.name * feature_name option

  let parse_simple_or_feature_ident s =
78 79
    check_special "feature ident" ["."] s;
    match Str.full_split (Str.regexp "\\.") s with
bguillaum's avatar
bguillaum committed
80 81 82
    | [Str.Text base; ] -> (base, None)
    | [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, Some fn)
    | _ -> Error.build "The identifier '%s' must be a feature identifier (with at most one '.' symbol, like \"V\" or \"V.cat\" for instance)" s
83 84


85
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
86
  type feature_kind =
87 88
    | Equality of feature_value list
    | Disequality of feature_value list
bguillaum's avatar
bguillaum committed
89
    | Equal_param of string (* $ident *)
bguillaum's avatar
bguillaum committed
90
    | Absent
bguillaum's avatar
bguillaum committed
91

Bruno Guillaume's avatar
Bruno Guillaume committed
92 93 94 95 96 97 98
  let feature_kind_to_string = function
    | Equality fv_list -> sprintf " = %s" (String.concat "|" fv_list)
    | Disequality [] -> ""
    | Disequality fv_list -> sprintf " <> %s" (String.concat "|" fv_list)
    | Equal_param param -> sprintf  " = $%s" param
    | Absent -> " <> *"

bguillaum's avatar
bguillaum committed
99
  type u_feature = {
100 101 102
    name: feature_name;
    kind: feature_kind;
  }
Bruno Guillaume's avatar
Bruno Guillaume committed
103 104 105
  let u_feature_to_string uf =
    sprintf "%s%s" uf.name (feature_kind_to_string uf.kind)

bguillaum's avatar
bguillaum committed
106
  type feature = u_feature * Loc.t
107

Bruno Guillaume's avatar
Bruno Guillaume committed
108

109 110 111 112 113
  let default_fs ?loc lab =
    match loc with
    | None -> [({name="label"; kind=Equality [lab]}, Loc.empty)]
    | Some l -> [({name="label"; kind=Equality [lab]}, l)]

bguillaum's avatar
bguillaum committed
114
  type u_node = {
bguillaum's avatar
bguillaum committed
115 116 117 118
    node_id: Id.name;
    position: float option;
    fs: feature list;
  }
bguillaum's avatar
bguillaum committed
119
  type node = u_node * Loc.t
120

121 122
  let grewpy_compare (n1,_) (n2,_) = Id.grewpy_compare n1.node_id n2.node_id

123 124
  type edge_label = string

125 126 127 128
  type edge_label_cst =
    | Pos_list of edge_label list (*  X|Y|Z    *)
    | Neg_list of edge_label list (*  ^X|Y|Z   *)
    | Regexp of string            (*  re"a.*"  *)
bguillaum's avatar
bguillaum committed
129

bguillaum's avatar
bguillaum committed
130
  type u_edge = {
bguillaum's avatar
bguillaum committed
131 132
    edge_id: Id.name option;
    src: Id.name;
bguillaum's avatar
bguillaum committed
133
    edge_label_cst: edge_label_cst;
bguillaum's avatar
bguillaum committed
134 135
    tar: Id.name;
  }
bguillaum's avatar
bguillaum committed
136
  type edge = u_edge * Loc.t
bguillaum's avatar
bguillaum committed
137 138 139 140 141 142 143 144 145

  type ineq = Lt | Gt | Le | Ge

  let string_of_ineq = function
    | Lt -> "<"
    | Gt -> ">"
    | Le -> "≤"
    | Ge -> "≥"

146
  type u_const =
147 148
    | Cst_out of Id.name * edge_label_cst
    | Cst_in of Id.name * edge_label_cst
149 150 151
    | Features_eq of feature_ident * feature_ident
    | Features_diseq of feature_ident * feature_ident
    | Features_ineq of ineq * feature_ident * feature_ident
152
    | Feature_ineq_cst of ineq * feature_ident * float
153
    | Feature_eq_float of feature_ident * float
bguillaum's avatar
bguillaum committed
154 155
    | Feature_diff_float of feature_ident * float

156 157
    | Feature_eq_regexp of feature_ident * string
    | Feature_eq_cst of feature_ident * string
bguillaum's avatar
bguillaum committed
158 159
    | Feature_diff_cst of feature_ident * string

160 161
    | Immediate_prec of Id.name * Id.name
    | Large_prec of Id.name * Id.name
bguillaum's avatar
bguillaum committed
162
  type const = u_const * Loc.t
163

bguillaum's avatar
bguillaum committed
164
  type basic = {
bguillaum's avatar
bguillaum committed
165 166 167 168
    pat_nodes: node list;
    pat_edges: edge list;
    pat_const: const list;
  }
bguillaum's avatar
bguillaum committed
169

170 171 172 173 174
  type pattern = {
    pat_pos: basic;
    pat_negs: basic list;
  }

175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
  let check_duplicate_edge_identifier basic =
    let ids = List_.opt_map
      (function ({edge_id= Some e},loc) -> Some (e, loc) | _ -> None)
       basic.pat_edges in
    let rec loop = function
    | [] -> ()
    | (x,loc)::t when List.exists (fun (y,_) -> x=y) t ->
        Error.build ~loc "The identifier '%s' is used twice" x
    | _::t -> loop t in
    loop ids

  let normalize_pattern pattern =
    check_duplicate_edge_identifier pattern.pat_pos;
    { pattern with pat_negs =
        List.map
          (fun pat_neg ->
            { pat_neg with pat_edges =
              List.map
                (fun (u_edge,loc) ->
                  match u_edge.edge_id with
                  | None -> (u_edge,loc)
                  | Some id ->
                    Log.fwarning "[%s] identifier \"%s\" is useless in without part" (Loc.to_string loc) id;
                    ({u_edge with edge_id=None},loc)
                ) pat_neg.pat_edges
            }
          ) pattern.pat_negs
    }

204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
  let add_implicit_node loc aux name pat_nodes =
    if (List.exists (fun ({node_id},_) -> node_id=name) pat_nodes)
    || (List.exists (fun ({node_id},_) -> node_id=name) aux)
    then pat_nodes
    else ({node_id=name; position=None; fs=[]}, loc) :: pat_nodes

  let complete_basic aux {pat_nodes; pat_edges; pat_const} =
    let pat_nodes_2 = List.fold_left
    (fun acc ({src; tar}, loc) ->
      acc
      |> (add_implicit_node loc aux src)
      |> (add_implicit_node loc aux tar)
    ) pat_nodes pat_edges in

    let pat_nodes_3 = List.fold_left
    (fun acc (u_const, loc) -> match u_const with
220 221 222 223 224
      | Features_eq ((name1,_), (name2,_))
      | Features_diseq ((name1,_), (name2,_))
      | Features_ineq (_, (name1,_), (name2,_))
      | Immediate_prec (name1, name2)
      | Large_prec (name1, name2) ->
225 226 227
        acc
        |> (add_implicit_node loc aux name1)
        |> (add_implicit_node loc aux name2)
228
      | Feature_ineq_cst (_, (name,_), _)
229
      | Feature_eq_cst ((name,_), _)
bguillaum's avatar
bguillaum committed
230
      | Feature_diff_cst ((name,_), _)
231
      | Feature_eq_float ((name,_), _)
bguillaum's avatar
bguillaum committed
232
      | Feature_diff_float ((name,_), _)
233
      | Feature_eq_regexp ((name,_), _)
234 235
      | Cst_in (name,_)
      | Cst_out (name, _) ->
236 237
        acc
        |> (add_implicit_node loc aux name)
238 239 240 241 242 243 244 245 246 247
    ) pat_nodes_2 pat_const in

    {pat_nodes=pat_nodes_3; pat_edges; pat_const}

  let complete_pattern pattern =
    let new_pat_pos = complete_basic [] pattern.pat_pos in
    let aux = new_pat_pos.pat_nodes in
    let new_pat_negs = List.map (complete_basic aux) pattern.pat_negs in
    { pat_pos = new_pat_pos; pat_negs = new_pat_negs;}

bguillaum's avatar
bguillaum committed
248
  type concat_item =
249
    | Qfn_item of feature_ident
bguillaum's avatar
bguillaum committed
250
    | String_item of string
251
    | Param_item of string
bguillaum's avatar
bguillaum committed
252

bguillaum's avatar
bguillaum committed
253 254 255 256 257
  let string_of_concat_item = function
    | Qfn_item id -> sprintf "%s" (dump_feature_ident id)
    | String_item s -> sprintf "\"%s\"" s
    | Param_item var -> sprintf "%s" var

bguillaum's avatar
bguillaum committed
258
  type u_command =
bguillaum's avatar
bguillaum committed
259
    | Del_edge_expl of (Id.name * Id.name * edge_label)
bguillaum's avatar
bguillaum committed
260
    | Del_edge_name of string
bguillaum's avatar
bguillaum committed
261
    | Add_edge of (Id.name * Id.name * edge_label)
262
    | Add_edge_expl of (Id.name * Id.name * string)
263 264

    (* 4 args: source, target, labels, flag true iff negative cst *)
bguillaum's avatar
bguillaum committed
265 266 267
    | Shift_in of (Id.name * Id.name * edge_label_cst)
    | Shift_out of (Id.name * Id.name * edge_label_cst)
    | Shift_edge of (Id.name * Id.name * edge_label_cst)
268

bguillaum's avatar
bguillaum committed
269 270 271 272
    | New_node of Id.name
    | New_before of (Id.name * Id.name)
    | New_after of (Id.name * Id.name)

bguillaum's avatar
bguillaum committed
273
    | Del_node of Id.name
274

bguillaum's avatar
bguillaum committed
275 276
    | Del_feat of feature_ident
    | Update_feat of feature_ident * concat_item list
bguillaum's avatar
bguillaum committed
277 278
  type command = u_command * Loc.t

bguillaum's avatar
bguillaum committed
279 280 281 282 283 284
  let string_of_u_command u_command = match u_command with
    | Del_edge_expl (n1,n2,label) ->
      sprintf "del_edge %s -[%s]-> %s" n1 label n2
    | Del_edge_name name -> sprintf "del_edge %s" name
    | Add_edge (n1,n2,label) ->
      sprintf "add_edge %s -[%s]-> %s" n1 label n2
285 286
    | Add_edge_expl (n1,n2,name) ->
        sprintf "add_edge %s: %s -> %s" name n1 n2
bguillaum's avatar
bguillaum committed
287

288
    | Shift_in (n1,n2,Neg_list []) ->
bguillaum's avatar
bguillaum committed
289
      sprintf "shift_in %s ==> %s" n1 n2
290
    | Shift_in (n1,n2,Pos_list labels) ->
bguillaum's avatar
bguillaum committed
291
      sprintf "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
292
    | Shift_in (n1,n2,Neg_list labels) ->
bguillaum's avatar
bguillaum committed
293
      sprintf "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
294 295
    | Shift_in (n1,n2,Regexp re) ->
      sprintf "shift_in %s =[re\"%s\"]=> %s" n1 re n2
bguillaum's avatar
bguillaum committed
296

297
    | Shift_out (n1,n2,Neg_list []) ->
bguillaum's avatar
bguillaum committed
298
      sprintf "shift_out %s ==> %s" n1 n2
299
    | Shift_out (n1,n2,Pos_list labels) ->
bguillaum's avatar
bguillaum committed
300
      sprintf "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
301
    | Shift_out (n1,n2,Neg_list labels) ->
bguillaum's avatar
bguillaum committed
302
      sprintf "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
303 304
    | Shift_out (n1,n2,Regexp re) ->
      sprintf "shift_out %s =[re\"%s\"]=> %s" n1 re n2
bguillaum's avatar
bguillaum committed
305

306 307

    | Shift_edge (n1,n2,Neg_list []) ->
bguillaum's avatar
bguillaum committed
308
      sprintf "shift %s ==> %s" n1 n2
309
    | Shift_edge (n1,n2,Pos_list labels) ->
bguillaum's avatar
bguillaum committed
310
      sprintf "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
311
    | Shift_edge (n1,n2,Neg_list labels) ->
bguillaum's avatar
bguillaum committed
312
      sprintf "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
313 314
    | Shift_edge (n1,n2,Regexp re) ->
      sprintf "shift %s =[re\"%s\"]=> %s" n1 re n2
bguillaum's avatar
bguillaum committed
315 316 317 318 319 320 321 322 323 324

    | New_node (n) -> sprintf "add_node %s" n
    | New_before (n1,n2) -> sprintf "add_node %s :< %s" n1 n2
    | New_after (n1,n2) -> sprintf "add_node %s :> %s" n1 n2
    | Del_node act_id -> sprintf "del_node %s" act_id
    | Update_feat ((act_id, feat_name),item_list) ->
      sprintf "%s.%s = %s" act_id feat_name (List_.to_string string_of_concat_item " + " item_list)
    | Del_feat (act_id, feat_name) ->
      sprintf "del_feat %s.%s" act_id feat_name

325
  (* the [rule] type is used for 3 kinds of module items:
326 327
     - rule     { param=None; ... }
     - lex_rule
bguillaum's avatar
bguillaum committed
328
  *)
bguillaum's avatar
bguillaum committed
329
  type rule = {
bguillaum's avatar
bguillaum committed
330
    rule_id:Id.name;
331
    pattern: pattern;
bguillaum's avatar
bguillaum committed
332
    commands: command list;
333 334
    param: (string list * string list) option; (* (files, vars) *)
    lex_par: string list option; (* lexical parameters in the file *)
bguillaum's avatar
bguillaum committed
335 336
    rule_doc:string list;
    rule_loc: Loc.t;
337
    rule_dir: string option; (* the real folder where the file is defined *)
bguillaum's avatar
bguillaum committed
338
  }
339

bguillaum's avatar
bguillaum committed
340
  type modul = {
bguillaum's avatar
bguillaum committed
341 342
    module_id:Id.name;
    rules: rule list;
343
    deterministic: bool;
bguillaum's avatar
bguillaum committed
344 345 346 347 348
    module_doc:string list;
    mod_loc:Loc.t;
    mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
  }

349
  type strat_def = (* /!\ The list must not be empty in the Seq constructor *)
350 351 352
    | Ref of string            (* reference to a module name or to another strategy *)
    | Seq of strat_def list    (* a sequence of strategies to apply one after the other *)
    | Star of strat_def        (* a strategy to apply iteratively *)
353
    | Pick of strat_def        (* pick one normal form a the given strategy; return 0 if nf *)
354 355 356 357
    | Sequence of string list  (* compatibility mode with old code *)

  let rec strat_def_to_string = function
  | Ref m -> m
358 359 360
  | Seq l -> "(" ^ (String.concat "; " (List.map strat_def_to_string l)) ^ ")"
  | Star s -> "(" ^ (strat_def_to_string s) ^")" ^ "*"
  | Pick s -> "pick" ^ "(" ^(strat_def_to_string s)^")"
361 362 363 364 365 366 367
  | Sequence names -> "{" ^ (String.concat ";" names) ^ "}"

  (* invariant: Seq list and Plus list are not empty in the input and so not empty in the output *)
  let rec strat_def_flatten = function
  | Sequence l -> Sequence l
  | Ref m -> Ref m
  | Star s -> Star (strat_def_flatten s)
368
  | Pick s -> Pick (strat_def_flatten s)
369 370 371 372 373 374 375 376 377 378 379 380 381 382
  | Seq l ->
    let fl = List.map strat_def_flatten l in
    let rec loop = function
    | [] -> []
    | (Seq l) :: tail -> l @ (loop tail)
    | x :: tail -> x :: (loop tail)
    in Seq (loop fl)

  type strategy = {
    strat_name: string;
    strat_def: strat_def;
    strat_doc: string list;
    strat_loc: Loc.t;
  }
bguillaum's avatar
bguillaum committed
383 384 385

  (** a GRS: graph rewriting system *)
  type module_or_include =
bguillaum's avatar
bguillaum committed
386
    | Modul of modul
387
    | Includ of (string * Loc.t)
bguillaum's avatar
bguillaum committed
388

389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
  type feature_spec =
    | Closed of feature_name * feature_atom list (* cat:V,N *)
    | Open of feature_name (* phon, lemma, ... *)
    | Num of feature_name (* position *)

  let build_closed feature_name feature_values =
    let sorted_list = List.sort Pervasives.compare feature_values in
    let without_duplicate =
      let rec loop = function
        | [] -> []
        | x::y::tail when x=y ->
          Log.fwarning "In the declaration of the feature name \"%s\", the value \"%s\" appears more than once" feature_name x;
          loop (y::tail)
        | x::tail -> x:: (loop tail)
      in loop sorted_list in
    Closed (feature_name, without_duplicate)

406
  type domain = {
407 408 409
    feature_domain: feature_spec list;
    label_domain: (string * string list) list;
  }
410

411 412 413
  type domain_wi = Dom of domain | Dom_file of string

  type grs_wi = {
bguillaum's avatar
bguillaum committed
414
    domain_wi: domain_wi option;
bguillaum's avatar
bguillaum committed
415
    modules_wi: module_or_include list;
416
    strategies_wi: strategy list;
bguillaum's avatar
bguillaum committed
417
  }
bguillaum's avatar
bguillaum committed
418 419

  type grs = {
bguillaum's avatar
bguillaum committed
420
    domain: domain option;
bguillaum's avatar
bguillaum committed
421
    modules: modul list;
422
    strategies: strategy list;
bguillaum's avatar
bguillaum committed
423
  }
bguillaum's avatar
bguillaum committed
424 425

  type gr = {
426
    meta: string list;
427 428 429
    nodes: node list;
    edges: edge list;
  }
bguillaum's avatar
bguillaum committed
430

431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447
  let complete id nodes =
    let rec loop n = match n with
    | [] -> [{node_id=id; position=None; fs=default_fs id},Loc.empty]
    | ({ node_id = head_id },_)::_ when head_id = id -> n
    | head::tail -> head :: (loop tail)
  in loop nodes

  let complete_graph gr =
    let new_nodes =
      List.fold_left
        (fun acc (edge,_) ->
          acc
          |> (complete edge.src)
          |> (complete edge.tar)
        ) gr.nodes gr.edges in
    { gr with nodes = new_nodes }

bguillaum's avatar
bguillaum committed
448
  let empty_grs = { domain = None; modules = []; strategies= [] }
bguillaum's avatar
bguillaum committed
449

450 451 452 453 454 455 456 457
  (* phrase structure tree *)
  type pst =
  | Leaf of (Loc.t * string) (* phon *)
  | T of (Loc.t * string * pst list)

  let rec word_list = function
    | Leaf (_, p) -> [p]
    | T (_,_,l) -> List.flatten (List.map word_list l)
458
end (* module Ast *)
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473



(* ================================================================================================ *)
module New_ast = struct
  type strat =
  | Ref of Ast.node_ident       (* reference to a rule name or to another strategy *)
  | Pick of strat               (* pick one normal form a the given strategy; return 0 if nf *)
  | Alt of strat list           (* a set of strategies to apply in parallel *)
  | Seq of strat list           (* a sequence of strategies to apply one after the other *)
  | Iter of strat               (* a strategy to apply iteratively *)
  | If of strat * strat * strat (* choose a stragegy with a test *)
  | Try of strat                (* ≜ If (S, S, Empty): pick one normal form a the given strategy; return input if nf *)

  type decl =
474 475
  | Features of Ast.feature_spec list
  | Labels of (string * string list) list
476
  | Package of (Loc.t * Ast.simple_ident * decl list)
477
  | Rule of Ast.rule
478
  | Strategy of (Loc.t * Ast.simple_ident * strat)
479 480 481
  | Import of string
  | Include of string

482
  type grs = decl list
483 484 485 486 487 488 489 490

  let strat_list grs =
    let rec loop pref = function
    [] -> []
    | Strategy (_,name,_) :: tail -> name :: (loop pref tail)
    | Package (_,pack_name,decl_list) :: tail -> (loop (pref^"."^pack_name) decl_list) @  (loop pref tail)
    | _ :: tail -> loop pref tail
    in loop "" grs
491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521

  (* conversion from old grs to new ones *)
  let modul2package modul =
    let decl_list = List.map (fun rule -> Rule rule) modul.Ast.rules in
    Package (modul.Ast.mod_loc, modul.Ast.module_id, decl_list)

  let convert_strat det_modules old_strat =
    let new_strat_list =
      match old_strat.Ast.strat_def with
      | Ast.Sequence module_list ->
        Seq (List.map
          (fun name ->
            if List.mem name det_modules
            then Pick (Iter (Ref name))
            else Iter (Ref name)
          ) module_list
        )
      | _ -> failwith "No translation of old strat ≠ Sequence" in
    let strat_name = old_strat.Ast.strat_name in
    let loc = old_strat.Ast.strat_loc in
    Strategy (loc, strat_name, new_strat_list)

  let convert old_grs =
    let new_domain =
      match old_grs.Ast.domain with
      | None -> []
      | Some { Ast.feature_domain; label_domain } -> [Features feature_domain; Labels label_domain] in
    let packages = List.map modul2package old_grs.Ast.modules in
    let det_modules = List.fold_left (fun acc modul -> if modul.Ast.deterministic then modul.Ast.module_id::acc else acc) [] old_grs.Ast.modules in
    let new_strat_list = List.map (convert_strat det_modules) old_grs.Ast.strategies in
    new_domain @ packages @ new_strat_list
522
  end (* module New_ast *)
523 524 525 526 527 528