Merge pull request #1688 from rgrinberg/split-commands-dune

Split dune commands to separate modules

bin/common.ml

@@ -1,5 +1,10 @@
 open Stdune
-open Dune
+
+module Config = Dune.Config
+module Colors = Dune.Colors
+module Clflags = Dune.Clflags
+module Package = Dune.Package
+
 module Term = Cmdliner.Term
 module Manpage = Cmdliner.Manpage
 module Let_syntax = Term
@@ -12,7 +17,7 @@ type t =
   ; workspace_file        : Arg.Path.t option
   ; root                  : string
   ; target_prefix         : string
-  ; only_packages         : Package.Name.Set.t option
+  ; only_packages         : Dune.Package.Name.Set.t option
   ; capture_outputs       : bool
   ; x                     : string option
   ; diff_command          : string option
@@ -23,7 +28,7 @@ type t =
   ; no_print_directory    : bool
   ; (* Original arguments for the external-lib-deps hint *)
     orig_args             : string list
-  ; config                : Config.t
+  ; config                : Dune.Config.t
   ; default_target        : string
   (* For build & runtest only *)
   ; watch : bool
@@ -54,7 +59,7 @@ let set_common_other c ~targets =
       ; c.orig_args
       ; targets
       ];
-  Option.iter ~f:Stats.enable c.stats_trace_file
+  Option.iter ~f:Dune.Stats.enable c.stats_trace_file
 
 let set_common c ~targets =
   set_dirs c;
@@ -92,10 +97,10 @@ let term =
     let arg =
       Arg.conv
         ((fun s ->
-           Result.map_error (Config.Concurrency.of_string s)
+           Result.map_error (Dune.Config.Concurrency.of_string s)
              ~f:(fun s -> `Msg s)),
          fun pp x ->
-           Format.pp_print_string pp (Config.Concurrency.to_string x))
+           Format.pp_print_string pp (Dune.Config.Concurrency.to_string x))
     in
     Arg.(value
          & opt (some arg) None
@@ -400,3 +405,8 @@ let term =
 let term =
   let%map t, orig_args = Term.with_used_args term in
   { t with orig_args }
+
+let context_arg ~doc =
+  Arg.(value
+       & opt string "default"
+       & info ["context"] ~docv:"CONTEXT" ~doc)

bin/common.mli

@@ -1,5 +1,3 @@
-open Dune
-
 type t =
   { debug_dep_path        : bool
   ; debug_findlib         : bool
@@ -8,7 +6,7 @@ type t =
   ; workspace_file        : Arg.Path.t option
   ; root                  : string
   ; target_prefix         : string
-  ; only_packages         : Package.Name.Set.t option
+  ; only_packages         : Dune.Package.Name.Set.t option
   ; capture_outputs       : bool
   ; x                     : string option
   ; diff_command          : string option
@@ -19,7 +17,7 @@ type t =
   ; no_print_directory    : bool
   ; (* Original arguments for the external-lib-deps hint *)
     orig_args             : string list
-  ; config                : Config.t
+  ; config                : Dune.Config.t
   ; default_target        : string
   (* For build & runtest only *)
   ; watch : bool
@@ -42,3 +40,5 @@ val help_secs
 val footer : [> `Blocks of [> `P of string | `S of string ] list ]
 
 val term : t Cmdliner.Term.t
+
+val context_arg : doc:string -> string Cmdliner.Term.t

bin/compute.ml

@@ -0,0 +1,79 @@
+open Stdune
+open Import
+open Fiber.O
+
+let doc = "Compute internal function."
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P {|Run a registered memoize function with the given input and
+           print the output. |}
+  ; `P {|This should only be used for debugging dune.|}
+  ; `Blocks Common.help_secs
+  ]
+
+let info = Term.info "compute" ~doc ~man
+
+let term =
+  Term.ret @@
+  let%map common = Common.term
+  and fn =
+    Arg.(required
+         & pos 0 (some string) None
+         & info [] ~docv:"FUNCTION"
+             ~doc:"Compute $(docv) for a given input.")
+  and inp =
+    Arg.(value
+         & pos 1 (some string) None
+         & info [] ~docv:"INPUT"
+             ~doc:"Use $(docv) as the input to the function.")
+  in
+  Common.set_common common ~targets:[];
+  let log = Log.create common in
+  let action =
+    Scheduler.go ~log ~common (fun () ->
+      Import.Main.setup ~log common ~external_lib_deps_mode:true
+      >>= fun _setup ->
+      match fn, inp with
+      | "list", None ->
+        Fiber.return `List
+      | "list", Some _ ->
+        Fiber.return (`Error "'list' doesn't take an argument")
+      | "help", Some fn ->
+        Fiber.return (`Show_doc fn)
+      | fn, Some inp ->
+        let sexp =
+          Dune_lang.parse_string
+            ~fname:"<command-line>"
+            ~mode:Dune_lang.Parser.Mode.Single inp
+        in
+        Memo.call fn sexp >>| fun res ->
+        `Result res
+      | fn, None ->
+        Fiber.return (`Error (sprintf "argument missing for '%s'" fn))
+    )
+  in
+  match action with
+  | `Error msg ->
+    `Error (true, msg)
+  | `Result res ->
+    Format.printf "%a\n%!" Sexp.pp res;
+    `Ok ()
+  | `List ->
+    let fns = Memo.registered_functions () in
+    let longest = String.longest_map fns ~f:(fun info -> info.name) in
+    List.iter fns ~f:(fun { Memo.Function_info.name; doc } ->
+      Printf.printf "%-*s : %s\n" longest name doc);
+    flush stdout;
+    `Ok ()
+  | `Show_doc fn ->
+    let info = Memo.function_info fn in
+    Printf.printf "%s\n\
+                   %s\n\
+                   %s\n"
+      info.name
+      (String.make (String.length info.name) '=')
+      info.doc;
+    `Ok ()
+
+let command = term, info

bin/compute.mli

@@ -0,0 +1 @@
+val command : unit Cmdliner.Term.t * Cmdliner.Term.info

bin/exec.ml

@@ -0,0 +1,113 @@
+open Stdune
+open Import
+
+let doc =
+  "Execute a command in a similar environment as if installation was performed."
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P {|$(b,dune exec -- COMMAND) should behave in the same way as if you
+          do:|}
+  ; `Pre "  \\$ dune install\n\
+          \  \\$ COMMAND"
+  ; `P {|In particular if you run $(b,dune exec ocaml), you will have
+          access to the libraries defined in the workspace using your usual
+          directives ($(b,#require) for instance)|}
+  ; `P {|When a leading / is present in the command (absolute path), then the
+          path is interpreted as an absolute path|}
+  ; `P {|When a / is present at any other position (relative path), then the
+          path is interpreted as relative to the build context + current
+          working directory (or the value of $(b,--root) when ran outside of
+          the project root)|}
+  ; `Blocks Common.help_secs
+  ]
+
+let info = Term.info "exec" ~doc ~man
+
+let term =
+  let%map common = Common.term
+  and context =
+    Common.context_arg ~doc:{|Run the command in this build context.|}
+  and prog =
+    Arg.(required
+         & pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
+  and no_rebuild =
+    Arg.(value & flag
+         & info ["no-build"]
+             ~doc:"don't rebuild target before executing")
+  and args =
+    Arg.(value
+         & pos_right 0 string [] (Arg.info [] ~docv:"ARGS"))
+  in
+  Common.set_common common ~targets:[prog];
+  let log = Log.create common in
+  let setup =
+    Scheduler.go ~log ~common (fun () -> Import.Main.setup ~log common) in
+  let context = Import.Main.find_context_exn setup ~name:context in
+  let prog_where =
+    match Filename.analyze_program_name prog with
+    | Absolute ->
+      `This_abs (Path.of_string prog)
+    | In_path ->
+      `Search prog
+    | Relative_to_current_dir ->
+      let prog = Common.prefix_target common prog in
+      `This_rel (Path.relative context.build_dir prog) in
+  let targets = lazy (
+    (match prog_where with
+     | `Search p ->
+       [Path.relative (Config.local_install_bin_dir ~context:context.name) p]
+     | `This_rel p when Sys.win32 ->
+       [p; Path.extend_basename p ~suffix:Bin.exe]
+     | `This_rel p ->
+       [p]
+     | `This_abs p when Path.is_in_build_dir p ->
+       [p]
+     | `This_abs _ ->
+       [])
+    |> List.map ~f:(fun p -> Target.Path p)
+    |> Target.resolve_targets_mixed ~log common setup
+    |> List.concat_map ~f:(function
+      | Ok targets -> targets
+      | Error _ -> [])
+  ) in
+  let real_prog =
+    if not no_rebuild then begin
+      match Lazy.force targets with
+      | [] -> ()
+      | targets ->
+        Scheduler.go ~log ~common (fun () -> do_build setup targets);
+        Hooks.End_of_build.run ();
+    end;
+    match prog_where with
+    | `Search prog ->
+      let path = Config.local_install_bin_dir ~context:context.name :: context.path in
+      Bin.which prog ~path
+    | `This_rel prog
+    | `This_abs prog ->
+      if Path.exists prog then
+        Some prog
+      else if not Sys.win32 then
+        None
+      else
+        let prog = Path.extend_basename prog ~suffix:Bin.exe in
+        Option.some_if (Path.exists prog) prog
+  in
+  match real_prog, no_rebuild with
+  | None, true ->
+    begin match Lazy.force targets with
+    | [] ->
+      die "@{<Error>Error@}: Program %S not found!" prog
+    | _::_ ->
+      die "@{<Error>Error@}: Program %S isn't built yet \
+           you need to build it first or remove the \
+           --no-build option." prog
+    end
+  | None, false ->
+    die "@{<Error>Error@}: Program %S not found!" prog
+  | Some real_prog, _ ->
+    let real_prog = Path.to_string real_prog     in
+    let argv      = prog :: args in
+    restore_cwd_and_execve common real_prog argv context.env
+
+let command = term, info

bin/exec.mli

@@ -0,0 +1 @@
+val command : unit Cmdliner.Term.t * Cmdliner.Term.info