added jbuilder extract-makefile

Makefile

@@ -24,4 +24,7 @@ all-supported-ocaml-versions:
 clean:
 	rm -rf _build
 
+extract-makefile:
+	$(BIN) extract-makefile -o Makefile.extracted @install
+
 .PHONY: default install uninstall reinstall clean test

bin/main.ml

@@ -50,20 +50,6 @@ end
 let do_build (setup : Main.setup) targets =
   Build_system.do_build_exn setup.build_system targets
 
-type ('a, 'b) walk_result =
-  | Cont of 'a
-  | Stop of 'b
-
-let rec walk_parents dir ~init ~f =
-  match f init dir with
-  | Stop x -> Stop x
-  | Cont x ->
-    let parent = Filename.dirname dir in
-    if parent = dir then
-      Cont x
-    else
-      walk_parents parent ~init:x ~f
-
 let find_root () =
   let cwd = Sys.getcwd () in
   let rec loop counter ~candidates ~to_cwd dir =
@@ -527,6 +513,51 @@ let external_lib_deps =
                  & Arg.info [] ~docv:"TARGET"))
   , Term.info "external-lib-deps" ~doc ~man)
 
+let extract_makefile =
+  let doc = "Extract a makefile that can build the given targets." in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|Extract a makefile that can build the given targets.|}
+    ; `Blocks help_secs
+    ]
+  in
+  let go common out targets =
+    set_common common;
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false
+       >>= fun setup ->
+       let targets =
+         match targets with
+         | [] -> Build_system.all_targets setup.build_system
+         | _  -> resolve_targets ~log common setup targets
+       in
+       Build_system.build_rules setup.build_system targets >>= fun rules ->
+       Io.with_file_out out ~f:(fun oc ->
+         let ppf = Format.formatter_of_out_channel oc in
+         List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
+           Format.fprintf ppf "%s:%s\n\t%s\n\n"
+             (Path.Set.elements rule.targets
+              |> List.map ~f:Path.to_string
+              |> String.concat ~sep:" ")
+             (Path.Set.elements rule.deps
+              |> List.map ~f:(fun p -> " " ^ Path.to_string p)
+              |> String.concat ~sep:"")
+             (Action.sexp_of_t rule.action |> Sexp.to_string));
+         Format.pp_print_flush ppf ());
+       Future.return ())
+  in
+  ( Term.(const go
+          $ common
+          $ Arg.(required
+                 & opt (some string) None
+                 & info ["o"] ~docv:"FILE"
+                     ~doc:"Output file.")
+          $ Arg.(value
+                 & pos_all string []
+                 & Arg.info [] ~docv:"TARGET"))
+  , Term.info "extract-makefile" ~doc ~man)
+
 let opam_installer () =
   match Bin.which "opam-installer" with
   | None ->
@@ -696,6 +727,7 @@ let all =
   ; uninstall
   ; exec
   ; subst
+  ; extract_makefile
   ]
 
 let default =

bin/main.mli

@@ -0,0 +1 @@
+(* empty *)

doc/jbuild

@@ -11,6 +11,7 @@ let commands =
   ; "uninstall"
   ; "exec"
   ; "subst"
+  ; "extract-makefile"
   ]
 
 let jbuild =

src/build_system.ml

@@ -18,14 +18,34 @@ module Exec_status = struct
     | Running  of Running.t
 end
 
-module Rule = struct
+module Internal_rule = struct
+  module Id : sig
+    type t
+    val to_int : t -> int
+    val compare : t -> t -> int
+    val gen : unit -> t
+  end = struct
+    type t = int
+    let to_int x = x
+    let compare (x : int) y = compare x y
+
+    let counter = ref 0
+    let gen () =
+      let n = !counter in
+      counter := n + 1;
+      n
+  end
+
   type t =
-    { rule_deps      : Pset.t
+    { id             : Id.t
+    ; rule_deps      : Pset.t
     ; static_deps    : Pset.t
     ; targets        : Pset.t
     ; build          : (unit, Action.t) Build.t
     ; mutable exec   : Exec_status.t
     }
+
+  let compare a b = Id.compare a.id b.id
 end
 
 module File_kind = struct
@@ -44,7 +64,7 @@ end
 
 module File_spec = struct
   type 'a t =
-    { rule         : Rule.t (* Rule which produces it *)
+    { rule         : Internal_rule.t (* Rule which produces it *)
     ; mutable kind : 'a File_kind.t
     ; mutable data : 'a option
     }
@@ -478,8 +498,9 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
     )
   ) in
   let rule =
-    { Rule.
-      static_deps
+    { Internal_rule.
+      id = Internal_rule.Id.gen ()
+    ; static_deps
     ; rule_deps
     ; targets
     ; build
@@ -628,34 +649,43 @@ let do_build t targets =
   with Build_error.E e ->
     Error e
 
+module Ir_set = Set.Make(Internal_rule)
+
 let rules_for_files t paths =
   List.filter_map paths ~f:(fun path ->
     match Hashtbl.find t.files path with
     | None -> None
-    | Some (File_spec.T { rule; _ }) -> Some (path, rule))
+    | Some (File_spec.T { rule; _ }) -> Some rule)
+  |> Ir_set.of_list
+  |> Ir_set.elements
 
-module File_closure =
-  Top_closure.Make(Path)
+module Ir_closure =
+  Top_closure.Make(Internal_rule.Id)
     (struct
       type graph = t
-      type t = Path.t * Rule.t
-      let key (path, _) = path
-      let deps (_, rule) bs =
-        rules_for_files bs (Pset.elements (Pset.union rule.Rule.static_deps rule.Rule.rule_deps))
+      type t = Internal_rule.t
+      let key (t : t) = t.id
+      let deps (t : t) bs =
+        rules_for_files bs
+          (Pset.elements
+             (Pset.union
+                t.static_deps
+                t.rule_deps))
     end)
 
 let rules_for_targets t targets =
-  match File_closure.top_closure t (rules_for_files t targets) with
+  match Ir_closure.top_closure t (rules_for_files t targets) with
   | Ok l -> l
   | Error cycle ->
     die "dependency cycle detected:\n   %s"
-      (List.map cycle ~f:(fun (path, _) -> Path.to_string path)
+      (List.map cycle ~f:(fun rule ->
+         Path.to_string (Pset.choose rule.Internal_rule.targets))
        |> String.concat ~sep:"\n-> ")
 
 let all_lib_deps t targets =
   List.fold_left (rules_for_targets t targets) ~init:Pmap.empty
-    ~f:(fun acc (_, rule) ->
-      let lib_deps = Build_interpret.lib_deps rule.Rule.build in
+    ~f:(fun acc rule ->
+      let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in
       Pmap.merge acc lib_deps ~f:(fun _ a b ->
         match a, b with
         | None, None -> None
@@ -664,8 +694,8 @@ let all_lib_deps t targets =
         | Some a, Some b -> Some (Build.merge_lib_deps a b)))
 
 let all_lib_deps_by_context t targets =
-  List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc (_, rule) ->
-    let lib_deps = Build_interpret.lib_deps rule.Rule.build in
+  List.fold_left (rules_for_targets t targets) ~init:[] ~f:(fun acc rule ->
+    let lib_deps = Build_interpret.lib_deps rule.Internal_rule.build in
     Path.Map.fold lib_deps ~init:acc ~f:(fun ~key:path ~data:lib_deps acc ->
       match Path.extract_build_context path with
       | None -> acc
@@ -674,3 +704,80 @@ let all_lib_deps_by_context t targets =
   |> String_map.map ~f:(function
     | [] -> String_map.empty
     | x :: l -> List.fold_left l ~init:x ~f:Build.merge_lib_deps)
+
+module Rule = struct
+  module Id = Internal_rule.Id
+
+  type t =
+    { id      : Id.t
+    ; deps    : Path.Set.t
+    ; targets : Path.Set.t
+    ; action  : Action.t
+    }
+
+  let compare a b = Id.compare a.id b.id
+end
+
+module Rule_set = Set.Make(Rule)
+module Id_set = Set.Make(Rule.Id)
+
+let rules_for_files rules paths =
+  List.fold_left paths ~init:Rule_set.empty ~f:(fun acc path ->
+    match Pmap.find path rules with
+    | None -> acc
+    | Some rule -> Rule_set.add rule acc)
+  |> Rule_set.elements
+
+module Rule_closure =
+  Top_closure.Make(Rule.Id)
+    (struct
+      type graph = Rule.t Pmap.t
+      type t = Rule.t
+      let key (t : t) = t.id
+      let deps (t : t) (graph : graph) =
+        rules_for_files graph (Pset.elements t.deps)
+    end)
+
+let build_rules t targets =
+  let rules_seen = ref Id_set.empty in
+  let rules = ref [] in
+  let rec loop fn =
+    match Hashtbl.find t.files fn with
+    | None -> return ()
+    | Some (File_spec.T { rule = ir; _ }) ->
+      if Id_set.mem ir.id !rules_seen then
+        return ()
+      else begin
+        rules_seen := Id_set.add ir.id !rules_seen;
+        let rule =
+          wait_for_deps t ir.rule_deps ~targeting:fn
+          >>= fun () ->
+          let action, dyn_deps = Build_exec.exec t ir.build () in
+          return
+            { Rule.
+              id      = ir.id
+            ; deps    = Pset.union ir.static_deps dyn_deps
+            ; targets = ir.targets
+            ; action  = action
+            }
+        in
+        rules := rule :: !rules;
+        rule >>= fun rule ->
+        Future.all_unit (List.map (Pset.elements rule.deps) ~f:loop)
+      end
+  in
+  Future.all_unit (List.map targets ~f:loop)
+  >>= fun () ->
+  Future.all !rules
+  >>| fun rules ->
+  let rules =
+    List.fold_left rules ~init:Pmap.empty ~f:(fun acc (r : Rule.t) ->
+      Pset.fold r.targets ~init:acc ~f:(fun fn acc ->
+        Pmap.add acc ~key:fn ~data:r))
+  in
+  match Rule_closure.top_closure rules (rules_for_files rules targets) with
+  | Ok l -> l
+  | Error cycle ->
+    die "dependency cycle detected:\n   %s"
+      (List.map cycle ~f:(fun rule -> Path.to_string (Pset.choose rule.Rule.targets))
+       |> String.concat ~sep:"\n-> ")

src/build_system.mli

@@ -36,3 +36,22 @@ val all_lib_deps_by_context : t -> Path.t list -> Build.lib_deps String_map.t
 
 (** List of all buildable targets *)
 val all_targets : t -> Path.t list
+
+(** A fully built rule *)
+module Rule : sig
+  module Id : sig
+    type t
+    val to_int : t -> int
+    val compare : t -> t -> int
+  end
+
+  type t =
+    { id      : Id.t
+    ; deps    : Path.Set.t
+    ; targets : Path.Set.t
+    ; action  : Action.t
+    }
+end
+
+(** Build and the rules needed to build these targets *)
+val build_rules : t -> Path.t list -> Rule.t list Future.t