grew_fs.ml 20.2 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
open Printf
pj2m's avatar
pj2m committed
12
open Log
13
open Conll
bguillaum's avatar
bguillaum committed
14

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
pj2m's avatar
pj2m committed
19

20 21
  let decode_feat_name s = Str.global_replace (Str.regexp "__\\([0-9a-z]+\\)$") "[\\1]" s

22 23 24 25 26 27 28 29 30 31 32
(* ================================================================================ *)
module Feature_value = struct
  let build_disj ?loc ?domain name unsorted_values =
    Domain.build_disj ?loc ?domain name unsorted_values

  let build_value ?loc ?domain name value =
    match build_disj ?loc ?domain name [value] with
      | [x] -> x
      | _ -> Error.bug ?loc "[Feature_value.build_value]"
end (* module Feature_value *)

bguillaum's avatar
bguillaum committed
33
(* ================================================================================ *)
34
module G_feature = struct
bguillaum's avatar
bguillaum committed
35 36

  type t = string * value
37 38

  let get_name = fst
39

40
  let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
pj2m's avatar
pj2m committed
41

42
  (* another order used for printing purpose only *)
43
  let print_order = ["phon"; "form"; "cat"; "upos"; "lemma"; "pos"; "xpos"]
44 45 46 47 48
  let print_cmp (name1,_) (name2,_) =
    match (List_.index name1 print_order, List_.index name2 print_order) with
    | (Some i, Some j) -> Pervasives.compare i j
    | (Some i, None) -> -1
    | (None, Some j) -> 1
Bruno Guillaume's avatar
Bruno Guillaume committed
49
    | (None, None) -> Pervasives.compare name1 name2
50

bguillaum's avatar
bguillaum committed
51
  let build ?domain = function
52
    | ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
bguillaum's avatar
bguillaum committed
53
      (name, Feature_value.build_value ~loc ?domain name atom)
Bruno Guillaume's avatar
Bruno Guillaume committed
54
    | (uf,loc) -> Error.build ~loc "in graph nodes, features must follow the shape \"name = value\" (error on feature: \"%s\")" (Ast.u_feature_to_string uf)
55

bguillaum's avatar
bguillaum committed
56
  let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val)
57

bguillaum's avatar
bguillaum committed
58
  let to_gr (feat_name, feat_val) = sprintf "%s=\"%s\"" feat_name (string_of_value feat_val)
bguillaum's avatar
bguillaum committed
59

bguillaum's avatar
bguillaum committed
60
  let to_dot (feat_name, feat_val) =
bguillaum's avatar
bguillaum committed
61 62 63 64
    let string_val = string_of_value feat_val in
    match Str.split (Str.regexp ":C:") string_val with
      | [] -> Error.bug "[G_feature.to_dot] feature value '%s'" string_val
      | fv::_ -> sprintf "%s=%s" feat_name fv
65 66 67 68 69

  let buff_dot buff (feat_name, feat_val) =
    let string_val = string_of_value feat_val in
    match Str.split (Str.regexp ":C:") string_val with
      | [] -> Error.bug "[G_feature.to_dot] feature value '%s'" string_val
70
      | fv::_ -> bprintf buff "<TR><TD ALIGN=\"right\">%s</TD><TD>=</TD><TD ALIGN=\"left\">%s</TD></TR>\n" (decode_feat_name feat_name) fv
bguillaum's avatar
bguillaum committed
71
end (* module G_feature *)
72

bguillaum's avatar
bguillaum committed
73
(* ================================================================================ *)
74
module P_feature = struct
bguillaum's avatar
bguillaum committed
75
  (* feature= (feature_name, disjunction of atomic values) *)
76

bguillaum's avatar
bguillaum committed
77
  type cst =
bguillaum's avatar
bguillaum committed
78
    | Absent
bguillaum's avatar
bguillaum committed
79 80 81 82 83 84 85 86
    | Equal of value list     (* with Equal constr, the list MUST never be empty *)
    | Different of value list

  (* NB: in the current version, |in_param| ≤ 1 *)
  type v = {
    cst: cst;
    in_param: int list;  (* the list of parameters to which the value must belong *)
  }
87 88

  type t = string * v
bguillaum's avatar
bguillaum committed
89 90 91 92 93 94 95 96 97 98 99
  let dump (feature_name, {cst; in_param}) =
    printf "[P_feature.dump]\n";
    printf "%s%s\n"
      feature_name
      (match cst with
      | Different [] -> "=*"
      | Different l -> "≠" ^ (String.concat "|" (List.map string_of_value l))
      | Equal l -> "=" ^ (String.concat "|" (List.map string_of_value l))
      | Absent -> " must be Absent!");
    printf "in_param=[%s]\n" (String.concat "," (List.map string_of_int in_param));
    printf "%!"
100

Bruno Guillaume's avatar
Bruno Guillaume committed
101 102 103 104 105 106 107 108 109 110
  let to_json ?domain (feature_name, {cst}) =
    `Assoc [
      ("feature_name", `String feature_name);
      ( match cst with
        | Absent -> ("absent", `Null)
        | Equal val_list -> ("equal", `List (List.map (fun x -> `String (string_of_value x)) val_list))
        | Different val_list -> ("different", `List (List.map (fun x -> `String (string_of_value x)) val_list))
      )
    ]

111 112 113 114
  let get_name = fst

  let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)

bguillaum's avatar
bguillaum committed
115 116
  exception Fail_unif

117
  (** raise [P_feature.Fail_unif] *)
bguillaum's avatar
bguillaum committed
118 119 120
  let unif_value v1 v2 = match (v1, v2) with
    | ({cst=Absent;in_param=[]},{cst=Absent;in_param=[]}) -> v1
    | ({cst=Absent;in_param=[]},_)
bguillaum's avatar
bguillaum committed
121
    | (_,{cst=Absent;in_param=[]}) -> raise Fail_unif
bguillaum's avatar
bguillaum committed
122 123 124 125 126

    | ({cst=cst1; in_param=in1}, {cst=cst2; in_param=in2}) ->
      let cst =  match (cst1, cst2) with
        | (Equal l1, Equal l2) ->
            (match List_.sort_inter l1 l2 with
bguillaum's avatar
bguillaum committed
127
            | [] -> raise Fail_unif
bguillaum's avatar
bguillaum committed
128 129 130 131
            | l -> Equal l)
        | (Equal l1, Different l2)
        | (Different l2, Equal l1) ->
            (match List_.sort_diff l1 l2 with
bguillaum's avatar
bguillaum committed
132
            | [] -> raise Fail_unif
bguillaum's avatar
bguillaum committed
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
            | l -> Equal l)
        | (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
        | _ -> Error.bug "[P_feature.unif_value] inconsistent match case" in
      let (in_) = match (in1,in2) with
        | (_,[]) -> (in1)
        | ([],_) -> (in2)
        | _ -> Error.build "more than one parameter constraint for the same feature in not yet implemented" in
      {cst; in_param=in_}

  let to_string ?param_names t =
    let param_string index = match param_names with
      | None -> sprintf "$%d" index
      | Some (l,_) -> sprintf "%s" (List.nth l index) in

    match t with
    | (feat_name, {cst=Absent ;in_param=[]}) -> sprintf "!%s" feat_name
    | (feat_name, {cst=Equal atoms;in_param=[]}) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
    | (feat_name, {cst=Different [];in_param=[]}) -> sprintf "%s=*" feat_name
    | (feat_name, {cst=Different atoms;in_param=[]}) -> sprintf "%s≠%s" feat_name (List_.to_string string_of_value "|" atoms)

    | (feat_name, {cst=Equal atoms;in_param=[one_in]}) -> sprintf "%s=%s=$%s" feat_name (List_.to_string string_of_value "|" atoms) (param_string one_in)
    | (feat_name, {cst=Different [];in_param=[one_in]}) -> sprintf "%s=$%s" feat_name (param_string one_in)
    | (feat_name, {cst=Different atoms;in_param=[one_in]}) -> sprintf "%s≠%s^%s=%s" feat_name (List_.to_string string_of_value "|" atoms) feat_name (param_string one_in)

    | _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
158

bguillaum's avatar
bguillaum committed
159
  let build ?domain ?pat_vars = function
Bruno Guillaume's avatar
Bruno Guillaume committed
160
    | ({Ast.kind=Ast.Absent; name=name}, loc) ->
bguillaum's avatar
bguillaum committed
161
      Domain.check_feature_name ~loc ?domain name;
162
      (name, {cst=Absent;in_param=[];})
163
    | ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
bguillaum's avatar
bguillaum committed
164
      let values = Feature_value.build_disj ~loc ?domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
165
    | ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
bguillaum's avatar
bguillaum committed
166
      let values = Feature_value.build_disj ~loc ?domain name unsorted_values in (name, {cst=Different values;in_param=[];})
bguillaum's avatar
bguillaum committed
167 168 169 170 171
    | ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
        begin
          match pat_vars with
          | None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
          | Some l ->
172
              match List_.index var l with
bguillaum's avatar
bguillaum committed
173 174 175
              | Some index -> (name, {cst=Different []; in_param = [index]})
              | None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
        end
bguillaum's avatar
bguillaum committed
176
end (* module P_feature *)
pj2m's avatar
pj2m committed
177

bguillaum's avatar
bguillaum committed
178
(* ================================================================================ *)
179
module G_fs = struct
bguillaum's avatar
Typo  
bguillaum committed
180
  (* list are supposed to be strictly ordered wrt compare *)
181
  type t = G_feature.t list
bguillaum's avatar
bguillaum committed
182

183
  (* ---------------------------------------------------------------------- *)
184
  let empty = []
bguillaum's avatar
bguillaum committed
185

186
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
187 188
  let set_feat ?loc ?domain feature_name atom t =
    let new_value = Feature_value.build_value ?loc ?domain feature_name atom in
189
    let rec loop = function
bguillaum's avatar
bguillaum committed
190 191 192
    | [] -> [(feature_name, new_value)]
    | ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
    | (fn,_)::t when feature_name = fn -> (feature_name, new_value)::t
bguillaum's avatar
bguillaum committed
193
    | (fn,a)::t -> (fn,a) :: (loop t)
194
    in loop t
195

196
  (* ---------------------------------------------------------------------- *)
197
  let del_feat = List_.sort_remove_assoc_opt
198

199
  (* ---------------------------------------------------------------------- *)
200 201
  let get_atom = List_.sort_assoc

202
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
203
  let get_string_atom feat_name t =
bguillaum's avatar
bguillaum committed
204 205
    match List_.sort_assoc feat_name t with
      | None -> None
bguillaum's avatar
bguillaum committed
206
      | Some v -> Some (conll_string_of_value v)
bguillaum's avatar
bguillaum committed
207

208
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
209
  let get_float_feat feat_name t =
bguillaum's avatar
bguillaum committed
210 211
    match List_.sort_assoc feat_name t with
      | None -> None
bguillaum's avatar
bguillaum committed
212
      | Some (Float i) -> Some i
Bruno Guillaume's avatar
Bruno Guillaume committed
213
      | Some (String s) -> Error.build "[Fs.get_float_feat] feat_name=%s, value=%s" feat_name s
bguillaum's avatar
bguillaum committed
214

215
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
216
  let to_string t = List_.to_string G_feature.to_string "," t
217 218

  (* ---------------------------------------------------------------------- *)
219
  let to_gr t = List_.to_string G_feature.to_gr ", " t
pj2m's avatar
pj2m committed
220

221
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
222 223
  let build ?domain ast_fs =
    let unsorted = List.map (fun feat -> G_feature.build ?domain feat) ast_fs in
224 225
    List.sort G_feature.compare unsorted

226
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
227
  let of_conll ?loc ?domain line =
228
    let (c2, c3, c4, c5) = Domain.conll_fields domain in
229
    let raw_list0 =
230 231
      (c2, Feature_value.build_value ?loc ?domain c2 line.Conll.form)
      :: (c4, Feature_value.build_value ?loc ?domain c4 line.Conll.upos)
bguillaum's avatar
bguillaum committed
232
      :: (List.map (fun (f,v) -> (f, Feature_value.build_value ?loc ?domain f v)) line.Conll.feats) in
233
    let raw_list1 = match line.Conll.xpos with
234
      | "" | "_" -> raw_list0
235
      | s -> (c5, Feature_value.build_value ?loc ?domain c5 s) :: raw_list0 in
236 237
    let raw_list2 = match line.Conll.lemma with
      | "" | "_" -> raw_list1
238
      | s -> (c3, Feature_value.build_value ?loc ?domain c3 s) :: raw_list1 in
239 240
    List.sort G_feature.compare raw_list2

241 242 243 244 245

  (* ---------------------------------------------------------------------- *)
  let pst_leaf ?loc ?domain phon = [("phon", Feature_value.build_value ?loc ?domain "phon" phon)]
  let pst_node ?loc ?domain cat = [("cat", Feature_value.build_value ?loc ?domain "cat" cat)]

246
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
247 248
  exception Fail_unif
  let unif fs1 fs2 =
249 250 251 252
    let rec loop = function
      | [], fs | fs, [] -> fs
      | (f1::t1, f2::t2) when G_feature.compare f1 f2 < 0 -> f1 :: loop (t1, f2::t2)
      | (f1::t1, f2::t2) when G_feature.compare f1 f2 > 0 -> f2 :: loop (f1::t1, t2)
bguillaum's avatar
bguillaum committed
253

254 255 256 257
      (* all remaining case are fn1 = fn2 *)
      | ((fn, a1)::t1, (_, a2)::t2) when a1=a2 -> (fn,a1) :: (loop (t1, t2))
      | _ -> raise Fail_unif
    in try Some (loop (fs1, fs2)) with Fail_unif -> None
258

259
  (* ---------------------------------------------------------------------- *)
260
  let get_main ?main_feat t =
261
    let default_list = ["phon"; "form"; "label"; "cat"; "upos"] in
262
    let main_list = match main_feat with
263 264
    | None -> default_list
    | Some string -> (Str.split (Str.regexp "\\( *; *\\)\\|#") string) @ default_list in
265 266 267
    let rec loop = function
      | [] -> (None, t)
      | feat_name :: tail ->
268
          match List_.sort_assoc feat_name t with
269
          | Some atom -> (Some (feat_name, atom), List_.sort_remove_assoc feat_name t)
270
          | None -> loop tail in
271
    loop main_list
bguillaum's avatar
bguillaum committed
272

273
  (* ---------------------------------------------------------------------- *)
274 275 276 277 278 279 280 281 282 283 284 285 286 287
  let to_dot ?(decorated_feat=("",[])) ?main_feat t =
    let buff = Buffer.create 32 in
    let () = match (fst decorated_feat) with
      | "" -> ()
      | pid -> bprintf buff "<TR><TD COLSPAN=\"3\" BGCOLOR=\"yellow\"><B>[%s]</B></TD></TR>\n" pid in

    let next =
      match get_main ?main_feat t with
      | (None, sub) -> sub
      | (Some (feat_name,atom), sub) ->
        if List.mem feat_name (snd decorated_feat)
        then bprintf buff "<TR><TD COLSPAN=\"3\" BGCOLOR=\"yellow\"><B>%s</B></TD></TR>\n" (string_of_value atom)
        else bprintf buff "<TR><TD COLSPAN=\"3\"><B>%s</B></TD></TR>\n" (string_of_value atom);
        sub in
288
    let next = List.sort G_feature.print_cmp next in
289 290 291 292
    List.iter
      (fun g_feat ->
        G_feature.buff_dot buff g_feat
      ) next;
bguillaum's avatar
bguillaum committed
293 294 295 296 297

    match Buffer.contents buff with
      | "" -> ""
      | s -> sprintf "<TABLE BORDER=\"0\" CELLBORDER=\"0\" CELLSPACING=\"0\">\n%s\n</TABLE>\n" s

298
  (* ---------------------------------------------------------------------- *)
299 300 301 302 303 304
  let to_word (t:t) =
    match List_.sort_assoc "phon" t with
    | Some s -> Some (string_of_value s)
    | None -> match List_.sort_assoc "form" t with
        | Some s -> Some (string_of_value s)
        | None -> None
bguillaum's avatar
bguillaum committed
305

306 307 308 309
  (* ---------------------------------------------------------------------- *)
  let escape_sharp s =
    Str.global_replace (Str.regexp "#") "__SHARP__" s

310
  (* ---------------------------------------------------------------------- *)
311 312 313
  let to_dep ?(decorated_feat=("",[])) ?position ?main_feat ?filter t =
    let (pid_name, feat_list) = decorated_feat in

314 315 316
    let (main_opt, sub) = get_main ?main_feat t in
    let sub = List.sort G_feature.print_cmp sub in

317 318 319
    let main = match main_opt with
      | None -> []
      | Some (feat_name, atom) ->
320
        let esc_atom = escape_sharp (string_of_value atom) in
321
        [ if List.mem feat_name (snd decorated_feat)
Bruno Guillaume's avatar
colors  
Bruno Guillaume committed
322
          then sprintf "%s:B:#8bf56e" esc_atom
323
          else esc_atom] in
324 325 326

    let word_list = match pid_name with
      | "" -> main
Bruno Guillaume's avatar
colors  
Bruno Guillaume committed
327
      | _ -> (sprintf "[%s]:B:#8bf56e" pid_name)::main in
328 329 330 331 332

    let word = match word_list with
      | [] -> "_"
      | l ->  String.concat "#" l in

bguillaum's avatar
bguillaum committed
333 334
    let last = match (!Global.debug, position) with
      | (true, Some f) -> [(G_feature.to_string ("position", Float f))^":B:lightblue"]
335 336 337 338
      | _ -> [] in

    let lines = List.fold_left
      (fun acc (feat_name, atom) ->
339
        let esc_atom = escape_sharp (G_feature.to_string (decode_feat_name feat_name, atom)) in
340
        if List.mem feat_name (snd decorated_feat)
Bruno Guillaume's avatar
colors  
Bruno Guillaume committed
341
        then (sprintf "%s:B:#8bf56e" esc_atom) :: acc
342 343
        else
          match filter with
344
            | Some test when not (test feat_name) -> acc
345
            | _ -> esc_atom :: acc
346 347 348 349
      ) last sub in
    let subword = String.concat "#" (List.rev lines) in

    sprintf " word=\"%s\"; subword=\"%s\"" word subword
bguillaum's avatar
bguillaum committed
350

351
  (* ---------------------------------------------------------------------- *)
352
  let to_conll_string ?exclude t =
bguillaum's avatar
bguillaum committed
353 354
    let reduced_t = match exclude with
      | None -> t
355
      | Some list -> List.filter (fun (fn,_) -> not (List.mem fn list)) t in
356 357 358 359
    let ud_ordering = (* In UD CoNLL-U format, features are sorted wrt lowercase form *)
      List.sort
        (fun feat1 feat2 -> Pervasives.compare (String.lowercase_ascii (G_feature.get_name feat1)) (String.lowercase_ascii (G_feature.get_name feat2)))
        reduced_t in
bguillaum's avatar
bguillaum committed
360 361 362 363
    match reduced_t with
      | [] -> "_"
      | _ -> String.concat "|"
        (List.map
Bruno Guillaume's avatar
Bruno Guillaume committed
364 365
          (function
            | (fn, String "true") -> fn
366 367
            | (fn, fv) -> (decode_feat_name fn)^"="^(string_of_value fv))
          ud_ordering
bguillaum's avatar
bguillaum committed
368
        )
369 370 371 372 373 374 375 376 377 378 379

  (* ---------------------------------------------------------------------- *)
  let to_conll ?exclude t =
    let reduced_t = match exclude with
      | None -> t
      | Some list -> List.filter (fun (fn,_) -> not (List.mem fn list)) t in
    let ud_ordering = (* In UD CoNLL-U format, features are sorted wrt lowercase form *)
      List.sort
        (fun feat1 feat2 -> Pervasives.compare (String.lowercase_ascii (G_feature.get_name feat1)) (String.lowercase_ascii (G_feature.get_name feat2)))
        reduced_t in
    List.map (fun (fn, fv) -> (fn, string_of_value fv)) ud_ordering
bguillaum's avatar
bguillaum committed
380
end (* module G_fs *)
bguillaum's avatar
bguillaum committed
381

bguillaum's avatar
bguillaum committed
382
(* ================================================================================ *)
383
module P_fs = struct
bguillaum's avatar
bguillaum committed
384
  (* list are supposed to be striclty ordered wrt compare *)
385
  type t = P_feature.t list
pj2m's avatar
pj2m committed
386

387
  let empty = []
pj2m's avatar
pj2m committed
388

Bruno Guillaume's avatar
Bruno Guillaume committed
389 390
  let to_json ?domain t = `List (List.map (P_feature.to_json ?domain) t)

391 392
  let check_position ?param position t =
    try
393 394 395 396 397 398 399 400
      match (List.assoc "position" t, position) with
      | ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, Some p) -> List.mem (Float p) pos_list
      | ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, None) -> false
      | ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, Some p) -> not (List.mem (Float p) pos_list)
      | ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, None) -> false
      | ({P_feature.cst=P_feature.Absent}, Some _) -> false
      | ({P_feature.cst=P_feature.Absent}, None) -> true
      | _ -> Error.bug "Position can't be parametrized"
401 402
    with Not_found -> true

bguillaum's avatar
bguillaum committed
403 404
  let build ?domain ?pat_vars ast_fs =
    let unsorted = List.map (P_feature.build ?domain ?pat_vars) ast_fs in
bguillaum's avatar
bguillaum committed
405
    List.sort P_feature.compare unsorted
pj2m's avatar
pj2m committed
406

407 408
  let feat_list t = List.map P_feature.get_name t

409
  let to_string t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
410

411 412 413
  let to_dep ?filter param_names t =
    let reduced = match filter with
      | None -> t
414
      | Some test -> List.filter (fun (fn,_) -> test fn) t in
415
    List_.to_string (P_feature.to_string ~param_names) "#" reduced
bguillaum's avatar
bguillaum committed
416

417
  let to_dot t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
418

419
  exception Fail
pj2m's avatar
pj2m committed
420

bguillaum's avatar
bguillaum committed
421 422 423 424
  let match_ ?param p_fs g_fs =
    let p_fs_wo_pos =
      try List.remove_assoc "position" p_fs
      with Not_found -> p_fs in
425 426
    let rec loop acc = function
      | [], _ -> acc
pj2m's avatar
pj2m committed
427

bguillaum's avatar
bguillaum committed
428 429 430
      (* a feature_name present only in instance -> Skip it *)
      | ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)

bguillaum's avatar
bguillaum committed
431 432 433
      (* Two next cases: p_fs requires for the absence of a feature -> OK *)
      | ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, []) -> loop acc (t_pat, [])
      | ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, (fn, fa)::t) when fn_pat < fn -> loop acc (t_pat, (fn, fa)::t)
bguillaum's avatar
bguillaum committed
434

bguillaum's avatar
bguillaum committed
435
      (* Two next cases: each feature_name present in p_fs must be in instance: [] means unif failure *)
436 437
      | _, [] -> raise Fail
      | ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
pj2m's avatar
pj2m committed
438

439
      (* Next cases: fn_pat = fn *)
bguillaum's avatar
bguillaum committed
440 441 442 443 444 445 446 447 448 449 450 451 452 453 454
      | ((_, {P_feature.cst=cst; P_feature.in_param=in_param})::t_pat, (_, atom)::t) ->

        (* check for the constraint part and fail if needed *)
        let () = match cst with
        | P_feature.Absent -> raise Fail
        | P_feature.Equal fv when not (List_.sort_mem atom fv) -> raise Fail
        | P_feature.Different fv when List_.sort_mem atom fv -> raise Fail
        | _ -> () in

        (* if constraint part don't fail, look for lexical parameters *)
        match (acc, in_param) with
          | (_,[]) -> loop acc (t_pat,t)
          | (None,_) -> Log.bug "[P_fs.match_] Parametrized constraint in a non-parametrized rule"; exit 2
          | (Some param, [index]) ->
            (match Lex_par.select index (string_of_value atom) param with
455
              | None -> raise Fail
456
              | Some new_param -> loop (Some new_param) (t_pat,t)
bguillaum's avatar
bguillaum committed
457 458 459
            )
          | _ -> Error.bug "[P_fs.match_] several different parameters contraints for the same feature is not implemented" in
    loop param (p_fs_wo_pos,g_fs)
bguillaum's avatar
bguillaum committed
460

bguillaum's avatar
bguillaum committed
461
  exception Fail_unif
bguillaum's avatar
bguillaum committed
462
  let unif fs1 fs2 =
bguillaum's avatar
bguillaum committed
463 464 465 466 467 468 469 470
    let rec loop = function
      | [], fs -> fs
      | fs, [] -> fs

      | ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 < fn2 -> (fn1,v1) :: (loop (t1,(fn2,v2)::t2))
      | ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 > fn2 -> (fn2,v2) :: (loop ((fn1,v1)::t1,t2))

      (* all remaining case are fn1 = fn2 *)
bguillaum's avatar
bguillaum committed
471 472
      | ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) ->
        try (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
bguillaum's avatar
bguillaum committed
473 474 475
        with
        | P_feature.Fail_unif -> raise Fail_unif
        | Error.Build (msg,_) -> Error.build "Feature '%s', %s" fn1 msg
bguillaum's avatar
bguillaum committed
476
    in loop (fs1, fs2)
bguillaum's avatar
bguillaum committed
477
end (* module P_fs *)