matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Jérémie Dimino 2018-03-19 20:47:51 -04:00 committed by GitHub
parent 86f918df71
commit a8072f08bc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 124 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
src/inline_tests.ml
View File

@ -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

9
src/sexp.ml
View File

@ -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) =

8
src/sexp.mli
View File

@ -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

116
src/sub_system.ml
View File

@ -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 =

32
src/sub_system_intf.ml
View File

@ -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