Use Compilation_context in menhir
Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
parent
c9ead23c7d
commit
3bd9addeb2
105
src/gen_rules.ml
105
src/gen_rules.ml
|
@ -10,6 +10,7 @@ open! No_io
|
|||
|
||||
module Gen(P : Install_rules.Params) = struct
|
||||
module Alias = Build_system.Alias
|
||||
module CC = Compilation_context
|
||||
module SC = Super_context
|
||||
module Odoc = Odoc.Gen(P)
|
||||
|
||||
|
@ -253,8 +254,7 @@ module Gen(P : Install_rules.Params) = struct
|
|||
List.concat_map stanzas ~f:(fun stanza ->
|
||||
match (stanza : Stanza.t) with
|
||||
| Menhir menhir ->
|
||||
Menhir_rules.gen_rules sctx ~dir ~scope menhir
|
||||
|> List.map ~f:Path.basename
|
||||
Menhir_rules.targets menhir
|
||||
| Rule rule ->
|
||||
List.map (user_rule rule ~dir ~scope) ~f:Path.basename
|
||||
| Copy_files def ->
|
||||
|
@ -549,10 +549,6 @@ module Gen(P : Install_rules.Params) = struct
|
|||
let flags = SC.ocaml_flags sctx ~scope ~dir lib.buildable in
|
||||
let { modules; main_module_name; alias_module } = modules_by_lib ~dir lib in
|
||||
let source_modules = modules in
|
||||
let already_used =
|
||||
Modules_partitioner.acknowledge modules_partitioner
|
||||
~loc:lib.buildable.loc ~modules
|
||||
in
|
||||
(* Preprocess before adding the alias module as it doesn't need
|
||||
preprocessing *)
|
||||
let pp =
|
||||
|
@ -591,6 +587,11 @@ module Gen(P : Install_rules.Params) = struct
|
|||
~requires
|
||||
~preprocessing:pp
|
||||
in
|
||||
|
||||
let already_used =
|
||||
Modules_partitioner.acknowledge modules_partitioner cctx
|
||||
~loc:lib.buildable.loc ~modules:source_modules
|
||||
in
|
||||
let dep_graphs = Ocamldep.rules cctx ~already_used in
|
||||
|
||||
Option.iter alias_module ~f:(fun m ->
|
||||
|
@ -803,19 +804,12 @@ module Gen(P : Install_rules.Params) = struct
|
|||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let executables_rules ~dir ~all_modules
|
||||
?modules_partitioner ~scope ~compile_info
|
||||
~modules_partitioner ~scope ~compile_info
|
||||
(exes : Executables.t) =
|
||||
let requires = Lib.Compile.requires compile_info in
|
||||
let modules =
|
||||
parse_modules ~all_modules ~buildable:exes.buildable
|
||||
in
|
||||
let already_used =
|
||||
match modules_partitioner with
|
||||
| None -> Module.Name.Set.empty
|
||||
| Some mp ->
|
||||
Modules_partitioner.acknowledge mp
|
||||
~loc:exes.buildable.loc ~modules
|
||||
in
|
||||
|
||||
let preprocessor_deps =
|
||||
SC.Deps.interpret sctx exes.buildable.preprocessor_deps
|
||||
|
@ -894,6 +888,10 @@ module Gen(P : Install_rules.Params) = struct
|
|||
~requires
|
||||
~preprocessing:pp
|
||||
in
|
||||
let already_used =
|
||||
Modules_partitioner.acknowledge modules_partitioner cctx
|
||||
~loc:exes.buildable.loc ~modules
|
||||
in
|
||||
|
||||
Exe.build_and_link_many cctx
|
||||
~programs
|
||||
|
@ -909,7 +907,7 @@ module Gen(P : Install_rules.Params) = struct
|
|||
~objs_dirs:(Path.Set.singleton obj_dir)
|
||||
|
||||
let executables_rules ~dir ~all_modules
|
||||
?modules_partitioner ~scope (exes : Executables.t) =
|
||||
~modules_partitioner ~scope (exes : Executables.t) =
|
||||
let compile_info =
|
||||
Lib.DB.resolve_user_written_deps (Scope.libs scope)
|
||||
exes.buildable.libraries
|
||||
|
@ -920,7 +918,7 @@ module Gen(P : Install_rules.Params) = struct
|
|||
SC.Libs.with_lib_deps sctx compile_info ~dir
|
||||
~f:(fun () ->
|
||||
executables_rules exes ~dir ~all_modules
|
||||
?modules_partitioner ~scope ~compile_info)
|
||||
~modules_partitioner ~scope ~compile_info)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Aliases |
|
||||
|
@ -967,39 +965,56 @@ module Gen(P : Install_rules.Params) = struct
|
|||
(* This interprets "rule" and "copy_files" stanzas. *)
|
||||
let files = text_files ~dir:ctx_dir in
|
||||
let all_modules = modules_by_dir ~dir:ctx_dir in
|
||||
let modules_partitioner = Modules_partitioner.create ~all_modules in
|
||||
List.filter_map stanzas ~f:(fun stanza ->
|
||||
let dir = ctx_dir in
|
||||
match (stanza : Stanza.t) with
|
||||
| Library lib ->
|
||||
Some (library_rules lib ~dir ~files ~scope ~modules_partitioner)
|
||||
| Executables exes ->
|
||||
Some (executables_rules exes ~dir ~all_modules ~scope
|
||||
~modules_partitioner)
|
||||
| Alias alias ->
|
||||
alias_rules alias ~dir ~scope;
|
||||
None
|
||||
| Copy_files { glob; _ } ->
|
||||
let src_dir =
|
||||
let loc = String_with_vars.loc glob in
|
||||
let src_glob = SC.expand_vars sctx ~dir glob ~scope in
|
||||
Path.parent_exn (Path.relative src_dir src_glob ~error_loc:loc)
|
||||
in
|
||||
Some
|
||||
(Merlin.make ()
|
||||
~source_dirs:(Path.Set.singleton src_dir))
|
||||
| _ -> None)
|
||||
|> Merlin.merge_all
|
||||
|> Option.map ~f:(fun m -> Merlin.add_source_dir m src_dir)
|
||||
|> Option.iter ~f:(Merlin.add_rules sctx ~dir:ctx_dir ~scope);
|
||||
Utop.setup sctx ~dir:ctx_dir ~libs:(
|
||||
let modules_partitioner = Modules_partitioner.create () in
|
||||
let merlins =
|
||||
List.filter_map stanzas ~f:(fun stanza ->
|
||||
let dir = ctx_dir in
|
||||
match (stanza : Stanza.t) with
|
||||
| Library lib ->
|
||||
Some (library_rules lib ~dir ~files ~scope ~modules_partitioner)
|
||||
| Executables exes ->
|
||||
Some (executables_rules exes ~dir ~all_modules ~scope
|
||||
~modules_partitioner)
|
||||
| Alias alias ->
|
||||
alias_rules alias ~dir ~scope;
|
||||
None
|
||||
| Copy_files { glob; _ } ->
|
||||
let src_dir =
|
||||
let loc = String_with_vars.loc glob in
|
||||
let src_glob = SC.expand_vars sctx ~dir glob ~scope in
|
||||
Path.parent_exn (Path.relative src_dir src_glob ~error_loc:loc)
|
||||
in
|
||||
Some
|
||||
(Merlin.make ()
|
||||
~source_dirs:(Path.Set.singleton src_dir))
|
||||
| _ -> None)
|
||||
in
|
||||
Option.iter (Merlin.merge_all merlins) ~f:(fun m ->
|
||||
Merlin.add_rules sctx ~dir:ctx_dir ~scope
|
||||
(Merlin.add_source_dir m src_dir));
|
||||
Utop.setup sctx ~dir:ctx_dir ~scope ~libs:(
|
||||
List.filter_map stanzas ~f:(function
|
||||
| Library lib -> Some lib
|
||||
| _ -> None)
|
||||
) ~scope;
|
||||
| _ -> None));
|
||||
List.iter stanzas ~f:(fun stanza ->
|
||||
match (stanza : Stanza.t) with
|
||||
| Menhir m ->
|
||||
let cctx =
|
||||
match
|
||||
List.find_map (Menhir_rules.module_names m)
|
||||
~f:(Modules_partitioner.find modules_partitioner)
|
||||
with
|
||||
| None ->
|
||||
Loc.fail m.loc
|
||||
"I can't determine what library/executable the files produced \
|
||||
by this stanza are part of."
|
||||
| Some cctx -> cctx
|
||||
in
|
||||
Menhir_rules.gen_rules cctx m
|
||||
| _ -> ());
|
||||
Modules_partitioner.emit_warnings modules_partitioner
|
||||
|
||||
let gen_rules ~dir components : Build_system.extra_sub_directories_to_keep =
|
||||
let gen_rules ~dir components : Build_system.extra_sub_directories_to_keep =
|
||||
(match components with
|
||||
| ".js" :: rest -> Js_of_ocaml_rules.setup_separate_compilation_rules
|
||||
sctx rest
|
||||
|
|
|
@ -80,10 +80,8 @@ module Run (P : PARAMS) = struct
|
|||
let menhir (args : args) =
|
||||
flags >>> Build.run menhir_binary ~dir ~context args
|
||||
|
||||
(* The function [rule] adds a rule and returns the list of its targets. *)
|
||||
|
||||
let rule : (unit, Action.t) Build.t -> Path.t list =
|
||||
SC.add_rule_get_targets sctx ~mode:stanza.mode ~loc:stanza.loc
|
||||
let rule : (unit, Action.t) Build.t -> unit =
|
||||
SC.add_rule sctx ~mode:stanza.mode ~loc:stanza.loc
|
||||
|
||||
(* If there is no [base] clause, then a stanza that mentions several modules
|
||||
is equivalent to a list of stanzas, each of which mentions one module, so
|
||||
|
@ -119,7 +117,7 @@ module Run (P : PARAMS) = struct
|
|||
|
||||
*)
|
||||
|
||||
let process (stanza : stanza) : Path.t list =
|
||||
let process (stanza : stanza) =
|
||||
let base : string = Option.value_exn stanza.merge_into in
|
||||
let args : args =
|
||||
[ Dyn (fun flags -> As flags)
|
||||
|
@ -132,8 +130,8 @@ module Run (P : PARAMS) = struct
|
|||
|
||||
(* The main side effect. *)
|
||||
|
||||
let targets =
|
||||
List.concat_map ~f:process stanzas
|
||||
let () =
|
||||
List.iter ~f:process stanzas
|
||||
|
||||
end
|
||||
|
||||
|
@ -141,11 +139,22 @@ end
|
|||
|
||||
(* The final glue. *)
|
||||
|
||||
let gen_rules sctx ~dir ~scope stanza =
|
||||
let targets (stanza : Jbuild.Menhir.t) =
|
||||
let f m = [m ^ ".ml"; m ^ ".mli"] in
|
||||
match stanza.merge_into with
|
||||
| Some m -> f m
|
||||
| None -> List.concat_map stanza.modules ~f
|
||||
|
||||
let module_names (stanza : Jbuild.Menhir.t) =
|
||||
match stanza.merge_into with
|
||||
| Some m -> [Module.Name.of_string m]
|
||||
| None -> List.map stanza.modules ~f:Module.Name.of_string
|
||||
|
||||
let gen_rules cctx stanza =
|
||||
let module R = Run(struct
|
||||
let sctx = sctx
|
||||
let dir = dir
|
||||
let scope = scope
|
||||
let sctx = Compilation_context.super_context cctx
|
||||
let dir = Compilation_context.dir cctx
|
||||
let scope = Compilation_context.scope cctx
|
||||
let stanza = stanza
|
||||
end) in
|
||||
R.targets
|
||||
()
|
||||
|
|
|
@ -1,14 +1,15 @@
|
|||
(** Menhir rules *)
|
||||
|
||||
open Stdune
|
||||
(** Return the list of targets that are generated by this stanza. This
|
||||
list of targets is used by the code that computes the list of
|
||||
modules in the directory. *)
|
||||
val targets : Jbuild.Menhir.t -> string list
|
||||
|
||||
(** Generate the rules for a [(menhir ...)] stanza. Return the list of
|
||||
targets that are generated by these rules. This list of targets is
|
||||
used by the code that computes the list of modules in the
|
||||
directory. *)
|
||||
(** Return the list of modules that are generated by this stanza. *)
|
||||
val module_names : Jbuild.Menhir.t -> Module.Name.t list
|
||||
|
||||
(** Generate the rules for a [(menhir ...)] stanza. *)
|
||||
val gen_rules
|
||||
: Super_context.t
|
||||
-> dir:Path.t
|
||||
-> scope:Scope.t
|
||||
: Compilation_context.t
|
||||
-> Jbuild.Menhir.t
|
||||
-> Path.t list
|
||||
-> unit
|
||||
|
|
|
@ -1,16 +1,14 @@
|
|||
open Import
|
||||
|
||||
type t =
|
||||
{ all_modules : Module.t Module.Name.Map.t
|
||||
; mutable used : Loc.t list Module.Name.Map.t
|
||||
type 'a t =
|
||||
{ mutable used : ('a * Loc.t list) Module.Name.Map.t
|
||||
}
|
||||
|
||||
let create ~all_modules =
|
||||
{ all_modules
|
||||
; used = Module.Name.Map.empty
|
||||
let create () =
|
||||
{ used = Module.Name.Map.empty
|
||||
}
|
||||
|
||||
let acknowledge t ~loc ~modules =
|
||||
let acknowledge t part ~loc ~modules =
|
||||
let already_used =
|
||||
Module.Name.Map.merge modules t.used ~f:(fun _name x l ->
|
||||
Option.some_if (Option.is_some x && Option.is_some l) ())
|
||||
|
@ -18,14 +16,20 @@ let acknowledge t ~loc ~modules =
|
|||
|> Module.Name.Set.of_list
|
||||
in
|
||||
t.used <-
|
||||
Module.Name.Map.merge modules t.used ~f:(fun _name x l ->
|
||||
Module.Name.Map.merge modules t.used ~f:(fun _name x y ->
|
||||
match x with
|
||||
| None -> l
|
||||
| Some _ -> Some (loc :: Option.value l ~default:[]));
|
||||
| None -> y
|
||||
| Some _ ->
|
||||
Some (part,
|
||||
loc :: match y with
|
||||
| None -> []
|
||||
| Some (_, l) -> l));
|
||||
already_used
|
||||
|
||||
let find t name = Option.map (Module.Name.Map.find t.used name) ~f:fst
|
||||
|
||||
let emit_warnings t =
|
||||
Module.Name.Map.iteri t.used ~f:(fun name locs ->
|
||||
Module.Name.Map.iteri t.used ~f:(fun name (_, locs) ->
|
||||
match locs with
|
||||
| [] | [_] -> ()
|
||||
| loc :: _ ->
|
||||
|
|
|
@ -2,24 +2,26 @@
|
|||
|
||||
open! Stdune
|
||||
|
||||
type t
|
||||
type 'a t
|
||||
|
||||
val create
|
||||
: all_modules:Module.t Module.Name.Map.t
|
||||
-> t
|
||||
val create : unit -> 'a t
|
||||
|
||||
(** [acknowledge t ~loc ~modules] registers the fact that [modules]
|
||||
(** [acknowledge t partition ~loc ~modules] registers the fact that [modules]
|
||||
are associated with [loc].
|
||||
|
||||
Returns the set of modules that are already used at another
|
||||
location.
|
||||
*)
|
||||
val acknowledge
|
||||
: t
|
||||
: 'a t
|
||||
-> 'a
|
||||
-> loc:Loc.t
|
||||
-> modules:Module.t Module.Name.Map.t
|
||||
-> Module.Name.Set.t
|
||||
|
||||
(** Find which partition a module is part of *)
|
||||
val find : 'a t -> Module.Name.t -> 'a option
|
||||
|
||||
(** To be called after processing a directory. Emit warnings about
|
||||
detected problems *)
|
||||
val emit_warnings : t -> unit
|
||||
val emit_warnings : _ t -> unit
|
||||
|
|
Loading…
Reference in New Issue