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