From 50eacb06902644cf92740dac82f0054498e069b6 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 22 Jul 2018 10:37:37 +0200 Subject: [PATCH 1/4] Add signature to Modules_field_evaluator Signed-off-by: Rudi Grinberg --- src/dir_contents.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index dba32c25..a713a375 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -3,7 +3,12 @@ module Menhir_rules = Menhir open Jbuild open! No_io -module Modules_field_evaluator = struct +module Modules_field_evaluator : sig + val eval + : modules:Module.t Module.Name.Map.t + -> buildable:Buildable.t + -> Module.t Module.Name.Map.t +end = struct module Eval = Ordered_set_lang.Make(Module.Name)(struct type t = (Module.t, Module.Name.t * Loc.t) result From 093cefc58b47d07022f2cffa82e44149916c906d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 22 Jul 2018 18:30:31 +0200 Subject: [PATCH 2/4] Add Loc preserving version of Ordered_set_lang.Make Signed-off-by: Rudi Grinberg --- src/ordered_set_lang.ml | 20 ++++++++++++++++++++ src/ordered_set_lang.mli | 17 +++++++++++++++++ 2 files changed, 37 insertions(+) diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 393f7a76..4881b025 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -204,6 +204,26 @@ module Make(Key : Key)(Value : Value with type key = Key.t) = struct Unordered.eval t ~parse ~standard 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 = { ast = Ast.Standard ; loc = None diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli index 6ebaf74f..066ea14c 100644 --- a/src/ordered_set_lang.mli +++ b/src/ordered_set_lang.mli @@ -46,6 +46,23 @@ module Make(Key : Key)(Value : Value with type key = Key.t) : S with type value = Value.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 is_standard : t -> bool From 4970448edf28359c6869010f9cd028c01c7b6315 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 22 Jul 2018 19:06:50 +0200 Subject: [PATCH 3/4] Add Module.uncapitalize Signed-off-by: Rudi Grinberg --- src/module.ml | 2 ++ src/module.mli | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/module.ml b/src/module.ml index 29de6356..bf690ac9 100644 --- a/src/module.ml +++ b/src/module.ml @@ -11,6 +11,8 @@ module Name = struct let of_string = String.capitalize let to_string x = x + let uncapitalize = String.uncapitalize + let pp = Format.pp_print_string let pp_quote fmt x = Format.fprintf fmt "%S" x diff --git a/src/module.mli b/src/module.mli index 2761ab03..e09f6182 100644 --- a/src/module.mli +++ b/src/module.mli @@ -10,6 +10,8 @@ module Name : sig val of_string : string -> t val to_string : t -> string + val uncapitalize : t -> string + val pp : Format.formatter -> t -> unit val pp_quote : Format.formatter -> t -> unit From 7eb7c6e21ae68ff5b8cfce006ba60fa08fb84bec Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 22 Jul 2018 19:07:02 +0200 Subject: [PATCH 4/4] 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 --- src/dir_contents.ml | 115 ++++++++++++++++++++------------------------ 1 file changed, 51 insertions(+), 64 deletions(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index a713a375..ac092002 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -9,49 +9,54 @@ module Modules_field_evaluator : sig -> buildable:Buildable.t -> Module.t Module.Name.Map.t 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 let key = function - | Error (s, _) -> s + | Error s -> s | Ok m -> Module.name m - end) - - let eval ~modules:(all_modules : Module.t Module.Name.Map.t) - ~buildable:(conf : Buildable.t) = - let fake_modules = ref Module.Name.Map.empty in - let parse ~loc s = + end in + let module Eval = Ordered_set_lang.Make_loc(Module.Name)(Value) in + let parse ~all_modules ~fake_modules ~loc s = let name = Module.Name.of_string s in match Module.Name.Map.find all_modules name with | Some m -> Ok m | None -> fake_modules := Module.Name.Map.add !fake_modules name loc; - Error (name, loc) + Error name in - let modules = - Eval.eval_unordered - conf.modules - ~parse - ~standard:(Module.Name.Map.map all_modules ~f:(fun m -> Ok m)) + fun ~all_modules ~standard osl -> + let fake_modules = ref Module.Name.Map.empty in + let parse = parse ~fake_modules ~all_modules in + let standard = Module.Name.Map.map standard ~f:(fun m -> Ok m) in + 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 - let only_present_modules modules = - 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 -> + Module.Name.Map.iteri fake_modules ~f:(fun m loc -> Loc.warn loc "Module %a is excluded but it doesn't exist." Module.Name.pp m ); @@ -67,17 +72,13 @@ end = struct Module.Name.Map.merge intf_only real_intf_only ~f:(fun name x y -> match x, y with | Some _, Some _ -> None - | None , Some _ -> - Some (Left (String.uncapitalize (Module.Name.to_string name))) - | Some _, None -> - Some (Right (String.uncapitalize (Module.Name.to_string name))) + | None , Some _ -> Some (Left name) + | Some _, None -> Some (Right name) | None , None -> assert false) |> Module.Name.Map.values |> List.partition_map ~f:(fun x -> x) in - let list_modules l = - String.concat ~sep:"\n" (List.map l ~f:(sprintf "- %s")) - in + let uncapitalized = List.map ~f:Module.Name.uncapitalize in if should_be_listed <> [] then begin match Ordered_set_lang.loc conf.modules_without_implementation with | None -> @@ -92,9 +93,15 @@ end = struct "modules_without_implementation" in Sexp.to_string ~syntax:Dune (List [ tag - ; Sexp.To_sexp.(list string) should_be_listed + ; Sexp.To_sexp.(list string) + (uncapitalized should_be_listed) ])) | Some loc -> + let list_modules l = + uncapitalized l + |> List.map ~f:(sprintf "- %s") + |> String.concat ~sep:"\n" + in Loc.warn loc "The following modules must be listed here as they don't \ have an implementation:\n\ @@ -103,35 +110,15 @@ end = struct (list_modules should_be_listed) end; if shouldn't_be_listed <> [] then begin - (* Re-evaluate conf.modules_without_implementation but this - time keep locations *) - let module Eval = - Ordered_set_lang.Make(Module.Name)(struct - 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) + let module_name = List.hd shouldn't_be_listed in + let (loc, _) = + Module.Name.Map.find modules_without_implementation_locs module_name + |> Option.value_exn in (* CR-soon jdimino for jdimino: report all errors *) - let loc, m = List.hd shouldn't_be_listed in Loc.fail loc "Module %a has an implementation, it cannot be listed here" - Module.Name.pp m.name + Module.Name.pp module_name end; modules end