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:
Rudi Grinberg 2018-03-06 14:12:51 +07:00
parent ddefafa58b
commit c8355b454c
8 changed files with 59 additions and 55 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -15,3 +15,7 @@ let to_int = function
| Lt -> -1
| Eq -> 0
| Gt -> 1
let neq = function
| Eq -> false
| Lt | Gt -> true

View File

@ -7,3 +7,5 @@ type t =
val of_int : int -> t
val to_int : t -> int
val neq : t -> bool

View File

@ -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 =