matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ws

This commit is contained in:
Jeremie Dimino 2018-03-05 15:05:03 +00:00
parent 75fe147da9
commit 3edc029bf4
1 changed files with 115 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

230
src/lib.ml
View File

@ -663,132 +663,132 @@ and resolve_name db name ~stack =
instantiate db name info ~stack ~hidden:(Some hidden) instantiate db name info ~stack ~hidden:(Some hidden)
and available_internal db name ~stack = and available_internal db name ~stack =
match resolve_dep db name ~loc:Loc.none ~stack with match resolve_dep db name ~loc:Loc.none ~stack with
| Ok _ -> true | Ok _ -> true
| Error _ -> false | Error _ -> false
and resolve_simple_deps db names ~stack = and resolve_simple_deps db names ~stack =
let rec loop acc = function let rec loop acc = function
| [] -> Ok (List.rev acc) | [] -> Ok (List.rev acc)
| (loc, name) :: names -> | (loc, name) :: names ->
resolve_dep db name ~loc ~stack >>= fun x -> resolve_dep db name ~loc ~stack >>= fun x ->
loop (x :: acc) names loop (x :: acc) names
in in
loop [] names loop [] names
and resolve_complex_deps db deps ~stack = and resolve_complex_deps db deps ~stack =
let res, resolved_selects = let res, resolved_selects =
List.fold_left deps ~init:(Ok [], []) ~f:(fun (acc_res, acc_selects) dep -> List.fold_left deps ~init:(Ok [], []) ~f:(fun (acc_res, acc_selects) dep ->
let res, acc_selects = let res, acc_selects =
match (dep : Jbuild.Lib_dep.t) with match (dep : Jbuild.Lib_dep.t) with
| Direct (loc, name) -> | Direct (loc, name) ->
let res = let res =
resolve_dep db name ~loc ~stack >>| fun x -> [x] resolve_dep db name ~loc ~stack >>| fun x -> [x]
in in
(res, acc_selects) (res, acc_selects)
| Select { result_fn; choices; loc } -> | Select { result_fn; choices; loc } ->
let res, src_fn = let res, src_fn =
match match
List.find_map choices ~f:(fun { required; forbidden; file } -> List.find_map choices ~f:(fun { required; forbidden; file } ->
if String_set.exists forbidden if String_set.exists forbidden
~f:(available_internal db ~stack) then ~f:(available_internal db ~stack) then
None None
else else
match match
let deps = let deps =
String_set.fold required ~init:[] ~f:(fun x acc -> String_set.fold required ~init:[] ~f:(fun x acc ->
(Loc.none, x) :: acc) (Loc.none, x) :: acc)
in in
resolve_simple_deps db deps ~stack resolve_simple_deps db deps ~stack
with with
| Ok ts -> Some (ts, file) | Ok ts -> Some (ts, file)
| Error _ -> None) | Error _ -> None)
with with
| Some (ts, file) -> | Some (ts, file) ->
(Ok ts, Ok file) (Ok ts, Ok file)
| None -> | None ->
let e = { Error.No_solution_found_for_select.loc } in let e = { Error.No_solution_found_for_select.loc } in
(Error (Error (No_solution_found_for_select e)), (Error (Error (No_solution_found_for_select e)),
Error e) Error e)
in in
(res, { Resolved_select. src_fn; dst_fn = result_fn } :: acc_selects) (res, { Resolved_select. src_fn; dst_fn = result_fn } :: acc_selects)
in in
let res = let res =
match res, acc_res with match res, acc_res with
| Ok l, Ok acc -> Ok (List.rev_append l acc) | Ok l, Ok acc -> Ok (List.rev_append l acc)
| (Error _ as res), _ | (Error _ as res), _
| _, (Error _ as res) -> res | _, (Error _ as res) -> res
in in
(res, acc_selects)) (res, acc_selects))
in in
let res = let res =
match res with match res with
| Ok l -> Ok (List.rev l) | Ok l -> Ok (List.rev l)
| Error _ -> res | Error _ -> res
in in
(res, resolved_selects) (res, resolved_selects)
and resolve_deps db deps ~stack = and resolve_deps db deps ~stack =
match (deps : Info.Deps.t) with match (deps : Info.Deps.t) with
| Simple names -> (resolve_simple_deps db names ~stack, []) | Simple names -> (resolve_simple_deps db names ~stack, [])
| Complex names -> resolve_complex_deps db names ~stack | Complex names -> resolve_complex_deps db names ~stack
and resolve_user_deps db deps ~pps ~stack = and resolve_user_deps db deps ~pps ~stack =
let deps, resolved_selects = resolve_deps db deps ~stack in let deps, resolved_selects = resolve_deps db deps ~stack in
let deps, pps = let deps, pps =
match pps with match pps with
| [] -> (deps, Ok []) | [] -> (deps, Ok [])
| pps -> | pps ->
let pps = let pps =
let pps = (pps : (Loc.t * Jbuild.Pp.t) list :> (Loc.t * string) list) in let pps = (pps : (Loc.t * Jbuild.Pp.t) list :> (Loc.t * string) list) in
resolve_simple_deps db pps ~stack >>= fun pps -> resolve_simple_deps db pps ~stack >>= fun pps ->
closure pps ~stack closure pps ~stack
in
let deps =
let rec loop acc = function
| [] -> Ok acc
| pp :: pps ->
pp.ppx_runtime_deps >>= fun rt_deps ->
loop (List.rev_append rt_deps acc) pps
in in
let deps = deps >>= fun deps ->
let rec loop acc = function pps >>= fun pps ->
| [] -> Ok acc loop deps pps
| pp :: pps -> in
pp.ppx_runtime_deps >>= fun rt_deps -> (deps, pps)
loop (List.rev_append rt_deps acc) pps in
in (deps, pps, resolved_selects)
deps >>= fun deps ->
pps >>= fun pps ->
loop deps pps
in
(deps, pps)
in
(deps, pps, resolved_selects)
and closure ts ~stack = and closure 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
let rec loop t ~stack = let rec loop t ~stack =
match String_map.find !visited t.name with match String_map.find !visited t.name with
| Some (t', stack') -> | Some (t', stack') ->
if t.unique_id = t'.unique_id then if t.unique_id = t'.unique_id then
Ok () Ok ()
else else
let req_by = Dep_stack.to_required_by ~stop_at:orig_stack in let req_by = Dep_stack.to_required_by ~stop_at:orig_stack in
Error Error
(Error (Conflict { lib1 = (t', req_by stack') (Error (Conflict { lib1 = (t', req_by stack')
; lib2 = (t , req_by stack ) ; lib2 = (t , req_by stack )
})) }))
| None -> | None ->
visited := String_map.add !visited t.name (t, stack); visited := String_map.add !visited t.name (t, stack);
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 () -> iter deps ~stack >>| fun () ->
res := t :: !res res := t :: !res
and iter ts ~stack = and iter ts ~stack =
match ts with match ts with
| [] -> Ok () | [] -> Ok ()
| t :: ts -> | t :: ts ->
loop t ~stack >>= fun () -> loop t ~stack >>= fun () ->
iter ts ~stack iter ts ~stack
in in
iter ts ~stack >>| fun () -> iter ts ~stack >>| fun () ->
List.rev !res List.rev !res
let closure l = closure l ~stack:Dep_stack.empty let closure l = closure l ~stack:Dep_stack.empty