From f548fc970b91e55eb496041793670e0a7d527ed4 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 17 Dec 2018 22:24:31 +0100 Subject: [PATCH] Split dune commands to separate modules Signed-off-by: Rudi Grinberg --- bin/common.ml | 22 +- bin/common.mli | 8 +- bin/compute.ml | 79 +++ bin/compute.mli | 1 + bin/exec.ml | 113 ++++ bin/exec.mli | 1 + bin/external_lib_deps.ml | 146 +++++ bin/external_lib_deps.mli | 1 + bin/fmt_cmd.ml | 40 ++ bin/fmt_cmd.mli | 1 + bin/help.ml | 107 ++++ bin/help.mli | 1 + bin/import.ml | 92 +++ bin/install_uninstall.ml | 250 ++++++++ bin/installed_libraries.ml | 57 ++ bin/installed_libraries.mli | 1 + bin/main.ml | 1131 +---------------------------------- bin/print_rules.ml | 115 ++++ bin/print_rules.mli | 2 + bin/printenv.ml | 57 ++ bin/printenv.mli | 1 + bin/subst.ml | 74 +++ bin/subst.mli | 1 + bin/util.ml | 9 +- bin/utop.ml | 50 ++ bin/utop.mli | 1 + 26 files changed, 1230 insertions(+), 1131 deletions(-) create mode 100644 bin/compute.ml create mode 100644 bin/compute.mli create mode 100644 bin/exec.ml create mode 100644 bin/exec.mli create mode 100644 bin/external_lib_deps.ml create mode 100644 bin/external_lib_deps.mli create mode 100644 bin/fmt_cmd.ml create mode 100644 bin/fmt_cmd.mli create mode 100644 bin/help.ml create mode 100644 bin/help.mli create mode 100644 bin/import.ml create mode 100644 bin/install_uninstall.ml create mode 100644 bin/installed_libraries.ml create mode 100644 bin/installed_libraries.mli create mode 100644 bin/print_rules.ml create mode 100644 bin/print_rules.mli create mode 100644 bin/printenv.ml create mode 100644 bin/printenv.mli create mode 100644 bin/subst.ml create mode 100644 bin/subst.mli create mode 100644 bin/utop.ml create mode 100644 bin/utop.mli diff --git a/bin/common.ml b/bin/common.ml index 035b92606f3..5f767b92a3c 100644 --- a/bin/common.ml +++ b/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) diff --git a/bin/common.mli b/bin/common.mli index 7995d8cc4f7..825da95bffa 100644 --- a/bin/common.mli +++ b/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 diff --git a/bin/compute.ml b/bin/compute.ml new file mode 100644 index 00000000000..3b37512e301 --- /dev/null +++ b/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:"" + ~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 diff --git a/bin/compute.mli b/bin/compute.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/compute.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/exec.ml b/bin/exec.ml new file mode 100644 index 00000000000..5b548f48741 --- /dev/null +++ b/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@}: Program %S not found!" prog + | _::_ -> + die "@{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@}: 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 diff --git a/bin/exec.mli b/bin/exec.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/exec.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/external_lib_deps.ml b/bin/external_lib_deps.ml new file mode 100644 index 00000000000..caf2ddb7ed2 --- /dev/null +++ b/bin/external_lib_deps.ml @@ -0,0 +1,146 @@ +open Stdune +open Import +open Fiber.O + +let format_external_libs libs = + Lib_name.Map.to_list libs + |> List.map ~f:(fun (name, kind) -> + match (kind : Lib_deps_info.Kind.t) with + | Optional -> sprintf "- %s (optional)" (Lib_name.to_string name) + | Required -> sprintf "- %s" (Lib_name.to_string name)) + |> String.concat ~sep:"\n" + +let doc = "Print out external libraries needed to build the given targets." + +let man = + [ `S "DESCRIPTION" + ; `P {|Print out the external libraries needed to build the given targets.|} + ; `P {|The output of $(b,jbuild external-lib-deps @install) should be included + in what is written in your $(i,.opam) file.|} + ; `Blocks Common.help_secs + ] + +let info = Term.info "external-lib-deps" ~doc ~man + +let run ~lib_deps ~by_dir ~setup ~only_missing ~sexp = + String.Map.foldi lib_deps ~init:false + ~f:(fun context_name lib_deps_by_dir acc -> + let lib_deps = + Path.Map.values lib_deps_by_dir + |> List.fold_left ~init:Lib_name.Map.empty ~f:Lib_deps_info.merge + in + let internals = + String.Map.find_exn setup.Import.Main.scontexts context_name + |> Super_context.internal_lib_names + in + let is_external name _kind = not (Lib_name.Set.mem internals name) in + let externals = + Lib_name.Map.filteri lib_deps ~f:is_external + in + if only_missing then begin + if by_dir || sexp then + die "@{Error@}: --only-missing cannot be used with \ + --unstable-by-dir or --sexp"; + let context = + List.find_exn setup.contexts ~f:(fun c -> c.name = context_name) + in + let missing = + Lib_name.Map.filteri externals ~f:(fun name _ -> + not (Findlib.available context.findlib name)) + in + if Lib_name.Map.is_empty missing then + acc + else if Lib_name.Map.for_alli missing + ~f:(fun _ kind -> kind = Lib_deps_info.Kind.Optional) + then begin + Format.eprintf + "@{Error@}: The following libraries are missing \ + in the %s context:\n\ + %s@." + context_name + (format_external_libs missing); + false + end else begin + Format.eprintf + "@{Error@}: The following libraries are missing \ + in the %s context:\n\ + %s\n\ + Hint: try: opam install %s@." + context_name + (format_external_libs missing) + (Lib_name.Map.to_list missing + |> List.filter_map ~f:(fun (name, kind) -> + match (kind : Lib_deps_info.Kind.t) with + | Optional -> None + | Required -> Some (Lib_name.package_name name)) + |> Package.Name.Set.of_list + |> Package.Name.Set.to_list + |> List.map ~f:Package.Name.to_string + |> String.concat ~sep:" "); + true + end + end else if sexp then begin + if not by_dir then + die "@{Error@}: --sexp requires --unstable-by-dir"; + let lib_deps_by_dir = + lib_deps_by_dir + |> Path.Map.map ~f:(Lib_name.Map.filteri ~f:is_external) + |> Path.Map.filter ~f:(fun m -> not (Lib_name.Map.is_empty m)) + in + let sexp = + Map.to_sexp + Path.Map.to_list + (fun p -> Atom (Path.to_string p)) + Lib_deps_info.to_sexp + lib_deps_by_dir + in + Format.printf "%a@." Sexp.pp (List [Atom context_name; sexp]); + acc + end else begin + if by_dir then + die "@{Error@}: --unstable-by-dir cannot be used without --sexp"; + Printf.printf + "These are the external library dependencies in the %s context:\n\ + %s\n%!" + context_name + (format_external_libs externals); + acc + end) + +let term = + let%map common = Common.term + and only_missing = + Arg.(value + & flag + & info ["missing"] + ~doc:{|Only print out missing dependencies|}) + and targets = + Arg.(non_empty + & pos_all string [] + & Arg.info [] ~docv:"TARGET") + and by_dir = + Arg.(value + & flag + & info ["unstable-by-dir"] + ~doc:{|Print dependencies per directory + (this feature is currently unstable)|}) + and sexp = + Arg.(value + & flag + & info ["sexp"] + ~doc:{|Produce a s-expression output|}) + in + Common.set_common common ~targets:[]; + let log = Log.create common in + let setup, lib_deps = + Scheduler.go ~log ~common (fun () -> + Import.Main.setup ~log common ~external_lib_deps_mode:true >>= fun setup -> + let targets = Target.resolve_targets_exn ~log common setup targets in + let request = Target.request setup targets in + Build_system.all_lib_deps setup.build_system ~request >>| fun deps -> + (setup, deps)) + in + let failure = run ~by_dir ~setup ~lib_deps ~sexp ~only_missing in + if failure then raise Dune.Import.Already_reported + +let command = term, info diff --git a/bin/external_lib_deps.mli b/bin/external_lib_deps.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/external_lib_deps.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/fmt_cmd.ml b/bin/fmt_cmd.ml new file mode 100644 index 00000000000..15931a994bc --- /dev/null +++ b/bin/fmt_cmd.ml @@ -0,0 +1,40 @@ +open Import + +module Dune_fmt = Dune.Dune_fmt + +let doc = "Format dune files" + +let man = + [ `S "DESCRIPTION" + ; `P {|$(b,dune unstable-fmt) reads a dune file and outputs a formatted + version. This feature is unstable, and its interface or behaviour + might change. + |} + ] + +let info = Term.info "unstable-fmt" ~doc ~man + +let term = + let%map path_opt = + let docv = "FILE" in + let doc = "Path to the dune file to parse." in + Arg.(value & pos 0 (some path) None & info [] ~docv ~doc) + and inplace = + let doc = "Modify the file in place" in + Arg.(value & flag & info ["inplace"] ~doc) + in + let (input, output) = + match path_opt, inplace with + | None, false -> + (None, None) + | Some path, true -> + let path = Arg.Path.path path in + (Some path, Some path) + | Some path, false -> + (Some (Arg.Path.path path), None) + | None, true -> + die "--inplace requires a file name" + in + Dune_fmt.format_file ~input ~output + +let command = term, info diff --git a/bin/fmt_cmd.mli b/bin/fmt_cmd.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/fmt_cmd.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/help.ml b/bin/help.ml new file mode 100644 index 00000000000..55a2e82beeb --- /dev/null +++ b/bin/help.ml @@ -0,0 +1,107 @@ +open Stdune +open Import + +let config = + ("dune-config", 5, "", "Dune", "Dune manual"), + [ `S Manpage.s_synopsis + ; `Pre "~/.config/dune/config" + ; `S Manpage.s_description + ; `P {|Unless $(b,--no-config) or $(b,-p) is passed, Dune will read a + configuration file from the user home directory. This file is used + to control various aspects of the behavior of Dune.|} + ; `P {|The configuration file is normally $(b,~/.config/dune/config) on + Unix systems and $(b,Local Settings/dune/config) in the User home + directory on Windows. However, it is possible to specify an + alternative configuration file with the $(b,--config-file) option.|} + ; `P {|The first line of the file must be of the form (lang dune X.Y) + where X.Y is the version of the dune language used in the file.|} + ; `P {|The rest of the file must be written in S-expression syntax and be + composed of a list of stanzas. The following sections describe + the stanzas available.|} + ; `S "DISPLAY MODES" + ; `P {|Syntax: $(b,\(display MODE\))|} + ; `P {|This stanza controls how Dune reports what it is doing to the user. + This parameter can also be set from the command line via $(b,--display MODE). + The following display modes are available:|} + ; `Blocks + (List.map ~f:(fun (x, desc) -> `I (sprintf "$(b,%s)" x, desc)) + [ "progress", + {|This is the default, Dune shows and update a + status line as build goals are being completed.|} + ; "quiet", + {|Only display errors.|} + ; "short", + {|Print one line per command being executed, with the + binary name on the left and the reason it is being executed for + on the right.|} + ; "verbose", + {|Print the full command lines of programs being + executed by Dune, with some colors to help differentiate + programs.|} + ]) + ; `P {|Note that when the selected display mode is $(b,progress) and the + output is not a terminal then the $(b,quiet) mode is selected + instead. This rule doesn't apply when running Dune inside Emacs. + Dune detects whether it is executed from inside Emacs or not by + looking at the environment variable $(b,INSIDE_EMACS) that is set by + Emacs. If you want the same behavior with another editor, you can set + this variable. If your editor already sets another variable, + please open a ticket on the ocaml/dune github project so that we can + add support for it.|} + ; `S "JOBS" + ; `P {|Syntax: $(b,\(jobs NUMBER\))|} + ; `P {|Set the maximum number of jobs Dune might run in parallel. + This can also be set from the command line via $(b,-j NUMBER).|} + ; `P {|The default for this value is 4.|} + ; Common.footer + ] + +type what = + | Man of Manpage.t + | List_topics + +let commands = + [ "config", Man config + ; "topics", List_topics + ] + +let doc = "Additional Dune help" + +let man = + [ `S "DESCRIPTION" + ; `P {|$(b,dune help TOPIC) provides additional help on the given topic. + The following topics are available:|} + ; `Blocks (List.concat_map commands ~f:(fun (s, what) -> + match what with + | List_topics -> [] + | Man ((title, _, _, _, _), _) -> [`I (sprintf "$(b,%s)" s, title)])) + ; Common.footer + ] + +let info = Term.info "help" ~doc ~man + +let term = + Term.ret @@ + let%map man_format = Arg.man_format + and what = + Arg.(value + & pos 0 (some (enum commands)) None + & info [] ~docv:"TOPIC") + in + match what with + | None -> + `Help (man_format, Some "help") + | Some (Man man_page) -> + Format.printf "%a@?" (Manpage.print man_format) man_page; + `Ok () + | Some List_topics -> + List.filter_map commands ~f:(fun (s, what) -> + match what with + | List_topics -> None + | _ -> Some s) + |> List.sort ~compare:String.compare + |> String.concat ~sep:"\n" + |> print_endline; + `Ok () + +let command = term, info diff --git a/bin/help.mli b/bin/help.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/help.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/import.ml b/bin/import.ml new file mode 100644 index 00000000000..98d0127c7ec --- /dev/null +++ b/bin/import.ml @@ -0,0 +1,92 @@ +open Stdune +open Dune + +(* Things in src/ don't depend on cmdliner to speed up the + bootstrap, so we set this reference here *) +let () = Import.suggest_function := Cmdliner_suggest.value + +module Term = Cmdliner.Term +module Manpage = Cmdliner.Manpage +module Let_syntax = Cmdliner.Term + +module Super_context = Dune.Super_context +module Context = Dune.Context +module Config = Dune.Config +module Lib_name = Dune.Lib_name +module Lib_deps_info = Dune.Lib_deps_info +module Build_system = Dune.Build_system +module Findlib = Dune.Findlib +module Package = Dune.Package +module Dune_package = Dune.Dune_package +module Utils = Dune.Utils +module Hooks = Dune.Hooks +module Build = Dune.Build +module Action = Dune.Action +module Deps = Dune.Deps +module Action_to_sh = Dune.Action_to_sh +module Path_dune_lang = Dune.Path_dune_lang +module Install = Dune.Install +module Watermarks = Dune.Watermarks +module Promotion = Dune.Promotion +module Colors = Dune.Colors +module Report_error = Dune.Report_error +module Dune_project = Dune.Dune_project +module Workspace = Dune.Workspace + +let die = Dune.Import.die +let hint = Dune.Import.hint + +module Main = struct + include Dune.Main + + let setup ~log ?external_lib_deps_mode (common : Common.t) = + setup + ~log + ?workspace_file:(Option.map ~f:Arg.Path.path common.workspace_file) + ?only_packages:common.only_packages + ?external_lib_deps_mode + ?x:common.x + ?profile:common.profile + ~ignore_promoted_rules:common.ignore_promoted_rules + ~capture_outputs:common.capture_outputs + () +end + +module Log = struct + include Dune.Log + + let create (common : Common.t) = + Log.create ~display:common.config.display () +end + +module Scheduler = struct + include Dune.Scheduler + open Fiber.O + + let go ?log ~(common : Common.t) f = + let f () = + Main.set_concurrency ?log common.config >>= f + in + Scheduler.go ?log ~config:common.config f + + let poll ?log ~(common : Common.t) ~once ~finally () = + let once () = + Main.set_concurrency ?log common.config + >>= fun () -> + once () + in + Scheduler.poll ?log ~config:common.config ~once ~finally () +end + +let restore_cwd_and_execve (common : Common.t) prog argv env = + let prog = + if Filename.is_relative prog then + Filename.concat common.root prog + else + prog + in + Proc.restore_cwd_and_execve prog argv ~env + +let do_build (setup : Main.setup) targets = + Build_system.do_build setup.build_system + ~request:(Target.request setup targets) diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml new file mode 100644 index 00000000000..030f1af828a --- /dev/null +++ b/bin/install_uninstall.ml @@ -0,0 +1,250 @@ +open Stdune +open Import +open Fiber.O + +let interpret_destdir ~destdir path = + match destdir with + | None -> + path + | Some prefix -> + Path.append_local + (Path.of_string prefix) + (Path.local_part path) + +let get_dirs context ~prefix_from_command_line ~libdir_from_command_line = + match prefix_from_command_line with + | Some p -> + let prefix = Path.of_string p in + let dir = Option.value ~default:"lib" libdir_from_command_line in + Fiber.return (prefix, Some (Path.relative prefix dir)) + | None -> + Context.install_prefix context >>= fun prefix -> + let libdir = + match libdir_from_command_line with + | None -> Context.install_ocaml_libdir context + | Some l -> Fiber.return (Some (Path.relative prefix l)) + in + libdir >>| fun libdir -> + (prefix, libdir) + +let resolve_package_install setup pkg = + match Import.Main.package_install_file setup pkg with + | Ok path -> path + | Error () -> + let pkg = Package.Name.to_string pkg in + die "Unknown package %s!%s" pkg + (hint pkg + (Package.Name.Map.keys setup.packages + |> List.map ~f:Package.Name.to_string)) + +let print_unix_error f = + try + f () + with Unix.Unix_error (e, _, _) -> + Format.eprintf "@{Error@}: %s@." + (Unix.error_message e) + + +let set_executable_bits x = x lor 0o111 +let clear_executable_bits x = x land (lnot 0o111) + +(** Operations that act on real files or just pretend to (for --dry-run) *) +module type FILE_OPERATIONS = sig + val copy_file : src:Path.t -> dst:Path.t -> executable:bool -> unit + val mkdir_p : Path.t -> unit + val remove_if_exists : Path.t -> unit + val remove_dir_if_empty : Path.t -> unit +end + +module File_ops_dry_run : FILE_OPERATIONS = struct + let copy_file ~src ~dst ~executable = + Format.printf + "Copying %a to %a (executable: %b)\n" + Path.pp src + Path.pp dst + executable + + let mkdir_p path = + Format.printf + "Creating directory %a\n" + Path.pp + path + + let remove_if_exists path = + Format.printf + "Removing (if it exists) %a\n" + Path.pp + path + + let remove_dir_if_empty path = + Format.printf + "Removing directory (if empty) %a\n" + Path.pp + path +end + +module File_ops_real : FILE_OPERATIONS = struct + let copy_file ~src ~dst ~executable = + let chmod = + if executable then + set_executable_bits + else + clear_executable_bits + in + Io.copy_file ~src ~dst ~chmod () + + let remove_if_exists dst = + if Path.exists dst then begin + Printf.eprintf + "Deleting %s\n%!" + (Path.to_string_maybe_quoted dst); + print_unix_error (fun () -> Path.unlink dst) + end + + let remove_dir_if_empty dir = + if Path.exists dir then + match Path.readdir_unsorted dir with + | [] -> + Printf.eprintf "Deleting empty directory %s\n%!" + (Path.to_string_maybe_quoted dir); + print_unix_error (fun () -> Path.rmdir dir) + | _ -> () + + let mkdir_p = Path.mkdir_p +end + +let file_operations ~dry_run : (module FILE_OPERATIONS) = + if dry_run then + (module File_ops_dry_run) + else + (module File_ops_real) + +let install_uninstall ~what = + let doc = + sprintf "%s packages." (String.capitalize what) + in + let name_ = Arg.info [] ~docv:"PACKAGE" in + let term = + let%map common = Common.term + and prefix_from_command_line = + Arg.(value + & opt (some string) None + & info ["prefix"] + ~docv:"PREFIX" + ~doc:"Directory where files are copied. For instance binaries \ + are copied into $(i,\\$prefix/bin), library files into \ + $(i,\\$prefix/lib), etc... It defaults to the current opam \ + prefix if opam is available and configured, otherwise it uses \ + the same prefix as the ocaml compiler.") + and libdir_from_command_line = + Arg.(value + & opt (some string) None + & info ["libdir"] + ~docv:"PATH" + ~doc:"Directory where library files are copied, relative to \ + $(b,prefix) or absolute. If $(b,--prefix) \ + is specified the default is $(i,\\$prefix/lib), otherwise \ + it is the output of $(b,ocamlfind printconf destdir)" + ) + and destdir = + Arg.(value + & opt (some string) None + & info ["destdir"] + ~env:(env_var "DESTDIR") + ~docv:"PATH" + ~doc:"When passed, this directory is prepended to all \ + installed paths." + ) + and dry_run = + Arg.(value + & flag + & info ["dry-run"] + ~doc:"Only display the file operations that would be performed." + ) + and pkgs = + Arg.(value & pos_all package_name [] name_) + in + Common.set_common common ~targets:[]; + let log = Log.create common in + Scheduler.go ~log ~common (fun () -> + Import.Main.setup ~log common >>= fun setup -> + let pkgs = + match pkgs with + | [] -> Package.Name.Map.keys setup.packages + | l -> l + in + let install_files, missing_install_files = + List.concat_map pkgs ~f:(fun pkg -> + let fn = resolve_package_install setup pkg in + List.map setup.contexts ~f:(fun ctx -> + let fn = Path.append ctx.Context.build_dir fn in + if Path.exists fn then + Left (ctx, (pkg, fn)) + else + Right fn)) + |> List.partition_map ~f:(fun x -> x) + in + if missing_install_files <> [] then begin + die "The following .install are missing:\n\ + %s\n\ + You need to run: dune build @install" + (String.concat ~sep:"\n" + (List.map missing_install_files + ~f:(fun p -> sprintf "- %s" (Path.to_string p)))) + end; + (match + setup.contexts, prefix_from_command_line, libdir_from_command_line + with + | _ :: _ :: _, Some _, _ | _ :: _ :: _, _, Some _ -> + die "Cannot specify --prefix or --libdir when installing \ + into multiple contexts!" + | _ -> ()); + let module CMap = Map.Make(Context) in + let install_files_by_context = + CMap.of_list_multi install_files |> CMap.to_list + in + let (module Ops) = file_operations ~dry_run in + Fiber.parallel_iter install_files_by_context + ~f:(fun (context, install_files) -> + get_dirs context ~prefix_from_command_line ~libdir_from_command_line + >>| fun (prefix, libdir) -> + List.iter install_files ~f:(fun (package, path) -> + let entries = Install.load_install_file path in + let paths = + Install.Section.Paths.make + ~package + ~destdir:prefix + ?libdir + () + in + let files_deleted_in = ref Path.Set.empty in + List.iter entries ~f:(fun { Install.Entry. src; dst; section } -> + let dst = + dst + |> Option.value ~default:(Path.basename src) + |> Install.Section.Paths.install_path paths section + |> interpret_destdir ~destdir + in + let dir = Path.parent_exn dst in + if what = "install" then begin + Printf.eprintf "Installing %s\n%!" + (Path.to_string_maybe_quoted dst); + Ops.mkdir_p dir; + let executable = + Install.Section.should_set_executable_bit section + in + Ops.copy_file ~src ~dst ~executable + end else begin + Ops.remove_if_exists dst; + files_deleted_in := Path.Set.add !files_deleted_in dir; + end; + Path.Set.to_list !files_deleted_in + (* This [List.rev] is to ensure we process children + directories before their parents *) + |> List.rev + |> List.iter ~f:Ops.remove_dir_if_empty)))) + in + (term, Cmdliner.Term.info what ~doc ~man:Common.help_secs) + +let install = install_uninstall ~what:"install" +let uninstall = install_uninstall ~what:"uninstall" diff --git a/bin/installed_libraries.ml b/bin/installed_libraries.ml new file mode 100644 index 00000000000..dc5dd536052 --- /dev/null +++ b/bin/installed_libraries.ml @@ -0,0 +1,57 @@ +open Stdune +open Import +open Fiber.O + +let doc = "Print out libraries installed on the system." + +let info = Term.info "installed-libraries" ~doc + +let term = + let%map common = Common.term + and na = + Arg.(value + & flag + & info ["na"; "not-available"] + ~doc:"List libraries that are not available and explain why") + in + Common.set_common common ~targets:[]; + let env = Import.Main.setup_env ~capture_outputs:common.capture_outputs in + Scheduler.go ~log:(Log.create common) ~common (fun () -> + Context.create ~env + { merlin_context = Some "default" + ; contexts = [Default { loc = Loc.of_pos __POS__ + ; targets = [Native] + ; profile = Config.default_build_profile + ; env = None + ; toolchain = None + }] + ; env = None + } + >>= fun ctxs -> + let ctx = List.hd ctxs in + let findlib = ctx.findlib in + if na then begin + let pkgs = Findlib.all_unavailable_packages findlib in + let longest = + String.longest_map pkgs ~f:(fun (n, _) -> Lib_name.to_string n) in + let ppf = Format.std_formatter in + List.iter pkgs ~f:(fun (n, r) -> + Format.fprintf ppf "%-*s -> %a@\n" longest (Lib_name.to_string n) + Findlib.Unavailable_reason.pp r); + Format.pp_print_flush ppf (); + Fiber.return () + end else begin + let pkgs = Findlib.all_packages findlib in + let max_len = + String.longest_map pkgs ~f:(fun (n : _ Dune_package.Lib.t) -> + Lib_name.to_string (Dune_package.Lib.name n)) in + List.iter pkgs ~f:(fun (pkg : _ Dune_package.Lib.t) -> + let ver = + Option.value (Dune_package.Lib.version pkg) ~default:"n/a" + in + Printf.printf "%-*s (version: %s)\n" max_len + (Lib_name.to_string (Dune_package.Lib.name pkg)) ver); + Fiber.return () + end) + +let command = term, info diff --git a/bin/installed_libraries.mli b/bin/installed_libraries.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/installed_libraries.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/main.ml b/bin/main.ml index 961c326e7cf..113aee339da 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,132 +1,7 @@ open! Stdune -open Dune open Import -module Term = Cmdliner.Term -module Manpage = Cmdliner.Manpage open Fiber.O -(* Things in src/ don't depend on cmdliner to speed up the - bootstrap, so we set this reference here *) -let () = suggest_function := Cmdliner_suggest.value - -module Let_syntax = Cmdliner.Term - -let restore_cwd_and_execve (common : Common.t) prog argv env = - let prog = - if Filename.is_relative prog then - Filename.concat common.root prog - else - prog - in - Proc.restore_cwd_and_execve prog argv ~env - -module Main = struct - include Dune.Main - - let setup ~log ?external_lib_deps_mode (common : Common.t) = - setup - ~log - ?workspace_file:(Option.map ~f:Arg.Path.path common.workspace_file) - ?only_packages:common.only_packages - ?external_lib_deps_mode - ?x:common.x - ?profile:common.profile - ~ignore_promoted_rules:common.ignore_promoted_rules - ~capture_outputs:common.capture_outputs - () -end - -module Log = struct - include Dune.Log - - let create (common : Common.t) = - Log.create ~display:common.config.display () -end - -module Scheduler = struct - include Dune.Scheduler - - let go ?log ~(common : Common.t) f = - let f () = - Main.set_concurrency ?log common.config >>= f - in - Scheduler.go ?log ~config:common.config f - - let poll ?log ~(common : Common.t) ~once ~finally () = - let once () = - Main.set_concurrency ?log common.config - >>= fun () -> - once () - in - Scheduler.poll ?log ~config:common.config ~once ~finally () -end - -let do_build (setup : Main.setup) targets = - Build_system.do_build setup.build_system - ~request:(Target.request setup targets) - -let installed_libraries = - let doc = "Print out libraries installed on the system." in - let term = - let%map common = Common.term - and na = - Arg.(value - & flag - & info ["na"; "not-available"] - ~doc:"List libraries that are not available and explain why") - in - Common.set_common common ~targets:[]; - let env = Main.setup_env ~capture_outputs:common.capture_outputs in - Scheduler.go ~log:(Log.create common) ~common (fun () -> - Context.create ~env - { merlin_context = Some "default" - ; contexts = [Default { loc = Loc.of_pos __POS__ - ; targets = [Native] - ; profile = Config.default_build_profile - ; env = None - ; toolchain = None - }] - ; env = None - } - >>= fun ctxs -> - let ctx = List.hd ctxs in - let findlib = ctx.findlib in - if na then begin - let pkgs = Findlib.all_unavailable_packages findlib in - let longest = - String.longest_map pkgs ~f:(fun (n, _) -> Lib_name.to_string n) in - let ppf = Format.std_formatter in - List.iter pkgs ~f:(fun (n, r) -> - Format.fprintf ppf "%-*s -> %a@\n" longest (Lib_name.to_string n) - Findlib.Unavailable_reason.pp r); - Format.pp_print_flush ppf (); - Fiber.return () - end else begin - let pkgs = Findlib.all_packages findlib in - let max_len = - String.longest_map pkgs ~f:(fun (n : _ Dune_package.Lib.t) -> - Lib_name.to_string (Dune_package.Lib.name n)) in - List.iter pkgs ~f:(fun (pkg : _ Dune_package.Lib.t) -> - let ver = - Option.value (Dune_package.Lib.version pkg) ~default:"n/a" - in - Printf.printf "%-*s (version: %s)\n" max_len - (Lib_name.to_string (Dune_package.Lib.name pkg)) ver); - Fiber.return () - end) - in - (term, Term.info "installed-libraries" ~doc) - -let resolve_package_install setup pkg = - match Main.package_install_file setup pkg with - | Ok path -> path - | Error () -> - let pkg = Package.Name.to_string pkg in - die "Unknown package %s!%s" pkg - (hint pkg - (Package.Name.Map.keys setup.packages - |> List.map ~f:Package.Name.to_string)) - let run_build_command ~log ~common ~targets = let once () = Main.setup ~log common @@ -215,794 +90,6 @@ let clean = in (term, Term.info "clean" ~doc ~man) -let format_external_libs libs = - Lib_name.Map.to_list libs - |> List.map ~f:(fun (name, kind) -> - match (kind : Lib_deps_info.Kind.t) with - | Optional -> sprintf "- %s (optional)" (Lib_name.to_string name) - | Required -> sprintf "- %s" (Lib_name.to_string name)) - |> String.concat ~sep:"\n" - -let external_lib_deps = - let doc = "Print out external libraries needed to build the given targets." in - let man = - [ `S "DESCRIPTION" - ; `P {|Print out the external libraries needed to build the given targets.|} - ; `P {|The output of $(b,jbuild external-lib-deps @install) should be included - in what is written in your $(i,.opam) file.|} - ; `Blocks Common.help_secs - ] - in - let term = - let%map common = Common.term - and only_missing = - Arg.(value - & flag - & info ["missing"] - ~doc:{|Only print out missing dependencies|}) - and targets = - Arg.(non_empty - & pos_all string [] - & Arg.info [] ~docv:"TARGET") - and by_dir = - Arg.(value - & flag - & info ["unstable-by-dir"] - ~doc:{|Print dependencies per directory - (this feature is currently unstable)|}) - and sexp = - Arg.(value - & flag - & info ["sexp"] - ~doc:{|Produce a s-expression output|}) - in - Common.set_common common ~targets:[]; - let log = Log.create common in - let setup, lib_deps = - Scheduler.go ~log ~common (fun () -> - Main.setup ~log common ~external_lib_deps_mode:true >>= fun setup -> - let targets = Target.resolve_targets_exn ~log common setup targets in - let request = Target.request setup targets in - Build_system.all_lib_deps setup.build_system ~request >>| fun deps -> - (setup, deps)) - in - let failure = - String.Map.foldi lib_deps ~init:false - ~f:(fun context_name lib_deps_by_dir acc -> - let lib_deps = - Path.Map.values lib_deps_by_dir - |> List.fold_left ~init:Lib_name.Map.empty ~f:Lib_deps_info.merge - in - let internals = - Super_context.internal_lib_names - (match String.Map.find setup.Main.scontexts context_name with - | None -> assert false - | Some x -> x) - in - let is_external name _kind = not (Lib_name.Set.mem internals name) in - let externals = - Lib_name.Map.filteri lib_deps ~f:is_external - in - if only_missing then begin - if by_dir || sexp then - die "@{Error@}: --only-missing cannot be used with \ - --unstable-by-dir or --sexp"; - let context = - List.find_exn setup.contexts ~f:(fun c -> c.name = context_name) - in - let missing = - Lib_name.Map.filteri externals ~f:(fun name _ -> - not (Findlib.available context.findlib name)) - in - if Lib_name.Map.is_empty missing then - acc - else if Lib_name.Map.for_alli missing - ~f:(fun _ kind -> kind = Lib_deps_info.Kind.Optional) - then begin - Format.eprintf - "@{Error@}: The following libraries are missing \ - in the %s context:\n\ - %s@." - context_name - (format_external_libs missing); - false - end else begin - Format.eprintf - "@{Error@}: The following libraries are missing \ - in the %s context:\n\ - %s\n\ - Hint: try: opam install %s@." - context_name - (format_external_libs missing) - (Lib_name.Map.to_list missing - |> List.filter_map ~f:(fun (name, kind) -> - match (kind : Lib_deps_info.Kind.t) with - | Optional -> None - | Required -> Some (Lib_name.package_name name)) - |> Package.Name.Set.of_list - |> Package.Name.Set.to_list - |> List.map ~f:Package.Name.to_string - |> String.concat ~sep:" "); - true - end - end else if sexp then begin - if not by_dir then - die "@{Error@}: --sexp requires --unstable-by-dir"; - let lib_deps_by_dir = - lib_deps_by_dir - |> Path.Map.map ~f:(Lib_name.Map.filteri ~f:is_external) - |> Path.Map.filter ~f:(fun m -> not (Lib_name.Map.is_empty m)) - in - let sexp = - Map.to_sexp - Path.Map.to_list - (fun p -> Atom (Path.to_string p)) - Lib_deps_info.to_sexp - lib_deps_by_dir - in - Format.printf "%a@." Sexp.pp (List [Atom context_name; sexp]); - acc - end else begin - if by_dir then - die "@{Error@}: --unstable-by-dir cannot be used without --sexp"; - Printf.printf - "These are the external library dependencies in the %s context:\n\ - %s\n%!" - context_name - (format_external_libs externals); - acc - end) - in - if failure then raise Already_reported - in - (term, Term.info "external-lib-deps" ~doc ~man) - -let compute = - let doc = "Compute internal function." in - 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 - ] - in - 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 () -> - 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:"" - ~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 () - in - (term, Term.info "compute" ~doc ~man) - -let rules = - let doc = "Dump internal rules." in - let man = - [ `S "DESCRIPTION" - ; `P {|Dump Dune internal rules for the given targets. - If no targets are given, dump all the internal rules.|} - ; `P {|By default the output is a list of S-expressions, - one S-expression per rule. Each S-expression is of the form:|} - ; `Pre " ((deps ())\n\ - \ (targets ())\n\ - \ (context )\n\ - \ (action ))" - ; `P {|$(b,) is the context is which the action is executed. - It is omitted if the action is independent from the context.|} - ; `P {|$(b,) is the action following the same syntax as user actions, - as described in the manual.|} - ; `Blocks Common.help_secs - ] - in - let term = - let%map common = Common.term - and out = - Arg.(value - & opt (some string) None - & info ["o"] ~docv:"FILE" - ~doc:"Output to a file instead of stdout.") - and recursive = - Arg.(value - & flag - & info ["r"; "recursive"] - ~doc:"Print all rules needed to build the transitive \ - dependencies of the given targets.") - and makefile_syntax = - Arg.(value - & flag - & info ["m"; "makefile"] - ~doc:"Output the rules in Makefile syntax.") - and targets = - Arg.(value - & pos_all string [] - & Arg.info [] ~docv:"TARGET") - in - let out = Option.map ~f:Path.of_string out in - Common.set_common common ~targets; - let log = Log.create common in - Scheduler.go ~log ~common (fun () -> - Main.setup ~log common ~external_lib_deps_mode:true - >>= fun setup -> - let request = - match targets with - | [] -> Build.paths (Build_system.all_targets setup.build_system) - | _ -> - Target.resolve_targets_exn ~log common setup targets - |> Target.request setup - in - Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules -> - let sexp_of_action action = - Action.for_shell action |> Action.For_shell.encode - in - let print oc = - let ppf = Format.formatter_of_out_channel oc in - Dune_lang.prepare_formatter ppf; - Format.pp_open_vbox ppf 0; - if makefile_syntax then begin - List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> - let action = - Action.For_shell.Progn - [ Mkdir (Path.to_string rule.dir) - ; Action.for_shell rule.action - ] - in - Format.fprintf ppf - "@[@{%a:%t@}@]@,\ - @<0>\t@{%a@}@,@," - (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p -> - Format.pp_print_string ppf (Path.to_string p))) - (Path.Set.to_list rule.targets) - (fun ppf -> - Path.Set.iter (Deps.paths rule.deps) ~f:(fun dep -> - Format.fprintf ppf "@ %s" (Path.to_string dep))) - Pp.pp - (Action_to_sh.pp action)) - end else begin - List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> - let sexp = - let paths ps = - Dune_lang.Encoder.list Path_dune_lang.encode (Path.Set.to_list ps) - in - Dune_lang.Encoder.record ( - List.concat - [ [ "deps" , Deps.to_sexp rule.deps - ; "targets", paths rule.targets ] - ; (match rule.context with - | None -> [] - | Some c -> ["context", - Dune_lang.atom_or_quoted_string c.name]) - ; [ "action" , sexp_of_action rule.action ] - ]) - in - Format.fprintf ppf "%a@," Dune_lang.pp_split_strings sexp) - end; - Format.pp_print_flush ppf (); - Fiber.return () - in - match out with - | None -> print stdout - | Some fn -> Io.with_file_out fn ~f:print) - in - (term, Term.info "rules" ~doc ~man) - -let interpret_destdir ~destdir path = - match destdir with - | None -> - path - | Some prefix -> - Path.append_local - (Path.of_string prefix) - (Path.local_part path) - -let get_dirs context ~prefix_from_command_line ~libdir_from_command_line = - match prefix_from_command_line with - | Some p -> - let prefix = Path.of_string p in - let dir = Option.value ~default:"lib" libdir_from_command_line in - Fiber.return (prefix, Some (Path.relative prefix dir)) - | None -> - Context.install_prefix context >>= fun prefix -> - let libdir = - match libdir_from_command_line with - | None -> Context.install_ocaml_libdir context - | Some l -> Fiber.return (Some (Path.relative prefix l)) - in - libdir >>| fun libdir -> - (prefix, libdir) - -let print_unix_error f = - try - f () - with Unix.Unix_error (e, _, _) -> - Format.eprintf "@{Error@}: %s@." - (Unix.error_message e) - -let set_executable_bits x = x lor 0o111 -let clear_executable_bits x = x land (lnot 0o111) - -(** Operations that act on real files or just pretend to (for --dry-run) *) -module type FILE_OPERATIONS = sig - val copy_file : src:Path.t -> dst:Path.t -> executable:bool -> unit - val mkdir_p : Path.t -> unit - val remove_if_exists : Path.t -> unit - val remove_dir_if_empty : Path.t -> unit -end - -module File_ops_dry_run : FILE_OPERATIONS = struct - let copy_file ~src ~dst ~executable = - Format.printf - "Copying %a to %a (executable: %b)\n" - Path.pp src - Path.pp dst - executable - - let mkdir_p path = - Format.printf - "Creating directory %a\n" - Path.pp - path - - let remove_if_exists path = - Format.printf - "Removing (if it exists) %a\n" - Path.pp - path - - let remove_dir_if_empty path = - Format.printf - "Removing directory (if empty) %a\n" - Path.pp - path -end - -module File_ops_real : FILE_OPERATIONS = struct - let copy_file ~src ~dst ~executable = - let chmod = - if executable then - set_executable_bits - else - clear_executable_bits - in - Io.copy_file ~src ~dst ~chmod () - - let remove_if_exists dst = - if Path.exists dst then begin - Printf.eprintf - "Deleting %s\n%!" - (Path.to_string_maybe_quoted dst); - print_unix_error (fun () -> Path.unlink dst) - end - - let remove_dir_if_empty dir = - if Path.exists dir then - match Path.readdir_unsorted dir with - | [] -> - Printf.eprintf "Deleting empty directory %s\n%!" - (Path.to_string_maybe_quoted dir); - print_unix_error (fun () -> Path.rmdir dir) - | _ -> () - - let mkdir_p = Path.mkdir_p -end - -let file_operations ~dry_run : (module FILE_OPERATIONS) = - if dry_run then - (module File_ops_dry_run) - else - (module File_ops_real) - -let install_uninstall ~what = - let doc = - sprintf "%s packages." (String.capitalize what) - in - let name_ = Arg.info [] ~docv:"PACKAGE" in - let term = - let%map common = Common.term - and prefix_from_command_line = - Arg.(value - & opt (some string) None - & info ["prefix"] - ~docv:"PREFIX" - ~doc:"Directory where files are copied. For instance binaries \ - are copied into $(i,\\$prefix/bin), library files into \ - $(i,\\$prefix/lib), etc... It defaults to the current opam \ - prefix if opam is available and configured, otherwise it uses \ - the same prefix as the ocaml compiler.") - and libdir_from_command_line = - Arg.(value - & opt (some string) None - & info ["libdir"] - ~docv:"PATH" - ~doc:"Directory where library files are copied, relative to \ - $(b,prefix) or absolute. If $(b,--prefix) \ - is specified the default is $(i,\\$prefix/lib), otherwise \ - it is the output of $(b,ocamlfind printconf destdir)" - ) - and destdir = - Arg.(value - & opt (some string) None - & info ["destdir"] - ~env:(env_var "DESTDIR") - ~docv:"PATH" - ~doc:"When passed, this directory is prepended to all \ - installed paths." - ) - and dry_run = - Arg.(value - & flag - & info ["dry-run"] - ~doc:"Only display the file operations that would be performed." - ) - and pkgs = - Arg.(value & pos_all package_name [] name_) - in - Common.set_common common ~targets:[]; - let log = Log.create common in - Scheduler.go ~log ~common (fun () -> - Main.setup ~log common >>= fun setup -> - let pkgs = - match pkgs with - | [] -> Package.Name.Map.keys setup.packages - | l -> l - in - let install_files, missing_install_files = - List.concat_map pkgs ~f:(fun pkg -> - let fn = resolve_package_install setup pkg in - List.map setup.contexts ~f:(fun ctx -> - let fn = Path.append ctx.Context.build_dir fn in - if Path.exists fn then - Left (ctx, (pkg, fn)) - else - Right fn)) - |> List.partition_map ~f:(fun x -> x) - in - if missing_install_files <> [] then begin - die "The following .install are missing:\n\ - %s\n\ - You need to run: dune build @install" - (String.concat ~sep:"\n" - (List.map missing_install_files - ~f:(fun p -> sprintf "- %s" (Path.to_string p)))) - end; - (match - setup.contexts, prefix_from_command_line, libdir_from_command_line - with - | _ :: _ :: _, Some _, _ | _ :: _ :: _, _, Some _ -> - die "Cannot specify --prefix or --libdir when installing \ - into multiple contexts!" - | _ -> ()); - let module CMap = Map.Make(Context) in - let install_files_by_context = - CMap.of_list_multi install_files |> CMap.to_list - in - let (module Ops) = file_operations ~dry_run in - Fiber.parallel_iter install_files_by_context - ~f:(fun (context, install_files) -> - get_dirs context ~prefix_from_command_line ~libdir_from_command_line - >>| fun (prefix, libdir) -> - List.iter install_files ~f:(fun (package, path) -> - let entries = Install.load_install_file path in - let paths = - Install.Section.Paths.make - ~package - ~destdir:prefix - ?libdir - () - in - let files_deleted_in = ref Path.Set.empty in - List.iter entries ~f:(fun { Install.Entry. src; dst; section } -> - let dst = - dst - |> Option.value ~default:(Path.basename src) - |> Install.Section.Paths.install_path paths section - |> interpret_destdir ~destdir - in - let dir = Path.parent_exn dst in - if what = "install" then begin - Printf.eprintf "Installing %s\n%!" - (Path.to_string_maybe_quoted dst); - Ops.mkdir_p dir; - let executable = - Install.Section.should_set_executable_bit section - in - Ops.copy_file ~src ~dst ~executable - end else begin - Ops.remove_if_exists dst; - files_deleted_in := Path.Set.add !files_deleted_in dir; - end; - Path.Set.to_list !files_deleted_in - (* This [List.rev] is to ensure we process children - directories before their parents *) - |> List.rev - |> List.iter ~f:Ops.remove_dir_if_empty)))) - in - (term, Term.info what ~doc ~man:Common.help_secs) - -let install = install_uninstall ~what:"install" -let uninstall = install_uninstall ~what:"uninstall" - -let context_arg ~doc = - Arg.(value - & opt string "default" - & info ["context"] ~docv:"CONTEXT" ~doc) - -let exec = - let doc = - "Execute a command in a similar environment as if installation was performed." - in - 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 - ] - in - let term = - let%map common = Common.term - and context = 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 () -> Main.setup ~log common) in - let context = 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@}: Program %S not found!" prog - | _::_ -> - die "@{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@}: 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 - in - (term, Term.info "exec" ~doc ~man) - -(** A string that is "%%VERSION%%" but not expanded by [dune subst] *) -let literal_version = - "%%" ^ "VERSION%%" - -let subst = - let doc = - "Substitute watermarks in source files." - in - let man = - let var name desc = - `Blocks [`Noblank; `P ("- $(b,%%" ^ name ^ "%%), " ^ desc) ] - in - let opam field = - var ("PKG_" ^ String.uppercase field) - ("contents of the $(b," ^ field ^ ":) field from the opam file") - in - [ `S "DESCRIPTION" - ; `P {|Substitute $(b,%%ID%%) strings in source files, in a similar fashion to - what topkg does in the default configuration.|} - ; `P ({|This command is only meant to be called when a user pins a package to - its development version. Especially it replaces $(b,|} ^ literal_version - ^{|) strings by the version obtained from the vcs. Currently only git is - supported and the version is obtained from the output of:|}) - ; `Pre {| \$ git describe --always --dirty|} - ; `P {|$(b,dune subst) substitutes the variables that topkg substitutes with - the defatult configuration:|} - ; var "NAME" "the name of the project (from the dune-project file)" - ; var "VERSION" "output of $(b,git describe --always --dirty)" - ; var "VERSION_NUM" ("same as $(b," ^ literal_version ^ - ") but with a potential leading 'v' or 'V' dropped") - ; var "VCS_COMMIT_ID" "commit hash from the vcs" - ; opam "maintainer" - ; opam "authors" - ; opam "homepage" - ; opam "issues" - ; opam "doc" - ; opam "license" - ; opam "repo" - ; `P {|In order to call $(b,dune subst) when your package is pinned, add this line - to the $(b,build:) field of your opam file:|} - ; `Pre {| [dune "subst"] {pinned}|} - ; `P {|Note that this command is meant to be called only from opam files and - behaves a bit differently from other dune commands. In particular it - doesn't try to detect the root and must be called from the root of - the project.|} - ; `Blocks Common.help_secs - ] - in - let term = - match Which_program.t with - | Jbuilder -> - let%map common = Common.term - and name = - Arg.(value - & opt (some string) None - & info ["n"; "name"] ~docv:"NAME" - ~doc:"Use this project name instead of detecting it.") - in - Common.set_common common ~targets:[]; - Scheduler.go ~common (Watermarks.subst ?name) - | Dune -> - let%map () = Term.const () in - let config : Config.t = - { display = Quiet - ; concurrency = Fixed 1 - } - in - Path.set_root (Path.External.cwd ()); - Dune.Scheduler.go ~config Watermarks.subst - in - (term, Term.info "subst" ~doc ~man) - -let utop = - let doc = "Load library in utop" in - let man = - [ `S "DESCRIPTION" - ; `P {|$(b,dune utop DIR) build and run utop toplevel with libraries defined in DIR|} - ; `Blocks Common.help_secs - ] in - let term = - let%map common = Common.term - and dir = Arg.(value & pos 0 string "" & Arg.info [] ~docv:"DIR") - and ctx_name = context_arg ~doc:{|Select context where to build/run utop.|} - and args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")) - in - Common.set_dirs common; - if not (Path.is_directory - (Path.of_string (Common.prefix_target common dir))) then - die "cannot find directory: %s" (String.maybe_quoted dir); - let utop_target = Filename.concat dir Utop.utop_exe in - Common.set_common_other common ~targets:[utop_target]; - let log = Log.create common in - let (context, utop_path) = - Scheduler.go ~log ~common (fun () -> - Main.setup ~log common >>= fun setup -> - let context = Main.find_context_exn setup ~name:ctx_name in - let setup = { setup with contexts = [context] } in - let target = - match Target.resolve_target common ~setup utop_target with - | Error _ -> - die "no library is defined in %s" (String.maybe_quoted dir) - | Ok [File target] -> target - | Ok _ -> assert false - in - do_build setup [File target] >>| fun () -> - (context, Path.to_string target)) - in - Hooks.End_of_build.run (); - restore_cwd_and_execve common utop_path (utop_path :: args) - context.env - in - (term, Term.info "utop" ~doc ~man ) - let promote = let doc = "Promote files from the last run" in let man = @@ -1039,217 +126,23 @@ let promote = in (term, Term.info "promote" ~doc ~man ) -let printenv = - let doc = "Print the environment of a directory" in - let man = - [ `S "DESCRIPTION" - ; `P {|$(b,dune printenv DIR) prints the environment of a directory|} - ; `Blocks Common.help_secs - ] in - let term = - let%map common = Common.term - and dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH") - in - Common.set_common common ~targets:[]; - let log = Log.create common in - Scheduler.go ~log ~common (fun () -> - Main.setup ~log common >>= fun setup -> - let dir = Path.of_string dir in - Util.check_path setup.contexts dir; - let request = - let dump sctx ~dir = - let open Build.O in - Super_context.dump_env sctx ~dir - >>^ fun env -> - ((Super_context.context sctx).name, env) - in - Build.all ( - match Path.extract_build_context dir with - | Some (ctx, _) -> - let sctx = String.Map.find_exn setup.scontexts ctx in - [dump sctx ~dir] - | None -> - String.Map.values setup.scontexts - |> List.map ~f:(fun sctx -> - let dir = - Path.append (Super_context.context sctx).build_dir dir - in - dump sctx ~dir) - ) - in - Build_system.do_build setup.build_system ~request - >>| fun l -> - let pp ppf = Format.fprintf ppf "@[(@,@[%a@]@]@,)" - (Format.pp_print_list (Dune_lang.pp Dune)) in - match l with - | [(_, env)] -> - Format.printf "%a@." pp env - | l -> - List.iter l ~f:(fun (name, env) -> - Format.printf "@[Environment for context %s:@,%a@]@." name pp env) - ) - in - (term, Term.info "printenv" ~doc ~man ) - -let fmt = - let doc = "Format dune files" in - let man = - [ `S "DESCRIPTION" - ; `P {|$(b,dune unstable-fmt) reads a dune file and outputs a formatted - version. This feature is unstable, and its interface or behaviour - might change. - |} - ] in - let term = - let%map path_opt = - let docv = "FILE" in - let doc = "Path to the dune file to parse." in - Arg.(value & pos 0 (some path) None & info [] ~docv ~doc) - and inplace = - let doc = "Modify the file in place" in - Arg.(value & flag & info ["inplace"] ~doc) - in - if true then - let (input, output) = - match path_opt, inplace with - | None, false -> - (None, None) - | Some path, true -> - let path = Arg.Path.path path in - (Some path, Some path) - | Some path, false -> - (Some (Arg.Path.path path), None) - | None, true -> - die "--inplace requires a file name" - in - Dune_fmt.format_file ~input ~output - else - die "This command is unstable. Please pass --unstable to use it nonetheless." - in - (term, Term.info "unstable-fmt" ~doc ~man ) - -module Help = struct - let config = - ("dune-config", 5, "", "Dune", "Dune manual"), - [ `S Manpage.s_synopsis - ; `Pre "~/.config/dune/config" - ; `S Manpage.s_description - ; `P {|Unless $(b,--no-config) or $(b,-p) is passed, Dune will read a - configuration file from the user home directory. This file is used - to control various aspects of the behavior of Dune.|} - ; `P {|The configuration file is normally $(b,~/.config/dune/config) on - Unix systems and $(b,Local Settings/dune/config) in the User home - directory on Windows. However, it is possible to specify an - alternative configuration file with the $(b,--config-file) option.|} - ; `P {|The first line of the file must be of the form (lang dune X.Y) - where X.Y is the version of the dune language used in the file.|} - ; `P {|The rest of the file must be written in S-expression syntax and be - composed of a list of stanzas. The following sections describe - the stanzas available.|} - ; `S "DISPLAY MODES" - ; `P {|Syntax: $(b,\(display MODE\))|} - ; `P {|This stanza controls how Dune reports what it is doing to the user. - This parameter can also be set from the command line via $(b,--display MODE). - The following display modes are available:|} - ; `Blocks - (List.map ~f:(fun (x, desc) -> `I (sprintf "$(b,%s)" x, desc)) - [ "progress", - {|This is the default, Dune shows and update a - status line as build goals are being completed.|} - ; "quiet", - {|Only display errors.|} - ; "short", - {|Print one line per command being executed, with the - binary name on the left and the reason it is being executed for - on the right.|} - ; "verbose", - {|Print the full command lines of programs being - executed by Dune, with some colors to help differentiate - programs.|} - ]) - ; `P {|Note that when the selected display mode is $(b,progress) and the - output is not a terminal then the $(b,quiet) mode is selected - instead. This rule doesn't apply when running Dune inside Emacs. - Dune detects whether it is executed from inside Emacs or not by - looking at the environment variable $(b,INSIDE_EMACS) that is set by - Emacs. If you want the same behavior with another editor, you can set - this variable. If your editor already sets another variable, - please open a ticket on the ocaml/dune github project so that we can - add support for it.|} - ; `S "JOBS" - ; `P {|Syntax: $(b,\(jobs NUMBER\))|} - ; `P {|Set the maximum number of jobs Dune might run in parallel. - This can also be set from the command line via $(b,-j NUMBER).|} - ; `P {|The default for this value is 4.|} - ; Common.footer - ] - - type what = - | Man of Manpage.t - | List_topics - - let commands = - [ "config", Man config - ; "topics", List_topics - ] - - let help = - let doc = "Additional Dune help" in - let man = - [ `S "DESCRIPTION" - ; `P {|$(b,dune help TOPIC) provides additional help on the given topic. - The following topics are available:|} - ; `Blocks (List.concat_map commands ~f:(fun (s, what) -> - match what with - | List_topics -> [] - | Man ((title, _, _, _, _), _) -> [`I (sprintf "$(b,%s)" s, title)])) - ; Common.footer - ] - in - let term = - Term.ret @@ - let%map man_format = Arg.man_format - and what = - Arg.(value - & pos 0 (some (enum commands)) None - & info [] ~docv:"TOPIC") - in - match what with - | None -> - `Help (man_format, Some "help") - | Some (Man man_page) -> - Format.printf "%a@?" (Manpage.print man_format) man_page; - `Ok () - | Some List_topics -> - List.filter_map commands ~f:(fun (s, what) -> - match what with - | List_topics -> None - | _ -> Some s) - |> List.sort ~compare:String.compare - |> String.concat ~sep:"\n" - |> print_endline; - `Ok () - in - (term, Term.info "help" ~doc ~man) -end - let all = - [ installed_libraries - ; external_lib_deps + [ Installed_libraries.command + ; External_lib_deps.command ; build_targets ; runtest ; clean - ; install - ; uninstall - ; exec - ; subst - ; rules - ; utop + ; Install_uninstall.install + ; Install_uninstall.uninstall + ; Exec.command + ; Subst.command + ; Print_rules.command + ; Utop.command ; promote - ; printenv - ; Help.help - ; fmt - ; compute + ; Printenv.command + ; Help.command + ; Fmt_cmd.command + ; Compute.command ] let default = diff --git a/bin/print_rules.ml b/bin/print_rules.ml new file mode 100644 index 00000000000..2c30c93c616 --- /dev/null +++ b/bin/print_rules.ml @@ -0,0 +1,115 @@ +open Stdune +open Import +open Fiber.O + +let doc = "Dump internal rules." + +let man = + [ `S "DESCRIPTION" + ; `P {|Dump Dune internal rules for the given targets. + If no targets are given, dump all the internal rules.|} + ; `P {|By default the output is a list of S-expressions, + one S-expression per rule. Each S-expression is of the form:|} + ; `Pre " ((deps ())\n\ + \ (targets ())\n\ + \ (context )\n\ + \ (action ))" + ; `P {|$(b,) is the context is which the action is executed. + It is omitted if the action is independent from the context.|} + ; `P {|$(b,) is the action following the same syntax as user actions, + as described in the manual.|} + ; `Blocks Common.help_secs + ] + +let info = Term.info "rules" ~doc ~man + +let term = + let%map common = Common.term + and out = + Arg.(value + & opt (some string) None + & info ["o"] ~docv:"FILE" + ~doc:"Output to a file instead of stdout.") + and recursive = + Arg.(value + & flag + & info ["r"; "recursive"] + ~doc:"Print all rules needed to build the transitive \ + dependencies of the given targets.") + and makefile_syntax = + Arg.(value + & flag + & info ["m"; "makefile"] + ~doc:"Output the rules in Makefile syntax.") + and targets = + Arg.(value + & pos_all string [] + & Arg.info [] ~docv:"TARGET") + in + let out = Option.map ~f:Path.of_string out in + Common.set_common common ~targets; + let log = Log.create common in + Scheduler.go ~log ~common (fun () -> + Import.Main.setup ~log common ~external_lib_deps_mode:true + >>= fun setup -> + let request = + match targets with + | [] -> Build.paths (Build_system.all_targets setup.build_system) + | _ -> + Target.resolve_targets_exn ~log common setup targets + |> Target.request setup + in + Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules -> + let sexp_of_action action = + Action.for_shell action |> Action.For_shell.encode + in + let print oc = + let ppf = Format.formatter_of_out_channel oc in + Dune_lang.prepare_formatter ppf; + Format.pp_open_vbox ppf 0; + if makefile_syntax then begin + List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> + let action = + Action.For_shell.Progn + [ Mkdir (Path.to_string rule.dir) + ; Action.for_shell rule.action + ] + in + Format.fprintf ppf + "@[@{%a:%t@}@]@,\ + @<0>\t@{%a@}@,@," + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p -> + Format.pp_print_string ppf (Path.to_string p))) + (Path.Set.to_list rule.targets) + (fun ppf -> + Path.Set.iter (Deps.paths rule.deps) ~f:(fun dep -> + Format.fprintf ppf "@ %s" (Path.to_string dep))) + Pp.pp + (Action_to_sh.pp action)) + end else begin + List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> + let sexp = + let paths ps = + Dune_lang.Encoder.list Path_dune_lang.encode (Path.Set.to_list ps) + in + Dune_lang.Encoder.record ( + List.concat + [ [ "deps" , Deps.to_sexp rule.deps + ; "targets", paths rule.targets ] + ; (match rule.context with + | None -> [] + | Some c -> ["context", + Dune_lang.atom_or_quoted_string c.name]) + ; [ "action" , sexp_of_action rule.action ] + ]) + in + Format.fprintf ppf "%a@," Dune_lang.pp_split_strings sexp) + end; + Format.pp_print_flush ppf (); + Fiber.return () + in + match out with + | None -> print stdout + | Some fn -> Io.with_file_out fn ~f:print) + +let command = term, info diff --git a/bin/print_rules.mli b/bin/print_rules.mli new file mode 100644 index 00000000000..00d85ffa6db --- /dev/null +++ b/bin/print_rules.mli @@ -0,0 +1,2 @@ + +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/printenv.ml b/bin/printenv.ml new file mode 100644 index 00000000000..689b1415f97 --- /dev/null +++ b/bin/printenv.ml @@ -0,0 +1,57 @@ +open Stdune +open Import +open Fiber.O + +let doc = "Print the environment of a directory" + +let man = + [ `S "DESCRIPTION" + ; `P {|$(b,dune printenv DIR) prints the environment of a directory|} + ; `Blocks Common.help_secs + ] + +let info = Term.info "printenv" ~doc ~man + +let dump sctx ~dir = + let open Build.O in + Super_context.dump_env sctx ~dir + >>^ fun env -> + ((Super_context.context sctx).name, env) + +let term = + let%map common = Common.term + and dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH") + in + Common.set_common common ~targets:[]; + let log = Log.create common in + Scheduler.go ~log ~common (fun () -> + Import.Main.setup ~log common >>= fun setup -> + let dir = Path.of_string dir in + Util.check_path setup.contexts dir; + let request = + Build.all ( + match Path.extract_build_context dir with + | Some (ctx, _) -> + let sctx = String.Map.find_exn setup.scontexts ctx in + [dump sctx ~dir] + | None -> + String.Map.values setup.scontexts + |> List.map ~f:(fun sctx -> + let dir = + Path.append (Super_context.context sctx).build_dir dir + in + dump sctx ~dir) + ) + in + Build_system.do_build setup.build_system ~request + >>| fun l -> + let pp ppf = Format.fprintf ppf "@[(@,@[%a@]@]@,)" + (Format.pp_print_list (Dune_lang.pp Dune)) in + match l with + | [(_, env)] -> + Format.printf "%a@." pp env + | l -> + List.iter l ~f:(fun (name, env) -> + Format.printf "@[Environment for context %s:@,%a@]@." name pp env)) + +let command = term, info diff --git a/bin/printenv.mli b/bin/printenv.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/printenv.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/subst.ml b/bin/subst.ml new file mode 100644 index 00000000000..ab895712242 --- /dev/null +++ b/bin/subst.ml @@ -0,0 +1,74 @@ +open Stdune +open Import + +(** A string that is "%%VERSION%%" but not expanded by [dune subst] *) +let literal_version = + "%%" ^ "VERSION%%" + +let doc = "Substitute watermarks in source files." + +let man = + let var name desc = + `Blocks [`Noblank; `P ("- $(b,%%" ^ name ^ "%%), " ^ desc) ] + in + let opam field = + var ("PKG_" ^ String.uppercase field) + ("contents of the $(b," ^ field ^ ":) field from the opam file") + in + [ `S "DESCRIPTION" + ; `P {|Substitute $(b,%%ID%%) strings in source files, in a similar fashion to + what topkg does in the default configuration.|} + ; `P ({|This command is only meant to be called when a user pins a package to + its development version. Especially it replaces $(b,|} ^ literal_version + ^{|) strings by the version obtained from the vcs. Currently only git is + supported and the version is obtained from the output of:|}) + ; `Pre {| \$ git describe --always --dirty|} + ; `P {|$(b,dune subst) substitutes the variables that topkg substitutes with + the defatult configuration:|} + ; var "NAME" "the name of the project (from the dune-project file)" + ; var "VERSION" "output of $(b,git describe --always --dirty)" + ; var "VERSION_NUM" ("same as $(b," ^ literal_version ^ + ") but with a potential leading 'v' or 'V' dropped") + ; var "VCS_COMMIT_ID" "commit hash from the vcs" + ; opam "maintainer" + ; opam "authors" + ; opam "homepage" + ; opam "issues" + ; opam "doc" + ; opam "license" + ; opam "repo" + ; `P {|In order to call $(b,dune subst) when your package is pinned, add this line + to the $(b,build:) field of your opam file:|} + ; `Pre {| [dune "subst"] {pinned}|} + ; `P {|Note that this command is meant to be called only from opam files and + behaves a bit differently from other dune commands. In particular it + doesn't try to detect the root and must be called from the root of + the project.|} + ; `Blocks Common.help_secs + ] + +let info = Term.info "subst" ~doc ~man + +let term = + match Which_program.t with + | Jbuilder -> + let%map common = Common.term + and name = + Arg.(value + & opt (some string) None + & info ["n"; "name"] ~docv:"NAME" + ~doc:"Use this project name instead of detecting it.") + in + Common.set_common common ~targets:[]; + Scheduler.go ~common (Watermarks.subst ?name) + | Dune -> + let%map () = Term.const () in + let config : Config.t = + { display = Quiet + ; concurrency = Fixed 1 + } + in + Path.set_root (Path.External.cwd ()); + Dune.Scheduler.go ~config Watermarks.subst + +let command = term, info diff --git a/bin/subst.mli b/bin/subst.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/subst.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/util.ml b/bin/util.ml index ee834d6afa9..60e96e4df85 100644 --- a/bin/util.ml +++ b/bin/util.ml @@ -1,6 +1,11 @@ open! Stdune -open Dune -open Import + +module Context = Dune.Context +module Workspace = Dune.Workspace +module Dune_project = Dune.Dune_project + +let die = Dune.Import.die +let hint = Dune.Import.hint let check_path contexts = let contexts = diff --git a/bin/utop.ml b/bin/utop.ml new file mode 100644 index 00000000000..82a316cf4e2 --- /dev/null +++ b/bin/utop.ml @@ -0,0 +1,50 @@ +open Stdune +open Import +open Fiber.O + +module Utop = Dune.Utop + +let doc = "Load library in utop" + +let man = + [ `S "DESCRIPTION" + ; `P {|$(b,dune utop DIR) build and run utop toplevel with libraries defined in DIR|} + ; `Blocks Common.help_secs + ] + + let info = Term.info "utop" ~doc ~man + +let term = + let%map common = Common.term + and dir = Arg.(value & pos 0 string "" & Arg.info [] ~docv:"DIR") + and ctx_name = + Common.context_arg ~doc:{|Select context where to build/run utop.|} + and args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS")) + in + Common.set_dirs common; + if not (Path.is_directory + (Path.of_string (Common.prefix_target common dir))) then + die "cannot find directory: %s" (String.maybe_quoted dir); + let utop_target = Filename.concat dir Utop.utop_exe in + Common.set_common_other common ~targets:[utop_target]; + let log = Log.create common in + let (context, utop_path) = + Scheduler.go ~log ~common (fun () -> + Import.Main.setup ~log common >>= fun setup -> + let context = Import.Main.find_context_exn setup ~name:ctx_name in + let setup = { setup with contexts = [context] } in + let target = + match Target.resolve_target common ~setup utop_target with + | Error _ -> + die "no library is defined in %s" (String.maybe_quoted dir) + | Ok [File target] -> target + | Ok _ -> assert false + in + do_build setup [File target] >>| fun () -> + (context, Path.to_string target)) + in + Hooks.End_of_build.run (); + restore_cwd_and_execve common utop_path (utop_path :: args) + context.env + +let command = term, info diff --git a/bin/utop.mli b/bin/utop.mli new file mode 100644 index 00000000000..6d988967f3a --- /dev/null +++ b/bin/utop.mli @@ -0,0 +1 @@ +val command : unit Cmdliner.Term.t * Cmdliner.Term.info