From d5ebd0e9be80bfb0d16c556fe426b1ed15e71447 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 28 Feb 2018 19:04:02 +0000 Subject: [PATCH] Allow to capture the library a backend is attached to --- src/inline_tests.ml | 10 ++++----- src/lib.ml | 47 +++++++++++++++++++++++++----------------- src/lib.mli | 14 +++++-------- src/sub_system.ml | 12 +++++++---- src/sub_system_intf.ml | 4 ++-- 5 files changed, 48 insertions(+), 39 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 2479a580..294bb82b 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -54,7 +54,7 @@ module Backend = struct type t = { info : Info.t - ; id : Lib.Id.t + ; lib : Lib.t ; runner_libraries : (Lib.t list, exn) result ; extends : ( t list, exn) result option } @@ -62,12 +62,12 @@ module Backend = struct let desc ~plural = "inline tests backend" ^ if plural then "s" else "" let desc_article = "an" - let id t = t.id + let lib t = t.lib let deps t = t.extends - let instantiate ~resolve ~get id (info : Info.t) = + let instantiate ~resolve ~get lib (info : Info.t) = { info - ; id + ; lib ; runner_libraries = Result.all (List.map info.runner_libraries ~f:resolve) ; extends = let open Result.O in @@ -87,7 +87,7 @@ module Backend = struct let to_sexp t = let open Sexp.To_sexp in let lib x = string (Lib.name x) in - let f x = string x.id.name in + let f x = string (Lib.name x.lib) in ((1, 0), record [ "runner_libraries", list lib (Result.ok_exn t.runner_libraries) diff --git a/src/lib.ml b/src/lib.ml index 182a50ec..3e04aedc 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -194,7 +194,7 @@ module Sub_system0 = struct type 'a s = (module S with type t = 'a) module Instance = struct - type t = T : 'a s * 'a Lazy.t -> t + type t = T : 'a s * 'a -> t end end @@ -226,7 +226,13 @@ type t = ; resolved_selects : Resolved_select.t list ; optional : bool ; user_written_deps : Jbuild.Lib_deps.t - ; sub_systems : Sub_system0.Instance.t Sub_system_name.Map.t + ; (* This is mutable to avoid this error: + + {[ + This kind of expression is not allowed as right-hand side of `let rec' + }] + *) + mutable sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t } and db = @@ -298,6 +304,7 @@ let synopsis t = t.synopsis let archives t = t.archives let plugins t = t.plugins let jsoo_runtime t = t.jsoo_runtime +let unique_id t = t.unique_id let src_dir t = t.src_dir let obj_dir t = t.obj_dir @@ -377,7 +384,7 @@ module Sub_system = struct val instantiate : resolve:(Loc.t * string -> (lib, exn) result) -> get:(lib -> t option) - -> Id.t + -> lib -> Info.t -> t val to_sexp : (t -> Syntax.Version.t * Sexp.t) option @@ -394,7 +401,7 @@ module Sub_system = struct module Register(M : S) = struct let get lib = Option.map (Sub_system_name.Map.find lib.sub_systems M.Info.name) - ~f:(fun (Sub_system0.Instance.T ((module X), lazy t)) -> + ~f:(fun (lazy (Sub_system0.Instance.T ((module X), t))) -> match X.T t with | M.T t -> t | _ -> assert false) @@ -409,19 +416,18 @@ module Sub_system = struct ~data:(Some (module M : S')) end - let instantiate_many sub_systems id ~resolve = - Sub_system_name.Map.mapi sub_systems ~f:(fun name info -> - let impl = Option.value_exn (Sub_system_name.Table.get all name) in - let (module M : S') = impl in - match info with - | M.Info.T info -> - Sub_system0.Instance.T - (M.for_instance, lazy (M.instantiate ~resolve ~get:M.get id info)) - | _ -> assert false) + let instantiate name info lib ~resolve = + let impl = Option.value_exn (Sub_system_name.Table.get all name) in + let (module M : S') = impl in + match info with + | M.Info.T info -> + Sub_system0.Instance.T + (M.for_instance, M.instantiate ~resolve ~get:M.get lib info) + | _ -> assert false let dump_config lib = - Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun inst -> - let (Sub_system0.Instance.T ((module M), lazy t)) = inst in + Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) -> + let (Sub_system0.Instance.T ((module M), t)) = inst in match M.to_sexp with | None -> None | Some f -> Some (f t)) @@ -567,10 +573,12 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = ; resolved_selects = resolved_selects ; optional = info.optional ; user_written_deps = Info.user_written_deps info - ; sub_systems = Sub_system.instantiate_many info.sub_systems id - ~resolve + ; sub_systems = Sub_system_name.Map.empty } in + t.sub_systems <- + Sub_system_name.Map.mapi info.sub_systems ~f:(fun name info -> + lazy (Sub_system.instantiate name info t ~resolve)); let res = let hidden = @@ -797,7 +805,7 @@ module Compile = struct ; resolved_selects : Resolved_select.t list ; optional : bool ; user_written_deps : Jbuild.Lib_deps.t - ; sub_systems : Sub_system0.Instance.t Sub_system_name.Map.t + ; sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t } let make libs = @@ -828,7 +836,8 @@ module Compile = struct let user_written_deps t = t.user_written_deps let sub_systems t = Sub_system_name.Map.values t.sub_systems - |> List.map ~f:(fun (Sub_system0.Instance.T ((module M), lazy t)) -> M.T t) + |> List.map ~f:(fun (lazy (Sub_system0.Instance.T ((module M), t))) -> + M.T t) end (* +-----------------------------------------------------------------+ diff --git a/src/lib.mli b/src/lib.mli index 795e8a2b..0cb112ea 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -26,6 +26,10 @@ val archives : t -> Path.t list Mode.Dict.t val plugins : t -> Path.t list Mode.Dict.t val jsoo_runtime : t -> Path.t list +(** A unique integer identifier. It is only unique for the duration of + the process *) +val unique_id : t -> int + module Status : sig type t = | Installed @@ -91,14 +95,6 @@ module Info : sig val of_findlib_package : Findlib.Package.t -> t end -module Id : sig - type t = - { unique_id : int - ; path : Path.t - ; name : string - } -end - (** {1 Errors} *) module Error : sig @@ -290,7 +286,7 @@ module Sub_system : sig val instantiate : resolve:(Loc.t * string -> (lib, exn) result) -> get:(lib -> t option) - -> Id.t + -> lib -> Info.t -> t val to_sexp : (t -> Syntax.Version.t * Sexp.t) option diff --git a/src/sub_system.ml b/src/sub_system.ml index 6f7c27fd..5ad36e13 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -15,7 +15,7 @@ module Register_backend(M : Backend) = struct (struct type t = M.t type graph = unit - let key t = (M.id t).unique_id + let key t = Lib.unique_id (M.lib t) let deps t () = match M.deps t with | Some (Ok l) -> l @@ -25,7 +25,10 @@ module Register_backend(M : Backend) = struct module Set = Set.Make(struct type t = M.t - let compare a b = compare (M.id a).unique_id (M.id b).unique_id + let compare a b = + compare + (Lib.unique_id (M.lib a)) + (Lib.unique_id (M.lib b)) end) let select_backends ~loc ~scope ~written_by_user to_scan = @@ -70,9 +73,10 @@ module Register_backend(M : Backend) = struct (M.desc ~plural:true) (String.concat ~sep:"\n" (List.map (Set.to_list roots) ~f:(fun t -> + let lib = M.lib t in sprintf "- %S in %s" - (M.id t).name - (Path.to_string_maybe_quoted (M.id t).path))))) + (Lib.name lib) + (Path.to_string_maybe_quoted (Lib.src_dir lib)))))) end type Lib.Sub_system.t += diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 8fb5a3dd..aa16ada3 100644 --- a/src/sub_system_intf.ml +++ b/src/sub_system_intf.ml @@ -13,7 +13,7 @@ module type S = sig val instantiate : resolve:(Loc.t * string -> (Lib.t, exn) result) -> get:(Lib.t -> t option) - -> Lib.Id.t + -> Lib.t -> Info.t -> t end @@ -30,7 +30,7 @@ module type Backend = sig val desc_article : string (** Library the backend is attached to *) - val id : t -> Lib.Id.t + val lib : t -> Lib.t (** Dependencies on other backends *) val deps : t -> (t list, exn) result option