Rework the sub system select (#632)
Split the select_backends between two functions: - one for backends that support extensions - one for backends that support replacement it might be possible to support both at once, but for now this is enough and it's simpler.
This commit is contained in:
parent
86f918df71
commit
a8072f08bc
|
@ -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
|
||||
(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)))
|
||||
| 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
|
||||
|
|
|
@ -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) =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
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 ->
|
||||
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))
|
||||
| None ->
|
||||
Ok (List.filter_map to_scan ~f:get)
|
||||
in
|
||||
backends >>= function
|
||||
| Some t -> Ok t
|
||||
|
||||
let written_by_user_or_scan ~loc ~written_by_user ~to_scan =
|
||||
match
|
||||
match written_by_user with
|
||||
| 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
|
||||
| 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
|
||||
(match M.deps t with
|
||||
| Some (Ok l) -> l
|
||||
| _ -> [])))
|
||||
Set.diff acc (Set.of_list (Result.ok_exn (extends t))))
|
||||
|> Set.to_list
|
||||
in
|
||||
if Set.cardinal roots = 1 then
|
||||
if List.length 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))))))
|
||||
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 =
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue