Merge pull request #514 from ocaml/small-findlib-improvements

Rewrite the findlib predicate stuff

src/findlib.ml

@@ -1,80 +1,44 @@
 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 =
       List.partition_map rule.predicates ~f:(function
         | 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)

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

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

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
 

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

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"

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