Refactor handling of backend selection errors + add tests

Signed-off-by: Jeremie Dimino <jdimino@janestreet.com>

src/loc.ml

@@ -33,8 +33,9 @@ let of_lexbuf lb =
   }
 
 let exnf t fmt =
+  Format.pp_open_box err_ppf 0;
   Format.pp_print_as err_ppf 7 ""; (* "Error: " *)
-  kerrf fmt ~f:(fun s -> Exn.Loc_error (t, s))
+  kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s))
 
 let fail t fmt =
   Format.pp_print_as err_ppf 7 ""; (* "Error: " *)

src/preprocessing.ml

@@ -109,6 +109,68 @@ module Driver = struct
   end
   include M
   include Sub_system.Register_backend(M)
+
+  (* Where are we called from? *)
+  type loc =
+    | User_file of Loc.t * (Loc.t * Pp.t) list
+    | Dot_ppx   of Path.t * Pp.t list
+
+  let make_error loc msg =
+    match loc with
+    | User_file (loc, _) -> Error (Loc.exnf loc "%a" Fmt.text msg)
+    | Dot_ppx (path, pps) ->
+      Error (Loc.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text
+               (sprintf
+                  "Failed to create on-demand ppx rewriter for %s; %s"
+                  (String.enumerate_and (List.map pps ~f:Pp.to_string))
+                  (String.uncapitalize msg)))
+
+  let select libs ~loc =
+    match select_replaceable_backend libs ~replaces with
+    | Ok _ as x -> x
+    | Error No_backend_found ->
+      let msg =
+        match libs with
+        | [] ->
+          "You must specify at least one ppx rewriter."
+        | _ ->
+          match
+            List.filter_map libs ~f:(fun lib ->
+              match Lib.name lib with
+              | "ocaml-migrate-parsetree" | "ppxlib" | "ppx_driver" as s ->
+                Some s
+              | _ -> None)
+          with
+          | [] ->
+            let pps =
+              match loc with
+              | User_file (_, pps) -> List.map pps ~f:snd
+              | Dot_ppx (_, pps) -> pps
+            in
+            sprintf
+              "No ppx driver were found. It seems that %s %s not \
+               compatible with Dune. Examples of ppx rewriters that \
+               are compatible with Dune are ones using \
+               ocaml-migrate-parsetree, ppxlib or ppx_driver."
+              (String.enumerate_and (List.map pps ~f:Pp.to_string))
+              (match pps with
+               | [_] -> "is"
+               | _   -> "are")
+          | names ->
+            sprintf
+              "No ppx driver were found.\n\
+               Hint: Try upgrading or reinstalling %s."
+              (String.enumerate_and names)
+      in
+      make_error loc msg
+    | Error (Too_many_backends ts) ->
+      make_error loc
+        (sprintf
+           "Too many incompatible ppx drivers were found: %s."
+           (String.enumerate_and (List.map ts ~f:(fun t ->
+              Lib.name (lib t)))))
+    | Error (Other exn) ->
+      Error exn
 end
 
 module Jbuild_driver = struct
@@ -184,24 +246,6 @@ let ppx_exe sctx ~key ~dir_kind =
   | Jbuild ->
     Path.relative (SC.build_dir sctx) (".ppx/jbuild/" ^ key ^ "/ppx.exe")
 
-let no_driver_error pps =
-  let has name =
-    List.exists pps ~f:(fun lib -> Lib.name lib = name)
-  in
-  match
-    List.find ["ocaml-migrate-parsetree"; "ppxlib"; "ppx_driver"] ~f:has
-  with
-  | Some name ->
-    sprintf
-      "No ppx driver found.\n\
-       Hint: Try upgrading or reinstalling %S." name
-  | None ->
-    sprintf
-      "No ppx driver found.\n\
-       It seems that these ppx rewriters are not compatible with Dune.\n\
-       Hint: Examples of ppx rewriters that are compatible with Dune are\n\
-       ones using ocaml-migrate-parsetree, ppxlib or ppx_driver."
-
 let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps =
   let ctx = SC.context sctx in
   let mode = Context.best_mode ctx in
@@ -226,9 +270,7 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps =
        >>= fun resolved_pps ->
        match jbuild_driver with
        | None ->
-         Driver.select_replaceable_backend resolved_pps ~loc:Loc.none
-           ~replaces:Driver.replaces
-           ~no_backend_error:no_driver_error
+         Driver.select resolved_pps ~loc:(Dot_ppx (target, pps))
          >>| fun driver ->
          (driver, resolved_pps)
        | Some driver ->
@@ -339,8 +381,7 @@ let get_ppx_driver sctx ~loc ~scope ~dir_kind pps =
     >>= fun libs ->
     Lib.closure libs
     >>=
-    Driver.select_replaceable_backend ~loc ~replaces:Driver.replaces
-      ~no_backend_error:no_driver_error
+    Driver.select ~loc:(User_file (loc, pps))
     >>= fun driver ->
     Ok (ppx_driver_exe sctx libs ~dir_kind, driver)
   | Jbuild ->

src/stdune/fmt.ml

@@ -23,6 +23,8 @@ let failwith fmt = kstrf failwith fmt
 let list = Format.pp_print_list
 let string s ppf = Format.pp_print_string ppf s
 
+let text = Format.pp_print_text
+
 let nl = Format.pp_print_newline
 
 let prefix f g ppf x = f ppf; g ppf x

src/stdune/fmt.mli

@@ -6,6 +6,8 @@ val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a
 
 val string : string -> Format.formatter -> unit
 
+val text : string t
+
 val prefix
   : (Format.formatter -> unit)
   -> (Format.formatter -> 'b -> 'c)

src/stdune/string.ml

@@ -201,3 +201,16 @@ let maybe_quoted s =
 
 module Set = Set.Make(T)
 module Map = Map.Make(T)
+
+let enumerate_gen s =
+  let s = " " ^ s ^ " " in
+  let rec loop = function
+    | [] -> []
+    | [x] -> [x]
+    | [x; y] -> [x; s; y]
+    | x :: l -> x :: ", " :: loop l
+  in
+  fun l -> concat (loop l) ~sep:""
+
+let enumerate_and = enumerate_gen "and"
+let enumerate_or  = enumerate_gen "or"

src/stdune/string.mli

@@ -45,5 +45,11 @@ val for_all : t -> f:(char -> bool) -> bool
     lexing conventions and [sprintf "%S" s] otherwise. *)
 val maybe_quoted : t -> t
 
+(** Produces: "x, y and z" *)
+val enumerate_and : string list -> string
+
+(** Produces: "x, y or z" *)
+val enumerate_or  : string list -> string
+
 module Set : Set.S with type elt = t
 module Map : Map.S with type key = t

src/sub_system.ml

@@ -43,39 +43,54 @@ module Register_backend(M : Backend) = struct
                (M.desc ~plural:false))
     | Some t -> Ok t
 
-  let written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error =
+  module Selection_error = struct
+    type t =
+      | Too_many_backends of M.t list
+      | No_backend_found
+      | Other of exn
+
+    let to_exn t ~loc =
+      match t with
+      | Too_many_backends 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)))))
+      | No_backend_found ->
+        Loc.exnf loc "No %s found." (M.desc ~plural:false)
+      | Other exn ->
+        exn
+
+    let or_exn res ~loc =
+      match res with
+      | Ok _ as x -> x
+      | Error t -> Error (to_exn t ~loc)
+
+    let wrap = function
+      | Ok _ as x -> x
+      | Error exn -> Error (Other exn)
+  end
+  open Selection_error
+
+  let written_by_user_or_scan ~written_by_user ~to_scan =
     match
       match written_by_user with
       | Some l -> l
       | None   -> List.filter_map to_scan ~f:get
     with
-    | [] -> begin
-        match no_backend_error with
-        | Some f ->
-          Error (Loc.exnf loc "%s" (f to_scan))
-        | None ->
-          Error
-            (Loc.exnf loc "No %s found." (M.desc ~plural:false))
-      end
+    | [] -> Error No_backend_found
     | 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 select_extensible_backends ?written_by_user ~extends to_scan =
     let open Result.O in
-    written_by_user_or_scan ~loc ~written_by_user ~to_scan
-      ~no_backend_error:None
+    written_by_user_or_scan ~written_by_user ~to_scan
     >>= fun backends ->
-    top_closure backends ~deps:extends
+    wrap (top_closure backends ~deps:extends)
     >>= fun backends ->
     let roots =
       let all = Set.of_list backends in
@@ -86,21 +101,20 @@ module Register_backend(M : Backend) = struct
     if List.length roots = 1 then
       Ok backends
     else
-      Error (too_many_backends ~loc roots)
+      Error (Too_many_backends roots)
 
-  let select_replaceable_backend ~loc ?written_by_user ~replaces
-        ?no_backend_error to_scan =
+  let select_replaceable_backend ?written_by_user ~replaces to_scan =
     let open Result.O in
-    written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error
+    written_by_user_or_scan ~written_by_user ~to_scan
     >>= fun backends ->
-    Result.concat_map backends ~f:replaces
+    wrap (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)
+    | l   -> Error (Too_many_backends l)
 end
 
 type Lib.Sub_system.t +=
@@ -120,11 +134,11 @@ module Register_end_point(M : End_point) = struct
          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)
-        ?written_by_user
-        ~extends:M.Backend.extends
-        (deps @ pps)
+      M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info)
+        (M.Backend.select_extensible_backends
+           ?written_by_user
+           ~extends:M.Backend.extends
+           (deps @ pps))
     in
     let fail, backends =
       match backends with

src/sub_system_intf.ml

@@ -45,6 +45,16 @@ module type Registered_backend = sig
   (** Resolve a backend name *)
   val resolve : Lib.DB.t -> Loc.t * string -> t Or_exn.t
 
+  module Selection_error : sig
+    type nonrec t =
+      | Too_many_backends of t list
+      | No_backend_found
+      | Other of exn
+
+    val to_exn : t -> loc:Loc.t -> exn
+    val or_exn : ('a, t) result -> loc:Loc.t -> 'a Or_exn.t
+  end
+
   (** Choose a backend by either using the ones written by the user or
       by scanning the dependencies.
 
@@ -53,23 +63,20 @@ module type Registered_backend = sig
       independant, i.e. none of them is in the transitive closure of
       the other one. *)
   val select_extensible_backends
-    :  loc:Loc.t
-    -> ?written_by_user:t list
+    :  ?written_by_user:t list
     -> extends:(t -> t list Or_exn.t)
     -> Lib.t list
-    -> t list Or_exn.t
+    -> (t list, Selection_error.t) 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
+    :  ?written_by_user:t list
     -> replaces:(t -> t list Or_exn.t)
-    -> ?no_backend_error:(Lib.t list -> string)
     -> Lib.t list
-    -> t Or_exn.t
+    -> (t, Selection_error.t) result
 end
 
 (* This is probably what we'll give to plugins *)

test/blackbox-tests/dune.inc

@@ -81,6 +81,15 @@
     test-cases/depend-on-the-universe
     (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))))
 
+(alias
+ ((name dune-ppx-driver-system)
+  (deps
+   ((package dune) (files_recursively_in test-cases/dune-ppx-driver-system)))
+  (action
+   (chdir
+    test-cases/dune-ppx-driver-system
+    (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))))
+
 (alias
  ((name env)
   (deps ((package dune) (files_recursively_in test-cases/env)))
@@ -537,6 +546,7 @@
     (alias cross-compilation)
     (alias custom-build-dir)
     (alias depend-on-the-universe)
+    (alias dune-ppx-driver-system)
     (alias env)
     (alias exclude-missing-module)
     (alias exec-cmd)
@@ -600,6 +610,7 @@
     (alias cross-compilation)
     (alias custom-build-dir)
     (alias depend-on-the-universe)
+    (alias dune-ppx-driver-system)
     (alias env)
     (alias exclude-missing-module)
     (alias exec-cmd)