Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Issue 395: Add tests for stack safety in Lwt_list. #538

Merged
merged 4 commits into from
Jan 16, 2018
Merged

Issue 395: Add tests for stack safety in Lwt_list. #538

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
ae259bb
Fix some terminology and add stack safety tests.
jsthomas Jan 15, 2018
371f636
Update Lwt_list to make all functions stack safe.
jsthomas Jan 15, 2018
d3d74b7
Revisions based on review comments.
jsthomas Jan 15, 2018
661a876
Fixed incompatible system call.
jsthomas Jan 16, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
172 changes: 65 additions & 107 deletions src/core/lwt_list.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -83,38 +83,35 @@ let map_p f l =
let ts = tail_recursive_map (Lwt.apply f) l in
_collect [] ts

let rec filter_map_s f l =
match l with
| [] ->
Lwt.return_nil
| x :: l ->
Lwt.apply f x >>= function
| Some x ->
filter_map_s f l >|= fun l ->
x :: l
| None ->
filter_map_s f l

let rec filter_map_p f l =
match l with
| [] ->
Lwt.return_nil
| x :: l ->
let tx = Lwt.apply f x and tl = filter_map_p f l in
tx >>= function
| Some x -> tl >|= fun l -> x :: l
| None -> tl
let filter_map_s f l =
let rec inner acc = function
| [] -> List.rev acc |> Lwt.return
| hd::tl ->
Lwt.apply f hd >>= function
| Some v -> (inner [@ocaml.tailcall]) (v::acc) tl
| None -> (inner [@ocaml.tailcall]) acc tl
in
inner [] l

let rec mapi_s i f l =
match l with
| [] ->
Lwt.return_nil
| x :: l ->
Lwt.apply (f i) x >>= fun x ->
mapi_s (i + 1) f l >|= fun l ->
x :: l
let filter_map_p f l =
let rec _collect_optional acc = function
| [] -> List.rev acc |> Lwt.return
| t::ts ->
t >>= function
| Some v -> (_collect_optional [@ocaml.tailcall]) (v::acc) ts
| None -> (_collect_optional [@ocaml.tailcall]) acc ts
in
let ts = tail_recursive_map (Lwt.apply f) l in
_collect_optional [] ts

let mapi_s f l = mapi_s 0 f l
let mapi_s f l =
let rec inner acc i = function
| [] -> List.rev acc |> Lwt.return
| hd::tl ->
Lwt.apply (f i) hd >>= fun v ->
(inner [@ocaml.tailcall]) (v::acc) (i+1) tl
in
inner [] 0 l

let mapi_p f l =
let f' i = Lwt.apply (f i) in
Expand Down Expand Up @@ -151,15 +148,15 @@ let rec fold_left_s f acc l =
Lwt.return acc
| x :: l ->
Lwt.apply (f acc) x >>= fun acc ->
fold_left_s f acc l
(fold_left_s [@ocaml.tailcall]) f acc l

let rec fold_right_s f l acc =
match l with
| [] ->
Lwt.return acc
| x :: l ->
fold_right_s f l acc >>= fun acc ->
Lwt.apply (f x) acc
let fold_right_s f l acc =
let rec inner f a = function
| [] -> Lwt.return a
| hd::tl -> (Lwt.apply (f hd) a) >>= fun a' ->
(inner [@ocaml.tailcall]) f a' tl
in
inner f acc (List.rev l)

let rec for_all_s f l =
match l with
Expand All @@ -168,19 +165,12 @@ let rec for_all_s f l =
| x :: l ->
Lwt.apply f x >>= function
| true ->
for_all_s f l
(for_all_s [@ocaml.tailcall]) f l
| false ->
Lwt.return_false

let rec for_all_p f l =
match l with
| [] ->
Lwt.return_true
| x :: l ->
let tx = Lwt.apply f x and tl = for_all_p f l in
tx >>= fun bx ->
tl >|= fun bl ->
bx && bl
let for_all_p f l =
map_p f l >>= fun bl -> List.for_all (fun x -> x) bl |> Lwt.return

let rec exists_s f l =
match l with
Expand All @@ -191,17 +181,10 @@ let rec exists_s f l =
| true ->
Lwt.return_true
| false ->
exists_s f l
(exists_s [@ocaml.tailcall]) f l

let rec exists_p f l =
match l with
| [] ->
Lwt.return_false
| x :: l ->
let tx = Lwt.apply f x and tl = exists_p f l in
tx >>= fun bx ->
tl >|= fun bl ->
bx || bl
let exists_p f l =
map_p f l >>= fun bl -> List.exists (fun x -> x) bl |> Lwt.return

let rec find_s f l =
match l with
Expand All @@ -212,56 +195,31 @@ let rec find_s f l =
| true ->
Lwt.return x
| false ->
find_s f l
(find_s [@ocaml.tailcall]) f l

let rec filter_s f l =
match l with
| [] ->
Lwt.return_nil
| x :: l ->
Lwt.apply f x >>= function
| true ->
filter_s f l >|= fun l ->
x :: l
| false ->
filter_s f l
let _optionalize f x =
f x >>= fun b -> if b then Lwt.return (Some x) else Lwt.return None

let rec filter_p f l =
match l with
| [] ->
Lwt.return_nil
| x :: l ->
let tx = Lwt.apply f x and tl = filter_p f l in
tx >>= fun bx ->
tl >|= fun l ->
if bx then
x :: l
else
l
let filter_s f l =
filter_map_s (_optionalize f) l

let return_nil_nil = Lwt.return ([], [])
let filter_p f l =
filter_map_p (_optionalize f) l

let rec partition_s f l =
match l with
| [] ->
return_nil_nil
| x :: l ->
Lwt.apply f x >>= fun bx ->
partition_s f l >|= fun (l_l, l_r) ->
if bx then
(x :: l_l, l_r)
else
(l_l, x :: l_r)

let rec partition_p f l =
match l with
| [] ->
return_nil_nil
| x :: l ->
let tx = Lwt.apply f x and tl = partition_p f l in
tx >>= fun bx ->
tl >|= fun (l_l, l_r) ->
if bx then
(x :: l_l, l_r)
else
(l_l, x :: l_r)
let partition_s f l =
let rec inner acc1 acc2 = function
| [] -> Lwt.return (List.rev acc1, List.rev acc2)
| hd::tl -> Lwt.apply f hd >>= fun b ->
if b then
inner (hd::acc1) acc2 tl
else
inner acc1 (hd::acc2) tl
in
inner [] [] l

let partition_p f l =
let g x = Lwt.apply f x >>= fun b -> Lwt.return (b, x) in
map_p g l >>= fun tl ->
let group1 = tail_recursive_map snd @@ List.filter fst tl in
let group2 = tail_recursive_map snd @@ List.filter (fun x -> not @@ fst x) tl in
Lwt.return (group1, group2)
3 changes: 2 additions & 1 deletion test/core/main.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,8 @@
Test.run "core"
(Test_lwt.suites @ [
Test_lwt_stream.suite;
Test_lwt_list.suite;
Test_lwt_list.suite_primary;
Test_lwt_list.suite_intensive;
Test_lwt_switch.suite;
Test_lwt_mutex.suite;
Test_lwt_result.suite;
Expand Down
Loading