From 6a08e36f4ba959bf456e42eda0a8f1f38d905126 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 10 Aug 2018 13:12:16 +0300 Subject: [PATCH 1/5] Simplify closure calculation with Result.iter Signed-off-by: Rudi Grinberg --- src/lib.ml | 10 ++-------- src/stdune/result.ml | 7 +++++++ src/stdune/result.mli | 2 ++ 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 11f44df5..07356f57 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -874,16 +874,10 @@ and closure_with_overlap_checks db ts ~stack = >>= fun () -> Dep_stack.push stack (to_id t) >>= fun stack -> t.requires >>= fun deps -> - iter deps ~stack >>| fun () -> + Result.iter deps ~f:(loop ~stack) >>| fun () -> res := t :: !res - and iter ts ~stack = - match ts with - | [] -> Ok () - | t :: ts -> - loop t ~stack >>= fun () -> - iter ts ~stack in - iter ts ~stack >>| fun () -> + Result.iter ts ~f:(loop ~stack) >>| fun () -> List.rev !res let closure_with_overlap_checks db l = diff --git a/src/stdune/result.ml b/src/stdune/result.ml index 47b3f882..0cb8a7ca 100644 --- a/src/stdune/result.ml +++ b/src/stdune/result.ml @@ -59,4 +59,11 @@ let concat_map = in fun l ~f -> loop f [] l +let rec iter t ~f = + match t with + | [] -> Ok () + | x :: xs -> + f x >>= fun () -> + iter xs ~f + type ('a, 'error) result = ('a, 'error) t diff --git a/src/stdune/result.mli b/src/stdune/result.mli index 7e0467ca..70ec345d 100644 --- a/src/stdune/result.mli +++ b/src/stdune/result.mli @@ -23,6 +23,8 @@ val map_error : ('a, 'error1) t -> f:('error1 -> 'error2) -> ('a, 'error2) t val all : ('a, 'error) t list -> ('a list, 'error) t +val iter : 'a list -> f:('a -> (unit, 'error) t) -> (unit, 'error) t + val concat_map : 'a list -> f:('a -> ('b list, 'error) t) From dc681a5961e71f8bc5362f2ade00d2377d11f60e Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 10 Aug 2018 14:01:00 +0300 Subject: [PATCH 2/5] Simplify resolution with Result combinators Signed-off-by: Rudi Grinberg --- src/lib.ml | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 07356f57..655ad7c5 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -575,7 +575,7 @@ module Dep_stack = struct } end -let check_private_deps ~(lib : lib) ~loc ~allow_private_deps = +let check_private_deps lib ~loc ~allow_private_deps = if (not allow_private_deps) && Status.is_private lib.info.status then Result.Error (Error ( Private_deps_not_allowed { private_dep = lib ; pd_loc = loc })) @@ -689,7 +689,7 @@ and resolve_dep db name ~allow_private_deps ~loc ~stack : t Or_exn.t = match find_internal db name ~stack with | St_initializing id -> Error (Dep_stack.dependency_cycle stack id) - | St_found lib -> check_private_deps ~lib ~loc ~allow_private_deps + | St_found lib -> check_private_deps lib ~loc ~allow_private_deps | St_not_found -> Error (Error (Library_not_available { loc; name; reason = Not_found })) | St_hidden (_, hidden) -> @@ -819,20 +819,12 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = closure_with_overlap_checks None pps ~stack in let deps = - let rec check_runtime_deps acc pps = function - | [] -> loop acc pps - | lib :: ppx_rts -> - check_private_deps ~lib ~loc ~allow_private_deps >>= fun rt -> - check_runtime_deps (rt :: acc) pps ppx_rts - and loop acc = function - | [] -> Ok acc - | pp :: pps -> - pp.ppx_runtime_deps >>= fun rt_deps -> - check_runtime_deps acc pps rt_deps - in - deps >>= fun deps -> - pps >>= fun pps -> - loop deps pps + (deps >>= fun deps -> + pps >>= Result.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) + >>| fun pp_deps -> List.rev_append deps pp_deps) + >>= fun deps -> + List.map deps ~f:(check_private_deps ~loc ~allow_private_deps) + |> Result.all in (deps, pps) in From a60fe7611778ecfc6af1acd15b28fa9f3a210dd5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 10 Aug 2018 15:19:02 +0300 Subject: [PATCH 3/5] Simplify more Result code with Result.List.map Signed-off-by: Rudi Grinberg --- src/lib.ml | 29 ++++++++--------------------- src/stdune/result.ml | 11 +++++++++++ src/stdune/result.mli | 4 ++++ 3 files changed, 23 insertions(+), 21 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 655ad7c5..41a159dc 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -733,13 +733,8 @@ and available_internal db name ~stack = | Error _ -> false and resolve_simple_deps db names ~allow_private_deps ~stack = - let rec loop acc = function - | [] -> Ok (List.rev acc) - | (loc, name) :: names -> - resolve_dep db name ~allow_private_deps ~loc ~stack >>= fun x -> - loop (x :: acc) names - in - loop [] names + Result.List.map names ~f:(fun (loc, name) -> + resolve_dep db name ~allow_private_deps ~loc ~stack) and resolve_complex_deps db deps ~allow_private_deps ~stack = let res, resolved_selects = @@ -819,12 +814,10 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = closure_with_overlap_checks None pps ~stack in let deps = - (deps >>= fun deps -> - pps >>= Result.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) - >>| fun pp_deps -> List.rev_append deps pp_deps) - >>= fun deps -> - List.map deps ~f:(check_private_deps ~loc ~allow_private_deps) - |> Result.all + deps >>= fun deps -> + pps >>= Result.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) + >>| List.rev_append deps + >>= Result.List.map ~f:(check_private_deps ~loc ~allow_private_deps) in (deps, pps) in @@ -1021,14 +1014,8 @@ module DB = struct ; reason })) - let find_many = - let rec loop t acc = function - | [] -> Ok (List.rev acc) - | name :: names -> - resolve t (Loc.none, name) >>= fun lib -> - loop t (lib ::acc) names - in - fun t names -> loop t [] names + let find_many t = + Result.List.map ~f:(fun name -> resolve t (Loc.none, name)) let available t name = available_internal t name ~stack:Dep_stack.empty diff --git a/src/stdune/result.ml b/src/stdune/result.ml index 0cb8a7ca..f612362c 100644 --- a/src/stdune/result.ml +++ b/src/stdune/result.ml @@ -67,3 +67,14 @@ let rec iter t ~f = iter xs ~f type ('a, 'error) result = ('a, 'error) t + +module List = struct + let map t ~f = + let rec loop acc = function + | [] -> Ok (List.rev acc) + | x :: xs -> + f x >>= fun x -> + loop (x :: acc) xs + in + loop [] t +end diff --git a/src/stdune/result.mli b/src/stdune/result.mli index 70ec345d..30620cb4 100644 --- a/src/stdune/result.mli +++ b/src/stdune/result.mli @@ -35,3 +35,7 @@ val errorf : ('a, unit, string, (_, string) t) format4 -> 'a (** For compatibility with some other code *) type ('a, 'error) result = ('a, 'error) t + +module List : sig + val map : 'a list -> f:('a -> ('b, 'e) t) -> ('b list, 'e) t +end From 9849a7dbb096c15650f56191207b2b1e6c942318 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 14 Aug 2018 10:46:07 +0300 Subject: [PATCH 4/5] Move list related Result functions to Result.List Signed-off-by: Rudi Grinberg --- src/inline_tests.ml | 8 +++---- src/lib.ml | 6 +++--- src/preprocessing.ml | 2 +- src/stdune/result.ml | 50 +++++++++++++++++++++---------------------- src/stdune/result.mli | 18 ++++++++-------- src/sub_system.ml | 4 ++-- 6 files changed, 44 insertions(+), 44 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 98098cc7..55d07341 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -65,10 +65,10 @@ module Backend = struct { info ; lib ; runner_libraries = - Result.all (List.map info.runner_libraries ~f:resolve) + Result.List.all (List.map info.runner_libraries ~f:resolve) ; extends = let open Result.O in - Result.all + Result.List.all (List.map info.extends ~f:(fun ((loc, name) as x) -> resolve x >>= fun lib -> @@ -182,12 +182,12 @@ include Sub_system.Register_end_point( let runner_libs = let open Result.O in - Result.concat_map backends + Result.List.concat_map backends ~f:(fun (backend : Backend.t) -> backend.runner_libraries) >>= fun libs -> Lib.DB.find_many (Scope.libs scope) [lib.name] >>= fun lib -> - Result.all + Result.List.all (List.map info.libraries ~f:(Lib.DB.resolve (Scope.libs scope))) >>= fun more_libs -> diff --git a/src/lib.ml b/src/lib.ml index 41a159dc..97caa61f 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -815,7 +815,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = in let deps = deps >>= fun deps -> - pps >>= Result.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) + pps >>= Result.List.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) >>| List.rev_append deps >>= Result.List.map ~f:(check_private_deps ~loc ~allow_private_deps) in @@ -859,10 +859,10 @@ and closure_with_overlap_checks db ts ~stack = >>= fun () -> Dep_stack.push stack (to_id t) >>= fun stack -> t.requires >>= fun deps -> - Result.iter deps ~f:(loop ~stack) >>| fun () -> + Result.List.iter deps ~f:(loop ~stack) >>| fun () -> res := t :: !res in - Result.iter ts ~f:(loop ~stack) >>| fun () -> + Result.List.iter ts ~f:(loop ~stack) >>| fun () -> List.rev !res let closure_with_overlap_checks db l = diff --git a/src/preprocessing.ml b/src/preprocessing.ml index c1a5a653..afe6499a 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -85,7 +85,7 @@ module Driver = struct ; lib = lazy lib ; replaces = let open Result.O in - Result.all + Result.List.all (List.map info.replaces ~f:(fun ((loc, name) as x) -> resolve x >>= fun lib -> diff --git a/src/stdune/result.ml b/src/stdune/result.ml index f612362c..cd5e4027 100644 --- a/src/stdune/result.ml +++ b/src/stdune/result.ml @@ -41,31 +41,6 @@ end open O -let all = - let rec loop acc = function - | [] -> Ok (List.rev acc) - | t :: l -> - t >>= fun x -> - loop (x :: acc) l - in - fun l -> loop [] l - -let concat_map = - let rec loop f acc = function - | [] -> Ok (List.rev acc) - | x :: l -> - f x >>= fun y -> - loop f (List.rev_append y acc) l - in - fun l ~f -> loop f [] l - -let rec iter t ~f = - match t with - | [] -> Ok () - | x :: xs -> - f x >>= fun () -> - iter xs ~f - type ('a, 'error) result = ('a, 'error) t module List = struct @@ -77,4 +52,29 @@ module List = struct loop (x :: acc) xs in loop [] t + + let all = + let rec loop acc = function + | [] -> Ok (List.rev acc) + | t :: l -> + t >>= fun x -> + loop (x :: acc) l + in + fun l -> loop [] l + + let concat_map = + let rec loop f acc = function + | [] -> Ok (List.rev acc) + | x :: l -> + f x >>= fun y -> + loop f (List.rev_append y acc) l + in + fun l ~f -> loop f [] l + + let rec iter t ~f = + match t with + | [] -> Ok () + | x :: xs -> + f x >>= fun () -> + iter xs ~f end diff --git a/src/stdune/result.mli b/src/stdune/result.mli index 30620cb4..202f380f 100644 --- a/src/stdune/result.mli +++ b/src/stdune/result.mli @@ -21,15 +21,6 @@ val bind : ('a, 'error) t -> f:('a -> ('b, 'error) t) -> ('b, 'error) t val map_error : ('a, 'error1) t -> f:('error1 -> 'error2) -> ('a, 'error2) t -val all : ('a, 'error) t list -> ('a list, 'error) t - -val iter : 'a list -> f:('a -> (unit, 'error) t) -> (unit, 'error) t - -val concat_map - : 'a list - -> f:('a -> ('b list, 'error) t) - -> ('b list, 'error) t - (** Produce [Error ] *) val errorf : ('a, unit, string, (_, string) t) format4 -> 'a @@ -38,4 +29,13 @@ type ('a, 'error) result = ('a, 'error) t module List : sig val map : 'a list -> f:('a -> ('b, 'e) t) -> ('b list, 'e) t + + val all : ('a, 'error) t list -> ('a list, 'error) t + + val iter : 'a list -> f:('a -> (unit, 'error) t) -> (unit, 'error) t + + val concat_map + : 'a list + -> f:('a -> ('b list, 'error) t) + -> ('b list, 'error) t end diff --git a/src/sub_system.ml b/src/sub_system.ml index c7a06b79..e738a7e3 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -107,7 +107,7 @@ module Register_backend(M : Backend) = struct let open Result.O in written_by_user_or_scan ~written_by_user ~to_scan >>= fun backends -> - wrap (Result.concat_map backends ~f:replaces) + wrap (Result.List.concat_map backends ~f:replaces) >>= fun replaced_backends -> match Set.diff (Set.of_list backends) (Set.of_list replaced_backends) @@ -131,7 +131,7 @@ module Register_end_point(M : End_point) = struct (match M.Info.backends info with | None -> Ok None | Some l -> - Result.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope))) + Result.List.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope))) >>| Option.some) >>= fun written_by_user -> M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info) From e1cd3b9094e44b36607eb52a819ee76f561dcd18 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 14 Aug 2018 10:59:50 +0300 Subject: [PATCH 5/5] Revert changes to resolve_user_deps Signed-off-by: Rudi Grinberg --- src/lib.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 97caa61f..f15a49dd 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -814,16 +814,26 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = closure_with_overlap_checks None pps ~stack in let deps = + let rec check_runtime_deps acc pps = function + | [] -> loop acc pps + | lib :: ppx_rts -> + check_private_deps lib ~loc ~allow_private_deps >>= fun rt -> + check_runtime_deps (rt :: acc) pps ppx_rts + and loop acc = function + | [] -> Ok acc + | pp :: pps -> + pp.ppx_runtime_deps >>= fun rt_deps -> + check_runtime_deps acc pps rt_deps + in deps >>= fun deps -> - pps >>= Result.List.concat_map ~f:(fun pp -> pp.ppx_runtime_deps) - >>| List.rev_append deps - >>= Result.List.map ~f:(check_private_deps ~loc ~allow_private_deps) + pps >>= fun pps -> + loop deps pps in (deps, pps) in (deps, pps, resolved_selects) -and closure_with_overlap_checks db ts ~stack = + and closure_with_overlap_checks db ts ~stack = let visited = ref String.Map.empty in let res = ref [] in let orig_stack = stack in