Decouple error detection from reporting in modules field
Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
3667db05fc
commit
7fb18ebbd3
|
@ -43,22 +43,61 @@ end = struct
|
||||||
, modules
|
, modules
|
||||||
)
|
)
|
||||||
|
|
||||||
let check_invalid_module_listing ~(buildable : Buildable.t) ~intf_only
|
type field =
|
||||||
~real_intf_only ~modules_without_implementation_locs =
|
| Modules
|
||||||
if not (Module.Name.Map.equal intf_only real_intf_only
|
| Intf_only
|
||||||
~equal:(fun a b -> Module.name a = Module.name b)) then begin
|
|
||||||
let should_be_listed, shouldn't_be_listed =
|
type incorrect_field =
|
||||||
Module.Name.Map.merge intf_only real_intf_only ~f:(fun name x y ->
|
{ correct_field : field
|
||||||
match x, y with
|
; module_: Module.t
|
||||||
| Some _, Some _ -> None
|
}
|
||||||
| None , Some _ -> Some (Left name)
|
|
||||||
| Some _, None -> Some (Right name)
|
type error =
|
||||||
| None , None -> assert false)
|
| Incorrect_field of incorrect_field
|
||||||
|> Module.Name.Map.values
|
|
||||||
|> List.partition_map ~f:(fun x -> x)
|
let fold_errors ~f ~init ~modules ~intf_only =
|
||||||
|
let init =
|
||||||
|
Module.Name.Map.fold intf_only ~init
|
||||||
|
~f:(fun (module_ : Module.t) acc ->
|
||||||
|
if Option.is_none module_.impl then
|
||||||
|
acc
|
||||||
|
else
|
||||||
|
f (Incorrect_field
|
||||||
|
{ correct_field = Modules
|
||||||
|
; module_
|
||||||
|
}
|
||||||
|
) acc)
|
||||||
in
|
in
|
||||||
let uncapitalized = List.map ~f:Module.Name.uncapitalize in
|
Module.Name.Map.fold modules ~init
|
||||||
if should_be_listed <> [] then begin
|
~f:(fun (module_ : Module.t) acc ->
|
||||||
|
if Option.is_some module_.impl then
|
||||||
|
acc
|
||||||
|
else if not (Module.Name.Map.mem intf_only (Module.name module_)) then
|
||||||
|
f (Incorrect_field
|
||||||
|
{ correct_field = Intf_only
|
||||||
|
; module_
|
||||||
|
}
|
||||||
|
) acc
|
||||||
|
else
|
||||||
|
acc)
|
||||||
|
|
||||||
|
let check_invalid_module_listing ~(buildable : Buildable.t) ~intf_only
|
||||||
|
~modules ~modules_without_implementation_locs =
|
||||||
|
let (missing_modules, missing_intf_only) =
|
||||||
|
let (missing_modules, missing_intf_only) =
|
||||||
|
fold_errors ~init:([], []) ~modules ~intf_only
|
||||||
|
~f:(fun e (missing_modules, missing_intf_only) ->
|
||||||
|
let (Incorrect_field { correct_field; module_ }) = e in
|
||||||
|
begin match correct_field with
|
||||||
|
| Modules -> (module_ :: missing_modules, missing_intf_only)
|
||||||
|
| Intf_only -> (missing_modules, module_ :: missing_intf_only)
|
||||||
|
end)
|
||||||
|
in
|
||||||
|
(List.rev missing_modules, List.rev missing_intf_only)
|
||||||
|
in
|
||||||
|
let uncapitalized =
|
||||||
|
List.map ~f:(fun m -> Module.name m |> Module.Name.uncapitalize) in
|
||||||
|
if missing_intf_only <> [] then begin
|
||||||
match Ordered_set_lang.loc buildable.modules_without_implementation with
|
match Ordered_set_lang.loc buildable.modules_without_implementation with
|
||||||
| None ->
|
| None ->
|
||||||
Loc.warn buildable.loc
|
Loc.warn buildable.loc
|
||||||
|
@ -71,7 +110,7 @@ end = struct
|
||||||
(let tag = Sexp.unsafe_atom_of_string
|
(let tag = Sexp.unsafe_atom_of_string
|
||||||
"modules_without_implementation" in
|
"modules_without_implementation" in
|
||||||
let modules =
|
let modules =
|
||||||
should_be_listed
|
missing_intf_only
|
||||||
|> uncapitalized
|
|> uncapitalized
|
||||||
|> List.map ~f:Sexp.To_sexp.string
|
|> List.map ~f:Sexp.To_sexp.string
|
||||||
in
|
in
|
||||||
|
@ -87,10 +126,10 @@ end = struct
|
||||||
have an implementation:\n\
|
have an implementation:\n\
|
||||||
%s\n\
|
%s\n\
|
||||||
This will become an error in the future."
|
This will become an error in the future."
|
||||||
(list_modules should_be_listed)
|
(list_modules missing_intf_only)
|
||||||
end;
|
end;
|
||||||
if shouldn't_be_listed <> [] then begin
|
if missing_modules <> [] then begin
|
||||||
let module_name = List.hd shouldn't_be_listed in
|
let module_name = Module.name (List.hd missing_modules) in
|
||||||
let (loc, _) =
|
let (loc, _) =
|
||||||
Module.Name.Map.find modules_without_implementation_locs module_name
|
Module.Name.Map.find modules_without_implementation_locs module_name
|
||||||
|> Option.value_exn
|
|> Option.value_exn
|
||||||
|
@ -100,7 +139,6 @@ end = struct
|
||||||
"Module %a has an implementation, it cannot be listed here"
|
"Module %a has an implementation, it cannot be listed here"
|
||||||
Module.Name.pp module_name
|
Module.Name.pp module_name
|
||||||
end
|
end
|
||||||
end
|
|
||||||
|
|
||||||
let eval ~modules:(all_modules : Module.t Module.Name.Map.t)
|
let eval ~modules:(all_modules : Module.t Module.Name.Map.t)
|
||||||
~buildable:(conf : Buildable.t) =
|
~buildable:(conf : Buildable.t) =
|
||||||
|
@ -119,10 +157,7 @@ end = struct
|
||||||
Loc.warn loc "Module %a is excluded but it doesn't exist."
|
Loc.warn loc "Module %a is excluded but it doesn't exist."
|
||||||
Module.Name.pp m
|
Module.Name.pp m
|
||||||
);
|
);
|
||||||
let real_intf_only =
|
check_invalid_module_listing ~buildable:conf ~intf_only ~modules
|
||||||
Module.Name.Map.filter modules
|
|
||||||
~f:(fun (m : Module.t) -> Option.is_none m.impl) in
|
|
||||||
check_invalid_module_listing ~buildable:conf ~intf_only ~real_intf_only
|
|
||||||
~modules_without_implementation_locs;
|
~modules_without_implementation_locs;
|
||||||
modules
|
modules
|
||||||
end
|
end
|
||||||
|
|
Loading…
Reference in New Issue