Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 795 lines (675 sloc) 21.495 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 include List
21 exception Empty
22
23 let sprintf = Printf.sprintf
24 let (|>) x f = f x
25 let (@*) f g x = f (g x)
26
27 let get_only_element = function
28 | [x] -> x
29 | _ -> invalid_arg "List.get_only_element"
30
31 let map_right f l = rev_map f (rev l)
32
33 let tail_append l1 l2 = rev_append (rev l1) l2
34
35 let rev_map_append fct l1 l2 =
36 let rec aux acc = function
37 | [] -> acc
38 | hd :: tl ->
39 let hd = fct hd in
40 aux (hd :: acc) tl
41 in
42 aux l2 l1
43
44 let rev_filter_map_append fct l1 l2 =
45 let rec aux acc = function
46 | [] -> acc
47 | hd :: tl -> (
48 match fct hd with
49 | None -> aux acc tl
50 | Some hd -> aux (hd :: acc) tl
51 )
52 in aux l2 l1
53
54 let empty = []
55
56 let is_empty = function
57 | [] -> true
58 | _ -> false
59
60 let rec mem_eq ~eq x = function
61 | [] -> false
62 | a :: l -> eq a x || mem_eq ~eq x l
63
64 let substract l1 l2 =
65 List.rev (fold_left (fun l x -> if mem x l2 then l else x::l) [] l1)
66 let subtract = substract (* backwards-typo compatibility *)
67
68 let substract_eq ~eq l1 l2 =
69 List.rev (fold_left (fun l x -> if mem_eq ~eq x l2 then l else x :: l) [] l1)
70
71 (* subset l1 l2 tests whether the list l1 is a subset of the list l2 *)
72 let subset l1 l2 =
73 List.for_all (fun e -> List.mem e l2) l1
74
75 let subset_eq ~eq l1 l2 =
76 List.for_all (fun e -> List.exists (eq e) l2) l1
77
78 let iter_right f l =
79 let rec aux = function
80 | [] -> ()
81 | hd::tl -> f hd ; aux tl
82 in aux l
83 let iteri f l =
84 ignore (
85 List.fold_left (fun acc x -> let () = f x acc in succ acc) 0 l
86 )
87 let rev_mapi f l =
88 fst (List.fold_left (fun (acc, i) x -> f i x :: acc, i + 1) ([], 0) l)
89 let mapi f l =
90 List.rev (rev_mapi f l)
91
92 let for_alli f l =
93 let rec aux i = function
94 | [] -> true
95 | h :: t -> f i h && aux (i+1) t
96 in
97 aux 0 l
98
99 let map_with_tail f = List.fold_right (fun x y -> (f x)::y)
100 let init n f =
101 let rec aux r i =
102 if i >= 0 then aux ((f i) :: r) (pred i)
103 else r
104 in aux [] (pred n)
105
106 let side_effect_init n f =
107 let rec aux acc i =
108 if i >= n then List.rev acc
109 else
110 aux ((f i) :: acc) (succ i)
111 in
112 aux [] 0
113
114 let rec last = function
115 | [] -> failwith "List.last"
116 | [e] -> e
117 | _e::l -> last l
118
119 let rec take n l =
120 assert (n >= 0);
121 if n = 0 then [] else
122 match l with
123 | [] -> []
124 | e::l -> e :: take (n-1) l
125
126 let rec take_last k l =
127 assert(k>=0);
128 let n=List.length l in
129 let rec aux i l = if i < n-k then aux (i+1) (List.tl l) else l in
130 aux 0 l
131
132 let rec drop n l =
133 assert (n >= 0);
134 if n = 0 then l else
135 match l with
136 | [] -> l
137 | _e::l -> drop (n-1) l
138
139 let rec extract_last = function
140 | [] -> failwith "List.extract_last"
141 | [e] -> [], e
142 | x::xs ->
143 let ys, y = extract_last xs in
144 x::ys, y
145
146 (* example: split_at 2 ["a";"b";"c"] gives ["a";"b"],["c"] *)
147 let split_at n l =
148 let rec aux accu n l =
149 match (n, l) with
150 | 0, _
151 | _, [] -> List.rev accu, l
152 | _, e::l -> aux (e::accu) (n-1) l
153 in
154 assert (n >= 0);
155 aux [] n l
156
157 (* example : split_ats [1;2;3] ["a";"b";"c";"d";"e";"f"] gives [["a"]; ["b";"c"]; ["d";"e";"f"]]*)
158 let split_ats lengths l =
159 let rec aux lengths l acc =
160 match lengths with
161 | [] ->
162 if l = [] then
163 List.rev acc
164 else
165 raise (Invalid_argument "List.split_ats")
166 | n :: lengths_t ->
167 let l1, r = split_at n l in
168 aux lengths_t r (l1 :: acc)
169 in
170 aux lengths l []
171
172 let split_at_sep f l =
173 let rec aux f l acc0 acc1 =
174 match l with
175 | x :: rl -> if f x then (List.rev acc0)::acc1 else aux f rl (x::acc0) acc1
176 | _ -> List.rev acc1
177 in aux f l [] []
178
179 (* example:
180 splice 1 1 [] ["a";"b";"c"] gives ["a";"c"]
181 splice 1 1 ["B"] ["a";"b";"c"] gives ["a";"B";"c"]
182 *)
183 let splice index nb_to_remove elts_to_add l =
184 let beg_to_keep, l = split_at index l in
185 let end_to_keep = drop nb_to_remove l in
186 beg_to_keep @ elts_to_add @ end_to_keep
187
188 let fold_left_i f init l =
189 snd (fold_left (fun (i, acc) x -> (succ i, f acc x i)) (0, init) l)
190
191 let fold_right_i f l init =
192 let len = ref 0 in
193 let l = rev_map (fun e -> incr(len) ; e) l in
194 snd (fold_left (fun (i, acc) x -> (pred i, f x i acc)) (pred (!len), init) l)
195
196 let fold f = function
197 | hd :: tl -> fold_left f hd tl
198 | _ -> raise Empty
199
200 let collect f l =
201 let rec collect_accu f accu = function
202 | [] -> accu
203 | e::l -> collect_accu f (List.rev_append (f e) accu) l
204 in
205 List.rev (collect_accu f [] l)
206
207 let rev_filter f tl =
208 let rec aux accu = function
209 | [] -> accu
210 | hd::tl ->
211 if f hd
212 then aux (hd::accu) tl
213 else aux accu tl
214 in
215 aux [] tl
216
217 let tail_filter f tl = List.rev (rev_filter f tl)
218
219 let to_string f l =
220 let rec aux = function
221 | hd::tl -> sprintf "%s%s" (f hd) (aux tl)
222 | _ -> "" in
223 aux l
224 let print f l =
225 let rec aux = function
226 | [] -> "]"
227 | [hd] -> sprintf "%s]" (f hd)
228 | hd::tl -> sprintf "%s;%s" (f hd) (aux tl) in
229 sprintf "[%s" (aux l)
230 let max, min =
231 let oper op = function
232 | [] -> raise Empty
233 | hd::tl -> fold_left op hd tl
234 in
235 (fun l -> oper max l),
236 (fun l -> oper min l)
237
238 let minmax =
239 let minmax (mi, ma) x = if x < mi then x, ma else if x > ma then mi, x else mi, ma in
240 function
241 | [] -> raise Empty
242 | hd::tl -> fold_left minmax (hd, hd) tl
243
244 let argmax, argmin =
245 let argoper op = function
246 | [] -> raise Empty
247 | hd::tl -> fold_left (fun acc x -> if op x acc then x else acc) hd tl
248 in
249 (fun l -> argoper (>) l),
250 (fun l -> argoper (<) l)
251
252 let remove_all v = filter (fun x -> x<>v)
253 let remove_first v =
254 let rec aux stack = function
255 | [] -> stack
256 | hd :: tl when hd = v -> List.rev stack @ tl
257 | hd :: tl -> aux (hd :: stack) tl
258 in aux []
259
260
261
262 (* ************************************************************************** *)
263 (** {b Descr}: See .mli file for documentation.
264 {b Visibility}: Exported outside this module. *)
265 (* ************************************************************************** *)
266 let remove_first_or_fail_eq ~eq v =
267 let rec aux stack = function
268 | [] -> raise Not_found
269 | hd :: tl when eq hd v -> List.rev stack @ tl
270 | hd :: tl -> aux (hd :: stack) tl
271 in aux []
272
273
274
275 let remove_last l =
276 fst (List.fold_right (
277 fun e (acc, last) ->
278 if last then
279 acc, false
280 else
281 e :: acc, last
282 ) l ([], true))
283
284 let replace v rl =
285 let rec aux acc = function
286 | [] -> rev acc
287 | hd :: tl when hd = v -> aux ((List.rev rl) @ acc) tl
288 | hd :: tl -> aux (hd :: acc) tl
289 in aux []
290
291 let cons e l = e::l
292
293 let uniq ?(cmp = Pervasives.compare) = function
294 | hd :: tl ->
295 let l, _ =
296 List.fold_left (
297 fun ((l, e) as acc) x ->
298 if 0 = cmp x e then acc
299 else (x :: l, x)
300 ) ([hd], hd) tl
301 in
302 List.rev l
303 | [] -> []
304
305 let uniq_unsorted ?(cmp = Pervasives.compare) ?(conflict=(fun _ _ -> ())) l =
306 let l = fold_left (fun acc e ->
307 try
308 let e' = find (fun x -> cmp e x = 0) acc in
309 conflict e e';
310 acc
311 with Not_found -> e :: acc) [] l
312 in
313 rev l
314
315 let rec insert p e l = match p, l with
316 | 0, _ -> e :: l
317 | _n, [] -> raise Empty
318 | _n, (t::q) -> t :: (insert (pred p) e q)
319
320 let insert_sorted ?(cmp=Pervasives.compare) ?(conflict=(fun x y -> [x;y])) x l =
321 let rec aux = function
322 | [] -> [x]
323 | (t::q) as l -> let c = cmp x t in
324 if c < 0 then x::l
325 else if c > 0 then t::(aux q)
326 else (conflict x t)@q
327 in aux l
328
329
330 let filter_and_fold f =
331 let rec aux accu = function
332 | [] -> accu, []
333 | e::l ->
334 let accu, b = f accu e in
335 let accu, l = aux accu l in
336 accu, (if b then e::l else l)
337 in aux
338
339 let filteri f =
340 let rec aux acc pos = function
341 | [] -> List.rev(acc)
342 | x::y -> aux (if f pos x then x::acc else acc) (pos+1) y
343 in
344 aux [] 0
345
346 let flip l =
347 let rec aux accu l =
348 match accu, l with
349 | accu, [] -> accu
350 | [], e::l -> [e]::(aux [] l)
351 | a::accu, e::l -> (e::a)::(aux accu l)
352 in
353 List.fold_left aux [] l
354
355 let combine_opt l1 l2 =
356 try Some (combine l1 l2) with Invalid_argument _ -> None
357
358 let assoc_opt key =
359 let rec aux = function
360 | [] -> None
361 | (k, v)::_ when key = k -> Some v
362 | _::q -> aux q
363 in aux
364
365 let find_opt f l =
366 try
367 Some (find f l)
368 with
369 | Not_found -> None
370
371 let find_map f l =
372 let rec aux = function
373 | [] -> None
374 | hd::tl -> (
375 match f hd with
376 | ( Some _ ) as some -> some
377 | None -> aux tl
378 )
379 in aux l
380
381 let findi f =
382 let rec aux i = function
383 | [] -> None
384 | x::_ when f x -> Some i
385 | _::l -> aux (succ i) l
386 in
387 fun l -> aux 0 l
388
389 let find_i f =
390 let rec aux i = function
391 | [] -> None
392 | x::_ when f x -> Some (i, x)
393 | _::l -> aux (succ i) l
394 in
395 fun l -> aux 0 l
396
397 let find_map f tl =
398 let rec aux = function
399 | [] -> None
400 | hd :: tl -> (
401 match f hd with
402 | None ->
403 aux tl
404 | ( Some _ ) as some -> some
405 )
406 in
407 aux tl
408
409 (** memi e l returns the index (position) of the element e *)
410 let memi e l = findi (fun x -> x = e) l
411 let pos_opt = memi
412
413 let filter_map f l =
414 List.fold_right (fun v acc -> match f v with None -> acc | Some v -> v::acc) l []
415
416 let filter_mapi f l =
417 mapi (fun i it -> (i, it) ) l
418 |> filter_map (fun (i, it) -> f i it)
419
420
421 let partition_map f l =
422 let cons_opt o l = Option.default_map l (fun x -> x::l) o in
423 List.fold_right (fun v (acc1, acc2) ->
424 let (o1, o2) = f v in
425 (cons_opt o1 acc1, cons_opt o2 acc2)) l ([], [])
426
427 let get_first_some list arg =
428 let rec aux = function
429 | [] -> None
430 | t::q ->
431 begin
432 match t arg with
433 | None -> aux q
434 | some -> some
435 end
436 in aux list
437
438 let get_first_some_ar2 list arg1 arg2 =
439 let rec aux = function
440 | [] -> None
441 | t::q ->
442 begin
443 match t arg1 arg2 with
444 | None -> aux q
445 | some -> some
446 end
447 in aux list
448
449 (* maping with accu : no tail rec or rev *)
450 let fold_right_map fct list accu =
451 let rec aux = function
452 | [] -> [], accu
453 | t::q ->
454 let tl, accu = aux q in
455 let hd, accu = fct t accu in
456 hd::tl, accu
457 in aux list
458
459
460 (* see the mli for comments on foldl[1] foldr[1] *)
461 let rec foldl f l a = match l with
462 | hd :: tl -> foldl f tl (f hd a)
463 | _ -> a
464
465 let foldl1 f = function
466 | [] -> invalid_arg "List.foldl1: empty list"
467 | e::l -> foldl f l e
468
469
470 let fold_left1 f = function
471 | [] -> invalid_arg "List.fold_left1: empty list"
472 | e::l -> List.fold_left f e l
473
474 let foldr = List.fold_right
475
476 let foldr1 f =
477 let rec aux = function
478 | [] -> invalid_arg "List.foldr1: empty list"
479 | [x] -> x
480 | t::q -> f t (aux q)
481 in aux
482
483 let rec fold_left_snd f acc = function
484 | [] -> acc
485 | (_,x) :: t -> fold_left_snd f (f acc x) t
486
487 let map_stable map list =
488 let equal = ref true in
489 let fct acc elt =
490 let felt = map elt in
491 if elt != felt then equal := false;
492 felt::acc in
493 let flist = List.fold_left fct [] list in
494 if !equal then list else List.rev flist
495
496 let fold_left_rev_map_end f acc end_ list =
497 let rec aux acc list = function
498 | [] -> acc, list
499 | h :: t ->
500 let acc, h = f acc h in
501 aux acc (h :: list) t in
502 aux acc end_ list
503
504 let fold_left_rev_map f acc list = fold_left_rev_map_end f acc [] list
505 let fold_left_map_init f acc rev_beginning list =
506 let acc, l = fold_left_rev_map_end f acc rev_beginning list in
507 acc, List.rev l
508
509 let fold_left_map f acc list = fold_left_map_init f acc [] list
510
511 let fold_left_map_stable f acc orig_list =
512 let rec aux acc list = function
513 | [] -> acc, orig_list (* if we come here, then all the images were physically
514 * to the original element, so we give back the input list *)
515 | h :: t ->
516 let acc, h' = f acc h in
517 if h == h' then
518 aux acc (h' :: list) t
519 else
520 (* when one equality fails, switching to the usual fold_left_map
521 * because there is no point in doing the other comparisons anymore *)
522 fold_left_map_init f acc (h' :: list) t in
523 aux acc [] orig_list
524
525 let fold_right_map_stable f acc orig_list =
526 let rec aux acc list = function
527 | [] -> acc, orig_list
528 | h :: t ->
529 let acc, h' = f acc h in
530 if h == h' then
531 aux acc (h' :: list) t
532 else
533 fold_left_rev_map_end f acc (h' :: list) t in
534 aux acc [] (List.rev orig_list)
535
536 let fold_left_filter_map fct accu list =
537 let fct (accu, list) elt =
538 let accu, elt = fct accu elt in
539 accu, (match elt with None -> list | Some elt -> elt::list) in
540 let accu, list = List.fold_left fct (accu,[]) list in
541 accu, List.rev list
542
543 (** raises Invalid_argument "fold_left2" *)
544 let fold_left_map2 fct accu list1 list2 =
545 let fct (accu, list) elt1 elt2 =
546 let accu, elt = fct accu elt1 elt2 in
547 accu, elt::list in
548 let accu, list = List.fold_left2 fct (accu,[]) list1 list2 in
549 accu, List.rev list
550
551 let fold_left_collect fct accu list =
552 let fct (accu, list) elt =
553 let accu, elt_list = fct accu elt in
554 accu, List.rev_append elt_list list in
555 let accu, list = List.fold_left fct (accu, []) list in
556 accu, List.rev list
557
558 let fold_left_map_i f init l =
559 let (_, acc), l = fold_left_map
560 (fun (i, acc) x ->
561 let acc, x = f i acc x
562 in ((succ i, acc), x)) (0, init) l
563 in acc, l
564
565 let for_all2_same_length f l1 l2 =
566 List.length l1 = List.length l2 && for_all2 f l1 l2
567
568 (* tail rec *)
569 let rev_concat_map fct =
570 let rec aux accu = function
571 | [] -> accu
572 | e::l -> aux (List.rev_append (fct e) accu) l
573 in aux []
574
575 let concat_map f = rev @* rev_concat_map f
576
577 let rev_concat_map2 fct l1 l2 =
578 let rec aux acc l1 l2 =
579 match l1, l2 with
580 | [], [] -> acc
581 | e1 :: l1, e2 :: l2 -> aux (List.rev_append (fct e1 e2) acc) l1 l2
582 | _ -> invalid_arg "List.rev_concat_map2" in
583 aux [] l1 l2
584 let concat_map2 f l1 l2 = rev (rev_concat_map2 f l1 l2)
585
586 let tail_concat l = (* dont factor l : '_a *)
587 let rec aux accu = function
588 | [] -> List.rev accu
589 | t::q -> aux (List.rev_append t accu) q
590 in aux [] l
591
592 let tail_append_keep_length a b =
593 let rec aux acc i = function
594 | [] -> i, acc
595 | t::q -> aux (t::acc) (succ i) q in
596 let la, a = aux [] 0 a in
597 let lb, ba = aux a 0 b in
598 la, lb, List.rev ba
599
600 let tail_split a =
601 let u, v = List.fold_left (fun (u, v) (x, y) -> x::u, y::v) ([], []) a in
602 List.rev u, List.rev v
603
604 let tail_map f a = List.rev (List.rev_map f a)
605 let tail_map2 f a b = List.rev (List.rev_map2 f a b)
606
607 (* association lists; value map, index map and renaming map *)
608 let vmap f l = List.map (fun (i, v) -> (i, f v)) l
609 let imap f l = List.map (fun (i, _v) -> (i, f i)) l
610 let rmap f l = List.map (fun (i, v) -> (f i, v)) l
611
612 (* association lists, tail version : value map, index map and renaming map *)
613 let tail_vmap f l = tail_map (fun (i, v) -> (i, f v)) l
614 let tail_imap f l = tail_map (fun (i, _v) -> (i, f i)) l
615 let tail_rmap f l = tail_map (fun (i, v) -> (f i, v)) l
616
617 (* applies f on all pairs of the cartesian product l1 * l2 *)
618 let rectangle_map f l1 l2 =
619 if l2 = [] then [] (* speedup *) else
620 let rec aux l1 l2 =
621 match l1 with
622 | [] -> []
623 | h1::t1 -> List.map (f h1) l2 @ aux t1 l2
624 in aux l1 l2
625
626 (* a combinator useful when forall x y. f x y = f y x *)
627 let triangle_map f l1 l2 =
628 if l1 = [] || l2 = [] then [] (* speedup *) else
629 let (l1, l2) =
630 if List.length l1 <= List.length l2
631 then (l1, l2) else (l2, l1) in
632 let rec aux l1 l2 =
633 match l1 with
634 | [] -> []
635 | [h1] -> List.map (f h1) l2
636 | h1::t1 ->
637 match l2 with
638 | [] -> assert false (* because length l1 <= length l2 *)
639 | _h2::t2 -> List.map (f h1) l2 @ aux t1 t2
640 in aux l1 l2
641
642 let make_compare cmp =
643 let rec compare l1 l2 = match l1, l2 with
644 | [], [] -> 0
645 | [], _ -> -1
646 | _, [] -> 1
647 | h1::t1, h2::t2 -> let cmp_h = cmp h1 h2 in
648 if cmp_h <> 0 then cmp_h else compare t1 t2
649 in compare
650
651 let option_like_merge conflict l1 l2 =
652 match l1, l2 with
653 | [], [] -> []
654 | _, [] -> l1
655 | [], _ -> l2
656 | _, _ -> conflict l1 l2
657
658 let choose_random = function
659 | [] -> invalid_arg "List.choose"
660 | l ->
661 let idx = Random.int (length l) in
662 nth l idx
663
664 (** A generic range filtering function, used in db *)
665 let filterbounds (start_opt, len) index l =
666 let rec cut_beg cond =
667 function x::r when cond x -> cut_beg cond r | l -> l in
668 let rec rev_cut_end cond acc =
669 function [] -> acc | x::_ when cond x -> acc | x::r -> rev_cut_end cond (x::acc) r in
670 let rec rev_cut_len n acc =
671 function [] -> acc | x::r -> if n <= 0 then acc else rev_cut_len (n-1) (x::acc) r in
672 if len >= 0 then
673 let l = match start_opt with Some s -> cut_beg (fun x -> index x < s) l | None -> l in
674 if len <> 0 then rev (rev_cut_len len [] l) else l
675 else
676 match start_opt with
677 | Some s -> rev_cut_end (fun x -> index x > s) [] l |> rev_cut_len (0-len) [] |> rev
678 | None -> rev l |> rev_cut_len (- len) [] |> rev
679
680
681
682 (* ************************************************************************** *)
683 (** {b Descr}: Returns the value (second component) associated with the key
684 (first component) equal to [x] in a list of pairs.
685 Raises [Not_found] if there is no value associated with [x] in the list.
686 Equality test is performed with the provided function [eq] instead of the
687 general [=] function. *)
688 (* ************************************************************************** *)
689 let rec assoc_custom_equality ~eq x = function
690 | [] -> raise Not_found
691 | (k, v) :: rem ->
692 if eq k x then v else assoc_custom_equality ~eq x rem
693
694
695 (* ************************************************************************** *)
696 (** {b Descr}: Transforms a list of triplets into a triplet of lists. *)
697 (* ************************************************************************** *)
698 let rec split3 = function
699 [] -> ([], [], [])
700 | (x,y,z) :: l ->
701 let (rx, ry, rz) = split3 l in (x :: rx, y :: ry, z :: rz)
702
703 module MakeAssoc(S:Map.OrderedType) = struct
704 type 'a t = (S.t * 'a) list
705 let equal x y = S.compare x y = 0
706 let rec find k = function
707 | [] -> raise Not_found
708 | (k',v) :: t ->
709 if equal k k' then v
710 else find k t
711 let rec find_opt k = function
712 | [] -> None
713 | (k',v) :: t ->
714 if equal k k' then Some v
715 else find_opt k t
716 let rec mem k = function
717 | [] -> false
718 | (k',_) :: t -> equal k k' || mem k t
719 let remove k l =
720 let rec aux acc = function
721 | [] -> l
722 | ((k',_) as c) :: t ->
723 if equal k k' then List.rev_append acc t
724 else aux (c :: acc) t in
725 aux [] l
726
727 let sorted_merge l1 l2 =
728 let rec aux acc l1 l2 =
729 match l1, l2 with
730 | [], l
731 | l, [] -> List.rev_append acc l
732 | ((k1,_) as c1) :: t1, ((k2,_) as c2) :: t2 ->
733 let c = S.compare k1 k2 in
734 if c < 0 then
735 aux (c1 :: acc) t1 l2
736 else
737 aux (c2 :: acc) l1 t2 in
738 aux [] l1 l2
739
740 let unique_sorted_merge ~merge l1 l2 =
741 let rec aux acc l1 l2 =
742 match l1, l2 with
743 | [], l
744 | l, [] -> List.rev_append acc l
745 | ((k1,_) as c1) :: t1, ((k2,_) as c2) :: t2 ->
746 let c = S.compare k1 k2 in
747 if c < 0 then
748 aux (c1 :: acc) t1 l2
749 else if c = 0 then (
750 let (k3,_) as r = merge c1 c2 in
751 if not (equal k1 k3) then invalid_arg "BaseList.MakeAssoc.unique_sorted_merge";
752 aux acc (r :: t1) t2
753 ) else
754 aux (c2 :: acc) l1 t2 in
755 aux [] l1 l2
756
757 let sort l =
758 sort (fun (k1,_) (k2,_) -> S.compare k1 k2) l
759 end
760
761 module StringAssoc = MakeAssoc(String)
762
763 let rev_partial_map2 f l1 l2 =
764 let rec aux acc l1 l2 =
765 match l1, l2 with
766 | [], _
767 | _, [] -> acc
768 | h1 :: t1, h2 :: t2 -> aux (f h1 h2 :: acc) t1 t2 in
769 aux [] l1 l2
770 let partial_map2 f l1 l2 = List.rev (rev_partial_map2 f l1 l2)
771
772 let rev_fold_left_partial_map2 f acc l1 l2 =
773 let rec aux acc1 acc2 l1 l2 =
774 match l1, l2 with
775 | [], _
776 | _, [] -> acc1, acc2
777 | h1 :: t1, h2 :: t2 ->
778 let acc1, h = f acc1 h1 h2 in
779 aux acc1 (h :: acc2) t1 t2 in
780 aux acc [] l1 l2
781 let fold_left_partial_map2 f acc l1 l2 =
782 let acc, l = rev_fold_left_partial_map2 f acc l1 l2 in
783 acc, List.rev l
784
785 let filter2 f l1 l2 =
786 let rec aux acc1 acc2 l1 l2 =
787 match l1, l2 with
788 | [], [] -> List.rev acc1, List.rev acc2
789 | h1 :: t1, h2 :: t2 ->
790 if f h1 h2
791 then aux (h1 :: acc1) (h2 :: acc2) t1 t2
792 else aux acc1 acc2 t1 t2
793 | _ -> invalid_arg "List.filter2" in
794 aux [] [] l1 l2
Something went wrong with that request. Please try again.