grew_fs.ml 18.1 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
pj2m's avatar
pj2m committed
18

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

bguillaum's avatar
bguillaum committed
21
(* ================================================================================ *)
22
module G_feature = struct
bguillaum's avatar
bguillaum committed
23 24

  type t = string * value
25 26

  let get_name = fst
27

pj2m's avatar
pj2m committed
28 29
  let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)

30 31 32 33 34 35 36 37 38
  (* another order used for printing purpose only *)
  let print_order = ["phon"; "cat"; "lemma"; "pos"]
  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
    | (None, None) -> Pervasives.compare name1 name2    

39
  let build domain = function
40
    | ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
41
      (name, Feature_value.build_value ~loc domain name atom)
42 43
    | _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"

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

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

bguillaum's avatar
bguillaum committed
48
  let to_dot (feat_name, feat_val) =
bguillaum's avatar
bguillaum committed
49 50 51 52
    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
53 54 55 56 57

  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
58
      | 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
59
end (* module G_feature *)
60

bguillaum's avatar
bguillaum committed
61
(* ================================================================================ *)
62
module P_feature = struct
bguillaum's avatar
bguillaum committed
63
  (* feature= (feature_name, disjunction of atomic values) *)
64

bguillaum's avatar
bguillaum committed
65
  type cst =
bguillaum's avatar
bguillaum committed
66
    | Absent
bguillaum's avatar
bguillaum committed
67 68 69 70 71 72 73 74
    | 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 *)
  }
75 76

  type t = string * v
bguillaum's avatar
bguillaum committed
77 78 79 80 81 82 83 84 85 86 87
  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 "%!"
88 89 90 91 92

  let get_name = fst

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

bguillaum's avatar
bguillaum committed
93 94
  exception Fail_unif

95
  (** raise [P_feature.Fail_unif] *)
bguillaum's avatar
bguillaum committed
96 97 98
  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
99
    | (_,{cst=Absent;in_param=[]}) -> raise Fail_unif
bguillaum's avatar
bguillaum committed
100 101 102 103 104

    | ({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
105
            | [] -> raise Fail_unif
bguillaum's avatar
bguillaum committed
106 107 108 109
            | l -> Equal l)
        | (Equal l1, Different l2)
        | (Different l2, Equal l1) ->
            (match List_.sort_diff l1 l2 with
bguillaum's avatar
bguillaum committed
110
            | [] -> raise Fail_unif
bguillaum's avatar
bguillaum committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
            | 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"
136

137
  let build domain ?pat_vars = function
138
    | ({Ast.kind=Ast.Absent; name=name}, loc) -> 
139
      Domain.check_feature_name ~loc domain name;
140
      (name, {cst=Absent;in_param=[];})
141
    | ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
142
      let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
143
    | ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
144
      let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Different values;in_param=[];})
bguillaum's avatar
bguillaum committed
145 146 147 148 149
    | ({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 ->
150
              match List_.index var l with
bguillaum's avatar
bguillaum committed
151 152 153
              | 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
154
end (* module P_feature *)
pj2m's avatar
pj2m committed
155

bguillaum's avatar
bguillaum committed
156
(* ================================================================================ *)
157
module G_fs = struct
bguillaum's avatar
Typo  
bguillaum committed
158
  (* list are supposed to be strictly ordered wrt compare *)
159
  type t = G_feature.t list
bguillaum's avatar
bguillaum committed
160

161
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
162
  let to_raw t = List.map (fun (name, value) -> (name, string_of_value value)) t
bguillaum's avatar
bguillaum committed
163

164
  (* ---------------------------------------------------------------------- *)
165
  let empty = []
bguillaum's avatar
bguillaum committed
166

167
  (* ---------------------------------------------------------------------- *)
168
  let set_feat ?loc domain feature_name atom t =
169
    let new_value = Feature_value.build_value ?loc domain feature_name atom in
170
    let rec loop = function
bguillaum's avatar
bguillaum committed
171 172 173
    | [] -> [(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
174
    | (fn,a)::t -> (fn,a) :: (loop t)
175
    in loop t
176

177
  (* ---------------------------------------------------------------------- *)
178
  let del_feat = List_.sort_remove_assoc
179

180
  (* ---------------------------------------------------------------------- *)
181 182
  let get_atom = List_.sort_assoc

183
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
184
  let get_annot_info fs =
bguillaum's avatar
bguillaum committed
185
    match List.filter (fun (fn,_) -> String.length fn > 1 && String.sub fn 0 2 = "__") fs with
bguillaum's avatar
bguillaum committed
186
      | [] -> None
bguillaum's avatar
bguillaum committed
187
      | [(fn,_)] -> Some (String.sub fn 2 ((String.length fn) - 2))
bguillaum's avatar
bguillaum committed
188 189
      | _ -> Error.build "[Fs.get_annot_info] More than one annot feature in the same feature structure"

190
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
191
  let get_string_atom feat_name t =
bguillaum's avatar
bguillaum committed
192 193
    match List_.sort_assoc feat_name t with
      | None -> None
bguillaum's avatar
bguillaum committed
194
      | Some v -> Some (conll_string_of_value v)
bguillaum's avatar
bguillaum committed
195

196
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
197
  let get_float_feat feat_name t =
bguillaum's avatar
bguillaum committed
198 199
    match List_.sort_assoc feat_name t with
      | None -> None
bguillaum's avatar
bguillaum committed
200 201
      | Some (Float i) -> Some i
      | Some _ -> Error.build "[Fs.get_float_feat]"
bguillaum's avatar
bguillaum committed
202

203
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
204
  let to_string t = List_.to_string G_feature.to_string "," t
205 206

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

209
  (* ---------------------------------------------------------------------- *)
210 211
  let build domain ast_fs =
    let unsorted = List.map (fun feat -> G_feature.build domain feat) ast_fs in
212 213
    List.sort G_feature.compare unsorted

214
  (* ---------------------------------------------------------------------- *)
215
  let of_conll ?loc domain line =
216
    let raw_list0 =
217 218 219 220
      ("phon", Feature_value.build_value ?loc domain "phon" line.Conll.form)
      :: ("cat", Feature_value.build_value ?loc domain "cat" line.Conll.upos)
      :: (List.map (fun (f,v) -> (f, Feature_value.build_value ?loc domain f v)) line.Conll.feats) in
    let raw_list1 = match line.Conll.xpos with
221
      | "" | "_" -> raw_list0
222
      | s -> ("pos", Feature_value.build_value ?loc domain "pos" s) :: raw_list0 in
223 224
    let raw_list2 = match line.Conll.lemma with
      | "" | "_" -> raw_list1
225
      | s -> ("lemma", Feature_value.build_value ?loc domain "lemma" s) :: raw_list1 in
226 227 228
    List.sort G_feature.compare raw_list2

  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
229 230
  exception Fail_unif
  let unif fs1 fs2 =
231 232 233 234
    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
235

236 237 238 239
      (* 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
240

241
  (* ---------------------------------------------------------------------- *)
242 243
  let get_main ?main_feat t =
    let main_list = match main_feat with
bguillaum's avatar
bguillaum committed
244
    | None -> ["phon"]
bguillaum's avatar
bguillaum committed
245
    | Some string -> Str.split (Str.regexp "\\( *; *\\)\\|#") string in
246 247 248
    let rec loop = function
      | [] -> (None, t)
      | feat_name :: tail ->
249
          match List_.sort_assoc feat_name t with
250
          | Some atom -> (Some (feat_name, atom), List_.sort_remove_assoc feat_name t)
251
          | None -> loop tail in
252
    loop main_list
bguillaum's avatar
bguillaum committed
253

254
  (* ---------------------------------------------------------------------- *)
255 256 257 258 259 260 261 262 263 264 265 266 267 268
  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
269
    let next = List.sort G_feature.print_cmp next in
270 271 272 273
    List.iter
      (fun g_feat ->
        G_feature.buff_dot buff g_feat
      ) next;
bguillaum's avatar
bguillaum committed
274 275 276 277 278

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

279
  (* ---------------------------------------------------------------------- *)
280 281 282
  let to_word ?main_feat t =
    match get_main ?main_feat t with
      | (None, _) -> "#"
283
      | (Some (_,atom), _) -> string_of_value atom
bguillaum's avatar
bguillaum committed
284

285 286 287 288
  (* ---------------------------------------------------------------------- *)
  let escape_sharp s =
    Str.global_replace (Str.regexp "#") "__SHARP__" s

289
  (* ---------------------------------------------------------------------- *)
290 291 292
  let to_dep ?(decorated_feat=("",[])) ?position ?main_feat ?filter t =
    let (pid_name, feat_list) = decorated_feat in

293 294 295
    let (main_opt, sub) = get_main ?main_feat t in
    let sub = List.sort G_feature.print_cmp sub in

296 297 298
    let main = match main_opt with
      | None -> []
      | Some (feat_name, atom) ->
299
        let esc_atom = escape_sharp (string_of_value atom) in
300
        [ if List.mem feat_name (snd decorated_feat)
301 302
          then sprintf "%s:B:yellow" esc_atom
          else esc_atom] in
303 304 305 306 307 308 309 310 311

    let word_list = match pid_name with
      | "" -> main
      | _ -> (sprintf "[%s]:B:yellow" pid_name)::main in

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

bguillaum's avatar
bguillaum committed
312 313
    let last = match (!Global.debug, position) with
      | (true, Some f) -> [(G_feature.to_string ("position", Float f))^":B:lightblue"]
314 315 316 317
      | _ -> [] in

    let lines = List.fold_left
      (fun acc (feat_name, atom) ->
318
        let esc_atom = escape_sharp (G_feature.to_string (decode_feat_name feat_name, atom)) in
319
        if List.mem feat_name (snd decorated_feat)
320
        then (sprintf "%s:B:yellow" esc_atom) :: acc
321 322 323
        else
          match filter with
            | Some filt_list when not (List.mem feat_name filt_list) -> acc
324
            | _ -> esc_atom :: acc
325 326 327 328
      ) last sub in
    let subword = String.concat "#" (List.rev lines) in

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

330
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
331 332 333 334
  let to_conll ?exclude t =
    let reduced_t = match exclude with
      | None -> t
      | Some list -> List.filter (fun (fn,_) -> not (List.mem fn list || fn.[0]='_')) t in
bguillaum's avatar
bguillaum committed
335 336 337 338
    match reduced_t with
      | [] -> "_"
      | _ -> String.concat "|"
        (List.map
339
           (function (fn, String "true") -> fn | (fn, fv) -> (decode_feat_name fn)^"="^(string_of_value fv))
bguillaum's avatar
bguillaum committed
340 341
           reduced_t
        )
bguillaum's avatar
bguillaum committed
342
end (* module G_fs *)
bguillaum's avatar
bguillaum committed
343

bguillaum's avatar
bguillaum committed
344
(* ================================================================================ *)
345
module P_fs = struct
bguillaum's avatar
bguillaum committed
346
  (* list are supposed to be striclty ordered wrt compare *)
347
  type t = P_feature.t list
pj2m's avatar
pj2m committed
348

349
  let empty = []
pj2m's avatar
pj2m committed
350

351 352 353
  let check_position ?param position t =
    try
      match List.assoc "position" t with
bguillaum's avatar
bguillaum committed
354 355 356 357
        | {P_feature.cst=P_feature.Equal pos_list; in_param=[]} -> List.mem (Float position) pos_list
        | {P_feature.cst=P_feature.Different pos_list; in_param=[]} -> not (List.mem (Float position) pos_list)
        | {P_feature.cst=P_feature.Absent} -> false
        | _ -> Error.bug "Position can't be parametrized"
358 359
    with Not_found -> true

360 361
  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
362
    List.sort P_feature.compare unsorted
pj2m's avatar
pj2m committed
363

364 365
  let feat_list t = List.map P_feature.get_name t

366
  let to_string t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
367

368 369 370 371 372
  let to_dep ?filter param_names t =
    let reduced = match filter with
      | None -> t
      | Some l -> List.filter (fun (fn,_) -> List.mem fn l) t in
    List_.to_string (P_feature.to_string ~param_names) "#" reduced
bguillaum's avatar
bguillaum committed
373

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

376
  exception Fail
pj2m's avatar
pj2m committed
377

bguillaum's avatar
bguillaum committed
378 379 380 381
  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
382 383
    let rec loop acc = function
      | [], _ -> acc
pj2m's avatar
pj2m committed
384

bguillaum's avatar
bguillaum committed
385 386 387
      (* 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
388 389 390
      (* 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
391

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

396
      (* Next cases: fn_pat = fn *)
bguillaum's avatar
bguillaum committed
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
      | ((_, {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
412
              | None -> raise Fail
413
              | Some new_param -> loop (Some new_param) (t_pat,t)
bguillaum's avatar
bguillaum committed
414 415 416
            )
          | _ -> 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
417

bguillaum's avatar
bguillaum committed
418
  exception Fail_unif
bguillaum's avatar
bguillaum committed
419
  let unif fs1 fs2 =
bguillaum's avatar
bguillaum committed
420 421 422 423 424 425 426 427
    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
428 429
      | ((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
430 431 432
        with
        | P_feature.Fail_unif -> raise Fail_unif
        | Error.Build (msg,_) -> Error.build "Feature '%s', %s" fn1 msg
bguillaum's avatar
bguillaum committed
433
    in loop (fs1, fs2)
bguillaum's avatar
bguillaum committed
434
end (* module P_fs *)