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
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 0 l
-let split_nth msg n l =
+let split_nth n l =
let rec aux acc n l =
match n, l with
| 0, _ -> List.rev acc, l
- | n, [] -> raise (Failure ("HExtlib.split_nth: " ^ msg))
+ | n, [] -> raise (Failure "HExtlib.split_nth")
| n, hd :: tl -> aux (hd :: acc) (n - 1) tl in
aux [] n l
| _ :: 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 =