Refactor handling of backend selection errors + add tests
Signed-off-by: Jeremie Dimino <jdimino@janestreet.com>
This commit is contained in:
parent
84f1f9b82b
commit
ec6ca4be67
|
@ -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: " *)
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
|
@ -0,0 +1 @@
|
|||
(lang dune 0.1)
|
|
@ -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]
|
Loading…
Reference in New Issue