Use Compilation_context in menhir

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
2018-05-26 01:30:27 +01:00 · 2018-05-26 01:30:27 +01:00 · 3bd9addeb2
parent c9ead23c7d
commit 3bd9addeb2
5 changed files with 115 additions and 84 deletions
--- 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
--- 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
+  ()
--- 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
--- 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 :: _ ->
--- 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