diff --git a/src/findlib.ml b/src/findlib.ml index 23c0bcda..c5b2286f 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -1,60 +1,22 @@ open Import -module Preds : sig - type t - - val make : string list -> t - val count : t -> int - val is_subset : t -> subset:t -> bool - val intersects : t -> t -> bool -end = struct - type t = string list - - let make l = List.sort l ~cmp:String.compare - - let count = List.length - - let rec is_subset t ~subset = - match t, subset with - | _, [] -> true - | [], _ :: _ -> false - | x1 :: l1, x2 :: l2 -> - let d = String.compare x1 x2 in - if d = 0 then - is_subset l1 ~subset:l2 - else if d < 0 then - is_subset l1 ~subset - else - false - - let rec intersects a b = - match a, b with - | [], _ | _, [] -> false - | x1 :: l1, x2 :: l2 -> - let d = String.compare x1 x2 in - if d = 0 then - true - else if d < 0 then - intersects l1 b - else - intersects a l2 -end +module P = Variant +module Ps = Variant.Set (* An assignment or addition *) module Rule = struct type t = - { preds_required : Preds.t - ; preds_forbidden : Preds.t + { preds_required : Ps.t + ; preds_forbidden : Ps.t ; value : string } let formal_predicates_count t = - Preds.count t.preds_required + Preds.count t.preds_forbidden + Ps.cardinal t.preds_required + Ps.cardinal t.preds_forbidden let matches t ~preds = - Preds.is_subset preds ~subset:t.preds_required && - not (Preds.intersects preds t.preds_forbidden) - + Ps.subset t.preds_required preds && + Ps.is_empty (Ps.inter preds t.preds_forbidden) let make (rule : Meta.rule) = let preds_required, preds_forbidden = @@ -62,19 +24,21 @@ module Rule = struct | Pos x -> Inl x | Neg x -> Inr x) in - { preds_required = Preds.make preds_required - ; preds_forbidden = Preds.make preds_forbidden + { preds_required = Ps.make preds_required + ; preds_forbidden = Ps.make preds_forbidden ; value = rule.value } end (* Set of rules for a given variable of a package *) module Rules = struct - (* To implement the algorithm described in [1], [set_rules] is sorted by decreasing - number of formal predicates, then according to the order of the META - file. [add_rules] are in the same order as in the META file. + (* To implement the algorithm described in [1], [set_rules] is + sorted by decreasing number of formal predicates, then according + to the order of the META file. [add_rules] are in the same order + as in the META file. - [1] http://projects.camlcity.org/projects/dl/findlib-1.6.3/doc/ref-html/r729.html *) + [1] http://projects.camlcity.org/projects/dl/findlib-1.6.3/doc/ref-html/r729.html + *) type t = { set_rules : Rule.t list ; add_rules : Rule.t list @@ -101,7 +65,9 @@ module Rules = struct let set_rules = List.map rules.set_rules ~f:Rule.make |> List.stable_sort ~cmp:(fun a b -> - compare (Rule.formal_predicates_count b) (Rule.formal_predicates_count a)) + compare + (Rule.formal_predicates_count b) + (Rule.formal_predicates_count a)) in { add_rules; set_rules } end @@ -110,7 +76,6 @@ module Vars = struct type t = Rules.t String_map.t let get (t : t) var preds = - let preds = Preds.make preds in match String_map.find var t with | None -> "" | Some rules -> Rules.interpret rules ~preds @@ -121,7 +86,7 @@ end module Config = struct type t = { vars : Vars.t - ; preds : string list + ; preds : Ps.t } let load path ~toolchain ~context = @@ -135,7 +100,9 @@ module Config = struct ; entries = Meta.load (Path.to_string conf_file) }).vars in - { vars = String_map.map vars ~f:Rules.of_meta_rules; preds = [toolchain] } + { vars = String_map.map vars ~f:Rules.of_meta_rules + ; preds = Ps.make [toolchain] + } let get { vars; preds } var = Vars.get vars var preds @@ -236,7 +203,7 @@ let gen_package_unique_id = (* Parse a single package from a META file *) let rec parse_package t ~name ~parent_dir ~vars = - let pkg_dir = Vars.get vars "directory" [] in + let pkg_dir = Vars.get vars "directory" Ps.empty in let dir = if pkg_dir = "" then parent_dir @@ -250,30 +217,30 @@ let rec parse_package t ~name ~parent_dir ~vars = in let archives var preds = Mode.Dict.of_func (fun ~mode -> - List.map (Vars.get_words vars var (Mode.findlib_predicate mode :: preds)) + List.map (Vars.get_words vars var (Ps.add (Mode.variant mode) preds)) ~f:(Path.relative dir)) in - let exists_if = Vars.get_words vars "exists_if" [] in + let exists_if = Vars.get_words vars "exists_if" Ps.empty in let exists = List.for_all exists_if ~f:(fun fn -> Path.exists (Path.relative dir fn)) in (dir, if exists then - let jsoo_runtime = Vars.get_words vars "jsoo_runtime" [] in - let preds = ["ppx_driver"; "mt"; "mt_posix"] in + let jsoo_runtime = Vars.get_words vars "jsoo_runtime" Ps.empty in + let preds = Ps.of_list [P.ppx_driver; P.mt; P.mt_posix] in let requires = Vars.get_words vars "requires" preds in let ppx_runtime_deps = Vars.get_words vars "ppx_runtime_deps" preds in Ok { name ; dir ; unique_id = gen_package_unique_id () - ; version = Vars.get vars "version" [] - ; description = Vars.get vars "description" [] + ; version = Vars.get vars "version" Ps.empty + ; description = Vars.get vars "description" Ps.empty ; archives = archives "archive" preds ; jsoo_runtime ; plugins = Mode.Dict.map2 ~f:(@) - (archives "archive" ("plugin" :: preds)) + (archives "archive" (Ps.add Variant.plugin preds)) (archives "plugin" preds) ; requires = lazy (resolve_deps t requires) ; ppx_runtime_deps = lazy (resolve_deps t ppx_runtime_deps) diff --git a/src/interned.ml b/src/interned.ml new file mode 100644 index 00000000..69eee954 --- /dev/null +++ b/src/interned.ml @@ -0,0 +1,45 @@ +open Import + +module type S = sig + type t + + val make : string -> t + val compare : t -> t -> int + + module Set : sig + include Set.S with type elt = t + + val make : string list -> t + end + + module Map : Map.S with type key = t +end + +module Int = struct + type t = int + let compare : int -> int -> int = compare +end +module Int_set = Set.Make(Int) +module Int_map = Map.Make(Int) + +module Make() = struct + include Int + + let table = Hashtbl.create 1024 + let next = ref 0 + + let make s = + Hashtbl.find_or_add table s ~f:(fun _ -> + let n = !next in + next := n + 1; + n) + + module Set = struct + include Int_set + + let make l = + List.fold_left l ~init:empty ~f:(fun acc s -> add (make s) acc) + end + + module Map = Int_map +end diff --git a/src/interned.mli b/src/interned.mli new file mode 100644 index 00000000..5abdcd44 --- /dev/null +++ b/src/interned.mli @@ -0,0 +1,20 @@ +(** Interned strings *) + +open! Import + +module type S = sig + type t + + val make : string -> t + val compare : t -> t -> int + + module Set : sig + include Set.S with type elt = t + + val make : string list -> t + end + + module Map : Map.S with type key = t +end + +module Make() : S diff --git a/src/mode.ml b/src/mode.ml index af929064..8a30c4a1 100644 --- a/src/mode.ml +++ b/src/mode.ml @@ -18,7 +18,7 @@ let choose byte native = function let compiled_unit_ext = choose ".cmo" ".cmx" let compiled_lib_ext = choose ".cma" ".cmxa" -let findlib_predicate = choose "byte" "native" +let variant = choose Variant.byte Variant.native let cm_kind = choose Cm_kind.Cmo Cmx diff --git a/src/mode.mli b/src/mode.mli index e37ec9b7..bbbe90e0 100644 --- a/src/mode.mli +++ b/src/mode.mli @@ -13,7 +13,7 @@ val exe_ext : t -> string val cm_kind : t -> Cm_kind.t val of_cm_kind : Cm_kind.t -> t -val findlib_predicate : t -> string +val variant : t -> Variant.t module Dict : sig type mode = t diff --git a/src/variant.ml b/src/variant.ml new file mode 100644 index 00000000..0eab5f40 --- /dev/null +++ b/src/variant.ml @@ -0,0 +1,8 @@ +include Interned.Make() + +let ppx_driver = make "ppx_driver" +let mt = make "mt" +let mt_posix = make "mt_posix" +let byte = make "byte" +let native = make "native" +let plugin = make "plugin" diff --git a/src/variant.mli b/src/variant.mli new file mode 100644 index 00000000..93f98488 --- /dev/null +++ b/src/variant.mli @@ -0,0 +1,17 @@ +(** Library variants *) + +(** Library variants allow to select the implementation of a library + at link time. + + They are directly mapped to findlib predicates. +*) + +include Interned.S + +(** Well-known variants *) +val ppx_driver : t +val mt : t +val mt_posix : t +val byte : t +val native : t +val plugin : t