Merge pull request #1122 from rgrinberg/result-iter
Simplify Result code with Combinators
This commit is contained in:
commit
acfb844e93
|
@ -65,10 +65,10 @@ module Backend = struct
|
||||||
{ info
|
{ info
|
||||||
; lib
|
; lib
|
||||||
; runner_libraries =
|
; runner_libraries =
|
||||||
Result.all (List.map info.runner_libraries ~f:resolve)
|
Result.List.all (List.map info.runner_libraries ~f:resolve)
|
||||||
; extends =
|
; extends =
|
||||||
let open Result.O in
|
let open Result.O in
|
||||||
Result.all
|
Result.List.all
|
||||||
(List.map info.extends
|
(List.map info.extends
|
||||||
~f:(fun ((loc, name) as x) ->
|
~f:(fun ((loc, name) as x) ->
|
||||||
resolve x >>= fun lib ->
|
resolve x >>= fun lib ->
|
||||||
|
@ -182,12 +182,12 @@ include Sub_system.Register_end_point(
|
||||||
|
|
||||||
let runner_libs =
|
let runner_libs =
|
||||||
let open Result.O in
|
let open Result.O in
|
||||||
Result.concat_map backends
|
Result.List.concat_map backends
|
||||||
~f:(fun (backend : Backend.t) -> backend.runner_libraries)
|
~f:(fun (backend : Backend.t) -> backend.runner_libraries)
|
||||||
>>= fun libs ->
|
>>= fun libs ->
|
||||||
Lib.DB.find_many (Scope.libs scope) [lib.name]
|
Lib.DB.find_many (Scope.libs scope) [lib.name]
|
||||||
>>= fun lib ->
|
>>= fun lib ->
|
||||||
Result.all
|
Result.List.all
|
||||||
(List.map info.libraries
|
(List.map info.libraries
|
||||||
~f:(Lib.DB.resolve (Scope.libs scope)))
|
~f:(Lib.DB.resolve (Scope.libs scope)))
|
||||||
>>= fun more_libs ->
|
>>= fun more_libs ->
|
||||||
|
|
37
src/lib.ml
37
src/lib.ml
|
@ -575,7 +575,7 @@ module Dep_stack = struct
|
||||||
}
|
}
|
||||||
end
|
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
|
if (not allow_private_deps) && Status.is_private lib.info.status then
|
||||||
Result.Error (Error (
|
Result.Error (Error (
|
||||||
Private_deps_not_allowed { private_dep = lib ; pd_loc = loc }))
|
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
|
match find_internal db name ~stack with
|
||||||
| St_initializing id ->
|
| St_initializing id ->
|
||||||
Error (Dep_stack.dependency_cycle stack 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 ->
|
| St_not_found ->
|
||||||
Error (Error (Library_not_available { loc; name; reason = Not_found }))
|
Error (Error (Library_not_available { loc; name; reason = Not_found }))
|
||||||
| St_hidden (_, hidden) ->
|
| St_hidden (_, hidden) ->
|
||||||
|
@ -733,13 +733,8 @@ and available_internal db name ~stack =
|
||||||
| Error _ -> false
|
| Error _ -> false
|
||||||
|
|
||||||
and resolve_simple_deps db names ~allow_private_deps ~stack =
|
and resolve_simple_deps db names ~allow_private_deps ~stack =
|
||||||
let rec loop acc = function
|
Result.List.map names ~f:(fun (loc, name) ->
|
||||||
| [] -> Ok (List.rev acc)
|
resolve_dep db name ~allow_private_deps ~loc ~stack)
|
||||||
| (loc, name) :: names ->
|
|
||||||
resolve_dep db name ~allow_private_deps ~loc ~stack >>= fun x ->
|
|
||||||
loop (x :: acc) names
|
|
||||||
in
|
|
||||||
loop [] names
|
|
||||||
|
|
||||||
and resolve_complex_deps db deps ~allow_private_deps ~stack =
|
and resolve_complex_deps db deps ~allow_private_deps ~stack =
|
||||||
let res, resolved_selects =
|
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
|
let rec check_runtime_deps acc pps = function
|
||||||
| [] -> loop acc pps
|
| [] -> loop acc pps
|
||||||
| lib :: ppx_rts ->
|
| 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
|
check_runtime_deps (rt :: acc) pps ppx_rts
|
||||||
and loop acc = function
|
and loop acc = function
|
||||||
| [] -> Ok acc
|
| [] -> Ok acc
|
||||||
|
@ -838,7 +833,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
|
||||||
in
|
in
|
||||||
(deps, pps, resolved_selects)
|
(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 visited = ref String.Map.empty in
|
||||||
let res = ref [] in
|
let res = ref [] in
|
||||||
let orig_stack = stack in
|
let orig_stack = stack in
|
||||||
|
@ -874,16 +869,10 @@ and closure_with_overlap_checks db ts ~stack =
|
||||||
>>= fun () ->
|
>>= fun () ->
|
||||||
Dep_stack.push stack (to_id t) >>= fun stack ->
|
Dep_stack.push stack (to_id t) >>= fun stack ->
|
||||||
t.requires >>= fun deps ->
|
t.requires >>= fun deps ->
|
||||||
iter deps ~stack >>| fun () ->
|
Result.List.iter deps ~f:(loop ~stack) >>| fun () ->
|
||||||
res := t :: !res
|
res := t :: !res
|
||||||
and iter ts ~stack =
|
|
||||||
match ts with
|
|
||||||
| [] -> Ok ()
|
|
||||||
| t :: ts ->
|
|
||||||
loop t ~stack >>= fun () ->
|
|
||||||
iter ts ~stack
|
|
||||||
in
|
in
|
||||||
iter ts ~stack >>| fun () ->
|
Result.List.iter ts ~f:(loop ~stack) >>| fun () ->
|
||||||
List.rev !res
|
List.rev !res
|
||||||
|
|
||||||
let closure_with_overlap_checks db l =
|
let closure_with_overlap_checks db l =
|
||||||
|
@ -1035,14 +1024,8 @@ module DB = struct
|
||||||
; reason
|
; reason
|
||||||
}))
|
}))
|
||||||
|
|
||||||
let find_many =
|
let find_many t =
|
||||||
let rec loop t acc = function
|
Result.List.map ~f:(fun name -> resolve t (Loc.none, name))
|
||||||
| [] -> 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 available t name = available_internal t name ~stack:Dep_stack.empty
|
let available t name = available_internal t name ~stack:Dep_stack.empty
|
||||||
|
|
||||||
|
|
|
@ -85,7 +85,7 @@ module Driver = struct
|
||||||
; lib = lazy lib
|
; lib = lazy lib
|
||||||
; replaces =
|
; replaces =
|
||||||
let open Result.O in
|
let open Result.O in
|
||||||
Result.all
|
Result.List.all
|
||||||
(List.map info.replaces
|
(List.map info.replaces
|
||||||
~f:(fun ((loc, name) as x) ->
|
~f:(fun ((loc, name) as x) ->
|
||||||
resolve x >>= fun lib ->
|
resolve x >>= fun lib ->
|
||||||
|
|
|
@ -41,22 +41,40 @@ end
|
||||||
|
|
||||||
open O
|
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
|
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
|
||||||
|
|
|
@ -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 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 <message>] *)
|
(** Produce [Error <message>] *)
|
||||||
val errorf : ('a, unit, string, (_, string) t) format4 -> 'a
|
val errorf : ('a, unit, string, (_, string) t) format4 -> 'a
|
||||||
|
|
||||||
(** For compatibility with some other code *)
|
(** For compatibility with some other code *)
|
||||||
type ('a, 'error) result = ('a, 'error) t
|
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
|
||||||
|
|
|
@ -107,7 +107,7 @@ module Register_backend(M : Backend) = struct
|
||||||
let open Result.O in
|
let open Result.O in
|
||||||
written_by_user_or_scan ~written_by_user ~to_scan
|
written_by_user_or_scan ~written_by_user ~to_scan
|
||||||
>>= fun backends ->
|
>>= fun backends ->
|
||||||
wrap (Result.concat_map backends ~f:replaces)
|
wrap (Result.List.concat_map backends ~f:replaces)
|
||||||
>>= fun replaced_backends ->
|
>>= fun replaced_backends ->
|
||||||
match
|
match
|
||||||
Set.diff (Set.of_list backends) (Set.of_list replaced_backends)
|
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
|
(match M.Info.backends info with
|
||||||
| None -> Ok None
|
| None -> Ok None
|
||||||
| Some l ->
|
| 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)
|
>>| Option.some)
|
||||||
>>= fun written_by_user ->
|
>>= fun written_by_user ->
|
||||||
M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info)
|
M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info)
|
||||||
|
|
Loading…
Reference in New Issue