Accept correction files produced by ppx_driver (#415)
* Accept correction files produced by ppx_driver so that [@@deriving_inline] works * Change promote-if so that it doesn't promote the file when the source file doesn't exist in the source tree
This commit is contained in:
parent
d4dec9b4f5
commit
49edf8ed65
|
@ -1017,9 +1017,10 @@ The following constructions are available:
|
|||
- ``(promote <files-to-promote>)`` copy generated files to the source
|
||||
tree. See `Promotion`_ for more details
|
||||
- ``(promote-if <files-to-promote>)`` is the same as ``(promote
|
||||
<files-to-promote>)`` except that it does nothing when the files to
|
||||
copy don't exist. This can be used with command that only produce a
|
||||
correction when differences are found
|
||||
<files-to-promote>)`` except that a form ``(<a> as <b>)`` is ignored
|
||||
when ``<a>`` doesn't exists. Additionally, ``<a>`` won't be copied
|
||||
if ``<b>`` doesn't already exist. This can be used with command that
|
||||
only produce a correction when differences are found
|
||||
|
||||
As mentioned ``copy#`` inserts a line directive at the beginning of
|
||||
the destination file. More precisely, it inserts the following line:
|
||||
|
|
|
@ -137,7 +137,8 @@ struct
|
|||
let remove_tree path = Remove_tree path
|
||||
let mkdir path = Mkdir path
|
||||
let digest_files files = Digest_files files
|
||||
let promote mode files = Promote { mode; files }
|
||||
let promote files = Promote { mode = Always; files }
|
||||
let promote_if files = Promote { mode = If_corrected_file_exists; files }
|
||||
end
|
||||
|
||||
module Make_mapper
|
||||
|
@ -758,10 +759,12 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
|
|||
if promote_mode = Copy then
|
||||
Future.Scheduler.at_exit_after_waiting_for_commands (fun () ->
|
||||
List.iter not_ok ~f:(fun { Promote. src; dst } ->
|
||||
Format.eprintf "Promoting %s to %s.@."
|
||||
(Path.to_string_maybe_quoted src)
|
||||
(Path.to_string_maybe_quoted dst);
|
||||
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)));
|
||||
if mode = Always || Path.exists dst then begin
|
||||
Format.eprintf "Promoting %s to %s.@."
|
||||
(Path.to_string_maybe_quoted src)
|
||||
(Path.to_string_maybe_quoted dst);
|
||||
Io.copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
|
||||
end));
|
||||
Future.all_unit (List.map not_ok ~f:(fun { Promote. src; dst } ->
|
||||
Diff.print dst src))
|
||||
end
|
||||
|
|
|
@ -76,5 +76,6 @@ module type Helpers = sig
|
|||
val remove_tree : path -> t
|
||||
val mkdir : path -> t
|
||||
val digest_files : path list -> t
|
||||
val promote : Promote_mode.t -> promote_file list -> t
|
||||
val promote : promote_file list -> t
|
||||
val promote_if : promote_file list -> t
|
||||
end
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
open Import
|
||||
open Jbuild
|
||||
|
||||
module A = Action
|
||||
module Pset = Path.Set
|
||||
|
||||
module Dir_with_jbuild = struct
|
||||
|
@ -901,6 +902,24 @@ module PP = struct
|
|||
mli) in
|
||||
{ m with impl ; intf }
|
||||
|
||||
let uses_ppx_driver ~pps =
|
||||
match Option.map ~f:Pp.to_string (List.last pps) with
|
||||
| Some "ppx_driver.runner" -> true
|
||||
| Some _ | None -> false
|
||||
|
||||
let promote_correction ~uses_ppx_driver fn build =
|
||||
if not uses_ppx_driver then
|
||||
build
|
||||
else
|
||||
Build.progn
|
||||
[ build
|
||||
; Build.return
|
||||
(A.promote_if
|
||||
[{ src = Path.extend_basename fn ~suffix:".ppx-corrected"
|
||||
; dst = Path.drop_build_context fn
|
||||
}])
|
||||
]
|
||||
|
||||
let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir
|
||||
~dep_kind ~lint ~lib_name ~scope =
|
||||
let alias = Alias.lint ~dir in
|
||||
|
@ -909,7 +928,8 @@ module PP = struct
|
|||
(Alias.add_build (aliases sctx) alias build
|
||||
~stamp:(List [ Atom "lint"
|
||||
; Sexp.To_sexp.(option string) lib_name
|
||||
; Atom fn]))
|
||||
; Atom fn
|
||||
]))
|
||||
in
|
||||
match Preprocess_map.find source.name lint with
|
||||
| No_preprocessing -> ()
|
||||
|
@ -938,15 +958,19 @@ module PP = struct
|
|||
; Dep src_path
|
||||
]
|
||||
in
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
let args =
|
||||
(* This hack is needed until -null is standard:
|
||||
https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35 *)
|
||||
match Option.map ~f:Pp.to_string (List.last pps) with
|
||||
| Some "ppx_driver.runner" -> args @ [A "-null"]
|
||||
| Some _ | None -> args
|
||||
if uses_ppx_driver then
|
||||
args @ [ A "-null"; A "-diff-cmd"; A "-" ]
|
||||
else
|
||||
args
|
||||
in
|
||||
add_alias src.name
|
||||
(Build.run ~context:sctx.context (Ok ppx_exe) args)
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file ~dir source kind))
|
||||
(Build.run ~context:sctx.context (Ok ppx_exe) args))
|
||||
)
|
||||
|
||||
(* Generate rules to build the .pp files and return a new module map where all filenames
|
||||
|
@ -959,51 +983,54 @@ module PP = struct
|
|||
in
|
||||
let lint_module = lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope in
|
||||
String_map.map modules ~f:(fun (m : Module.t) ->
|
||||
match Preprocess_map.find m.name preprocess with
|
||||
| No_preprocessing ->
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
ast
|
||||
| Action action ->
|
||||
let ast =
|
||||
pped_module m ~dir ~f:(fun _kind src dst ->
|
||||
add_rule sctx
|
||||
(preprocessor_deps
|
||||
>>>
|
||||
Build.path src
|
||||
>>^ (fun _ -> [src])
|
||||
>>>
|
||||
Action.run sctx
|
||||
(Redirect
|
||||
(Stdout,
|
||||
target_var,
|
||||
Chdir (root_var,
|
||||
action)))
|
||||
~dir
|
||||
~dep_kind
|
||||
~targets:(Static [dst])
|
||||
~scope))
|
||||
|> setup_reason_rules sctx ~dir in
|
||||
lint_module ~ast ~source:m;
|
||||
ast
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
pped_module ast ~dir ~f:(fun kind src dst ->
|
||||
match Preprocess_map.find m.name preprocess with
|
||||
| No_preprocessing ->
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
ast
|
||||
| Action action ->
|
||||
let ast =
|
||||
pped_module m ~dir ~f:(fun _kind src dst ->
|
||||
add_rule sctx
|
||||
(preprocessor_deps
|
||||
>>>
|
||||
Build.run ~context:sctx.context
|
||||
(Ok ppx_exe)
|
||||
[ As flags
|
||||
; A "--dump-ast"
|
||||
; As (cookie_library_name lib_name)
|
||||
; A "-o"; Target dst
|
||||
; Ml_kind.ppx_driver_flag kind; Dep src
|
||||
]))
|
||||
Build.path src
|
||||
>>^ (fun _ -> [src])
|
||||
>>>
|
||||
Action.run sctx
|
||||
(Redirect
|
||||
(Stdout,
|
||||
target_var,
|
||||
Chdir (root_var,
|
||||
action)))
|
||||
~dir
|
||||
~dep_kind
|
||||
~targets:(Static [dst])
|
||||
~scope))
|
||||
|> setup_reason_rules sctx ~dir in
|
||||
lint_module ~ast ~source:m;
|
||||
ast
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
pped_module ast ~dir ~f:(fun kind src dst ->
|
||||
add_rule sctx
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file m ~dir kind))
|
||||
(preprocessor_deps
|
||||
>>>
|
||||
Build.run ~context:sctx.context
|
||||
(Ok ppx_exe)
|
||||
[ As flags
|
||||
; A "--dump-ast"
|
||||
; As (cookie_library_name lib_name)
|
||||
; As (if uses_ppx_driver then ["-diff-cmd"; "-"] else [])
|
||||
; A "-o"; Target dst
|
||||
; Ml_kind.ppx_driver_flag kind; Dep src
|
||||
])))
|
||||
)
|
||||
|
||||
end
|
||||
|
||||
let expand_and_eval_set t ~scope ~dir set ~standard =
|
||||
|
|
Loading…
Reference in New Issue