List.flatten (List.map f l)
;;
+let list_mapi f l =
+ let rec aux k = function
+ | [] -> []
+ | h::tl -> f h k :: aux (k+1) tl
+ in
+ aux 0 l
+;;
+
+let list_mapi_acc f a l =
+ let rec aux k a res = function
+ | [] -> a, List.rev res
+ | h::tl -> let a,h = f h k a in aux (k+1) a (h::res) tl
+ in
+ aux 0 a [] l
+;;
+
+let list_index p =
+ let rec aux n =
+ function
+ [] -> None
+ | he::_ when p he -> Some (n,he)
+ | _::tl -> aux (n + 1) tl
+ in
+ aux 0
+;;
+
+let rec list_iter_default2 f l1 def l2 =
+ match l1,l2 with
+ | [], _ -> ()
+ | a::ta, b::tb -> f a b; list_iter_default2 f ta def tb
+ | a::ta, [] -> f a def; list_iter_default2 f ta def []
+;;
+
+let rec list_forall_default3 f l1 l2 def l3 =
+ match l1,l2,l3 with
+ | [], [], _ -> true
+ | [], _, _
+ | _, [], _ -> raise (Invalid_argument "list_forall_default3")
+ | a::ta, b::tb, c::tc -> f a b c && list_forall_default3 f ta tb def tc
+ | a::ta, b::tb, [] -> f a b def && list_forall_default3 f ta tb def []
+;;
+
+exception FailureAt of int;;
+
+let list_forall_default3_var f l1 l2 def l3 =
+ let rec aux f l1 l2 def l3 i =
+ match l1,l2,l3 with
+ | [], [], _ -> true
+ | [], _, _
+ | _, [], _ -> raise (Invalid_argument "list_forall_default3")
+ | a::ta, b::tb, c::tc ->
+ if f a b c then aux f ta tb def tc (i+1)
+ else raise (FailureAt i)
+ | a::ta, b::tb, [] ->
+ if f a b def then aux f ta tb def [] (i+1)
+ else raise (FailureAt i)
+ in aux f l1 l2 def l3 0
+;;
+
+let sharing_map f l =
+ let unchanged = ref true in
+ let rec aux b = function
+ | [] as t -> unchanged := b; t
+ | he::tl ->
+ let he1 = f he in
+ he1 :: aux (b && he1 == he) tl
+ in
+ let l1 = aux true l in
+ if !unchanged then l else l1
+;;
+
+let sharing_map_acc f acc l =
+ let unchanged = ref true in
+ let final_acc = ref acc in
+ let rec aux b acc = function
+ | [] as t -> unchanged := b; final_acc := acc; t
+ | he::tl ->
+ let acc, he1 = f acc he in
+ he1 :: aux (b && he1 == he) acc tl
+ in
+ let l1 = aux true acc l in
+ !final_acc, if !unchanged then l else l1
+;;
+
let rec list_uniq ?(eq=(=)) = function
| [] -> []
| h::[] -> [h]
| None -> filter_map f tl
| Some v -> v :: filter_map f tl)
+let filter_map_acc f acc l =
+ let acc, res =
+ List.fold_left
+ (fun (acc, res) t ->
+ match f acc t with
+ | None -> acc, res
+ | Some (acc, x) -> acc, x::res)
+ (acc,[]) l
+ in
+ acc, List.rev res
+;;
+
+let filter_map_monad f acc l =
+ let acc, res =
+ List.fold_left
+ (fun (acc, res) t ->
+ match f acc t with
+ | acc, None -> acc, res
+ | acc, Some x -> acc, x::res)
+ (acc,[]) l
+ in
+ acc, List.rev res
+;;
+
let list_rev_map_filter f l =
let rec aux a = function
| [] -> a
in
aux []
+let list_iter_sep ~sep f =
+ let rec aux =
+ function
+ | [] -> ()
+ | [ last ] -> f last
+ | hd :: tl -> f hd; sep (); aux tl
+ in
+ aux
+
let rec list_findopt f l =
- let rec aux = function
+ let rec aux k = function
| [] -> None
| x::tl ->
- (match f x with
- | None -> aux tl
+ (match f x k with
+ | None -> aux (succ k) tl
| Some _ as rc -> rc)
in
- aux l
+ aux 0 l
let split_nth n l =
let rec aux acc n l =
let l = List.rev l in
try List.hd l with exn -> raise (Failure "HExtlib.list_last")
;;
-
+
+let rec list_assoc_all a = function
+ | [] -> []
+ | (x, y) :: tl when x = a -> y :: list_assoc_all a tl
+ | _ :: tl -> list_assoc_all a tl
+;;
+
+let rec rm_assoc_option n = function
+ | [] -> None,[]
+ | (x,i)::tl when n=x -> Some i,tl
+ | p::tl -> let i,tl = rm_assoc_option n tl in i,p::tl
+;;
+
+let rm_assoc_assert n l =
+ match rm_assoc_option n l with
+ | None,_ -> assert false
+ | Some i,l -> i,l
+;;
+
+(* naif implementation of the union-find merge operation
+ canonicals maps elements to canonicals
+ elements maps canonicals to the classes *)
+let merge canonicals elements extern n m =
+ let cn,canonicals = rm_assoc_option n canonicals in
+ let cm,canonicals = rm_assoc_option m canonicals in
+ match cn,cm with
+ | None, None -> canonicals, elements, extern
+ | None, Some c
+ | Some c, None ->
+ let l,elements = rm_assoc_assert c elements in
+ let canonicals =
+ List.filter (fun (_,xc) -> not (xc = c)) canonicals
+ in
+ canonicals,elements,l@extern
+ | Some cn, Some cm when cn=cm ->
+ (n,cm)::(m,cm)::canonicals, elements, extern
+ | Some cn, Some cm ->
+ let ln,elements = rm_assoc_assert cn elements in
+ let lm,elements = rm_assoc_assert cm elements in
+ let canonicals =
+ (n,cm)::(m,cm)::List.map
+ (fun ((x,xc) as p) ->
+ if xc = cn then (x,cm) else p) canonicals
+ in
+ let elements = (cm,ln@lm)::elements
+ in
+ canonicals,elements,extern
+;;
+
+(* f x gives the direct dependencies of x.
+ x must not belong to (f x).
+ All elements not in l are merged into a single extern class *)
+let clusters f l =
+ let canonicals = List.map (fun x -> (x,x)) l in
+ let elements = List.map (fun x -> (x,[x])) l in
+ let extern = [] in
+ let _,elements,extern =
+ List.fold_left
+ (fun (canonicals,elements,extern) x ->
+ let dep = f x in
+ List.fold_left
+ (fun (canonicals,elements,extern) d ->
+ merge canonicals elements extern d x)
+ (canonicals,elements,extern) dep)
+ (canonicals,elements,extern) l
+ in
+ let c = (List.map snd elements) in
+ if extern = [] then c else extern::c
+;;
+
(** {2 File predicates} *)
let is_dir fname =
let floc_of_loc (loc_begin, loc_end) =
Stdpp.make_loc (loc_begin, loc_end)
-let dummy_floc = floc_of_loc (-1, -1)
+let dummy_floc = floc_of_loc (0, 0)
let raise_localized_exception ~offset floc exn =
let x, y = loc_of_floc floc in
let touch s =
try close_out(open_out s) with Sys_error _ -> ()
;;
+
+let rec mk_list x = function
+ | 0 -> []
+ | n -> x :: mk_list x (n-1)
+;;
+
+let list_seq start stop =
+ if start > stop then [] else
+ let rec aux pos =
+ if pos = stop then []
+ else pos :: (aux (pos+1))
+ in
+ aux start
+;;
+
+let rec list_skip n l =
+ match n,l with
+ | 0,_ -> l
+ | n,_::l -> list_skip (n-1) l
+ | _, [] -> assert false
+;;
+