Generalize Ordered_set_lang to return a custom map
This simplifes all the conversion from and to Module.Name.Map.t
This commit is contained in:
parent
ddefafa58b
commit
c8355b454c
|
@ -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
|
||||
|
||||
type key = Module.Name.t
|
||||
|
||||
let key = function
|
||||
| Error (s, _) -> s
|
||||
| Ok m -> Module.name m)
|
||||
|> Module.Name.to_string
|
||||
)
|
||||
| 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -15,3 +15,7 @@ let to_int = function
|
|||
| Lt -> -1
|
||||
| Eq -> 0
|
||||
| Gt -> 1
|
||||
|
||||
let neq = function
|
||||
| Eq -> false
|
||||
| Lt | Gt -> true
|
||||
|
|
|
@ -7,3 +7,5 @@ type t =
|
|||
|
||||
val of_int : int -> t
|
||||
val to_int : t -> int
|
||||
|
||||
val neq : t -> bool
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue