grew_base.ml 17.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                                                   *)
(**********************************************************************************)

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 22 23
(* ================================================================================ *)
module Loc = struct
  type t = string * int

bguillaum's avatar
bguillaum committed
24
  let file_line f l = (f,l)
25 26 27
  let file_opt_line fo l = match fo with
  | Some f -> file_line f l
  | None -> file_line "No_file" l
bguillaum's avatar
bguillaum committed
28 29 30 31

  let file f = (f, -1)

  let to_string (file,line) = sprintf "[file: %s, line: %d]" (Filename.basename file) line
32
  let to_line (_,line) = line
bguillaum's avatar
bguillaum committed
33 34 35 36 37 38 39 40 41 42 43 44 45

  let opt_set_line line = function
    | None -> None
    | Some (file,_) -> Some (file, line)
end (* module Loc *)

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

  exception Build of (string * Loc.t option)
  exception Run of (string * Loc.t option)
  exception Bug of (string * Loc.t option)

bguillaum's avatar
Typos  
bguillaum committed
46
  let build_ ?loc message = raise (Build (message, loc))
bguillaum's avatar
bguillaum committed
47 48 49 50 51 52 53 54
  let build ?loc = Printf.ksprintf (build_ ?loc)

  let run_ ?loc message = raise (Run (message, loc))
  let run ?loc = Printf.ksprintf (run_ ?loc)

  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
end (* module Error *)
55

bguillaum's avatar
bguillaum committed
56 57 58 59 60
(* ================================================================================ *)
module String_ = struct

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

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

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

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

74
  let re_match re s = (Str.string_match re s 0) && (Str.matched_string s = s)
75

bguillaum's avatar
bguillaum committed
76
end (* module String_ *)
77

bguillaum's avatar
bguillaum committed
78 79 80 81 82 83 84 85
(* ================================================================================ *)
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 *)
86

bguillaum's avatar
bguillaum committed
87 88 89 90 91 92 93
(* ================================================================================ *)
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
94
  let read file =
bguillaum's avatar
bguillaum committed
95
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
96 97 98
    (* 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
99 100 101 102 103 104 105 106
    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
bguillaum's avatar
bguillaum committed
107
    with End_of_file ->
bguillaum's avatar
bguillaum committed
108 109
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
110

bguillaum's avatar
bguillaum committed
111 112
  (* [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
113
    let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
114 115 116
    (* 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
117 118 119 120 121 122 123 124 125 126
    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
127
    with End_of_file ->
bguillaum's avatar
bguillaum committed
128 129
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153

  let load file =
    let ch = open_in file in
    let buff = Buffer.create 32 in
    try
      while true do
        let next = input_line ch in 
        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
154 155
 end (* module File *)

bguillaum's avatar
bguillaum committed
156
(* ================================================================================ *)
pj2m's avatar
pj2m committed
157 158 159
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
160
      (if low > high
pj2m's avatar
pj2m committed
161 162
      then false
      else
163 164 165 166
        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
167
      ) in
pj2m's avatar
pj2m committed
168 169 170 171 172 173 174 175 176
    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
177
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
178
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
179

pj2m's avatar
pj2m committed
180 181 182 183 184 185
  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
186
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
187
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
188
end (* module Array_ *)
pj2m's avatar
pj2m committed
189

bguillaum's avatar
bguillaum committed
190
(* ================================================================================ *)
pj2m's avatar
pj2m committed
191
module List_ = struct
192 193 194 195 196
  let rec cut size = function
    | [] -> []
    | _ when size=0 -> []
    | x::t -> x:: (cut (size-1) t)

bguillaum's avatar
bguillaum committed
197 198 199 200 201
  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
202 203 204 205 206
  let rec rm elt = function
    | [] -> raise Not_found
    | x::t when x=elt -> t
    | x::t -> x::(rm elt t)

207
  let index x l =
bguillaum's avatar
bguillaum committed
208 209 210 211 212 213
    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
214 215 216 217 218 219 220
  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
221
    | x::t ->
222 223 224
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
225

bguillaum's avatar
bguillaum committed
226 227 228 229 230 231 232 233 234
  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
235 236 237 238
  let rec flat_map f = function
    | [] -> []
    | x::t -> (f x)@(flat_map f t)

bguillaum's avatar
bguillaum committed
239 240
  let opt_mapi fct =
    let rec loop i = function
241 242 243 244 245 246 247
      | [] -> []
      | 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
248
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
249 250
    fst
      (List.fold_left
251 252
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
253 254 255 256 257 258
      )

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

pj2m's avatar
pj2m committed
260 261 262
  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
263

264 265 266 267
  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
268 269
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
270
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
271 272 273 274 275 276
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
277
    | h::t (* when elt>h *) -> sort_mem elt t
278 279 280 281 282

  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
283
    | (_,v)::_ -> Some v
284 285 286 287 288 289 290

  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

pj2m's avatar
pj2m committed
291 292
  exception Usort

bguillaum's avatar
bguillaum committed
293
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
294 295 296 297 298 299 300 301 302 303
    | [] -> 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)
304
      | _ -> raise Usort in
pj2m's avatar
pj2m committed
305
    try Some (loop l) with Usort -> None
306

bguillaum's avatar
bguillaum committed
307
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
308 309 310 311
    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
312
    | _ -> false
313

bguillaum's avatar
bguillaum committed
314
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
315 316 317 318 319
    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
320
    loop (l1,l2)
pj2m's avatar
pj2m committed
321

bguillaum's avatar
bguillaum committed
322
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
323 324 325 326 327 328
    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
329 330

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
331 332 333 334 335 336 337 338
    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
339
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
340
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
341 342 343 344 345 346
    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
347 348

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
349 350 351 352 353 354 355
    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
356 357

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
358 359 360 361 362 363 364 365
    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
366
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
367 368 369 370 371 372 373 374
    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
375 376 377 378 379 380 381
  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
382
end (* module List_ *)
pj2m's avatar
pj2m committed
383

bguillaum's avatar
bguillaum committed
384
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
385 386 387 388
module type OrderedType = sig
  type t
  val compare: t -> t -> int
end (* module type OrderedType *)
389

bguillaum's avatar
bguillaum committed
390
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
391 392
module type S = sig
  type key
393

bguillaum's avatar
bguillaum committed
394
  type +'a t
395

bguillaum's avatar
bguillaum committed
396
  val empty: 'a t
397

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

bguillaum's avatar
bguillaum committed
401
  val is_empty: 'a t -> bool
402

bguillaum's avatar
bguillaum committed
403
  val to_string: ('a -> string) -> 'a t -> string
404

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

bguillaum's avatar
bguillaum committed
407
  val add: key -> 'a -> 'a t -> 'a t option
408

409 410
  val replace: key -> 'a list -> 'a t -> 'a t

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

bguillaum's avatar
bguillaum committed
413 414
  (* raise Not_found if no (key,elt) *)
  val remove: key -> 'a -> 'a t -> 'a t
415

bguillaum's avatar
bguillaum committed
416 417
  (* raise Not_found if no (key,elt) *)
  val remove_key: key -> 'a t -> 'a t
418

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

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

bguillaum's avatar
bguillaum committed
425 426
  exception Not_disjoint
  val disjoint_union: 'a t -> 'a t -> 'a t
427

bguillaum's avatar
bguillaum committed
428 429
  exception Duplicate
  val merge_key: key -> key -> 'a t -> 'a t
430

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

bguillaum's avatar
bguillaum committed
433 434
  val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
435

bguillaum's avatar
bguillaum committed
436
(* ================================================================================ *)
437 438 439 440 441 442 443 444 445 446 447
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
448 449
  let assoc key t =
    try M.find key t
450 451
    with Not_found -> []

452
  let to_string _ _ = failwith "Not implemented"
453 454

  let iter fct t =
bguillaum's avatar
bguillaum committed
455
    M.iter
456 457 458
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

459 460
  let replace = M.add

bguillaum's avatar
bguillaum committed
461
  let add key elt t =
462 463
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
464
      match List_.usort_insert elt list with
465 466 467 468 469 470 471
        | 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
472
        List.fold_left
473 474 475 476
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
477

478 479 480 481 482 483
  (* 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

484
  let remove_key key t = M.remove key t
485 486 487 488 489 490 491 492 493 494

  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
495
    M.fold
496
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
497
        try
498 499 500 501 502 503 504 505
          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
506

507 508 509 510 511
  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
512
    with
513 514 515
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
516 517 518 519 520 521 522 523 524 525 526
  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

527 528 529 530 531 532
  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
533 534
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
535
(* ================================================================================ *)
pj2m's avatar
pj2m committed
536 537 538
module Id = struct
  type t = int

bguillaum's avatar
bguillaum committed
539 540 541 542 543
  type 'a gtable = 'a array * ('a -> string)

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

bguillaum's avatar
bguillaum committed
545 546 547 548 549 550 551 552 553
  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
    with Not_found -> Error.build ?loc "Identifier '%s' not found" key
pj2m's avatar
pj2m committed
554

bguillaum's avatar
bguillaum committed
555 556
  let build_opt key table =
    try Some (Array_.dicho_find key table)
pj2m's avatar
pj2m committed
557
    with Not_found -> None
bguillaum's avatar
bguillaum committed
558
end (* module Id *)
559

bguillaum's avatar
bguillaum committed
560
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
561 562 563
(* copy from leopar *)
module Timeout = struct
  exception Stop
564

bguillaum's avatar
bguillaum committed
565 566
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
567

bguillaum's avatar
bguillaum committed
568 569 570
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
571
    match !timeout with
bguillaum's avatar
bguillaum committed
572 573 574 575
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
576
end (* module Timeout *)
bguillaum's avatar
bguillaum committed
577 578 579 580

(* ================================================================================ *)
module Global = struct
  let current_file = ref "Not a file"
bguillaum's avatar
bguillaum committed
581
  let current_line = ref 1
bguillaum's avatar
bguillaum committed
582
  let label_flag = ref false
bguillaum's avatar
bguillaum committed
583
  let debug = ref false
bguillaum's avatar
bguillaum committed
584 585 586

  let init file =
    current_file := file;
bguillaum's avatar
bguillaum committed
587
    current_line := 1;
bguillaum's avatar
bguillaum committed
588
    label_flag := false;
bguillaum's avatar
bguillaum committed
589
end