From 3bd9addeb2dc922117e59c506484488381fe4f14 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 26 May 2018 01:30:27 +0100 Subject: [PATCH] Use Compilation_context in menhir Signed-off-by: Jeremie Dimino --- src/gen_rules.ml | 105 ++++++++++++++++++++---------------- src/menhir.ml | 33 +++++++----- src/menhir.mli | 19 +++---- src/modules_partitioner.ml | 26 +++++---- src/modules_partitioner.mli | 16 +++--- 5 files changed, 115 insertions(+), 84 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 53585a47..bd48a3cd 100644 --- a/src/gen_rules.ml +++ b/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 diff --git a/src/menhir.ml b/src/menhir.ml index 5c3e6146..0aa756cc 100644 --- a/src/menhir.ml +++ b/src/menhir.ml @@ -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 + () diff --git a/src/menhir.mli b/src/menhir.mli index 23f9ab24..36c5c6af 100644 --- a/src/menhir.mli +++ b/src/menhir.mli @@ -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 diff --git a/src/modules_partitioner.ml b/src/modules_partitioner.ml index 4ffd49f2..c0ce4802 100644 --- a/src/modules_partitioner.ml +++ b/src/modules_partitioner.ml @@ -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 :: _ -> diff --git a/src/modules_partitioner.mli b/src/modules_partitioner.mli index 8e9d3a27..ae05eb15 100644 --- a/src/modules_partitioner.mli +++ b/src/modules_partitioner.mli @@ -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