[486] | 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 |
---|