Merge pull request #1043 from rgrinberg/module-evaluator
Simplify module evaluator logic
This commit is contained in:
commit
5e7841abf2
|
@ -3,50 +3,60 @@ module Menhir_rules = Menhir
|
||||||
open Jbuild
|
open Jbuild
|
||||||
open! No_io
|
open! No_io
|
||||||
|
|
||||||
module Modules_field_evaluator = struct
|
module Modules_field_evaluator : sig
|
||||||
module Eval = Ordered_set_lang.Make(Module.Name)(struct
|
val eval
|
||||||
type t = (Module.t, Module.Name.t * Loc.t) result
|
: modules:Module.t Module.Name.Map.t
|
||||||
|
-> buildable:Buildable.t
|
||||||
|
-> Module.t Module.Name.Map.t
|
||||||
|
end = struct
|
||||||
|
|
||||||
|
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
|
||||||
);
|
);
|
||||||
|
@ -62,17 +72,13 @@ module Modules_field_evaluator = 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 ->
|
||||||
|
@ -87,9 +93,15 @@ module Modules_field_evaluator = 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\
|
||||||
|
@ -98,35 +110,15 @@ module Modules_field_evaluator = 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
|
||||||
|
|
|
@ -11,6 +11,8 @@ module Name = struct
|
||||||
let of_string = String.capitalize
|
let of_string = String.capitalize
|
||||||
let to_string x = x
|
let to_string x = x
|
||||||
|
|
||||||
|
let uncapitalize = String.uncapitalize
|
||||||
|
|
||||||
let pp = Format.pp_print_string
|
let pp = Format.pp_print_string
|
||||||
let pp_quote fmt x = Format.fprintf fmt "%S" x
|
let pp_quote fmt x = Format.fprintf fmt "%S" x
|
||||||
|
|
||||||
|
|
|
@ -10,6 +10,8 @@ module Name : sig
|
||||||
val of_string : string -> t
|
val of_string : string -> t
|
||||||
val to_string : t -> string
|
val to_string : t -> string
|
||||||
|
|
||||||
|
val uncapitalize : t -> string
|
||||||
|
|
||||||
val pp : Format.formatter -> t -> unit
|
val pp : Format.formatter -> t -> unit
|
||||||
val pp_quote : Format.formatter -> t -> unit
|
val pp_quote : Format.formatter -> t -> unit
|
||||||
|
|
||||||
|
|
|
@ -204,6 +204,26 @@ module Make(Key : Key)(Value : Value with type key = Key.t) = struct
|
||||||
Unordered.eval t ~parse ~standard
|
Unordered.eval t ~parse ~standard
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Make_loc(Key : Key)(Value : Value with type key = Key.t) = struct
|
||||||
|
module No_loc = Make(Key)(struct
|
||||||
|
type t = Loc.t * Value.t
|
||||||
|
type key = Key.t
|
||||||
|
let key (_loc, s) = Value.key s
|
||||||
|
end)
|
||||||
|
|
||||||
|
let loc_parse f ~loc s = (loc, f ~loc s)
|
||||||
|
|
||||||
|
let eval t ~parse ~standard =
|
||||||
|
No_loc.eval t
|
||||||
|
~parse:(loc_parse parse)
|
||||||
|
~standard:(List.map standard ~f:(fun x -> (Loc.none, x)))
|
||||||
|
|
||||||
|
let eval_unordered t ~parse ~standard =
|
||||||
|
No_loc.eval_unordered t
|
||||||
|
~parse:(loc_parse parse)
|
||||||
|
~standard:(Key.Map.map standard ~f:(fun x -> (Loc.none, x)))
|
||||||
|
end
|
||||||
|
|
||||||
let standard =
|
let standard =
|
||||||
{ ast = Ast.Standard
|
{ ast = Ast.Standard
|
||||||
; loc = None
|
; loc = None
|
||||||
|
|
|
@ -46,6 +46,23 @@ module Make(Key : Key)(Value : Value with type key = Key.t)
|
||||||
: S with type value = Value.t
|
: S with type value = Value.t
|
||||||
and type 'a map = 'a Key.Map.t
|
and type 'a map = 'a Key.Map.t
|
||||||
|
|
||||||
|
(** same as [Make] but will retain the source location of the values in the
|
||||||
|
evaluated results *)
|
||||||
|
module Make_loc (Key : Key)(Value : Value with type key = Key.t) : sig
|
||||||
|
val eval
|
||||||
|
: t
|
||||||
|
-> parse:(loc:Loc.t -> string -> Value.t)
|
||||||
|
-> standard:Value.t list
|
||||||
|
-> (Loc.t * Value.t) list
|
||||||
|
|
||||||
|
(** Same as [eval] but the result is unordered *)
|
||||||
|
val eval_unordered
|
||||||
|
: t
|
||||||
|
-> parse:(loc:Loc.t -> string -> Value.t)
|
||||||
|
-> standard:Value.t Key.Map.t
|
||||||
|
-> (Loc.t * Value.t) Key.Map.t
|
||||||
|
end
|
||||||
|
|
||||||
val standard : t
|
val standard : t
|
||||||
val is_standard : t -> bool
|
val is_standard : t -> bool
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue