diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 1ff25a574f7..03a1f1505b2 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -15,7 +15,7 @@ module Backend = struct ; runner_libraries : (Loc.t * string) list ; flags : Ordered_set_lang.Unexpanded.t ; generate_runner : Action.Unexpanded.t option - ; extends : (Loc.t * string) list option + ; extends : (Loc.t * string) list } type Jbuild.Sub_system_info.t += T of t @@ -33,7 +33,8 @@ module Backend = struct Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> field_o "generate_runner" Action.Unexpanded.t >>= fun generate_runner -> - field_o "extends" (list (located string)) >>= fun extends -> + field "extends" (list (located string)) ~default:[] + >>= fun extends -> return { loc ; runner_libraries @@ -56,32 +57,31 @@ module Backend = struct { info : Info.t ; lib : Lib.t ; runner_libraries : (Lib.t list, exn) result - ; extends : ( t list, exn) result option + ; extends : ( t list, exn) result } let desc ~plural = "inline tests backend" ^ if plural then "s" else "" let desc_article = "an" let lib t = t.lib - let deps t = t.extends + let extends t = t.extends let instantiate ~resolve ~get lib (info : Info.t) = { info ; lib - ; runner_libraries = Result.all (List.map info.runner_libraries ~f:resolve) + ; runner_libraries = + Result.all (List.map info.runner_libraries ~f:resolve) ; extends = let open Result.O in - Option.map info.extends - ~f:(fun l -> - Result.all - (List.map l - ~f:(fun ((loc, name) as x) -> - resolve x >>= fun lib -> - match get lib with - | None -> - Error (Loc.exnf loc "%S is not an %s" name - (desc ~plural:false)) - | Some t -> Ok t))) + Result.all + (List.map info.extends + ~f:(fun ((loc, name) as x) -> + resolve x >>= fun lib -> + match get lib with + | None -> + Error (Loc.exnf loc "%S is not an %s" name + (desc ~plural:false)) + | Some t -> Ok t)) } let to_sexp t = @@ -95,7 +95,7 @@ module Backend = struct ; field "flags" Ordered_set_lang.Unexpanded.sexp_of_t t.info.flags ; field_o "generate_runner" Action.Unexpanded.sexp_of_t t.info.generate_runner - ; field_o "extends" (list f) (Option.map t.extends ~f:Result.ok_exn) + ; field "extends" (list f) (Result.ok_exn t.extends) ~default:[] ]) end include M diff --git a/src/sexp.ml b/src/sexp.ml index 252b2fc2a50..71dacfaa5f3 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -107,7 +107,14 @@ module To_sexp = struct type field = string * Usexp.t option - let field name f v = (name, Some (f v)) + let field name f ?(equal=(=)) ?default v = + match default with + | None -> (name, Some (f v)) + | Some d -> + if equal d v then + (name, None) + else + (name, Some (f v)) let field_o name f v = (name, Option.map ~f v) let record_fields (l : field list) = diff --git a/src/sexp.mli b/src/sexp.mli index cf06bf2b4f0..d28798b45ba 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -49,7 +49,13 @@ module To_sexp : sig type field - val field : string -> 'a t -> 'a -> field + val field + : string + -> 'a t + -> ?equal:('a -> 'a -> bool) + -> ?default:'a + -> 'a + -> field val field_o : string -> 'a t-> 'a option -> field val record_fields : field list t diff --git a/src/sub_system.ml b/src/sub_system.ml index 09d49f2c73f..adb24c6102a 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -10,15 +10,14 @@ module Register_backend(M : Backend) = struct let to_sexp = Some to_sexp end) - let top_closure l = + let top_closure l ~deps = match Top_closure.Int.top_closure l ~key:(fun t -> Lib.unique_id (M.lib t)) ~deps:(fun t -> - match M.deps t with - | None -> [] - | Some (Ok l) -> l - | Some (Error e) -> raise_notrace e) + match deps t with + | Ok l -> l + | Error e -> raise_notrace e) with | Ok _ as res -> res | Error _ -> @@ -35,51 +34,66 @@ module Register_backend(M : Backend) = struct (Lib.unique_id (M.lib b)) end) - let select_backends ~loc ~scope ~written_by_user to_scan = + let resolve db (loc, name) = let open Result.O in - let backends = + Lib.DB.resolve db (loc, name) >>= fun lib -> + match get lib with + | None -> + Error (Loc.exnf loc "%S is not %s %s" name M.desc_article + (M.desc ~plural:false)) + | Some t -> Ok t + + let written_by_user_or_scan ~loc ~written_by_user ~to_scan = + match match written_by_user with - | Some l -> - Result.all - (List.map l ~f:(fun ((loc, name) as x) -> - Lib.DB.resolve (Scope.libs scope) x >>= fun lib -> - match get lib with - | None -> - Error (Loc.exnf loc "%S is not %s %s" name M.desc_article - (M.desc ~plural:false)) - | Some t -> Ok t)) - | None -> - Ok (List.filter_map to_scan ~f:get) - in - backends >>= function + | Some l -> l + | None -> List.filter_map to_scan ~f:get + with | [] -> Error (Loc.exnf loc "No %s found." (M.desc ~plural:false)) - | backends -> - Result.all (List.filter_map backends ~f:M.deps) >>= fun _ -> - top_closure backends - >>= fun backends -> - let roots = - let all = Set.of_list backends in - List.fold_left backends ~init:all ~f:(fun acc t -> - Set.diff acc (Set.of_list - (match M.deps t with - | Some (Ok l) -> l - | _ -> []))) - in - if Set.cardinal roots = 1 then - Ok backends - else - Error - (Loc.exnf loc - "Too many independant %s found:\n%s" - (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" - (Lib.name lib) - (Path.to_string_maybe_quoted (Lib.src_dir lib)))))) + | l -> Ok l + + let too_many_backends ~loc backends = + Loc.exnf loc + "Too many independant %s found:\n%s" + (M.desc ~plural:true) + (String.concat ~sep:"\n" + (List.map backends ~f:(fun t -> + let lib = M.lib t in + sprintf "- %S in %s" + (Lib.name lib) + (Path.to_string_maybe_quoted (Lib.src_dir lib))))) + + let select_extensible_backends ~loc ?written_by_user ~extends to_scan = + let open Result.O in + written_by_user_or_scan ~loc ~written_by_user ~to_scan + >>= fun backends -> + top_closure backends ~deps:extends + >>= fun backends -> + let roots = + let all = Set.of_list backends in + List.fold_left backends ~init:all ~f:(fun acc t -> + Set.diff acc (Set.of_list (Result.ok_exn (extends t)))) + |> Set.to_list + in + if List.length roots = 1 then + Ok backends + else + Error (too_many_backends ~loc roots) + + let select_replaceable_backend ~loc ?written_by_user ~replaces to_scan = + let open Result.O in + written_by_user_or_scan ~loc ~written_by_user ~to_scan + >>= fun backends -> + Result.concat_map backends ~f:replaces + >>= fun replaced_backends -> + match + Set.diff (Set.of_list backends) (Set.of_list replaced_backends) + |> Set.to_list + with + | [b] -> Ok b + | l -> Error (too_many_backends ~loc l) end type Lib.Sub_system.t += @@ -93,10 +107,16 @@ module Register_end_point(M : End_point) = struct let backends = Lib.Compile.direct_requires c.compile_info >>= fun deps -> Lib.Compile.pps c.compile_info >>= fun pps -> - M.Backend.select_backends + (match M.Info.backends info with + | None -> Ok None + | Some l -> + Result.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope))) + >>| Option.some) + >>= fun written_by_user -> + M.Backend.select_extensible_backends ~loc:(M.Info.loc info) - ~scope:c.scope - ~written_by_user:(M.Info.backends info) + ?written_by_user + ~extends:M.Backend.extends (deps @ pps) in let fail, backends = diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 948bffefad2..2a9b403ddc3 100644 --- a/src/sub_system_intf.ml +++ b/src/sub_system_intf.ml @@ -32,9 +32,6 @@ module type Backend = sig (** Library the backend is attached to *) val lib : t -> Lib.t - (** Dependencies on other backends *) - val deps : t -> (t list, exn) result option - (** Dump the sub-system configuration. This is used to generate META files. *) val to_sexp : t -> Syntax.Version.t * Sexp.t @@ -45,19 +42,33 @@ module type Registered_backend = sig val get : Lib.t -> t option + (** Resolve a backend name *) + val resolve : Lib.DB.t -> Loc.t * string -> (t, exn) result + (** Choose a backend by either using the ones written by the user or - by by scanning the dependencies. + by scanning the dependencies. The returned list is sorted by order of dependencies. It is not allowed to have two different backend that are completely independant, i.e. none of them is in the transitive closure of the other one. *) - val select_backends + val select_extensible_backends : loc:Loc.t - -> scope:Scope.t - -> written_by_user:(Loc.t * string) list option + -> ?written_by_user:t list + -> extends:(t -> (t list, exn) result) -> Lib.t list -> (t list, exn) result + + (** Choose a backend by either using the ones written by the user or + by scanning the dependencies. + + A backend can replace other backends *) + val select_replaceable_backend + : loc:Loc.t + -> ?written_by_user:t list + -> replaces:(t -> (t list, exn) result) + -> Lib.t list + -> (t, exn) result end (* This is probably what we'll give to plugins *) @@ -74,7 +85,12 @@ end (** An end-point, for users of the systems *) module type End_point = sig - module Backend : Registered_backend + module Backend : sig + include Registered_backend + + (** Backends that this backends extends *) + val extends : t -> (t list, exn) result + end module Info : sig include Info