Simplify module OSL evaluation
Use Ordered_set_lang.Make_loc to automatically book keep the location for us. Also cut down on some module name to string conversions that was just making the code noisy. The fake_modules detection has been changed to hide the mutabiility from the main algorithm Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
4970448edf
commit
7eb7c6e21a
|
@ -9,49 +9,54 @@ module Modules_field_evaluator : sig
|
||||||
-> buildable:Buildable.t
|
-> buildable:Buildable.t
|
||||||
-> Module.t Module.Name.Map.t
|
-> Module.t Module.Name.Map.t
|
||||||
end = struct
|
end = struct
|
||||||
module Eval = Ordered_set_lang.Make(Module.Name)(struct
|
|
||||||
type t = (Module.t, Module.Name.t * Loc.t) result
|
let eval =
|
||||||
|
let module Value = struct
|
||||||
|
type t = (Module.t, Module.Name.t) result
|
||||||
|
|
||||||
type key = Module.Name.t
|
type key = Module.Name.t
|
||||||
|
|
||||||
let key = function
|
let key = function
|
||||||
| Error (s, _) -> s
|
| Error s -> s
|
||||||
| Ok m -> Module.name m
|
| Ok m -> Module.name m
|
||||||
end)
|
end in
|
||||||
|
let module Eval = Ordered_set_lang.Make_loc(Module.Name)(Value) in
|
||||||
let eval ~modules:(all_modules : Module.t Module.Name.Map.t)
|
let parse ~all_modules ~fake_modules ~loc s =
|
||||||
~buildable:(conf : Buildable.t) =
|
|
||||||
let fake_modules = ref Module.Name.Map.empty in
|
|
||||||
let parse ~loc s =
|
|
||||||
let name = Module.Name.of_string s in
|
let name = Module.Name.of_string s in
|
||||||
match Module.Name.Map.find all_modules name with
|
match Module.Name.Map.find all_modules name with
|
||||||
| Some m -> Ok m
|
| Some m -> Ok m
|
||||||
| None ->
|
| None ->
|
||||||
fake_modules := Module.Name.Map.add !fake_modules name loc;
|
fake_modules := Module.Name.Map.add !fake_modules name loc;
|
||||||
Error (name, loc)
|
Error name
|
||||||
in
|
in
|
||||||
let modules =
|
fun ~all_modules ~standard osl ->
|
||||||
Eval.eval_unordered
|
let fake_modules = ref Module.Name.Map.empty in
|
||||||
conf.modules
|
let parse = parse ~fake_modules ~all_modules in
|
||||||
~parse
|
let standard = Module.Name.Map.map standard ~f:(fun m -> Ok m) in
|
||||||
~standard:(Module.Name.Map.map all_modules ~f:(fun m -> Ok m))
|
let modules = Eval.eval_unordered ~parse ~standard osl in
|
||||||
|
( !fake_modules
|
||||||
|
, Module.Name.Map.filter_map modules ~f:(fun (loc, m) ->
|
||||||
|
match m with
|
||||||
|
| Ok m -> Some m
|
||||||
|
| Error s ->
|
||||||
|
Loc.fail loc "Module %a doesn't exist." Module.Name.pp s)
|
||||||
|
, modules
|
||||||
|
)
|
||||||
|
|
||||||
|
let eval ~modules:(all_modules : Module.t Module.Name.Map.t)
|
||||||
|
~buildable:(conf : Buildable.t) =
|
||||||
|
let (fake_modules, modules, _) =
|
||||||
|
eval ~standard:all_modules ~all_modules conf.modules in
|
||||||
|
let (fake_modules, intf_only, modules_without_implementation_locs) =
|
||||||
|
let (fake_modules', intf_only, locs) =
|
||||||
|
eval ~standard:Module.Name.Map.empty ~all_modules
|
||||||
|
conf.modules_without_implementation in
|
||||||
|
( Module.Name.Map.superpose fake_modules' fake_modules
|
||||||
|
, intf_only
|
||||||
|
, locs
|
||||||
|
)
|
||||||
in
|
in
|
||||||
let only_present_modules modules =
|
Module.Name.Map.iteri fake_modules ~f:(fun m loc ->
|
||||||
Module.Name.Map.filter_map ~f:(function
|
|
||||||
| Ok m -> Some m
|
|
||||||
| Error (s, loc) ->
|
|
||||||
Loc.fail loc "Module %a doesn't exist." Module.Name.pp s
|
|
||||||
) modules
|
|
||||||
in
|
|
||||||
let modules = only_present_modules modules in
|
|
||||||
let intf_only =
|
|
||||||
Eval.eval_unordered
|
|
||||||
conf.modules_without_implementation
|
|
||||||
~parse
|
|
||||||
~standard:Module.Name.Map.empty
|
|
||||||
in
|
|
||||||
let intf_only = only_present_modules intf_only in
|
|
||||||
Module.Name.Map.iteri !fake_modules ~f:(fun m loc ->
|
|
||||||
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
|
||||||
);
|
);
|
||||||
|
@ -67,17 +72,13 @@ end = struct
|
||||||
Module.Name.Map.merge intf_only real_intf_only ~f:(fun name x y ->
|
Module.Name.Map.merge intf_only real_intf_only ~f:(fun name x y ->
|
||||||
match x, y with
|
match x, y with
|
||||||
| Some _, Some _ -> None
|
| Some _, Some _ -> None
|
||||||
| None , Some _ ->
|
| None , Some _ -> Some (Left name)
|
||||||
Some (Left (String.uncapitalize (Module.Name.to_string name)))
|
| Some _, None -> Some (Right name)
|
||||||
| Some _, None ->
|
|
||||||
Some (Right (String.uncapitalize (Module.Name.to_string name)))
|
|
||||||
| None , None -> assert false)
|
| None , None -> assert false)
|
||||||
|> Module.Name.Map.values
|
|> Module.Name.Map.values
|
||||||
|> List.partition_map ~f:(fun x -> x)
|
|> List.partition_map ~f:(fun x -> x)
|
||||||
in
|
in
|
||||||
let list_modules l =
|
let uncapitalized = List.map ~f:Module.Name.uncapitalize in
|
||||||
String.concat ~sep:"\n" (List.map l ~f:(sprintf "- %s"))
|
|
||||||
in
|
|
||||||
if should_be_listed <> [] then begin
|
if should_be_listed <> [] then begin
|
||||||
match Ordered_set_lang.loc conf.modules_without_implementation with
|
match Ordered_set_lang.loc conf.modules_without_implementation with
|
||||||
| None ->
|
| None ->
|
||||||
|
@ -92,9 +93,15 @@ end = struct
|
||||||
"modules_without_implementation" in
|
"modules_without_implementation" in
|
||||||
Sexp.to_string ~syntax:Dune
|
Sexp.to_string ~syntax:Dune
|
||||||
(List [ tag
|
(List [ tag
|
||||||
; Sexp.To_sexp.(list string) should_be_listed
|
; Sexp.To_sexp.(list string)
|
||||||
|
(uncapitalized should_be_listed)
|
||||||
]))
|
]))
|
||||||
| Some loc ->
|
| Some loc ->
|
||||||
|
let list_modules l =
|
||||||
|
uncapitalized l
|
||||||
|
|> List.map ~f:(sprintf "- %s")
|
||||||
|
|> String.concat ~sep:"\n"
|
||||||
|
in
|
||||||
Loc.warn loc
|
Loc.warn loc
|
||||||
"The following modules must be listed here as they don't \
|
"The following modules must be listed here as they don't \
|
||||||
have an implementation:\n\
|
have an implementation:\n\
|
||||||
|
@ -103,35 +110,15 @@ end = struct
|
||||||
(list_modules should_be_listed)
|
(list_modules should_be_listed)
|
||||||
end;
|
end;
|
||||||
if shouldn't_be_listed <> [] then begin
|
if shouldn't_be_listed <> [] then begin
|
||||||
(* Re-evaluate conf.modules_without_implementation but this
|
let module_name = List.hd shouldn't_be_listed in
|
||||||
time keep locations *)
|
let (loc, _) =
|
||||||
let module Eval =
|
Module.Name.Map.find modules_without_implementation_locs module_name
|
||||||
Ordered_set_lang.Make(Module.Name)(struct
|
|> Option.value_exn
|
||||||
type t = Loc.t * Module.t
|
|
||||||
type key = Module.Name.t
|
|
||||||
let key (_, m) = Module.name m
|
|
||||||
end)
|
|
||||||
in
|
|
||||||
let parse ~loc s =
|
|
||||||
let name = Module.Name.of_string s in
|
|
||||||
match Module.Name.Map.find all_modules name with
|
|
||||||
| Some m -> m
|
|
||||||
| None -> Loc.fail loc "Module %s doesn't exist." s
|
|
||||||
in
|
|
||||||
let parse ~loc s = (loc, parse ~loc s) in
|
|
||||||
let shouldn't_be_listed =
|
|
||||||
Eval.eval_unordered conf.modules_without_implementation
|
|
||||||
~parse
|
|
||||||
~standard:(Module.Name.Map.map all_modules ~f:(fun m -> (Loc.none, m)))
|
|
||||||
|> Module.Name.Map.values
|
|
||||||
|> List.filter ~f:(fun (_, (m : Module.t)) ->
|
|
||||||
Option.is_some m.impl)
|
|
||||||
in
|
in
|
||||||
(* CR-soon jdimino for jdimino: report all errors *)
|
(* CR-soon jdimino for jdimino: report all errors *)
|
||||||
let loc, m = List.hd shouldn't_be_listed in
|
|
||||||
Loc.fail loc
|
Loc.fail loc
|
||||||
"Module %a has an implementation, it cannot be listed here"
|
"Module %a has an implementation, it cannot be listed here"
|
||||||
Module.Name.pp m.name
|
Module.Name.pp module_name
|
||||||
end;
|
end;
|
||||||
modules
|
modules
|
||||||
end
|
end
|
||||||
|
|
Loading…
Reference in New Issue