wrapper/misc.ml

   1 module LexingExt = struct
   2
   3   open Lexing
   4
   5   let new_line lexbuf =
   6     lexbuf.lex_curr_p <- {
   7       lexbuf.lex_curr_p with
   8         pos_bol  = 0;
   9         pos_lnum = lexbuf.lex_curr_p.pos_lnum + 1
  10     }
  11
  12 end
  13
  14 module ListExt = struct
  15
  16   let inv_assoc l = List.map (fun (x, y) -> (y, x)) l
  17
  18   exception EmptyList
  19
  20   let last l = try List.hd (List.rev l) with _ -> raise EmptyList
  21
  22   let cut_last l =
  23     let rec aux l = function
  24       | []      -> raise EmptyList
  25       | [ x ]   -> (x, List.rev l)
  26       | x :: xs -> aux (x :: l) xs
  27     in
  28     aux [] l
  29
  30   let multi_set_of_list l =
  31     let h = Hashtbl.create 13 in
  32     let incr_occ x =
  33       let o = try Hashtbl.find h x with Not_found -> 0 in
  34       Hashtbl.replace h x (o + 1)
  35     in
  36     List.iter incr_occ l;
  37     Hashtbl.fold (fun k v accu -> (k, v) :: accu) h []
  38
  39   let hashtbl_of_assoc l =
  40     let h = Hashtbl.create 13 in
  41     List.iter (fun (k, v) -> Hashtbl.add h k v) l;
  42     h
  43
  44   exception Conflict
  45   let assoc_union l1 l2 =
  46     let h1 = hashtbl_of_assoc l1 in
  47     l1
  48     @ List.filter
  49       (fun (k, v1) ->
  50         try
  51           let v2 = Hashtbl.find h1 k in
  52           if v1 <> v2 then raise Conflict;
  53           false
  54         with _ -> true) l2
  55
  56   let assoc_diff l1 l2 =
  57     let h1 = hashtbl_of_assoc l1 in
  58     let h2 = hashtbl_of_assoc l2 in
  59     let diff h1 h2 f =
  60       Hashtbl.fold
  61         (fun k v1 accu ->
  62           let v2 =
  63             try Some (Hashtbl.find h2 k)
  64             with Not_found -> None
  65           in
  66           if Some v1 <> v2 then
  67             if f then
  68               (k, (Some v1, v2)) :: accu
  69             else
  70               (k, (v2, Some v1)) :: accu
  71           else
  72             accu)
  73         h1 []
  74     in
  75     let d1 = diff h1 h2 true in
  76     let d2 = diff h2 h1 false in
  77     try assoc_union d1 d2
  78     with Conflict -> assert false
  79
  80   let transitive_forall2 p l =
  81     let rec aux = function
  82       | []  -> None
  83       | [x] -> None
  84       | x1 :: ((x2 :: _) as xs) ->
  85         if not (p x1 x2) then Some (x1, x2) else aux xs
  86     in
  87     aux l
  88
  89 end
  90
  91 module ArgExt = struct
  92
  93   let extra_doc s = "", Arg.Unit ignore, s
  94
  95 end
  96
  97 module SysExt = struct
  98
  99   let safe_remove name =
 100     try Sys.remove name with Sys_error _ -> ()
 101
 102   let rec alternative name =
 103     if not (Sys.file_exists name) then
 104       name
 105     else
 106       let dirname = Filename.dirname name in
 107       let filename = Filename.basename name in
 108       let r = Str.regexp "\\([0-9]+\\)-\\(.*\\)" in
 109       let filename =
 110         if Str.string_match r filename 0 then
 111           let i = int_of_string (Str.matched_group 1 filename) in
 112           Printf.sprintf "%02d-%s" (i + 1) (Str.matched_group 2 filename)
 113         else
 114           "01-" ^ filename
 115       in
 116       alternative (Filename.concat dirname filename)
 117
 118 end
 119
 120
 121 let fresh_file prefix suffix =
 122   let string_of_complement = function
 123     | None -> ""
 124     | Some i -> string_of_int i in
 125   let next_complement = function
 126     | None -> Some 0
 127     | Some i -> Some (i+1) in
 128   let rec aux complement =
 129     let filename = prefix ^ (string_of_complement complement) ^ suffix in
 130     if not (Sys.file_exists filename) then filename
 131     else aux (next_complement complement) in
 132   aux None
 133
 134 let exists_exts base exts =
 135   let f res ext = res || (Sys.file_exists (base ^ ext)) in
 136   List.fold_left f false exts
 137
 138 let fresh_base base exts =
 139   let string_of_complement = function
 140     | None -> ""
 141     | Some i -> string_of_int i in
 142   let next_complement = function
 143     | None -> Some 0
 144     | Some i -> Some (i+1) in
 145   let rec aux complement =
 146     let new_base = base ^ (string_of_complement complement) in
 147     if not (exists_exts new_base exts) then new_base
 148     else aux (next_complement complement) in
 149   aux None
 150
 151 let rec repeat n f a =
 152   if n = 0 then a
 153   else repeat (n-1) f (f a)