Merge pull request #514 from ocaml/small-findlib-improvements
Rewrite the findlib predicate stuff
This commit is contained in:
commit
ee48e865dd
|
@ -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)
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
|
@ -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
|
Loading…
Reference in New Issue