diff --git a/src/loc.ml b/src/loc.ml index 70122da3333..28d7a1dc1b2 100644 --- a/src/loc.ml +++ b/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: " *) diff --git a/src/preprocessing.ml b/src/preprocessing.ml index e184ac0ee5e..51ab79a058d 100644 --- a/src/preprocessing.ml +++ b/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 -> diff --git a/src/stdune/fmt.ml b/src/stdune/fmt.ml index a0d2609036e..eebd3ed8791 100644 --- a/src/stdune/fmt.ml +++ b/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 diff --git a/src/stdune/fmt.mli b/src/stdune/fmt.mli index 8681035ed21..eaa53cc75ff 100644 --- a/src/stdune/fmt.mli +++ b/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) diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 3e5920b5783..16a3c9f11bc 100644 --- a/src/stdune/string.ml +++ b/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" diff --git a/src/stdune/string.mli b/src/stdune/string.mli index 1e2059d715c..a2c9d9820d7 100644 --- a/src/stdune/string.mli +++ b/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 diff --git a/src/sub_system.ml b/src/sub_system.ml index 2d1d214fd54..554791d23c2 100644 --- a/src/sub_system.ml +++ b/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 diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 0a4159ad780..a482a80a546 100644 --- a/src/sub_system_intf.ml +++ b/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 *) diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 89e6c0d8740..0af19fcf64c 100644 --- a/test/blackbox-tests/dune.inc +++ b/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) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune new file mode 100644 index 00000000000..b38b91fb322 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune @@ -0,0 +1,56 @@ +; No driver found +(library + ((name foo1) + (public_name foo.1) + (modules (foo1)) + (preprocess (pps ())))) + +; Too many drivers +(library + ((name foo2) + (public_name foo.2) + (modules (foo2)) + (preprocess (pps (ppx1 ppx2))))) + +; Incompatible with Dune +(library + ((name foo3) + (public_name foo.3) + (modules (foo3)) + (preprocess (pps (ppx_other))))) + +(rule (with-stdout-to foo1.ml (echo ""))) +(rule (with-stdout-to foo2.ml (echo ""))) +(rule (with-stdout-to foo3.ml (echo ""))) + +(library + ((name ppx1) + (public_name foo.ppx1) + (kind ppx_rewriter) + (modules ()) + (libraries (driver1)))) + +(library + ((name ppx2) + (public_name foo.ppx2) + (kind ppx_rewriter) + (modules ()) + (libraries (driver2)))) + +(library + ((name driver1) + (public_name foo.driver1) + (modules ()) + (ppx.driver ((main "(fun () -> assert false)"))))) + +(library + ((name driver2) + (public_name foo.driver2) + (modules ()) + (ppx.driver ((main "(fun () -> assert false)"))))) + +(library + ((name ppx_other) + (public_name foo.ppx-other) + (modules ()) + (kind ppx_rewriter))) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project new file mode 100644 index 00000000000..b278e95bd74 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project @@ -0,0 +1 @@ +(lang dune 0.1) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/foo.opam b/test/blackbox-tests/test-cases/dune-ppx-driver-system/foo.opam new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t new file mode 100644 index 00000000000..dc7881e2b52 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t @@ -0,0 +1,39 @@ +No ppx driver found + + $ dune build foo1.cma + File "dune", line 6, characters 14-22: + Error: You must specify at least one ppx rewriter. + [1] + +Too many drivers + + $ dune build foo2.cma + File "dune", line 13, characters 14-31: + Error: Too many incompatible ppx drivers were found: foo.driver2 and + foo.driver1. + [1] + +Not compatible with Dune + + $ dune build foo3.cma + File "dune", line 20, characters 14-31: + Error: No ppx driver were found. It seems that ppx_other is not compatible + with Dune. Examples of ppx rewriters that are compatible with Dune are ones + using ocaml-migrate-parsetree, ppxlib or ppx_driver. + [1] + +Same, but with error pointing to .ppx + + $ dune build .ppx/foo.ppx1+foo.ppx2/ppx.exe + File "_build/default/.ppx/foo.ppx1+foo.ppx2/ppx.exe", line 1, characters 0-0: + Error: Failed to create on-demand ppx rewriter for foo.ppx1 and foo.ppx2; too + many incompatible ppx drivers were found: foo.driver2 and foo.driver1. + [1] + + $ dune build .ppx/foo.ppx-other/ppx.exe + File "_build/default/.ppx/foo.ppx-other/ppx.exe", line 1, characters 0-0: + Error: Failed to create on-demand ppx rewriter for foo.ppx-other; no ppx + driver were found. It seems that foo.ppx-other is not compatible with Dune. + Examples of ppx rewriters that are compatible with Dune are ones using + ocaml-migrate-parsetree, ppxlib or ppx_driver. + [1]