dune/bin/main.ml

open Jbuilder
open Import
open Jbuilder_cmdliner.Cmdliner

(* Things in src/ don't depend on cmdliner to speed up the bootstrap, so we set this
   reference here *)
let () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value

let (>>=) = Future.(>>=)

type common =
  { concurrency      : int
  ; debug_dep_path   : bool
  ; debug_findlib    : bool
  ; debug_backtraces : bool
  ; dev_mode         : bool
  ; verbose          : bool
  ; workspace_file   : string option
  ; root             : string
  ; target_prefix    : string
  ; only_packages    : String_set.t option
  ; capture_outputs  : bool
  ; (* Original arguments for the external-lib-deps hint *)
    orig_args        : string list
  }

let prefix_target common s = common.target_prefix ^ s

let set_common c ~targets =
  Clflags.concurrency := c.concurrency;
  Clflags.debug_dep_path := c.debug_dep_path;
  Clflags.debug_findlib := c.debug_findlib;
  Clflags.debug_backtraces := c.debug_backtraces;
  Clflags.dev_mode := c.dev_mode;
  Clflags.verbose := c.verbose;
  Clflags.capture_outputs := c.capture_outputs;
  Clflags.workspace_root := c.root;
  if c.root <> Filename.current_dir_name then
    Sys.chdir c.root;
  Clflags.external_lib_deps_hint :=
    List.concat
      [ ["jbuilder"; "external-lib-deps"; "--missing"]
      ; c.orig_args
      ; targets
      ]

module Main = struct
  include Jbuilder.Main

  let setup ~log ?filter_out_optional_stanzas_with_missing_deps common =
    setup
      ~log
      ?workspace_file:common.workspace_file
      ?only_packages:common.only_packages
      ?filter_out_optional_stanzas_with_missing_deps ()
end

let do_build (setup : Main.setup) targets =
  Build_system.do_build_exn setup.build_system targets

let find_root () =
  let cwd = Sys.getcwd () in
  let rec loop counter ~candidates ~to_cwd dir =
    let files = Sys.readdir dir |> Array.to_list |> String_set.of_list in
    if String_set.mem "jbuild-workspace" files then
      cont counter ~candidates:((0, dir, to_cwd) :: candidates) dir ~to_cwd
    else if String_set.exists files ~f:(fun fn ->
        String.is_prefix fn ~prefix:"jbuild-workspace") then
      cont counter ~candidates:((1, dir, to_cwd) :: candidates) dir ~to_cwd
    else
      cont counter ~candidates dir ~to_cwd
  and cont counter ~candidates ~to_cwd dir =
    if counter > String.length cwd then
      candidates
    else
      let parent = Filename.dirname dir in
      if parent = dir then
        candidates
      else
        let base = Filename.basename dir in
        loop (counter + 1) parent ~candidates ~to_cwd:(base :: to_cwd)
  in
  match loop 0 ~candidates:[] ~to_cwd:[] cwd with
  | [] -> (cwd, [])
  | l ->
    let lowest_priority =
      List.fold_left l ~init:max_int ~f:(fun acc (prio, _, _) ->
        min acc prio)
    in
    match List.find l ~f:(fun (prio, _, _) -> prio = lowest_priority) with
    | None -> assert false
    | Some (_, dir, to_cwd) -> (dir, to_cwd)

let copts_sect = "COMMON OPTIONS"
let help_secs =
  [ `S copts_sect
  ; `P "These options are common to all commands."
  ; `S "MORE HELP"
  ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."
  ; `S "BUGS"
  ; `P "Check bug reports at https://github.com/janestreet/jbuilder/issues"
  ]

let common =
  let dump_opt name value =
    match value with
    | None -> []
    | Some s -> [name; s]
  in
  let make
        concurrency
        debug_dep_path
        debug_findlib
        debug_backtraces
        dev_mode
        verbose
        no_buffer
        workspace_file
        (root, only_packages, orig)
    =
    let root, to_cwd =
      match root with
      | Some dn -> (dn, [])
      | None -> find_root ()
    in
    let orig_args =
      List.concat
        [ if dev_mode then ["--dev"] else []
        ; dump_opt "--workspace" workspace_file
        ; orig
        ]
    in
    { concurrency
    ; debug_dep_path
    ; debug_findlib
    ; debug_backtraces
    ; dev_mode
    ; verbose
    ; capture_outputs = not no_buffer
    ; workspace_file
    ; root
    ; orig_args
    ; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
    ; only_packages =
        Option.map only_packages
          ~f:(fun s -> String_set.of_list (String.split s ~on:','))
    }
  in
  let docs = copts_sect in
  let concurrency =
    Arg.(value
         & opt int !Clflags.concurrency
         & info ["j"] ~docs ~docv:"JOBS"
             ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|}
        )
  in
  let only_packages =
    Arg.(value
         & opt (some string) None
         & info ["only-packages"] ~docs ~docv:"PACKAGES"
             ~doc:{|Ignore stanzas referring to a package that is not in $(b,PACKAGES).
                    $(b,PACKAGES) is a coma-separated list of package name.
                    Note that this has the same effect as deleting the relevant stanzas
                    from jbuild files. It is mostly meant for releases.
                    During development, it is likely that what you want instead is to
                    build a particular $(b,<package>.install) target.|}
        )
  in
  let ddep_path =
    Arg.(value
         & flag
         & info ["debug-dependency-path"] ~docs
             ~doc:{|In case of error, print the dependency path from
                    the targets on the command line to the rule that failed.
                  |})
  in
  let dfindlib =
    Arg.(value
         & flag
         & info ["debug-findlib"] ~docs
             ~doc:{|Debug the findlib sub-system.|})
  in
  let dbacktraces =
    Arg.(value
         & flag
         & info ["debug-backtraces"] ~docs
             ~doc:{|Always print exception backtraces.|})
  in
  let dev =
    Arg.(value
         & flag
         & info ["dev"] ~docs
             ~doc:{|Use stricter compilation flags by default.|})
  in
  let verbose =
    Arg.(value
         & flag
         & info ["verbose"] ~docs
             ~doc:"Print detailed information about commands being run")
  in
  let no_buffer =
    Arg.(value
         & flag
         & info ["no-buffer"] ~docs ~docv:"DIR"
             ~doc:{|Do not buffer the output of commands executed by jbuilder.
                    By default jbuilder buffers the output of subcommands, in order
                    to prevent interleaving when multiple commands are executed
                    in parallel. However, this can be an issue when debugging
                    long running tests. With $(b,--no-buffer), commands have direct
                    access to the terminal. Note that as a result their output won't
                    be captured in the log file.

                    You should use this option in conjunction with $(b,-j 1),
                    to avoid interleaving. Additionally you should use
                    $(b,--verbose) as well, to make sure that commands are printed
                    before they are being executed.|})
  in
  let workspace_file =
    Arg.(value
         & opt (some file) None
         & info ["workspace"] ~docs ~docv:"FILE"
             ~doc:"Use this specific workspace file instead of looking it up.")
  in
  let root =
    Arg.(value
         & opt (some dir) None
         & info ["root"] ~docs ~docv:"DIR"
             ~doc:{|Use this directory as workspace root instead of guessing it.
                    Note that this option doesn't change the interpretation of
                    targets given on the command line. It is only intended
                    for scripts.|})
  in
  let for_release = "for-release-of-packages" in
  let frop =
    Arg.(value
         & opt (some string) None
         & info ["p"; for_release] ~docs ~docv:"PACKAGES"
             ~doc:{|Shorthand for $(b,--root . --only-packages PACKAGE). You must use
                    this option in your $(i,<package>.opam) files, in order to build
                    only what's necessary when your project contains multiple packages
                    as well as getting reproducible builds.|})
  in
  let root_and_only_packages =
    let merge root only_packages release =
      match release, root, only_packages with
      | Some _, Some _, _ ->
        `Error (true,
                sprintf
                  "Cannot use %s and --root simultaneously"
                  for_release)
      | Some _, _, Some _ ->
        `Error (true,
                sprintf
                  "Cannot use %s and --only-packages simultaneously"
                  for_release)
      | Some pkgs, None, None ->
        `Ok (Some ".", Some pkgs, ["-p"; pkgs])
      | None, _, _ ->
        `Ok (root, only_packages,
             List.concat
               [ dump_opt "--root" root
               ; dump_opt "--only-packages" only_packages
               ])
    in
    Term.(ret (const merge
               $ root
               $ only_packages
               $ frop))
  in
  Term.(const make
        $ concurrency
        $ ddep_path
        $ dfindlib
        $ dbacktraces
        $ dev
        $ verbose
        $ no_buffer
        $ workspace_file
        $ root_and_only_packages
       )

let installed_libraries =
  let doc = "Print out libraries installed on the system." in
  let go common na =
    set_common common ~targets:[];
    Future.Scheduler.go ~log:(Log.create ())
      (Context.default () >>= fun ctx ->
       let findlib = ctx.findlib in
       if na then begin
         let pkgs = Findlib.all_unavailable_packages findlib in
         let longest = List.longest_map pkgs ~f:(fun na -> na.package) in
         let ppf = Format.std_formatter in
         List.iter pkgs ~f:(fun (na : Findlib.Package_not_available.t) ->
           Format.fprintf ppf "%-*s -> %a@\n" longest na.package
             Findlib.Package_not_available.explain na.reason);
         Format.pp_print_flush ppf ();
         Future.return ()
       end else begin
         let pkgs = Findlib.all_packages findlib in
         let max_len = List.longest_map pkgs ~f:(fun p -> p.name) in
         List.iter pkgs ~f:(fun pkg ->
           let ver =
             match pkg.Findlib.version with
             | "" -> "n/a"
             | v  -> v
           in
           Printf.printf "%-*s (version: %s)\n" max_len pkg.name ver);
         Future.return ()
       end)
  in
  ( Term.(const go
          $ common
          $ Arg.(value
                 & flag
                 & info ["na"; "not-available"]
                     ~doc:"List libraries that are not available and explain why"))
  , Term.info "installed-libraries" ~doc
  )

let resolve_package_install setup pkg =
  match Main.package_install_file setup pkg with
  | Ok path -> path
  | Error () ->
    die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages))

type target =
  | File  of Path.t
  | Alias of Path.t * Alias.t

let target_hint (setup : Main.setup) path =
  assert (Path.is_local path);
  let sub_dir = Path.parent path in
  let candidates = Build_system.all_targets setup.build_system in
  let candidates =
    if Path.is_in_build_dir path then
      candidates
    else
      List.map candidates ~f:(fun path ->
        match Path.extract_build_context path with
        | None -> path
        | Some (_, path) -> path)
  in
  let candidates =
    (* Only suggest hints for the basename, otherwise it's slow when there are lots of
       files *)
    List.filter_map candidates ~f:(fun path ->
      if Path.parent path = sub_dir then
        Some (Path.to_string path)
      else
        None)
  in
  let candidates = String_set.of_list candidates |> String_set.elements in
  hint (Path.to_string path) candidates

let resolve_targets ~log common (setup : Main.setup) user_targets =
  match user_targets with
  | [] -> []
  | _ ->
    let targets =
      List.concat_map user_targets ~f:(fun s ->
        if String.is_prefix s ~prefix:"@" then
          let s = String.sub s ~pos:1 ~len:(String.length s - 1) in
          let path = Path.relative Path.root (prefix_target common s) in
          if Path.is_root path then
            die "@@ on the command line must be followed by a valid alias name"
          else
            let dir = Path.parent path in
            let name = Path.basename path in
            [Alias (path, Alias.make ~dir name)]
        else
          let path = Path.relative Path.root (prefix_target common s) in
          let can't_build path =
            die "Don't know how to build %s%s" (Path.to_string path)
              (target_hint setup path)
          in
          if not (Path.is_local path) then
            [File path]
          else if Path.is_in_build_dir path then begin
            if Build_system.is_target setup.build_system path then
              [File path]
            else
              can't_build path
          end else
            match
              let l =
                List.filter_map setup.contexts ~f:(fun ctx ->
                    let path = Path.append ctx.Context.build_dir path in
                    if Build_system.is_target setup.build_system path then
                      Some (File path)
                    else
                      None)
              in
              if Build_system.is_target setup.build_system path ||
                 Path.exists path then
                File path :: l
              else
                l
            with
            | [] -> can't_build path
            | l  -> l
        )
    in
    if !Clflags.verbose then begin
      Log.info log "Actual targets:";
      List.iter targets ~f:(function
        | File path ->
          Log.info log @@ "- " ^ (Path.to_string path)
        | Alias (path, _) ->
          Log.info log @@ "- alias " ^ (Path.to_string path));
      flush stdout;
    end;
    List.map targets ~f:(function
      | File path -> path
      | Alias (_, alias) -> Alias.file alias)

let build_targets =
  let doc = "Build the given targets, or all installable targets if none are given." in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|Targets starting with a $(b,@) are interpreted as aliases.|}
    ; `Blocks help_secs
    ]
  in
  let name_ = Arg.info [] ~docv:"TARGET" in
  let go common targets =
    set_common common ~targets;
    let log = Log.create () in
    Future.Scheduler.go ~log
      (Main.setup ~log common >>= fun setup ->
       let targets = resolve_targets ~log common setup targets in
       do_build setup targets) in
  ( Term.(const go
          $ common
          $ Arg.(value & pos_all string ["@install"] name_))
  , Term.info "build" ~doc ~man)

let runtest =
  let doc = "Run tests." in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|This is a short-hand for calling:|}
    ; `Pre {|  jbuilder build @runtest|}
    ; `Blocks help_secs
    ]
  in
  let name_ = Arg.info [] ~docv:"DIR" in
  let go common dirs =
    set_common common
      ~targets:(List.map dirs ~f:(function
        | "" | "." -> "@runtest"
        | dir when dir.[String.length dir - 1] = '/' -> sprintf "@%sruntest" dir
        | dir -> sprintf "@%s/runtest" dir));
    let log = Log.create () in
    Future.Scheduler.go ~log
      (Main.setup ~log common >>= fun setup ->
       let targets =
         List.map dirs ~f:(fun dir ->
           let dir = Path.(relative root) (prefix_target common dir) in
           Alias.file (Alias.runtest ~dir))
       in
       do_build setup targets) in
  ( Term.(const go
          $ common
          $ Arg.(value & pos_all string ["."] name_))
  , Term.info "runtest" ~doc ~man)

let clean =
  let doc = "Clean the project." in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|Removes files added by jbuilder such as _build, <package>.install, and .merlin|}
    ; `Blocks help_secs
    ]
  in
  let go common =
    begin
      set_common common ~targets:[];
      Build_system.all_targets_ever_built () |> List.iter ~f:Path.unlink_no_err;
      Path.(rm_rf (append root (of_string "_build")))
    end
  in
  ( Term.(const go $ common)
  , Term.info "clean" ~doc ~man)

let format_external_libs libs =
  String_map.bindings libs
  |> List.map ~f:(fun (name, kind) ->
    match (kind : Build.lib_dep_kind) with
    | Optional -> sprintf "- %s (optional)" name
    | Required -> sprintf "- %s" 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,<package>.opam) file.|}
    ; `Blocks help_secs
    ]
  in
  let go common only_missing targets =
    set_common common ~targets:[];
    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 = resolve_targets ~log common setup targets in
       let failure =
         String_map.fold ~init:false
           (Build_system.all_lib_deps_by_context setup.build_system targets)
           ~f:(fun ~key:context_name ~data:lib_deps acc ->
             let internals =
               Jbuild_types.Stanzas.lib_names
                 (match String_map.find context_name setup.Main.stanzas with
                  | None -> assert false
                  | Some x -> x)
             in
             let externals =
               String_map.filter lib_deps ~f:(fun name _ ->
                 not (String_set.mem name internals))
             in
             if only_missing then begin
               let context =
                 match List.find setup.contexts ~f:(fun c -> c.name = context_name) with
                 | None -> assert false
                 | Some c -> c
               in
               let missing =
                 String_map.filter externals ~f:(fun name _ ->
                   not (Findlib.available context.findlib name ~required_by:[]))
               in
               if String_map.is_empty missing then
                 acc
               else begin
                 Format.eprintf
                   "@{<error>Error@}: The following required libraries are missing \
                    in the %s context:\n\
                    %s\n\
                    Hint: try: opam install %s@."
                   context_name
                   (format_external_libs missing)
                   (String_map.bindings missing
                    |> List.filter_map ~f:(fun (name, kind) ->
                      match (kind : Build.lib_dep_kind) with
                      | Optional -> None
                      | Required -> Some (Findlib.root_package_name name))
                    |> String_set.of_list
                    |> String_set.elements
                    |> String.concat ~sep:" ");
                 true
               end
             end else begin
               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 die "";
       Future.return ())
  in
  ( Term.(const go
          $ common
          $ Arg.(value
                 & flag
                 & info ["missing"]
                     ~doc:{|Only print out missing dependencies|})
          $ Arg.(non_empty
                 & pos_all string []
                 & Arg.info [] ~docv:"TARGET"))
  , Term.info "external-lib-deps" ~doc ~man)

let rules =
  let doc = "Dump internal rules." in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|Dump Jbuilder 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    (<dependencies>))\n\
           \   (targets (<targets>))\n\
           \   (context <context-name>)\n\
           \   (action  <action>))"
    ; `P {|$(b,<context-name>) is the context is which the action is executed.
           It is omitted if the action is independant from the context.|}
    ; `P {|$(b,<action>) is the action following the same syntax as user actions,
           as described in the manual.|}
    ; `Blocks help_secs
    ]
  in
  let go common out recursive makefile_syntax targets =
    set_common common ~targets;
    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 ~recursive >>= fun rules ->
       let print oc =
         let ppf = Format.formatter_of_out_channel oc in
         Sexp.prepare_formatter ppf;
         Format.pp_open_vbox ppf 0;
         if makefile_syntax then begin
           List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
             Format.fprintf ppf "@[<hov 2>@{<makefile-stuff>%a:%t@}@]@,@<0>\t@{<makefile-action>%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.elements rule.targets)
               (fun ppf ->
                  Path.Set.iter rule.deps ~f:(fun dep ->
                    Format.fprintf ppf "@ %s" (Path.to_string dep)))
               Sexp.pp_split_strings (Action.sexp_of_t rule.action))
         end else begin
           List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
             let sexp =
               let paths ps = Sexp.To_sexp.list Path.sexp_of_t (Path.Set.elements ps) in
               Sexp.To_sexp.record (
                 List.concat
                   [ [ "deps"   , paths rule.deps
                     ; "targets", paths rule.targets ]
                   ; (match rule.context with
                      | None -> []
                      | Some c -> ["context", Atom c.name])
                   ; [ "action" , Action.sexp_of_t rule.action ]
                   ])
             in
             Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp)
         end;
         Format.pp_print_flush ppf ();
         Future.return ()
       in
       match out with
       | None -> print stdout
       | Some fn -> Io.with_file_out fn ~f:print)
  in
  ( Term.(const go
          $ common
          $ Arg.(value
                 & opt (some string) None
                 & info ["o"] ~docv:"FILE"
                     ~doc:"Output to a file instead of stdout.")
          $ Arg.(value
                 & flag
                 & info ["r"; "recursive"]
                     ~doc:"Print all rules needed to build the transitive dependencies of the given targets.")
          $ Arg.(value
                 & flag
                 & info ["m"; "makefile"]
                     ~doc:"Output the rules in Makefile syntax.")
          $ Arg.(value
                 & pos_all string []
                 & Arg.info [] ~docv:"TARGET"))
  , Term.info "rules" ~doc ~man)

let opam_installer () =
  match Bin.which "opam-installer" with
  | None ->
    die "\
Sorry, you need the opam-installer tool to be able to install or
uninstall packages.

I couldn't find the opam-installer binary :-("
  | Some fn -> fn

let get_prefix context ~from_command_line =
  match from_command_line with
  | Some p -> Future.return (Path.of_string p)
  | None -> Context.install_prefix context

let install_uninstall ~what =
  let doc =
    sprintf "%s packages using opam-installer." (String.capitalize_ascii what)
  in
  let name_ = Arg.info [] ~docv:"PACKAGE" in
  let go common prefix pkgs =
    set_common common ~targets:[];
    let opam_installer = opam_installer () in
    let log = Log.create () in
    Future.Scheduler.go ~log
      (Main.setup ~log common >>= fun setup ->
       let pkgs =
         match pkgs with
         | [] -> String_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
               Inl (ctx, fn)
             else
               Inr fn))
         |> List.partition_map ~f:(fun x -> x)
       in
       if missing_install_files <> [] then begin
         die "The following <package>.install are missing:\n\
              %s\n\
              You need to run: jbuilder 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 with
        | _ :: _ :: _, Some _ ->
          die "Cannot specify --prefix when installing into multiple contexts!"
        | _ -> ());
       let module CMap = Map.Make(Context) in
       let install_files_by_context = CMap.of_alist_multi install_files |> CMap.bindings in
       Future.all_unit
         (List.map install_files_by_context ~f:(fun (context, install_files) ->
            get_prefix context ~from_command_line:prefix >>= fun prefix ->
            Future.all_unit
              (List.map install_files ~f:(fun path ->
                   let purpose = Future.Build_job install_files in
                   Future.run ~purpose Strict (Path.to_string opam_installer)
                     [ sprintf "-%c" what.[0]
                     ; "--prefix"
                     ; Path.to_string prefix
                     ; Path.to_string path
                     ])))))
  in
  ( Term.(const go
          $ common
          $ Arg.(value & opt (some dir) None & info ["prefix"])
          $ Arg.(value & pos_all string [] name_))
  , Term.info what ~doc ~man:help_secs)

let install   = install_uninstall ~what:"install"
let uninstall = install_uninstall ~what:"uninstall"

let exec =
  let doc =
    "Execute a command in a similar environment as if installation was performed."
  in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|$(b,jbuilder exec -- COMMAND) should behave in the same way as if you do:|}
    ; `Pre "  \\$ jbuilder install\n\
           \  \\$ COMMAND"
    ; `P {|In particular if you run $(b,jbuilder exec ocaml), you will have access
           to the libraries defined in the workspace using your usual directives
           ($(b,#require) for instance)|}
    ; `Blocks help_secs
    ]
  in
  let go common context prog args =
    set_common common ~targets:[];
    let log = Log.create () in
    let setup = Future.Scheduler.go ~log (Main.setup ~log common) in
    let context =
      match List.find setup.contexts ~f:(fun c -> c.name = context) with
      | Some ctx -> ctx
      | None ->
        Format.eprintf "@{<Error>Error@}: Context %S not found!@." context;
        die ""
    in
    let path = Config.local_install_bin_dir ~context:context.name :: context.path in
    match Bin.which ~path prog with
    | None ->
      Format.eprintf "@{<Error>Error@}: Program %S not found!@." prog;
      die ""
    | Some real_prog ->
      let real_prog = Path.to_string real_prog     in
      let env       = Context.env_for_exec context in
      let argv      = Array.of_list (prog :: args) in
      if Sys.win32 then
        let pid =
          Unix.create_process_env real_prog argv env
            Unix.stdin Unix.stdout Unix.stderr
        in
        match snd (Unix.waitpid [] pid) with
        | WEXITED   0 -> ()
        | WEXITED   n -> exit n
        | WSIGNALED _ -> exit 255
        | WSTOPPED  _ -> assert false
      else
        Unix.execve real_prog argv env
  in
  ( Term.(const go
          $ common
          $ Arg.(value
                 & opt string "default"
                 & info ["context"] ~docv:"CONTEXT"
                     ~doc:{|Run the command in this build context.|}
                )
          $ Arg.(required
                 & pos 0 (some string) None (Arg.info [] ~docv:"PROG"))
          $ Arg.(value
                 & pos_right 0 string [] (Arg.info [] ~docv:"ARGS"))
         )
  , Term.info "exec" ~doc ~man)

let subst =
  let doc =
    "Substitute watermarks in source files."
  in
  let man =
    [ `S "DESCRIPTION"
    ; `P {|Substitute %%ID%% strings in source files, in a similar fashion to
           what topkg does in the default configuration.|}
    ; `P {|If you use topkg to handle the releases of your project, then you
           should add this line to the $(b,build:) instructions in your opam file:|}
    ; `Pre {|  ["jbuilder" "subst" name] {pinned}|}
    ; `Blocks help_secs
    ]
  in
  let go common name =
    set_common common ~targets:[];
    Future.Scheduler.go (Watermarks.subst ?name ())
  in
  ( Term.(const go
          $ common
          $ Arg.(value
                 & opt (some string) None
                 & info ["n"; "name"] ~docv:"NAME"
                     ~doc:"Use this package name instead of detecting it.")
         )
  , Term.info "subst" ~doc ~man)

let all =
  [ installed_libraries
  ; external_lib_deps
  ; build_targets
  ; runtest
  ; clean
  ; install
  ; uninstall
  ; exec
  ; subst
  ; rules
  ]

let default =
  let doc = "composable build system for OCaml" in
  ( Term.(ret (const (fun _ -> `Help (`Pager, None)) $ common))
  , Term.info "jbuilder" ~doc ~version:"%%VERSION%%"
      ~man:
        [ `S "DESCRIPTION"
        ; `P {|Jbuilder is a build system designed for OCaml projects only. It
               focuses on providing the user with a consistent experience and takes
               care of most of the low-level details of OCaml compilation. All you
               have to do is provide a description of your project and Jbuilder will
               do the rest.
             |}
        ; `P {|The scheme it implements is inspired from the one used inside Jane
               Street and adapted to the open source world. It has matured over a
               long time and is used daily by hundred of developpers, which means
               that it is highly tested and productive.
             |}
        ; `Blocks help_secs
        ]
  )

let () =
  Ansi_color.setup_err_formatter_colors ();
  try
    match Term.eval_choice default all ~catch:false with
    | `Error _ -> exit 1
    | _ -> exit 0
  with exn ->
    Format.eprintf "%a@?" (Main.report_error ?map_fname:None) exn;
    exit 1