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