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 11f44df5..f15a49dd 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) -> @@ -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 = @@ -822,7 +817,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = 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_private_deps lib ~loc ~allow_private_deps >>= fun rt -> check_runtime_deps (rt :: acc) pps ppx_rts and loop acc = function | [] -> Ok acc @@ -838,7 +833,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = 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 @@ -874,16 +869,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.List.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.List.iter ts ~f:(loop ~stack) >>| fun () -> List.rev !res let closure_with_overlap_checks db l = @@ -1035,14 +1024,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/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 47b3f882..cd5e4027 100644 --- a/src/stdune/result.ml +++ b/src/stdune/result.ml @@ -41,22 +41,40 @@ 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 - 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 + + 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 7e0467ca..202f380f 100644 --- a/src/stdune/result.mli +++ b/src/stdune/result.mli @@ -21,15 +21,21 @@ 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 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 (** 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 + + 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)