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

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 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))
+    | Some t -> Ok t
-      | None ->
+
-        Ok (List.filter_map to_scan ~f:get)
+  let written_by_user_or_scan ~loc ~written_by_user ~to_scan =
-    in
+    match
-    backends >>= function
+      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 ->
+    | l -> Ok l
-      Result.all (List.filter_map backends ~f:M.deps) >>= fun _ ->
+
-      top_closure backends
+  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
+        Set.diff acc (Set.of_list (Result.ok_exn (extends t))))
-                          (match M.deps t with
+      |> Set.to_list
-                           | Some (Ok l) -> l
-                           | _ -> [])))
     in
-      if Set.cardinal roots = 1 then
+    if List.length roots = 1 then
       Ok backends
     else
-        Error
+      Error (too_many_backends ~loc roots)
-          (Loc.exnf loc
+
-             "Too many independant %s found:\n%s"
+  let select_replaceable_backend ~loc ?written_by_user ~replaces to_scan =
-             (M.desc ~plural:true)
+    let open Result.O in
-             (String.concat ~sep:"\n"
+    written_by_user_or_scan ~loc ~written_by_user ~to_scan
-                (List.map (Set.to_list roots) ~f:(fun t ->
+    >>= fun backends ->
-                   let lib = M.lib t in
+    Result.concat_map backends ~f:replaces
-                   sprintf "- %S in %s"
+    >>= fun replaced_backends ->
-                     (Lib.name lib)
+    match
-                     (Path.to_string_maybe_quoted (Lib.src_dir lib))))))
+      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