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.

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
+          Result.all
-            ~f:(fun l ->
+            (List.map info.extends
-              Result.all
+               ~f:(fun ((loc, name) as x) ->
-                (List.map l
+                 resolve x >>= fun lib ->
-                   ~f:(fun ((loc, name) as x) ->
+                 match get lib with
-                     resolve x >>= fun lib ->
+                 | None ->
-                     match get lib with
+                   Error (Loc.exnf loc "%S is not an %s" name
-                     | None ->
+                            (desc ~plural:false))
-                       Error (Loc.exnf loc "%S is not an %s" name
+                 | Some t -> Ok t))
-                                (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

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

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

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
+          match deps t with
-          | None           -> []
+          | Ok l    -> l
-          | Some (Ok l)    -> l
+          | Error e -> raise_notrace e)
-          | Some (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 ->
+      | Some l -> l
-        Result.all
+      | None   -> List.filter_map to_scan ~f:get
-          (List.map l ~f:(fun ((loc, name) as x) ->
+    with
-             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
     | [] ->
       Error
         (Loc.exnf loc "No %s found." (M.desc ~plural:false))
-    | backends ->
+    | l -> Ok l
-      Result.all (List.filter_map backends ~f:M.deps) >>= fun _ ->
+
-      top_closure backends
+  let too_many_backends ~loc backends =
-      >>= fun backends ->
+    Loc.exnf loc
-      let roots =
+      "Too many independant %s found:\n%s"
-        let all = Set.of_list backends in
+      (M.desc ~plural:true)
-        List.fold_left backends ~init:all ~f:(fun acc t ->
+      (String.concat ~sep:"\n"
-          Set.diff acc (Set.of_list
+         (List.map backends ~f:(fun t ->
-                          (match M.deps t with
+            let lib = M.lib t in
-                           | Some (Ok l) -> l
+            sprintf "- %S in %s"
-                           | _ -> [])))
+              (Lib.name lib)
-      in
+              (Path.to_string_maybe_quoted (Lib.src_dir lib)))))
-      if Set.cardinal roots = 1 then
+
-        Ok backends
+  let select_extensible_backends ~loc ?written_by_user ~extends to_scan =
-      else
+    let open Result.O in
-        Error
+    written_by_user_or_scan ~loc ~written_by_user ~to_scan
-          (Loc.exnf loc
+    >>= fun backends ->
-             "Too many independant %s found:\n%s"
+    top_closure backends ~deps:extends
-             (M.desc ~plural:true)
+    >>= fun backends ->
-             (String.concat ~sep:"\n"
+    let roots =
-                (List.map (Set.to_list roots) ~f:(fun t ->
+      let all = Set.of_list backends in
-                   let lib = M.lib t in
+      List.fold_left backends ~init:all ~f:(fun acc t ->
-                   sprintf "- %S in %s"
+        Set.diff acc (Set.of_list (Result.ok_exn (extends t))))
-                     (Lib.name lib)
+      |> Set.to_list
-                     (Path.to_string_maybe_quoted (Lib.src_dir lib))))))
+    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
-        ~written_by_user:(M.Info.backends info)
+        ~extends:M.Backend.extends
         (deps @ pps)
     in
     let fail, backends =

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:t list
-    -> written_by_user:(Loc.t * string) list option
+    -> 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