grew_base.ml 18.6 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
open Log
bguillaum's avatar
bguillaum committed
12
open Printf
pj2m's avatar
pj2m committed
13

bguillaum's avatar
bguillaum committed
14 15
module String_set = Set.Make (String)
module String_map = Map.Make (String)
pj2m's avatar
pj2m committed
16

bguillaum's avatar
bguillaum committed
17 18
module Int_set = Set.Make (struct type t = int let compare = Pervasives.compare end)
module Int_map = Map.Make (struct type t = int let compare = Pervasives.compare end)
19

bguillaum's avatar
bguillaum committed
20 21
(* ================================================================================ *)
module Loc = struct
Bruno Guillaume's avatar
Bruno Guillaume committed
22 23 24 25 26 27 28 29 30 31 32 33 34
  type t = string option * int option

  let empty = (None, None)
  let file f = (Some f, None)
  let file_line f l = (Some f, Some l)
  let file_opt_line fo l = (fo, Some l)
  let file_opt_line_opt fo lo = (fo, lo)

  let to_string = function
  | (Some file, Some line) -> sprintf "[file: %s, line: %d]" (Filename.basename file) line
  | (None, Some line) -> sprintf "[line: %d]" line
  | (Some file, None) -> sprintf "[file: %s]" (Filename.basename file)
  | (None, None) -> ""
bguillaum's avatar
bguillaum committed
35 36 37 38 39 40
end (* module Loc *)

(* ================================================================================ *)
module Error = struct

  exception Build of (string * Loc.t option)
bguillaum's avatar
Typos  
bguillaum committed
41
  let build_ ?loc message = raise (Build (message, loc))
bguillaum's avatar
bguillaum committed
42 43
  let build ?loc = Printf.ksprintf (build_ ?loc)

44
  exception Run of (string * Loc.t option)
bguillaum's avatar
bguillaum committed
45 46 47
  let run_ ?loc message = raise (Run (message, loc))
  let run ?loc = Printf.ksprintf (run_ ?loc)

48
  exception Bug of (string * Loc.t option)
bguillaum's avatar
bguillaum committed
49 50
  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
51 52 53 54 55 56

  exception Parse of (string * Loc.t option)
  let parse_ ?loc message = raise (Parse (message, loc))
  let parse ?loc = Printf.ksprintf (parse_ ?loc)


bguillaum's avatar
bguillaum committed
57
end (* module Error *)
58

bguillaum's avatar
bguillaum committed
59 60 61 62 63
(* ================================================================================ *)
module String_ = struct

  let to_float string =
    try float_of_string string
bguillaum's avatar
bguillaum committed
64 65 66
    with _ ->
      try float_of_string (Str.global_replace (Str.regexp "\\.") "," string)
      with _ -> Error.build "[String_.to_float] cannot convert '%s'" string
67

bguillaum's avatar
bguillaum committed
68
  let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
69

70
  let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
bguillaum's avatar
bguillaum committed
71 72 73 74 75 76

  let rm_peripheral_white s =
    s
    |> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "")
    |> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "")

77
  let re_match re s = (Str.string_match re s 0) && (Str.matched_string s = s)
78

bguillaum's avatar
bguillaum committed
79
end (* module String_ *)
80

bguillaum's avatar
bguillaum committed
81 82 83 84 85 86 87 88
(* ================================================================================ *)
module Dot = struct
  let to_png_file dot output_file =
    let temp_file_name,out_ch = Filename.open_temp_file ~mode:[Open_rdonly;Open_wronly;Open_text] "grewui_" ".dot" in
    fprintf out_ch "%s" dot;
    close_out out_ch;
    ignore(Sys.command(sprintf "dot -Tpng -o %s %s " output_file temp_file_name))
end (* module Dot *)
89

bguillaum's avatar
bguillaum committed
90 91 92 93 94 95 96
(* ================================================================================ *)
module File = struct
  let write data name =
    let out_ch = open_out name in
    fprintf out_ch "%s\n" data;
    close_out out_ch

bguillaum's avatar
bguillaum committed
97
  let read file =
bguillaum's avatar
bguillaum committed
98
    let in_ch = open_in file in
Bruno Guillaume's avatar
Bruno Guillaume committed
99
    try
100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
      (* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
      (match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);

      let rev_lines = ref [] in
      try
        while true do
          let line = input_line in_ch in
          if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
          then ()
          else rev_lines := line :: !rev_lines
        done; assert false
      with End_of_file ->
        close_in in_ch;
        List.rev !rev_lines
    with End_of_file -> [] (* if the file is empty, input_byte raises End_of_file *)
bguillaum's avatar
bguillaum committed
115

bguillaum's avatar
bguillaum committed
116

bguillaum's avatar
bguillaum committed
117 118
  (* [read_ln file] returns a list of couples (line_num, line). Blank lines and lines starting with '%' are ignored. *)
  let read_ln file =
bguillaum's avatar
bguillaum committed
119
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
120 121 122
    (* if the input file contains an UTF-8 byte order mark (EF BB BF), skip 3 bytes, else get back to 0 *)
    (match input_byte in_ch with 0xEF -> seek_in in_ch 3 | _ -> seek_in in_ch 0);

bguillaum's avatar
bguillaum committed
123 124 125 126 127 128 129 130 131 132
    let cpt = ref 0 in
    let rev_lines = ref [] in
    try
      while true do
        let line = input_line in_ch in
        incr cpt;
        if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
        then ()
        else rev_lines := (!cpt, line) :: !rev_lines
      done; assert false
bguillaum's avatar
bguillaum committed
133
    with End_of_file ->
bguillaum's avatar
bguillaum committed
134 135
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
136 137 138 139 140 141

  let load file =
    let ch = open_in file in
    let buff = Buffer.create 32 in
    try
      while true do
Bruno Guillaume's avatar
Bruno Guillaume committed
142
        let next = input_line ch in
bguillaum's avatar
bguillaum committed
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
        Printf.bprintf buff "%s\n" next
      done; assert false
    with End_of_file ->
      close_in ch;
      Buffer.contents buff

  exception Found of int
  let get_suffix file_name =
  let len = String.length file_name in
    try
      for i = len-1 downto 0 do
        if file_name.[i] = '.'
        then raise (Found i)
      done;
      None
    with
    | Found i -> Some (String.sub file_name i (len-i))
bguillaum's avatar
bguillaum committed
160 161
 end (* module File *)

bguillaum's avatar
bguillaum committed
162
(* ================================================================================ *)
pj2m's avatar
pj2m committed
163 164 165
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
166
      (if low > high
pj2m's avatar
pj2m committed
167 168
      then false
      else
169 170 171 172
        match (low+high)/2 with
        | middle when array.(middle) = elt -> true
        | middle when array.(middle) < elt -> loop (middle+1) high
        | middle -> loop low (middle - 1)
bguillaum's avatar
bguillaum committed
173
      ) in
pj2m's avatar
pj2m committed
174 175 176 177 178 179 180 181 182
    loop 0 ((Array.length array) - 1)

  (* dichotomic search in a sorted array *)
  let dicho_find elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when array.(middle) = elt -> middle
      | middle when array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
183
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
184
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
185

pj2m's avatar
pj2m committed
186 187 188 189 190 191
  let dicho_find_assoc elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when fst array.(middle) = elt -> middle
      | middle when fst array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
192
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
193
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
194
end (* module Array_ *)
pj2m's avatar
pj2m committed
195

bguillaum's avatar
bguillaum committed
196
(* ================================================================================ *)
pj2m's avatar
pj2m committed
197
module List_ = struct
198 199 200 201 202
  let rec cut size = function
    | [] -> []
    | _ when size=0 -> []
    | x::t -> x:: (cut (size-1) t)

bguillaum's avatar
bguillaum committed
203 204 205 206 207
  let rec set position elt = function
    | [] -> failwith "List_.set"
    | _::t when position = 0 -> elt::t
    | x::t -> x:: (set (position-1) elt t)

pj2m's avatar
pj2m committed
208 209 210 211 212
  let rec rm elt = function
    | [] -> raise Not_found
    | x::t when x=elt -> t
    | x::t -> x::(rm elt t)

213
  let index x l =
bguillaum's avatar
bguillaum committed
214 215 216 217 218 219
    let rec loop i = function
    | [] -> None
    | h::t when h=x -> Some i
    | _::t -> loop (i+1) t in
    loop 0 l

pj2m's avatar
pj2m committed
220 221 222 223 224 225 226
  let rec opt = function
    | [] -> []
    | None :: t -> opt t
    | Some x :: t -> x :: (opt t)

  let rec opt_map f = function
    | [] -> []
bguillaum's avatar
bguillaum committed
227
    | x::t ->
228 229 230
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
231

bguillaum's avatar
bguillaum committed
232 233 234 235 236 237 238 239 240
  let rec try_map exc fct = function
    | [] -> []
    | x::t -> let tail =  try_map exc fct t in
      try (fct x)::tail
      with e ->
        if e = exc
        then tail
        else raise e

pj2m's avatar
pj2m committed
241 242 243 244
  let rec flat_map f = function
    | [] -> []
    | x::t -> (f x)@(flat_map f t)

bguillaum's avatar
bguillaum committed
245 246
  let opt_mapi fct =
    let rec loop i = function
247 248 249 250 251 252 253
      | [] -> []
      | h::t ->
        match fct i h with
          | None -> loop (i+1) t
          | Some res -> res :: (loop (i+1) t)
    in loop 0

pj2m's avatar
pj2m committed
254
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
255 256
    fst
      (List.fold_left
257 258
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
259 260 261 262 263 264
      )

  let rec remove elt = function
    | [] -> raise Not_found
    | a::tail when a = elt -> tail
    | a::tail -> a::(remove elt tail)
265

pj2m's avatar
pj2m committed
266 267 268
  let to_string string_of_item sep = function
    | [] -> ""
    | h::t -> List.fold_left (fun acc elt -> acc ^ sep ^ (string_of_item elt)) (string_of_item h) t
269

270 271 272 273
  let rev_to_string string_of_item sep = function
    | [] -> ""
    | h::t -> List.fold_left (fun acc elt -> (string_of_item elt) ^ sep ^ acc) (string_of_item h) t

pj2m's avatar
pj2m committed
274 275
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
276
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
277 278 279 280 281 282
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
283
    | h::t (* when elt>h *) -> sort_mem elt t
284 285 286 287 288

  let rec sort_assoc key = function
    | [] -> None
    | (k,_)::_ when key<k -> None
    | (k,_)::t when key>k -> sort_assoc key t
bguillaum's avatar
bguillaum committed
289
    | (_,v)::_ -> Some v
290 291 292 293 294 295 296

  let rec sort_remove_assoc key = function
    | [] -> []
    | (k,_)::_ as t when key<k -> t
    | (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
    | (_,v)::t -> t

297 298 299 300 301 302 303 304 305 306
  let rec sort_remove_assoc_opt key = function
    | [] -> None
    | (k,_)::_ when key<k -> None
    | (k,v)::t when key>k ->
      (match sort_remove_assoc_opt key t with
        | None -> None
        | Some new_t -> Some ((k,v) :: new_t)
      )
    | (_,v)::t (* key = k *) -> Some t

pj2m's avatar
pj2m committed
307 308
  exception Usort

bguillaum's avatar
bguillaum committed
309
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
310 311 312 313 314 315 316 317 318 319
    | [] -> raise Not_found
    | x::t when key < x -> raise Not_found
    | x::t when key = x -> t
    | x::t -> x::(usort_remove key t)

  let usort_insert ?(compare=Pervasives.compare) elt l =
    let rec loop = function
      | [] -> [elt]
      | x::t when compare elt x < 0 -> elt :: x :: t
      | x::t when compare elt x > 0 -> x :: (loop t)
320
      | _ -> raise Usort in
pj2m's avatar
pj2m committed
321
    try Some (loop l) with Usort -> None
322

bguillaum's avatar
bguillaum committed
323
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
324 325 326 327
    match (l1,l2) with
    | [], _ | _, [] -> true
    | h1::t1 , h2::t2 when h1<h2 -> sort_disjoint t1 l2
    | h1::t1 , h2::t2 when h1>h2 -> sort_disjoint l1 t2
bguillaum's avatar
bguillaum committed
328
    | _ -> false
329

bguillaum's avatar
bguillaum committed
330
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
331 332 333 334 335
    let rec loop = function
      | [], _ | _, [] -> true
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> false in
bguillaum's avatar
bguillaum committed
336
    loop (l1,l2)
pj2m's avatar
pj2m committed
337

bguillaum's avatar
bguillaum committed
338
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
339 340 341 342 343 344
    let rec loop = function
      | [], _ | _, [] -> []
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
345 346

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
347 348 349 350 351 352 353 354
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> x2 :: loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)


pj2m's avatar
pj2m committed
355
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
356
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
357 358 359 360 361 362
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when (compare x1 x2) < 0 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when (compare x1  x2) > 0 -> x2 :: loop (x1::t1, t2)
      | _ -> raise Not_disjoint in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
363 364

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
365 366 367 368 369 370 371
    let rec loop = function
      | [], l -> true
      | l, [] -> false
      | x1::t1, x2::t2 when x1 < x2 -> false
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
372 373

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
374 375 376 377 378 379 380 381
    let rec loop = function
      | [], l -> failwith "[sort_included_diff] not included"
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> failwith "[sort_included_diff] not included"
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

bguillaum's avatar
bguillaum committed
382
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
383 384 385 386 387 388 389 390
    let rec loop = function
      | [], l -> []
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

bguillaum's avatar
bguillaum committed
391 392 393 394 395 396 397
  let prev_next_iter fct list =
    let int_fct prev next elt = fct ?prev ?next elt in
    let rec loop prev = function
      | [] -> ()
      | [last] -> int_fct prev None last
      | head::snd::tail -> int_fct prev (Some snd) head; loop (Some head) (snd::tail)
    in loop None list
bguillaum's avatar
bguillaum committed
398
end (* module List_ *)
pj2m's avatar
pj2m committed
399

bguillaum's avatar
bguillaum committed
400
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
401 402 403 404
module type OrderedType = sig
  type t
  val compare: t -> t -> int
end (* module type OrderedType *)
405

bguillaum's avatar
bguillaum committed
406
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
407 408
module type S = sig
  type key
409

bguillaum's avatar
bguillaum committed
410
  type +'a t
411

bguillaum's avatar
bguillaum committed
412
  val empty: 'a t
413

bguillaum's avatar
bguillaum committed
414 415
  (* an empty list returned if the key is undefined *)
  val assoc: key -> 'a t -> 'a list
416

bguillaum's avatar
bguillaum committed
417
  val is_empty: 'a t -> bool
418

bguillaum's avatar
bguillaum committed
419
  val to_string: ('a -> string) -> 'a t -> string
420

bguillaum's avatar
bguillaum committed
421
  val iter: (key -> 'a -> unit) -> 'a t -> unit
422

Bruno Guillaume's avatar
Bruno Guillaume committed
423
  val add_opt: key -> 'a -> 'a t -> 'a t option
424

425 426
  val replace: key -> 'a list -> 'a t -> 'a t

bguillaum's avatar
bguillaum committed
427
  val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
428

bguillaum's avatar
bguillaum committed
429 430
  (* raise Not_found if no (key,elt) *)
  val remove: key -> 'a -> 'a t -> 'a t
Bruno Guillaume's avatar
Bruno Guillaume committed
431
  val remove_opt: key -> 'a -> 'a t -> 'a t option
432

bguillaum's avatar
bguillaum committed
433 434
  (* raise Not_found if no (key,elt) *)
  val remove_key: key -> 'a t -> 'a t
435

bguillaum's avatar
bguillaum committed
436 437
  (* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
  val mem: key -> 'a -> 'a t -> bool
438

bguillaum's avatar
bguillaum committed
439 440
  (* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
  val mem_key: key -> 'a t -> bool
441

bguillaum's avatar
bguillaum committed
442 443
  exception Not_disjoint
  val disjoint_union: 'a t -> 'a t -> 'a t
444

bguillaum's avatar
bguillaum committed
445 446
  exception Duplicate
  val merge_key: key -> key -> 'a t -> 'a t
447

bguillaum's avatar
bguillaum committed
448
  val exists: (key -> 'a -> bool) -> 'a t -> bool
449

bguillaum's avatar
bguillaum committed
450 451
  val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
452

bguillaum's avatar
bguillaum committed
453
(* ================================================================================ *)
454 455 456 457 458 459 460 461 462 463 464
module Massoc_make (Ord: OrderedType) = struct
  module M = Map.Make (Ord)

  type key = Ord.t

  type 'a t = ('a list) M.t

  let empty = M.empty

  let is_empty t = (t=empty)

bguillaum's avatar
bguillaum committed
465 466
  let assoc key t =
    try M.find key t
467 468
    with Not_found -> []

469
  let to_string _ _ = failwith "Not implemented"
470 471

  let iter fct t =
bguillaum's avatar
bguillaum committed
472
    M.iter
473 474 475
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

476 477
  let replace = M.add

Bruno Guillaume's avatar
Bruno Guillaume committed
478
  let add_opt key elt t =
479 480
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
481
      match List_.usort_insert elt list with
482 483 484 485 486 487 488
        | Some l -> Some (M.add key l t)
        | None -> None
    with Not_found -> Some (M.add key [elt] t)

  let fold fct init t =
    M.fold
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
489
        List.fold_left
490 491 492 493
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
494

495 496 497 498 499 500
  (* Not found raised in the value is not defined *)
  let remove key value t =
    match M.find key t with
      | [one] when one=value -> M.remove key t
      | old -> M.add key (List_.usort_remove value old) t

Bruno Guillaume's avatar
Bruno Guillaume committed
501 502 503 504
  let remove_opt key value t =
    try Some (remove key value t)
    with Not_found -> None

505
  let remove_key key t = M.remove key t
506 507 508 509 510 511 512 513 514 515

  let rec mem key value t =
    try List_.sort_mem value (M.find key t)
    with Not_found -> false

  let rec mem_key key t = M.mem key t

  exception Not_disjoint

  let disjoint_union t1 t2 =
bguillaum's avatar
bguillaum committed
516
    M.fold
517
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
518
        try
519 520 521 522 523 524 525 526
          let old = M.find key acc in
          M.add key (List_.sort_disjoint_union list old) acc
        with
          | Not_found -> M.add key list acc
          | List_.Not_disjoint -> raise Not_disjoint
      ) t1 t2

  exception Duplicate
bguillaum's avatar
bguillaum committed
527

528 529 530 531 532
  let merge_key i j t =
    try
      let old_i = M.find i t in
      let old_j = try M.find j t with Not_found -> [] in
      M.add j (List_.sort_disjoint_union old_i old_j) (M.remove i t)
bguillaum's avatar
bguillaum committed
533
    with
534 535 536
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
537 538 539 540 541 542 543 544 545 546 547
  exception True
  let exists fct t =
    try
      M.iter
        (fun key list ->
          if List.exists (fun elt -> fct key elt) list
          then raise True
        ) t;
      false
    with True -> true

548 549 550 551 552 553
  let rename mapping t =
    M.fold
      (fun key value acc ->
        let new_key = try List.assoc key mapping with Not_found -> key in
        M.add new_key value acc
      ) t M.empty
554 555
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
556
(* ================================================================================ *)
pj2m's avatar
pj2m committed
557 558 559
module Id = struct
  type t = int

bguillaum's avatar
bguillaum committed
560 561 562 563
  type 'a gtable = 'a array * ('a -> string)

  let gbuild ?(loc:Loc.t option) key (table,conv) =
    try Array_.dicho_find key table
564
    with Not_found -> Error.build ?loc "[Id.gbuild] Identifier '%s' not found" (conv key)
pj2m's avatar
pj2m committed
565

bguillaum's avatar
bguillaum committed
566 567 568 569 570 571 572 573
  let gbuild_opt key (table, _) =
    try Some (Array_.dicho_find key table)
    with Not_found -> None

  type name = string
  type table = string array
  let build ?(loc:Loc.t option) key table =
    try Array_.dicho_find key table
574
    with Not_found -> Error.build ?loc "[Id.build] Identifier '%s' not found" key
pj2m's avatar
pj2m committed
575

bguillaum's avatar
bguillaum committed
576 577
  let build_opt key table =
    try Some (Array_.dicho_find key table)
pj2m's avatar
pj2m committed
578
    with Not_found -> None
579 580 581 582 583 584 585 586 587 588 589 590 591 592

  let get_float name =
    try
      let len = String.length name in
      let index = Str.search_forward (Str.regexp "[0-9]") name 0 in
      let sub = String.sub name index (len-index) in
      try Some (float_of_string sub) with _ -> None
    with Not_found -> None

  let grewpy_compare name1 name2 =
    match (get_float name1, get_float name2) with
    | Some f1, Some f2 -> Pervasives.compare f1 f2
    | _ -> Pervasives.compare name1 name2

bguillaum's avatar
bguillaum committed
593
end (* module Id *)
594

bguillaum's avatar
bguillaum committed
595
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
596 597 598
(* copy from leopar *)
module Timeout = struct
  exception Stop
599

bguillaum's avatar
bguillaum committed
600 601
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
602

bguillaum's avatar
bguillaum committed
603 604 605
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
606
    match !timeout with
bguillaum's avatar
bguillaum committed
607 608 609 610
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
611
end (* module Timeout *)
bguillaum's avatar
bguillaum committed
612 613 614

(* ================================================================================ *)
module Global = struct
Bruno Guillaume's avatar
Bruno Guillaume committed
615
  let current_loc = ref Loc.empty
bguillaum's avatar
bguillaum committed
616
  let label_flag = ref false
bguillaum's avatar
bguillaum committed
617

Bruno Guillaume's avatar
Bruno Guillaume committed
618 619 620 621 622 623
  let get_loc () = !current_loc
  let loc_string () = Loc.to_string !current_loc

  let new_file filename =
    current_loc := (Some filename, Some 1);
    label_flag := false
Bruno Guillaume's avatar
Bruno Guillaume committed
624

Bruno Guillaume's avatar
Bruno Guillaume committed
625 626
  let new_string () =
    current_loc := (None , Some 1);
Bruno Guillaume's avatar
Bruno Guillaume committed
627
    label_flag := false
Bruno Guillaume's avatar
Bruno Guillaume committed
628 629 630 631 632 633

  let new_line () = match !current_loc with
  | (_,None) -> ()
  | (fo, Some l) -> current_loc := (fo, Some (l+1))

  let debug = ref false
Bruno Guillaume's avatar
Bruno Guillaume committed
634
  let strict = ref false
bguillaum's avatar
bguillaum committed
635
end