diff --git a/src/gen_rules.ml b/src/gen_rules.ml index c692b2f1..bbcf4b18 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -24,19 +24,18 @@ module Gen(P : Install_rules.Params) = struct | Interpretation of [modules] fields | +-----------------------------------------------------------------+ *) - module Eval_modules = Ordered_set_lang.Make(struct + module Eval_modules = Ordered_set_lang.Make(Module.Name)(struct type t = (Module.t, Module.Name.t * Loc.t) result - let name r = ( - (match r with - | Error (s, _) -> s - | Ok m -> Module.name m) - |> Module.Name.to_string - ) + + type key = Module.Name.t + + let key = function + | Error (s, _) -> s + | Ok m -> Module.name m end) - let parse_modules ~(all_modules : Module.t Module.Name.Map.t) ~buildable = - let conf : Buildable.t = buildable in - let standard_modules = Module.Name.Map.map all_modules ~f:(fun m -> Ok m) in + let parse_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 = let name = Module.Name.of_string s in @@ -47,12 +46,10 @@ module Gen(P : Install_rules.Params) = struct Error (name, loc) in let modules = - let standard = Module.Name.Map.to_smap standard_modules in Eval_modules.eval_unordered conf.modules ~parse - ~standard - |> Module.Name.Map.of_smap + ~standard:(Module.Name.Map.map all_modules ~f:(fun m -> Ok m)) in let only_present_modules modules = Module.Name.Map.filter_map ~f:(function @@ -66,8 +63,7 @@ module Gen(P : Install_rules.Params) = struct Eval_modules.eval_unordered conf.modules_without_implementation ~parse - ~standard:String_map.empty - |> Module.Name.Map.of_smap + ~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 -> @@ -124,9 +120,10 @@ module Gen(P : Install_rules.Params) = struct (* Re-evaluate conf.modules_without_implementation but this time keep locations *) let module Eval = - Ordered_set_lang.Make(struct + Ordered_set_lang.Make(Module.Name)(struct type t = Loc.t * Module.t - let name (_, m) = Module.Name.to_string (Module.name m) + type key = Module.Name.t + let key (_, m) = Module.name m end) in let parse ~loc s = @@ -137,11 +134,10 @@ module Gen(P : Install_rules.Params) = struct in let parse ~loc s = (loc, parse ~loc s) in let shouldn't_be_listed = - let all_modules = Module.Name.Map.to_smap all_modules in Eval.eval_unordered conf.modules_without_implementation ~parse - ~standard:(String_map.map all_modules ~f:(fun m -> (Loc.none, m))) - |> String_map.values + ~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 diff --git a/src/module.ml b/src/module.ml index 7c6d6673..a612fda2 100644 --- a/src/module.ml +++ b/src/module.ml @@ -14,17 +14,8 @@ module Name = struct let pp = Format.pp_print_string let pp_quote fmt x = Format.fprintf fmt "%S" x - module Set = struct - include String_set - let of_sset x = x - end - - module Map = struct - include String_map - - let to_smap x = x - let of_smap x = x - end + module Set = String_set + module Map = String_map end module Syntax = struct diff --git a/src/module.mli b/src/module.mli index ffb22f42..bd07a8dc 100644 --- a/src/module.mli +++ b/src/module.mli @@ -13,17 +13,8 @@ module Name : sig val pp : Format.formatter -> t -> unit val pp_quote : Format.formatter -> t -> unit - module Set : sig - include Set.S with type elt = t - - val of_sset : String_set.t -> t - end - module Map : sig - include Map.S with type key = t - - val to_smap : 'a t -> 'a String_map.t - val of_smap : 'a String_map.t -> 'a t - end + module Set : Set.S with type elt = t + module Map : Map.S with type key = t end module Syntax : sig diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index b268ffd1..fe5a6dc7 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -58,10 +58,17 @@ let is_standard t = module type Value = sig type t - val name : t -> string + type key + val key : t -> key end -module Make(Value : Value) = struct +module type Key = sig + type t + val compare : t -> t -> Ordering.t + module Map : Map.S with type key = t +end + +module Make(Key : Key)(Value : Value with type key = Key.t) = struct module type Named_values = sig type t @@ -99,23 +106,24 @@ module Make(Value : Value) = struct let union = List.flatten let diff a b = List.filter a ~f:(fun x -> - List.for_all b ~f:(fun y -> Value.name x <> Value.name y)) + List.for_all b ~f:(fun y -> + Ordering.neq (Key.compare (Value.key x) (Value.key y)))) end) module Unordered = Make(struct - type t = Value.t String_map.t + type t = Value.t Key.Map.t - let singleton x = String_map.singleton (Value.name x) x + let singleton x = Key.Map.singleton (Value.key x) x let union l = - List.fold_left l ~init:String_map.empty ~f:(fun acc t -> - String_map.merge acc t ~f:(fun _name x y -> + List.fold_left l ~init:Key.Map.empty ~f:(fun acc t -> + Key.Map.merge acc t ~f:(fun _name x y -> match x, y with | Some x, _ | _, Some x -> Some x | _ -> None)) let diff a b = - String_map.merge a b ~f:(fun _name x y -> + Key.Map.merge a b ~f:(fun _name x y -> match x, y with | Some _, None -> x | _ -> None) diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli index 483a1c08..cf975acb 100644 --- a/src/ordered_set_lang.mli +++ b/src/ordered_set_lang.mli @@ -12,10 +12,17 @@ val loc : t -> Loc.t option (** Value parsed from elements in the DSL *) module type Value = sig type t - val name : t -> string + type key + val key : t -> key end -module Make(Value : Value) : sig +module type Key = sig + type t + val compare : t -> t -> Ordering.t + module Map : Map.S with type key = t +end + +module Make(Key : Key)(Value : Value with type key = Key.t) : sig (** Evaluate an ordered set. [standard] is the interpretation of [:standard] inside the DSL. *) val eval @@ -28,8 +35,8 @@ module Make(Value : Value) : sig val eval_unordered : t -> parse:(loc:Loc.t -> string -> Value.t) - -> standard:Value.t String_map.t - -> Value.t String_map.t + -> standard:Value.t Key.Map.t + -> Value.t Key.Map.t end val standard : t diff --git a/src/stdune/ordering.ml b/src/stdune/ordering.ml index 99d48e2a..27ee1fd3 100644 --- a/src/stdune/ordering.ml +++ b/src/stdune/ordering.ml @@ -15,3 +15,7 @@ let to_int = function | Lt -> -1 | Eq -> 0 | Gt -> 1 + +let neq = function + | Eq -> false + | Lt | Gt -> true diff --git a/src/stdune/ordering.mli b/src/stdune/ordering.mli index 3c22f1f2..04bd168b 100644 --- a/src/stdune/ordering.mli +++ b/src/stdune/ordering.mli @@ -7,3 +7,5 @@ type t = val of_int : int -> t val to_int : t -> int + +val neq : t -> bool diff --git a/src/super_context.ml b/src/super_context.ml index 207badf1..9a83da73 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -649,7 +649,12 @@ end module Eval_strings = Ordered_set_lang.Make(struct type t = string - let name t = t + let compare = String.compare + module Map = String_map + end)(struct + type t = string + type key = string + let key x = x end) let expand_and_eval_set t ~scope ~dir ?extra_vars set ~standard =