Merge pull request #529 from ocaml/share-pps-computations
Share more results when preprocessing modules
This commit is contained in:
Rudi Grinberg
GitHub
commit
eefe4347f1
|
|
@ -141,6 +141,8 @@ module Hashtbl = struct
|
|||
end
|
||||
|
||||
module Map = struct
|
||||
module type OrderedType = MoreLabels.Map.OrderedType
|
||||
|
||||
module type S = sig
|
||||
include MoreLabels.Map.S
|
||||
|
||||
|
|
@ -155,7 +157,7 @@ module Map = struct
|
|||
val values : 'a t -> 'a list
|
||||
end
|
||||
|
||||
module Make(Key : MoreLabels.Map.OrderedType) : S with type key = Key.t = struct
|
||||
module Make(Key : OrderedType) : S with type key = Key.t = struct
|
||||
include MoreLabels.Map.Make(Key)
|
||||
|
||||
let add_multi t ~key ~data =
|
||||
|
|
|
|||
|
|
@ -264,46 +264,39 @@ module Preprocess = struct
|
|||
end
|
||||
|
||||
module Per_module = struct
|
||||
type 'a t =
|
||||
| For_all of 'a
|
||||
| Per_module of 'a String_map.t
|
||||
include Per_item.Make(String)
|
||||
|
||||
let t a sexp =
|
||||
let t ~default a sexp =
|
||||
match sexp with
|
||||
| List (_, Atom (_, "per_module") :: rest) -> begin
|
||||
List.concat_map rest ~f:(fun sexp ->
|
||||
let pp, names = pair a module_names sexp in
|
||||
List.map (String_set.elements names) ~f:(fun name -> (name, pp)))
|
||||
|> String_map.of_alist
|
||||
|> function
|
||||
| Ok map -> Per_module map
|
||||
| Error (name, _, _) ->
|
||||
of_sexp_error sexp (sprintf "module %s present in two different sets" name)
|
||||
end
|
||||
| sexp -> For_all (a sexp)
|
||||
List.map rest ~f:(fun sexp ->
|
||||
let pp, names = pair a module_names sexp in
|
||||
(String_set.elements names, pp))
|
||||
|> of_mapping ~default
|
||||
|> function
|
||||
| Ok t -> t
|
||||
| Error (name, _, _) ->
|
||||
of_sexp_error sexp (sprintf "module %s present in two different sets" name)
|
||||
end
|
||||
| sexp -> for_all (a sexp)
|
||||
end
|
||||
|
||||
module Preprocess_map = struct
|
||||
type t = Preprocess.t Per_module.t
|
||||
let t = Per_module.t Preprocess.t
|
||||
let t = Per_module.t Preprocess.t ~default:Preprocess.No_preprocessing
|
||||
|
||||
let no_preprocessing = Per_module.For_all Preprocess.No_preprocessing
|
||||
let no_preprocessing = Per_module.for_all Preprocess.No_preprocessing
|
||||
|
||||
let find module_name (t : t) =
|
||||
match t with
|
||||
| For_all pp -> pp
|
||||
| Per_module map -> String_map.find_default module_name map ~default:No_preprocessing
|
||||
let find module_name t = Per_module.get t module_name
|
||||
|
||||
let default : t = For_all No_preprocessing
|
||||
let default = Per_module.for_all Preprocess.No_preprocessing
|
||||
|
||||
module Pp_set = Set.Make(Pp)
|
||||
|
||||
let pps : t -> _ = function
|
||||
| For_all pp -> Preprocess.pps pp
|
||||
| Per_module map ->
|
||||
String_map.fold map ~init:Pp_set.empty ~f:(fun ~key:_ ~data:pp acc ->
|
||||
Pp_set.union acc (Pp_set.of_list (Preprocess.pps pp)))
|
||||
|> Pp_set.elements
|
||||
let pps t =
|
||||
Per_module.fold t ~init:Pp_set.empty ~f:(fun pp acc ->
|
||||
Pp_set.union acc (Pp_set.of_list (Preprocess.pps pp)))
|
||||
|> Pp_set.elements
|
||||
end
|
||||
|
||||
module Lint = struct
|
||||
|
|
@ -498,9 +491,10 @@ module Buildable = struct
|
|||
}
|
||||
|
||||
let single_preprocess t =
|
||||
match t.preprocess with
|
||||
| For_all pp -> pp
|
||||
| Per_module _ -> No_preprocessing
|
||||
if Per_module.is_constant t.preprocess then
|
||||
Per_module.get t.preprocess ""
|
||||
else
|
||||
Preprocess.No_preprocessing
|
||||
end
|
||||
|
||||
module Public_lib = struct
|
||||
|
|
|
|||
|
|
@ -45,13 +45,16 @@ module Preprocess : sig
|
|||
| Pps of pps
|
||||
end
|
||||
|
||||
module Per_module : Per_item.S with type key = string
|
||||
|
||||
module Preprocess_map : sig
|
||||
type t
|
||||
type t = Preprocess.t Per_module.t
|
||||
|
||||
val no_preprocessing : t
|
||||
val default : t
|
||||
|
||||
(** [find module_name] find the preprocessing specification for a given module *)
|
||||
(** [find module_name] find the preprocessing specification for a
|
||||
given module *)
|
||||
val find : string -> t -> Preprocess.t
|
||||
|
||||
val pps : t -> Pp.t list
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
open Import
|
||||
|
||||
module type S = sig
|
||||
type key
|
||||
|
||||
type 'a t
|
||||
|
||||
val for_all : 'a -> 'a t
|
||||
val of_mapping
|
||||
: (key list * 'a) list
|
||||
-> default:'a
|
||||
-> ('a t, key * 'a * 'a) result
|
||||
val get : 'a t -> key -> 'a
|
||||
val is_constant : _ t -> bool
|
||||
val map : 'a t -> f:('a -> 'b) -> 'b t
|
||||
val fold : 'a t -> init:'acc -> f:('a -> 'acc -> 'acc) -> 'acc
|
||||
end
|
||||
|
||||
module Make(Key : Map.OrderedType) : S with type key = Key.t = struct
|
||||
module Map = Map.Make(Key)
|
||||
|
||||
type key = Key.t
|
||||
|
||||
type 'a t =
|
||||
{ map : int Map.t
|
||||
; values : 'a array
|
||||
}
|
||||
|
||||
let for_all x =
|
||||
{ map = Map.empty
|
||||
; values = [|x|]
|
||||
}
|
||||
|
||||
let of_mapping l ~default =
|
||||
let values =
|
||||
Array.of_list (default :: List.map l ~f:snd)
|
||||
in
|
||||
List.mapi l ~f:(fun i (keys, _) ->
|
||||
List.map keys ~f:(fun key -> (key, i + 1)))
|
||||
|> List.concat
|
||||
|> Map.of_alist
|
||||
|> function
|
||||
| Ok map ->
|
||||
Ok { map; values }
|
||||
| Error (key, x, y) ->
|
||||
Error (key, values.(x), values.(y))
|
||||
|
||||
let get t key =
|
||||
let index =
|
||||
match Map.find key t.map with
|
||||
| None -> 0
|
||||
| Some i -> i
|
||||
in
|
||||
t.values.(index)
|
||||
|
||||
let map t ~f =
|
||||
{ t with values = Array.map t.values ~f }
|
||||
|
||||
let fold t ~init ~f =
|
||||
Array.fold_right t.values ~init ~f
|
||||
|
||||
let is_constant t = Array.length t.values = 1
|
||||
end
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
(** Module used to represent the [(per_xxx ...)] forms
|
||||
|
||||
The main different between this module and a plain [Map] is that
|
||||
the [map] operation applies transformations only once per distinct
|
||||
value.
|
||||
*)
|
||||
|
||||
open Import
|
||||
|
||||
module type S = sig
|
||||
type key
|
||||
|
||||
type 'a t
|
||||
|
||||
(** Create a mapping where all keys map to the same value *)
|
||||
val for_all : 'a -> 'a t
|
||||
|
||||
(** Create a mapping from a list of bindings *)
|
||||
val of_mapping
|
||||
: (key list * 'a) list
|
||||
-> default:'a
|
||||
-> ('a t, key * 'a * 'a) result
|
||||
|
||||
(** Get the configuration for the given item *)
|
||||
val get : 'a t -> key -> 'a
|
||||
|
||||
(** Returns [true] if the mapping returns the same value for all
|
||||
keys. Note that the mapping might still be constant if
|
||||
[is_constant] returns [false]. *)
|
||||
val is_constant : _ t -> bool
|
||||
|
||||
val map : 'a t -> f:('a -> 'b) -> 'b t
|
||||
val fold : 'a t -> init:'acc -> f:('a -> 'acc -> 'acc) -> 'acc
|
||||
end
|
||||
|
||||
module Make(Key : Map.OrderedType) : S with type key = Key.t
|
||||
|
|
@ -960,8 +960,7 @@ module PP = struct
|
|||
(Path.extend_basename fn ~suffix:".ppx-corrected"))
|
||||
]
|
||||
|
||||
let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir
|
||||
~dep_kind ~lint ~lib_name ~scope =
|
||||
let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage (
|
||||
let alias = Alias.lint ~dir in
|
||||
let add_alias fn build =
|
||||
Alias.add_action sctx.build_system alias build
|
||||
|
|
@ -970,50 +969,58 @@ module PP = struct
|
|||
; Atom fn
|
||||
])
|
||||
in
|
||||
match Preprocess_map.find source.name lint with
|
||||
| No_preprocessing -> ()
|
||||
| Action action ->
|
||||
let action = Action.U.Chdir (root_var, action) in
|
||||
Module.iter source ~f:(fun _ (src : Module.File.t) ->
|
||||
let src_path = Path.relative dir src.name in
|
||||
add_alias src.name
|
||||
(Build.path src_path
|
||||
>>^ (fun _ -> [src_path])
|
||||
>>> Action.run sctx
|
||||
action
|
||||
~dir
|
||||
~dep_kind
|
||||
~targets:(Static [])
|
||||
~scope)
|
||||
)
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx ~scope pps in
|
||||
Module.iter ast ~f:(fun kind src ->
|
||||
let src_path = Path.relative dir src.name in
|
||||
let args =
|
||||
[ Arg_spec.As flags
|
||||
; As (cookie_library_name lib_name)
|
||||
; Ml_kind.ppx_driver_flag kind
|
||||
; 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 *)
|
||||
if uses_ppx_driver then
|
||||
args @ [ A "-null"; A "-diff-cmd"; A "-" ]
|
||||
else
|
||||
args
|
||||
in
|
||||
add_alias src.name
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file ~dir source kind))
|
||||
(Build.run ~context:sctx.context (Ok ppx_exe) args))
|
||||
)
|
||||
let lint =
|
||||
Per_module.map lint ~f:(function
|
||||
| Preprocess.No_preprocessing ->
|
||||
(fun ~source:_ ~ast:_ -> ())
|
||||
| Action action ->
|
||||
(fun ~source ~ast:_ ->
|
||||
let action = Action.U.Chdir (root_var, action) in
|
||||
Module.iter source ~f:(fun _ (src : Module.File.t) ->
|
||||
let src_path = Path.relative dir src.name in
|
||||
add_alias src.name
|
||||
(Build.path src_path
|
||||
>>^ (fun _ -> [src_path])
|
||||
>>> Action.run sctx
|
||||
action
|
||||
~dir
|
||||
~dep_kind
|
||||
~targets:(Static [])
|
||||
~scope)))
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx ~scope pps in
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
let args : _ Arg_spec.t =
|
||||
S [ As flags
|
||||
; As (cookie_library_name lib_name)
|
||||
(* This hack is needed until -null is standard:
|
||||
https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35
|
||||
*)
|
||||
; As (if uses_ppx_driver then
|
||||
[ "-null"; "-diff-cmd"; "-" ]
|
||||
else
|
||||
[])
|
||||
]
|
||||
in
|
||||
(fun ~source ~ast ->
|
||||
Module.iter ast ~f:(fun kind src ->
|
||||
let args =
|
||||
[ args
|
||||
; Ml_kind.ppx_driver_flag kind
|
||||
; Dep (Path.relative dir src.name)
|
||||
]
|
||||
in
|
||||
add_alias src.name
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file ~dir source kind))
|
||||
(Build.run ~context:sctx.context (Ok ppx_exe) args))
|
||||
)))
|
||||
in
|
||||
fun ~(source : Module.t) ~ast ->
|
||||
Per_module.get lint source.name ~source ~ast)
|
||||
|
||||
(* Generate rules to build the .pp files and return a new module map where all filenames
|
||||
point to the .pp files *)
|
||||
(* Generate rules to build the .pp files and return a new module map
|
||||
where all filenames point to the .pp files *)
|
||||
let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess
|
||||
~preprocessor_deps ~lib_name
|
||||
~(scope : Lib_db.Scope.t With_required_by.t) =
|
||||
|
|
@ -1021,56 +1028,67 @@ module PP = struct
|
|||
Build.memoize "preprocessor deps"
|
||||
(Deps.interpret sctx ~scope:scope.data ~dir preprocessor_deps)
|
||||
in
|
||||
let lint_module = lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope in
|
||||
let lint_module =
|
||||
Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope)
|
||||
in
|
||||
let preprocess =
|
||||
Per_module.map preprocess ~f:(function
|
||||
| Preprocess.No_preprocessing ->
|
||||
(fun m ->
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
lint_module ~ast ~source:m;
|
||||
ast)
|
||||
| Action action ->
|
||||
(fun m ->
|
||||
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 ~scope pps in
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
let args : _ Arg_spec.t =
|
||||
S [ As flags
|
||||
; A "--dump-ast"
|
||||
; As (cookie_library_name lib_name)
|
||||
; As (if uses_ppx_driver then ["-diff-cmd"; "-"] else [])
|
||||
]
|
||||
in
|
||||
(fun m ->
|
||||
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
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file m ~dir kind))
|
||||
(preprocessor_deps
|
||||
>>>
|
||||
Build.run ~context:sctx.context
|
||||
(Ok ppx_exe)
|
||||
[ args
|
||||
; A "-o"; Target dst
|
||||
; Ml_kind.ppx_driver_flag kind; Dep src
|
||||
])))))
|
||||
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 ~scope pps 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
|
||||
])))
|
||||
)
|
||||
Per_module.get preprocess m.name m)
|
||||
end
|
||||
|
||||
module Eval_strings = Ordered_set_lang.Make(struct
|
||||
|
|
|
|||
Loading…
Reference in New Issue