Rewrite the findlib predicate stuff
- intern predicate names - add a Variant module
This commit is contained in:
parent
77ef63773f
commit
c569984af1
|
@ -1,60 +1,22 @@
|
||||||
open Import
|
open Import
|
||||||
|
|
||||||
module Preds : sig
|
module P = Variant
|
||||||
type t
|
module Ps = Variant.Set
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
(* An assignment or addition *)
|
(* An assignment or addition *)
|
||||||
module Rule = struct
|
module Rule = struct
|
||||||
type t =
|
type t =
|
||||||
{ preds_required : Preds.t
|
{ preds_required : Ps.t
|
||||||
; preds_forbidden : Preds.t
|
; preds_forbidden : Ps.t
|
||||||
; value : string
|
; value : string
|
||||||
}
|
}
|
||||||
|
|
||||||
let formal_predicates_count t =
|
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 =
|
let matches t ~preds =
|
||||||
Preds.is_subset preds ~subset:t.preds_required &&
|
Ps.subset t.preds_required preds &&
|
||||||
not (Preds.intersects preds t.preds_forbidden)
|
Ps.is_empty (Ps.inter preds t.preds_forbidden)
|
||||||
|
|
||||||
|
|
||||||
let make (rule : Meta.rule) =
|
let make (rule : Meta.rule) =
|
||||||
let preds_required, preds_forbidden =
|
let preds_required, preds_forbidden =
|
||||||
|
@ -62,19 +24,21 @@ module Rule = struct
|
||||||
| Pos x -> Inl x
|
| Pos x -> Inl x
|
||||||
| Neg x -> Inr x)
|
| Neg x -> Inr x)
|
||||||
in
|
in
|
||||||
{ preds_required = Preds.make preds_required
|
{ preds_required = Ps.make preds_required
|
||||||
; preds_forbidden = Preds.make preds_forbidden
|
; preds_forbidden = Ps.make preds_forbidden
|
||||||
; value = rule.value
|
; value = rule.value
|
||||||
}
|
}
|
||||||
end
|
end
|
||||||
|
|
||||||
(* Set of rules for a given variable of a package *)
|
(* Set of rules for a given variable of a package *)
|
||||||
module Rules = struct
|
module Rules = struct
|
||||||
(* To implement the algorithm described in [1], [set_rules] is sorted by decreasing
|
(* To implement the algorithm described in [1], [set_rules] is
|
||||||
number of formal predicates, then according to the order of the META
|
sorted by decreasing number of formal predicates, then according
|
||||||
file. [add_rules] are in the same order as in the META file.
|
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 =
|
type t =
|
||||||
{ set_rules : Rule.t list
|
{ set_rules : Rule.t list
|
||||||
; add_rules : Rule.t list
|
; add_rules : Rule.t list
|
||||||
|
@ -101,7 +65,9 @@ module Rules = struct
|
||||||
let set_rules =
|
let set_rules =
|
||||||
List.map rules.set_rules ~f:Rule.make
|
List.map rules.set_rules ~f:Rule.make
|
||||||
|> List.stable_sort ~cmp:(fun a b ->
|
|> 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
|
in
|
||||||
{ add_rules; set_rules }
|
{ add_rules; set_rules }
|
||||||
end
|
end
|
||||||
|
@ -110,7 +76,6 @@ module Vars = struct
|
||||||
type t = Rules.t String_map.t
|
type t = Rules.t String_map.t
|
||||||
|
|
||||||
let get (t : t) var preds =
|
let get (t : t) var preds =
|
||||||
let preds = Preds.make preds in
|
|
||||||
match String_map.find var t with
|
match String_map.find var t with
|
||||||
| None -> ""
|
| None -> ""
|
||||||
| Some rules -> Rules.interpret rules ~preds
|
| Some rules -> Rules.interpret rules ~preds
|
||||||
|
@ -121,7 +86,7 @@ end
|
||||||
module Config = struct
|
module Config = struct
|
||||||
type t =
|
type t =
|
||||||
{ vars : Vars.t
|
{ vars : Vars.t
|
||||||
; preds : string list
|
; preds : Ps.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let load path ~toolchain ~context =
|
let load path ~toolchain ~context =
|
||||||
|
@ -135,7 +100,9 @@ module Config = struct
|
||||||
; entries = Meta.load (Path.to_string conf_file)
|
; entries = Meta.load (Path.to_string conf_file)
|
||||||
}).vars
|
}).vars
|
||||||
in
|
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 =
|
let get { vars; preds } var =
|
||||||
Vars.get vars var preds
|
Vars.get vars var preds
|
||||||
|
@ -236,7 +203,7 @@ let gen_package_unique_id =
|
||||||
|
|
||||||
(* Parse a single package from a META file *)
|
(* Parse a single package from a META file *)
|
||||||
let rec parse_package t ~name ~parent_dir ~vars =
|
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 =
|
let dir =
|
||||||
if pkg_dir = "" then
|
if pkg_dir = "" then
|
||||||
parent_dir
|
parent_dir
|
||||||
|
@ -250,30 +217,30 @@ let rec parse_package t ~name ~parent_dir ~vars =
|
||||||
in
|
in
|
||||||
let archives var preds =
|
let archives var preds =
|
||||||
Mode.Dict.of_func (fun ~mode ->
|
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))
|
~f:(Path.relative dir))
|
||||||
in
|
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 =
|
let exists =
|
||||||
List.for_all exists_if ~f:(fun fn ->
|
List.for_all exists_if ~f:(fun fn ->
|
||||||
Path.exists (Path.relative dir fn))
|
Path.exists (Path.relative dir fn))
|
||||||
in
|
in
|
||||||
(dir,
|
(dir,
|
||||||
if exists then
|
if exists then
|
||||||
let jsoo_runtime = Vars.get_words vars "jsoo_runtime" [] in
|
let jsoo_runtime = Vars.get_words vars "jsoo_runtime" Ps.empty in
|
||||||
let preds = ["ppx_driver"; "mt"; "mt_posix"] 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 requires = Vars.get_words vars "requires" preds in
|
||||||
let ppx_runtime_deps = Vars.get_words vars "ppx_runtime_deps" preds in
|
let ppx_runtime_deps = Vars.get_words vars "ppx_runtime_deps" preds in
|
||||||
Ok
|
Ok
|
||||||
{ name
|
{ name
|
||||||
; dir
|
; dir
|
||||||
; unique_id = gen_package_unique_id ()
|
; unique_id = gen_package_unique_id ()
|
||||||
; version = Vars.get vars "version" []
|
; version = Vars.get vars "version" Ps.empty
|
||||||
; description = Vars.get vars "description" []
|
; description = Vars.get vars "description" Ps.empty
|
||||||
; archives = archives "archive" preds
|
; archives = archives "archive" preds
|
||||||
; jsoo_runtime
|
; jsoo_runtime
|
||||||
; plugins = Mode.Dict.map2 ~f:(@)
|
; plugins = Mode.Dict.map2 ~f:(@)
|
||||||
(archives "archive" ("plugin" :: preds))
|
(archives "archive" (Ps.add Variant.plugin preds))
|
||||||
(archives "plugin" preds)
|
(archives "plugin" preds)
|
||||||
; requires = lazy (resolve_deps t requires)
|
; requires = lazy (resolve_deps t requires)
|
||||||
; ppx_runtime_deps = lazy (resolve_deps t ppx_runtime_deps)
|
; 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_unit_ext = choose ".cmo" ".cmx"
|
||||||
let compiled_lib_ext = choose ".cma" ".cmxa"
|
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
|
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 cm_kind : t -> Cm_kind.t
|
||||||
val of_cm_kind : Cm_kind.t -> t
|
val of_cm_kind : Cm_kind.t -> t
|
||||||
|
|
||||||
val findlib_predicate : t -> string
|
val variant : t -> Variant.t
|
||||||
|
|
||||||
module Dict : sig
|
module Dict : sig
|
||||||
type mode = t
|
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