refactoring
This commit is contained in:
Jeremie Dimino
parent
0f5635068f
commit
d2b8acc3b7
165
src/gen_rules.ml
165
src/gen_rules.ml
|
|
@ -684,6 +684,116 @@ module Gen(P : Params) = struct
|
|||
; mli_fname = mli_pp_fname
|
||||
}
|
||||
|
||||
module Ppx_info : sig
|
||||
type t =
|
||||
{ uses_inline_test : bool
|
||||
; uses_inline_bench : bool
|
||||
; uses_here : bool
|
||||
; uses_libname : bool
|
||||
; uses_ppx_driver : bool
|
||||
}
|
||||
|
||||
val make_info_file
|
||||
: ppx_dir:Path.t
|
||||
-> libs:(unit, Lib.t list) Build.t
|
||||
-> (unit, t) Build.t
|
||||
|
||||
|
||||
val specific_args_for_ppx_rewriters
|
||||
: t
|
||||
-> dir:Path.t
|
||||
-> lib_name:string option
|
||||
-> for_merlin:bool
|
||||
-> _ Arg_spec.t
|
||||
end = struct
|
||||
type t =
|
||||
{ uses_inline_test : bool
|
||||
; uses_inline_bench : bool
|
||||
; uses_here : bool
|
||||
; uses_libname : bool
|
||||
; uses_ppx_driver : bool
|
||||
}
|
||||
|
||||
module Vfile =
|
||||
Vfile_kind.Make_full
|
||||
(struct type nonrec t = t end)
|
||||
(struct
|
||||
open Sexp.To_sexp
|
||||
let t _dir t =
|
||||
record
|
||||
[ "uses_inline_test" , bool t.uses_inline_test
|
||||
; "uses_inline_bench", bool t.uses_inline_bench
|
||||
; "uses_here" , bool t.uses_here
|
||||
; "uses_libname" , bool t.uses_libname
|
||||
; "uses_ppx_driver" , bool t.uses_ppx_driver
|
||||
]
|
||||
end)
|
||||
(struct
|
||||
open Sexp.Of_sexp
|
||||
let t _dir sexp =
|
||||
record
|
||||
(field "uses_inline_test" bool >>= fun uses_inline_test ->
|
||||
field "uses_inline_bench" bool >>= fun uses_inline_bench ->
|
||||
field "uses_here" bool >>= fun uses_here ->
|
||||
field "uses_libname" bool >>= fun uses_libname ->
|
||||
field "uses_ppx_driver" bool >>= fun uses_ppx_driver ->
|
||||
return
|
||||
{ uses_inline_test
|
||||
; uses_inline_bench
|
||||
; uses_here
|
||||
; uses_libname
|
||||
; uses_ppx_driver
|
||||
})
|
||||
sexp
|
||||
end)
|
||||
|
||||
let info_file ~ppx_dir =
|
||||
Build.Vspec.T (Path.relative ppx_dir "info.sexp",
|
||||
(module Vfile))
|
||||
|
||||
let make_info_file ~ppx_dir ~libs =
|
||||
let file = info_file ~ppx_dir in
|
||||
add_rule
|
||||
(libs >>^ (fun libs ->
|
||||
let uses_inline_test = ref false in
|
||||
let uses_inline_bench = ref false in
|
||||
let uses_here = ref false in
|
||||
let uses_libname = ref false in
|
||||
let uses_ppx_driver = ref false in
|
||||
List.iter libs ~f:(fun lib ->
|
||||
match Lib.best_name lib with
|
||||
| "ppx_here" | "ppx_assert" -> uses_here := true
|
||||
| "ppx_inline_test.libname" -> uses_libname := true
|
||||
| "ppx_expect" -> uses_inline_test := true; uses_here := true
|
||||
| "ppx_inline_test" -> uses_inline_test := true
|
||||
| "ppx_bench" -> uses_inline_bench := true
|
||||
| "ppx_driver.runner" -> uses_ppx_driver := true
|
||||
| _ -> ());
|
||||
{ uses_inline_test = !uses_inline_test
|
||||
; uses_inline_bench = !uses_inline_bench
|
||||
; uses_here = !uses_here
|
||||
; uses_libname = !uses_libname
|
||||
; uses_ppx_driver = !uses_ppx_driver
|
||||
})
|
||||
>>>
|
||||
Build.store_vfile file);
|
||||
Build.vpath file
|
||||
|
||||
let specific_args_for_ppx_rewriters t ~dir ~lib_name ~for_merlin =
|
||||
Arg_spec.S
|
||||
[ S (if t.uses_here
|
||||
then [A "-dirname"; Path dir]
|
||||
else [])
|
||||
; S (match lib_name with
|
||||
| Some name when t.uses_libname ->
|
||||
[ A "-inline-test-lib"; A name ]
|
||||
| _ -> [])
|
||||
; S (if t.uses_ppx_driver && not for_merlin
|
||||
then [ A "-embed-errors"; A "false" ]
|
||||
else [])
|
||||
]
|
||||
end
|
||||
|
||||
let ppx_drivers = Hashtbl.create 32
|
||||
|
||||
let migrate_driver_main = "ocaml-migrate-parsetree.driver-main"
|
||||
|
|
@ -775,42 +885,9 @@ module Gen(P : Params) = struct
|
|||
let libs =
|
||||
build_ppx_driver names ~dir ~dep_kind ~target:exe ~driver
|
||||
in
|
||||
Hashtbl.add ppx_drivers ~key ~data:(exe, libs);
|
||||
(exe, libs)
|
||||
|
||||
let specific_args_for_ppx_rewriters ~dir ~lib_name ~for_merlin (libs : Lib.t list) =
|
||||
let uses_inline_test = ref false in
|
||||
let uses_inline_bench = ref false in
|
||||
let uses_here = ref false in
|
||||
let uses_libname = ref false in
|
||||
let uses_ppx_driver = ref false in
|
||||
List.iter libs ~f:(fun lib ->
|
||||
match Lib.best_name lib with
|
||||
| "ppx_here" | "ppx_assert" -> uses_here := true
|
||||
| "ppx_inline_test.libname" -> uses_libname := true
|
||||
| "ppx_expect" -> uses_inline_test := true; uses_here := true
|
||||
| "ppx_inline_test" -> uses_inline_test := true
|
||||
| "ppx_bench" -> uses_inline_bench := true
|
||||
| "ppx_driver.runner" -> uses_ppx_driver := true
|
||||
| _ -> ());
|
||||
Arg_spec.S
|
||||
[ S (if !uses_here
|
||||
then [A "-dirname"; Path dir]
|
||||
else [])
|
||||
; S (match lib_name with
|
||||
| Some name when !uses_libname ->
|
||||
[ A "-inline-test-lib"; A name ]
|
||||
| _ -> [])
|
||||
; S (if !uses_inline_test(* && drop_test*)
|
||||
then [ A "-inline-test-drop-with-deadcode" ]
|
||||
else [])
|
||||
; S (if !uses_inline_bench (*&& drop_bench*)
|
||||
then [ A "-bench-drop-with-deadcode" ]
|
||||
else [])
|
||||
; S (if !uses_ppx_driver && not for_merlin
|
||||
then [ A "-embed-errors"; A "false" ]
|
||||
else [])
|
||||
]
|
||||
let info = Ppx_info.make_info_file ~ppx_dir ~libs in
|
||||
Hashtbl.add ppx_drivers ~key ~data:(exe, libs, info);
|
||||
(exe, libs, info)
|
||||
|
||||
let target_var = String_with_vars.of_string "${@}"
|
||||
let root_var = String_with_vars.of_string "${ROOT}"
|
||||
|
|
@ -840,16 +917,17 @@ module Gen(P : Params) = struct
|
|||
~targets:[dst]
|
||||
~deps:[Some src]))
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe, libs = get_ppx_driver pps ~dir ~dep_kind in
|
||||
let ppx_exe, _, info = get_ppx_driver pps ~dir ~dep_kind in
|
||||
pped_module m ~dir ~f:(fun kind src dst ->
|
||||
add_rule
|
||||
(preprocessor_deps
|
||||
>>>
|
||||
libs
|
||||
info
|
||||
>>>
|
||||
Build.run
|
||||
(Dep ppx_exe)
|
||||
[ Dyn (specific_args_for_ppx_rewriters ~dir ~lib_name ~for_merlin:false)
|
||||
[ Dyn (Ppx_info.specific_args_for_ppx_rewriters ~dir ~lib_name
|
||||
~for_merlin:false)
|
||||
; As flags
|
||||
; A "--dump-ast"
|
||||
; A "-o"; Target dst
|
||||
|
|
@ -910,11 +988,12 @@ module Gen(P : Params) = struct
|
|||
let ppx_flags ~dir ~src_dir { preprocess; libname; _ } =
|
||||
match preprocess with
|
||||
| Pps { pps; flags } ->
|
||||
let exe, libs = get_ppx_driver pps ~dir ~dep_kind:Optional in
|
||||
libs >>^ fun libs ->
|
||||
let exe, _, info = get_ppx_driver pps ~dir ~dep_kind:Optional in
|
||||
info >>^ fun info ->
|
||||
let specific_flags, _ =
|
||||
Arg_spec.expand ~dir:src_dir
|
||||
[specific_args_for_ppx_rewriters ~dir ~lib_name:libname libs ~for_merlin:true]
|
||||
[Ppx_info.specific_args_for_ppx_rewriters info ~dir ~lib_name:libname
|
||||
~for_merlin:true]
|
||||
()
|
||||
in
|
||||
let command =
|
||||
|
|
@ -1873,7 +1952,7 @@ module Gen(P : Params) = struct
|
|||
else
|
||||
pps
|
||||
in
|
||||
let ppx_exe, _ =
|
||||
let ppx_exe, _, _ =
|
||||
get_ppx_driver pps
|
||||
~dir ~dep_kind:(if lib.optional then Build.Optional else Required)
|
||||
in
|
||||
|
|
|
|||
Loading…
Reference in New Issue