open! Dune_exe
open Stdune
open Dune_config_file
open Dune_scheduler
module Console = Console
module Graph = Dune_graph.Graph
module Profile = Dune_lang.Profile

open struct
  open Dune_util
  module Execution_env = Execution_env
  module Log = Log
  module Report_error = Report_error
end

open struct
  open Dune_rules
  module Colors = Colors
  module Only_packages = Only_packages
end

module Workspace = Source.Workspace

open struct
  open Cmdliner
  module Cmd = Cmd

  module Term = struct
    include Term

    (* Evaluate a parser, passing it no command-line arguments, in an
       environment with no variables set. It's only valid to pass a parser
       which can be evaluated with no arguments, otherwise a code error will
       be raised. Returns the result of the parser. This is intended to be
       used to extract the default value for a type implied by the behaviour
       of its parser when no command-line arguments are passed to it. *)
    let eval_no_args_empty_env t =
      let raise_code_error data =
        Code_error.raise "Unexpected result evaluating term with no args" data
      in
      (* Cmdliner doesn't allow argv to be empty. *)
      let argv = [| "dune" |] in
      let env _ = None in
      match Cmd.eval_value ~argv ~env (Cmd.v (Cmd.info "dune") t) with
      | Ok (`Ok x) -> x
      | Ok `Help -> raise_code_error [ "ok", Dyn.string "help" ]
      | Ok `Version -> raise_code_error [ "ok", Dyn.string "version" ]
      | Error e ->
        let error_string =
          match e with
          | `Parse -> "parse"
          | `Term -> "term"
          | `Exn -> "exn"
        in
        raise_code_error [ "error", Dyn.string error_string ]
    ;;
  end

  module Manpage = Manpage
end

let default_build_dir = "_build"
let trace_file_name = "trace.csexp"

let find_default_trace_file () =
  let trace_file = Filename.concat default_build_dir trace_file_name in
  let cwd = Sys.getcwd () in
  let rec loop dir =
    let candidate = Filename.concat dir trace_file in
    if Sys.file_exists candidate
    then candidate
    else (
      let parent = Filename.dirname dir in
      if parent = dir then Filename.concat cwd trace_file else loop parent)
  in
  loop cwd
;;

module Package = Dune_lang.Package
open Let_syntax

let copts_sect = "COMMON OPTIONS"

let debug_backtraces_term =
  Arg.(
    value
    & flag
    & info
        [ "debug-backtraces" ]
        ~docs:copts_sect
        ~doc:(Some "Always print exception backtraces."))
;;

let one_of term1 term2 =
  Term.ret
  @@ let+ x, args1 = Term.with_used_args term1
     and+ y, args2 = Term.with_used_args term2 in
     match args1, args2 with
     | _, [] -> `Ok x
     | [], _ -> `Ok y
     | arg1 :: _, arg2 :: _ ->
       `Error (true, sprintf "Cannot use %s and %s simultaneously" arg1 arg2)
;;

let build_info =
  let+ build_info =
    Arg.(
      value
      & flag
      & info [ "build-info" ] ~docs:"OPTIONS" ~doc:(Some "Show build information."))
  in
  if build_info
  then (
    let module B = Build_info.V1 in
    let pr fmt = Printf.printf (fmt ^^ "\n") in
    let ver_string v =
      match v with
      | None -> "n/a"
      | Some v -> B.Version.to_string v
    in
    pr "version: %s" (ver_string (B.version ()));
    let libs =
      B.Statically_linked_libraries.to_list ()
      |> List.map ~f:(fun lib ->
        ( B.Statically_linked_library.name lib
        , ver_string (B.Statically_linked_library.version lib) ))
      |> List.sort ~compare:(Tuple.T2.compare String.compare String.compare)
    in
    (match libs with
     | [] -> ()
     | _ ->
       pr "statically linked libraries:";
       let longest = String.longest_map libs ~f:fst in
       List.iter libs ~f:(fun (name, v) -> pr "- %-*s %s" longest name v));
    exit 0)
;;

module No_build = struct
  type t = { debug_backtraces : bool }

  let equal t { debug_backtraces } = Bool.equal t.debug_backtraces debug_backtraces
  let debug_backtraces = debug_backtraces_term

  let set_debug_backtraces debug_backtraces =
    Dune_engine.Clflags.debug_backtraces debug_backtraces
  ;;

  let set { debug_backtraces } = set_debug_backtraces debug_backtraces

  let term =
    let+ () = build_info
    and+ debug_backtraces = debug_backtraces in
    { debug_backtraces }
  ;;

  let term_and_set =
    let+ t = term in
    set t
  ;;
end

module Options_implied_by_dash_p = struct
  type t =
    { root : string option
    ; only_packages : Only_packages.Clflags.t
    ; ignore_promoted_rules : bool
    ; config_from_config_file : Dune_config.Partial.t
    ; profile : Profile.t option
    ; default_target : Arg.Dep.t
    ; always_show_command_line : bool
    ; promote_install_files : bool
    ; require_dune_project_file : bool
    }

  let docs = copts_sect

  type config_file =
    | No_config
    | Default
    | This of Path.t

  let config_term =
    let+ x =
      one_of
        (let+ fn =
           Arg.(
             value
             & opt (some path) None
             & info
                 [ "config-file" ]
                 ~docs
                 ~docv:"FILE"
                 ~doc:(Some "Load this configuration file instead of the default one."))
         in
         Option.map fn ~f:(fun fn -> This (Arg.Path.path fn)))
        (let+ x =
           Arg.(
             value
             & flag
             & info [ "no-config" ] ~docs ~doc:(Some "Do not load the configuration file"))
         in
         Option.some_if x No_config)
    in
    match Option.value x ~default:Default with
    | No_config -> Dune_config.Partial.empty
    | This fname -> Dune_config.load_config_file fname
    | Default ->
      if Execution_env.inside_dune
      then Dune_config.Partial.empty
      else Dune_config.load_user_config_file ()
  ;;

  let packages =
    let parser s =
      let parse_one s =
        match Package.Name.of_string_opt s with
        | Some x -> Ok x
        | None -> ksprintf (fun s -> Error (`Msg s)) "Invalid package name: %S" s
      in
      String.split s ~on:','
      |> List.map ~f:parse_one
      |> Result.List.all
      |> Result.map ~f:Package.Name.Set.of_list
    in
    let printer ppf set =
      Format.pp_print_string
        ppf
        (String.concat
           ~sep:","
           (Package.Name.Set.to_list set |> List.map ~f:Package.Name.to_string))
    in
    Arg.conv ~docv:"PACKAGES" (parser, printer)
  ;;

  let options =
    let+ root =
      let 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
      Arg.(
        value
        & opt (some dir) None
        & info
            [ "root" ]
            ~docs
            ~docv:"DIR"
            ~doc:(Some doc)
            ~env:(Cmd.Env.info ~doc "DUNE_ROOT"))
    and+ ignore_promoted_rules =
      Arg.(
        value
        & flag
        & info
            [ "ignore-promoted-rules" ]
            ~docs
            ~doc:
              (Some
                 "Ignore rules with (mode promote), except ones with (only ...). The \
                  variable %{ignoring_promoted_rules} in dune files reflects whether \
                  this option was passed or not."))
    and+ config_from_config_file = config_term
    and+ default_target =
      Arg.(
        value
        & opt dep (Dep.alias ~dir:Stdune.Path.Local.root Dune_engine.Alias.Name.default)
        & info
            [ "default-target" ]
            ~docs
            ~docv:"TARGET"
            ~doc:
              (Some
                 "Set the default target that is used when none is specified to $(b,dune \
                  build)."))
    and+ always_show_command_line =
      let doc = "Always show the full command lines of programs executed by dune." in
      Arg.(value & flag & info [ "always-show-command-line" ] ~docs ~doc:(Some doc))
    and+ promote_install_files =
      let doc = "Promote any generated <package>.install files to the source tree." in
      Arg.(
        last
        & opt_all ~vopt:true bool [ false ]
        & info [ "promote-install-files" ] ~docs ~doc:(Some doc))
    and+ require_dune_project_file =
      let doc = "Fail if a dune-project file is missing." in
      Arg.(
        last
        & opt_all ~vopt:true bool [ false ]
        & info [ "require-dune-project-file" ] ~docs ~doc:(Some doc))
    in
    { root
    ; only_packages = No_restriction
    ; ignore_promoted_rules
    ; config_from_config_file
    ; profile = None
    ; default_target
    ; always_show_command_line
    ; promote_install_files
    ; require_dune_project_file
    }
  ;;

  let dash_dash_release =
    let shorthand_for =
      [ "--root"
      ; "."
      ; "--ignore-promoted-rules"
      ; "--no-config"
      ; "--profile"
      ; "release"
      ; "--always-show-command-line"
      ; "--promote-install-files"
      ; "--require-dune-project-file"
      ; "--default-target"
      ; "@install"
      ]
    in
    Arg.(
      value
      & alias shorthand_for
      & info
          [ "release" ]
          ~docs
          ~docv:"PACKAGES"
          ~doc:
            (Some
               (sprintf
                  "Put $(b,dune) into a reproducible $(i,release) mode. Shorthand for \
                   $(b,%s). You should use this option for release builds. For instance, \
                   you must use this option in your $(i,<package>.opam) files. Except if \
                   you already use $(b,-p), as $(b,-p) implies this option."
                  (String.concat ~sep:" " shorthand_for))))
  ;;

  let options =
    let+ t = options
    and+ _ = dash_dash_release
    and+ only_packages =
      let+ names =
        Arg.(
          value
          & opt (some packages) None
          & info
              [ "only-packages" ]
              ~docs
              ~docv:"PACKAGES"
              ~doc:
                (Some
                   "Ignore stanzas referring to a package that is not in $(b,PACKAGES). \
                    $(b,PACKAGES) is a comma-separated list of package names. Note that \
                    this has the same effect as deleting the relevant stanzas from dune \
                    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
      match names with
      | None -> Only_packages.Clflags.No_restriction
      | Some names -> Restrict { names; command_line_option = "--only-packages" }
    in
    { t with only_packages }
  ;;

  let dash_p =
    let dash_p_implies = [ "--release"; "--pkg=disabled"; "--only-packages" ] in
    Term.with_used_args
      Arg.(
        value
        & alias_opt (fun s -> dash_p_implies @ [ s ])
        & info
            [ "p"; "for-release-of-packages" ]
            ~docs
            ~docv:"PACKAGES"
            ~doc:
              (Some
                 (sprintf
                    "Shorthand for $(b,%s 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."
                    (String.concat ~sep:" " dash_p_implies))))
  ;;

  let term =
    let+ t = options
    and+ _ = dash_p
    and+ profile =
      let doc = "Build profile. $(b,dev) if unspecified or $(b,release) if -p is set." in
      Arg.(
        last
        & opt_all (some profile) [ None ]
        & info
            [ "profile" ]
            ~docs
            ~env:(Cmd.Env.info ~doc "DUNE_PROFILE")
            ~doc:
              (Some
                 (Printf.sprintf
                    "Select the build profile, for instance $(b,dev) or $(b,release). \
                     The default is $(b,%s)."
                    (Profile.to_string Profile.default))))
    in
    match profile with
    | None -> t
    | Some _ -> { t with profile }
  ;;
end

let display_term =
  let module Display = Dune_config.Display in
  one_of
    (let+ verbose =
       Arg.(
         value
         & flag
         & info
             [ "verbose" ]
             ~docs:copts_sect
             ~doc:(Some "Same as $(b,--display verbose)"))
     in
     Option.some_if verbose Dune_config.Display.verbose)
    Arg.(
      let doc =
        let all = Display.all |> List.map ~f:fst |> String.enumerate_or in
        sprintf
          "Control the display mode of Dune. See $(b,dune-config\\(5\\)) for more \
           details. Valid values for this option are %s."
          all
      in
      value
      & opt (some (enum Display.all)) None
      & info [ "display" ] ~docs:copts_sect ~docv:"MODE" ~doc:(Some doc))
;;

let shared_with_config_file ~allow_pkg_flag =
  let docs = copts_sect in
  let+ concurrency =
    let module Concurrency = Dune_config.Concurrency in
    let arg =
      Arg.conv
        ( (fun s -> Result.map_error (Concurrency.of_string s) ~f:(fun s -> `Msg s))
        , fun pp x -> Format.pp_print_string pp (Concurrency.to_string x) )
    in
    let doc =
      "Run no more than $(i,JOBS) commands simultaneously. $(i,JOBS) must be a positive \
       integer or $(b,auto) to auto-detect the number of cores (the default)."
    in
    Arg.(
      value
      & opt (some arg) None
      & info
          [ "j" ]
          ~docs
          ~docv:"JOBS"
          ~env:(Cmd.Env.info ~doc "DUNE_JOBS")
          ~doc:(Some doc))
  and+ sandboxing_preference =
    let all =
      List.map Dune_engine.Sandbox_mode.cli_options ~f:(fun s ->
        Dune_engine.Sandbox_mode.to_string s, s)
    in
    Arg.(
      value
      & opt (some (enum all)) None
      & info
          [ "sandbox" ]
          ~env:
            (Cmd.Env.info
               ~doc:"Sandboxing mode to use by default. (see --sandbox)"
               "DUNE_SANDBOX")
          ~doc:
            (Some
               (Printf.sprintf
                  "Set sandboxing mode. Some actions require a certain sandboxing mode, \
                   so they will ignore this setting. The allowed values are: %s."
                  (String.concat
                     ~sep:", "
                     (List.map
                        Dune_engine.Sandbox_mode.all_except_patch_back_source_tree
                        ~f:Dune_engine.Sandbox_mode.to_string)))))
  and+ terminal_persistence =
    let modes = Dune_config.Terminal_persistence.all in
    let doc =
      let f s = fst s |> Printf.sprintf "$(b,%s)" in
      Printf.sprintf
        "Change how the log of build results are displayed to the console between \
         rebuilds while in $(b,--watch) mode. Supported modes: %s."
        (List.map ~f modes |> String.concat ~sep:", ")
    in
    Arg.(
      value
      & opt (some (enum modes)) None
      & info [ "terminal-persistence" ] ~docs ~docv:"MODE" ~doc:(Some doc))
  and+ display = display_term
  and+ cache_enabled =
    let doc =
      Printf.sprintf
        "Enable or disable Dune cache (%s). Default is `%s'."
        (Arg.doc_alts_enum Dune_config.Cache.Toggle.all)
        (Dune_config.Cache.Toggle.to_string Dune_config.default.cache_enabled)
    in
    Arg.(
      value
      & opt (some (enum Dune_config.Cache.Toggle.all)) None
      & info [ "cache" ] ~docs ~env:(Cmd.Env.info ~doc "DUNE_CACHE") ~doc:(Some doc))
  and+ cache_storage_mode =
    let doc =
      Printf.sprintf
        "Dune cache storage mode (%s). Default is `%s'."
        (Arg.doc_alts_enum Dune_config.Cache.Storage_mode.all)
        (Dune_config.Cache.Storage_mode.to_string Dune_config.default.cache_storage_mode)
    in
    Arg.(
      value
      & opt (some (enum Dune_config.Cache.Storage_mode.all)) None
      & info
          [ "cache-storage-mode" ]
          ~docs
          ~env:(Cmd.Env.info ~doc "DUNE_CACHE_STORAGE_MODE")
          ~doc:(Some doc))
  and+ cache_check_probability =
    let doc =
      Printf.sprintf
        "Check build reproducibility by re-executing randomly chosen rules and comparing \
         their results with those stored in Dune cache. Note: by increasing the \
         probability of such checks you slow down the build. The default probability is \
         zero, i.e. no rules are checked."
    in
    Arg.(
      value
      & opt (some float) None
      & info
          [ "cache-check-probability" ]
          ~docs
          ~env:(Cmd.Env.info ~doc "DUNE_CACHE_CHECK_PROBABILITY")
          ~doc:(Some doc))
  and+ action_stdout_on_success =
    Arg.(
      value
      & opt (some (enum Dune_config.Action_output_on_success.all)) None
      & info
          [ "action-stdout-on-success" ]
          ~doc:
            (Some
               "Specify how to deal with the standard output of actions when they \
                succeed. Possible values are: $(b,print) to just print it to Dune's \
                output, $(b,swallow) to completely ignore it and $(b,must-be-empty) to \
                enforce that the action printed nothing. With $(b,must-be-empty), Dune \
                will consider that the action failed if it printed something to its \
                standard output. The default is $(b,print)."))
  and+ action_stderr_on_success =
    Arg.(
      value
      & opt (some (enum Dune_config.Action_output_on_success.all)) None
      & info
          [ "action-stderr-on-success" ]
          ~doc:
            (Some
               "Same as $(b,--action-stdout-on-success) but for standard error instead \
                of standard output. A good default for large mono-repositories is \
                $(b,--action-stdout-on-success=swallow \
                --action-stderr-on-success=must-be-empty). This ensures that a \
                successful build has a \"clean\" empty output."))
  and+ pkg_enabled =
    if allow_pkg_flag
    then
      Arg.(
        value
        & opt (some (enum Dune_config.Pkg_enabled.(all Cli))) None
        & info
            [ "pkg" ]
            ~docs
            ~doc:
              (Some
                 "Enable or disable package management. The default behaviour depends on \
                  whether a lock directory exists."))
    else Term.const None
  in
  { Dune_config.Partial.display
  ; concurrency
  ; sandboxing_preference = Option.map sandboxing_preference ~f:(fun x -> [ x ])
  ; terminal_persistence
  ; cache_enabled
  ; cache_reproducibility_check =
      Option.map
        cache_check_probability
        ~f:Dune_cache.Config.Reproducibility_check.check_with_probability
  ; cache_storage_mode
  ; action_stdout_on_success
  ; action_stderr_on_success
  ; project_defaults = None
  ; pkg_enabled
  ; experimental = None
  }
;;

module Builder = struct
  type t =
    { no_build : No_build.t
    ; debug_dep_path : bool
    ; debug_package_logs : bool
    ; wait_for_filesystem_clock : bool
    ; only_packages : Only_packages.Clflags.t
    ; capture_outputs : bool
    ; diff_command : string option
    ; promote : Dune_engine.Clflags.Promote.t option
    ; ignore_promoted_rules : bool
    ; force : bool
    ; no_print_directory : bool
    ; store_orig_src_dir : bool
    ; default_target : Arg.Dep.t (* For build & runtest only *)
    ; watch : Dune_rpc_impl.Watch_mode_config.t
    ; dump_gc_stats : Path.External.t option
    ; always_show_command_line : bool
    ; promote_install_files : bool
    ; file_watcher : Scheduler.Run.file_watcher
    ; workspace_config : Workspace.Clflags.t
    ; report_errors_config : Dune_engine.Report_errors_config.t
    ; separate_error_messages : bool
    ; stop_on_first_error : bool
    ; require_dune_project_file : bool
    ; watch_exclusions : string list
    ; build_dir : string
    ; root : string option
    ; trace_file : [ `Default | `User_specified of string ] option
    ; allow_builds : bool
    ; default_root_is_cwd : bool
    ; target_exec : string option
    }

  let set_no_build t no_build = { t with no_build }
  let root t = t.root
  let set_root t root = { t with root = Some root }
  let forbid_builds t = { t with allow_builds = false; no_print_directory = true }
  let default_root_is_cwd t = t.default_root_is_cwd
  let set_default_root_is_cwd t x = { t with default_root_is_cwd = x }
  let disable_log_file t = { t with trace_file = None }
  let set_promote t v = { t with promote = Some v }
  let default_target t = t.default_target

  (** Cmdliner documentation markup language
      (https://erratique.ch/software/cmdliner/doc/tool_man.html#doclang)
      requires that dollar signs (ex. $(tname)) and backslashes are escaped. *)
  let docmarkup_escape s =
    let b = Buffer.create (2 * String.length s) in
    for i = 0 to String.length s - 1 do
      match s.[i] with
      | ('$' | '\\') as c ->
        Buffer.add_char b '\\';
        Buffer.add_char b c
      | c -> Buffer.add_char b c
    done;
    Buffer.contents b
  ;;

  let make_term ~(trace : bool) ~allow_pkg_flag =
    let docs = copts_sect in
    let+ no_build = No_build.term
    and+ config_from_command_line = shared_with_config_file ~allow_pkg_flag
    and+ debug_dep_path =
      Arg.(
        value
        & flag
        & info
            [ "debug-dependency-path" ]
            ~docs
            ~doc:
              (Some
                 "In case of error, print the dependency path from the targets on the \
                  command line to the rule that failed."))
    and+ debug_package_logs =
      let doc = "Always print the standard logs when building packages" in
      Arg.(
        value
        & flag
        & info
            [ "debug-package-logs" ]
            ~docs
            ~doc:(Some doc)
            ~env:(Cmd.Env.info ~doc "DUNE_DEBUG_PACKAGE_LOGS"))
    and+ no_buffer =
      let doc =
        "Do not buffer the output of commands executed by dune. By default dune 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
      Arg.(value & flag & info [ "no-buffer" ] ~docs ~docv:"DIR" ~doc:(Some doc))
    and+ workspace_file =
      let doc = "Use this specific workspace file instead of looking it up." in
      Arg.(
        value
        & opt (some external_path) None
        & info
            [ "workspace" ]
            ~docs
            ~docv:"FILE"
            ~doc:(Some doc)
            ~env:(Cmd.Env.info ~doc "DUNE_WORKSPACE"))
    and+ promote =
      one_of
        (let+ auto =
           Arg.(
             value
             & flag
             & info
                 [ "auto-promote" ]
                 ~docs
                 ~doc:
                   (Some
                      "Automatically promote files. This is similar to running $(b,dune \
                       promote) after the build."))
         in
         Option.some_if auto Dune_engine.Clflags.Promote.Automatically)
        (let+ disable =
           let doc = "Disable all promotion rules" in
           let env = Cmd.Env.info ~doc "DUNE_DISABLE_PROMOTION" in
           Arg.(value & flag & info [ "disable-promotion" ] ~docs ~env ~doc:(Some doc))
         in
         Option.some_if disable Dune_engine.Clflags.Promote.Never)
    and+ force =
      Arg.(
        value
        & flag
        & info
            [ "force"; "f" ]
            ~doc:
              (Some
                 "Force actions associated to aliases to be re-executed even if their \
                  dependencies haven't changed."))
    and+ watch =
      let+ res =
        one_of
          (let+ watch =
             Arg.(
               value
               & flag
               & info
                   [ "watch"; "w" ]
                   ~doc:
                     (Some
                        "Instead of terminating build after completion, wait \
                         continuously for file changes."))
           in
           if watch then Some Dune_rpc_impl.Watch_mode_config.Eager else None)
          (let+ watch =
             Arg.(
               value
               & flag
               & info
                   [ "passive-watch-mode" ]
                   ~doc:
                     (Some
                        "Similar to [--watch], but only start a build when instructed \
                         externally by an RPC."))
           in
           if watch then Some Dune_rpc_impl.Watch_mode_config.Passive else None)
      in
      match res with
      | None -> Dune_rpc_impl.Watch_mode_config.No
      | Some mode -> Yes mode
    and+ dump_gc_stats =
      Arg.(
        value
        & opt (some string) None
        & info
            [ "dump-gc-stats" ]
            ~docs
            ~docv:"FILE"
            ~doc:
              (Some
                 "Dump the garbage collector stats to a file after the build is complete."))
    and+ { Options_implied_by_dash_p.root
         ; only_packages
         ; ignore_promoted_rules
         ; config_from_config_file
         ; profile
         ; default_target
         ; always_show_command_line
         ; promote_install_files
         ; require_dune_project_file
         }
      =
      Options_implied_by_dash_p.term
    and+ x =
      let doc = "Cross-compile using this toolchain." in
      Arg.(
        value
        & opt (some Arg.context_name) None
        & info [ "x" ] ~docs ~doc:(Some doc) ~env:(Cmd.Env.info ~doc "DUNE_CROSS_TARGET"))
    and+ target_exec =
      let doc =
        "Wrapper command for running target binaries when cross-compiling. Format: \
         TOOLCHAIN=CMD (e.g., 'windows=wine')."
      in
      Arg.(
        value
        & opt (some string) None
        & info
            [ "target-exec" ]
            ~docs
            ~docv:"TOOLCHAIN=CMD"
            ~doc:(Some doc)
            ~env:(Cmd.Env.info ~doc "DUNE_TARGET_EXEC"))
    and+ build_dir =
      let doc = "Specified build directory. _build if unspecified" in
      Arg.(
        value
        & opt (some string) None
        & info
            [ "build-dir" ]
            ~docs
            ~docv:"FILE"
            ~env:(Cmd.Env.info ~doc "DUNE_BUILD_DIR")
            ~doc:(Some doc))
    and+ diff_command =
      let doc =
        "Shell command to use to diff files. Use - to disable printing the diff."
      in
      Arg.(
        value
        & opt (some string) None
        & info
            [ "diff-command" ]
            ~docs
            ~env:(Cmd.Env.info ~doc "DUNE_DIFF_COMMAND")
            ~doc:(Some doc))
    and+ trace_file =
      Arg.(
        value
        & opt (some string) None
        & info
            [ "trace-file" ]
            ~docs
            ~docv:"FILE"
            ~doc:
              (Some
                 "Output trace data in catapult format (compatible with \
                  chrome://tracing)."))
    and+ no_print_directory =
      Arg.(
        value
        & flag
        & info
            [ "no-print-directory" ]
            ~docs
            ~doc:(Some "Suppress \"Entering directory\" messages."))
    and+ store_orig_src_dir =
      let doc = "Store original source location in dune-package metadata." in
      Arg.(
        value
        & flag
        & info
            [ "store-orig-source-dir" ]
            ~docs
            ~env:(Cmd.Env.info ~doc "DUNE_STORE_ORIG_SOURCE_DIR")
            ~doc:(Some doc))
    and+ instrument_with =
      let doc =
        "Enable instrumentation by $(b,BACKENDS). $(b,BACKENDS) is a comma-separated \
         list of library names, each one of which must declare an instrumentation \
         backend."
      in
      Arg.(
        value
        & opt (some (list lib_name)) None
        & info
            [ "instrument-with" ]
            ~docs
            ~env:(Cmd.Env.info ~doc "DUNE_INSTRUMENT_WITH")
            ~docv:"BACKENDS"
            ~doc:(Some doc))
    and+ file_watcher =
      let doc =
        "Mechanism to detect changes in the source. Automatic to make dune run an \
         external program to detect changes. Manual to notify dune that files have \
         changed manually."
      in
      Arg.(
        value
        & opt
            (enum [ "automatic", Scheduler.Run.Automatic; "manual", No_watcher ])
            Automatic
        & info [ "file-watcher" ] ~doc:(Some doc))
    and+ watch_exclusions =
      let std_exclusions = Dune_config.standard_watch_exclusions in
      let doc =
        let escaped_std_exclusions = List.map ~f:docmarkup_escape std_exclusions in
        "Adds a POSIX regular expression that will exclude matching directories from \
         $(b,`dune build --watch`). The option $(opt) can be repeated to add multiple \
         exclusions. Semicolons can be also used as a separator. If no exclusions are \
         provided, then a standard set of exclusions is used; however, if $(i,one or \
         more) $(opt) are used, $(b,none) of the standard exclusions are used. The \
         standard exclusions are: "
        ^ String.concat ~sep:" " escaped_std_exclusions
      in
      let arg =
        Arg.(
          value
          & opt_all (list ~sep:';' string) [ std_exclusions ]
          & info [ "watch-exclusions" ] ~docs ~docv:"REGEX" ~doc:(Some doc))
      in
      Term.(const List.flatten $ arg)
    and+ wait_for_filesystem_clock =
      Arg.(
        value
        & flag
        & info
            [ "wait-for-filesystem-clock" ]
            ~doc:
              (Some
                 "Dune digest file contents for better incrementally. These digests are \
                  themselves cached. In some cases, Dune needs to drop some digest cache \
                  entries in order for things to be reliable. This option makes Dune \
                  wait for the file system clock to advance so that it doesn't need to \
                  drop anything. You should probably not care about this option; it is \
                  mostly useful for Dune developers to make Dune tests of the digest \
                  cache more reproducible."))
    and+ report_errors_config =
      Arg.(
        value
        & opt
            (enum
               [ "early", Dune_engine.Report_errors_config.Early
               ; "deterministic", Deterministic
               ; "twice", Twice
               ])
            Dune_engine.Report_errors_config.default
        & info
            [ "error-reporting" ]
            ~doc:
              (Some
                 "Controls when the build errors are reported. $(b,early) reports errors \
                  as soon as they are discovered. $(b,deterministic) reports errors at \
                  the end of the build in a deterministic order. $(b,twice) reports each \
                  error twice: once as soon as the error is discovered and then again at \
                  the end of the build, in a deterministic order."))
    and+ separate_error_messages =
      Arg.(
        value
        & flag
        & info
            [ "display-separate-messages" ]
            ~doc:(Some "Separate error messages with a blank line."))
    and+ stop_on_first_error =
      Arg.(
        value
        & flag
        & info
            [ "stop-on-first-error" ]
            ~doc:(Some "Stop the build as soon as an error is encountered."))
    in
    { no_build
    ; debug_dep_path
    ; debug_package_logs
    ; wait_for_filesystem_clock
    ; only_packages
    ; capture_outputs = not no_buffer
    ; diff_command
    ; promote
    ; ignore_promoted_rules
    ; force
    ; no_print_directory
    ; store_orig_src_dir
    ; default_target
    ; watch
    ; dump_gc_stats =
        Option.map dump_gc_stats ~f:Path.External.of_filename_relative_to_initial_cwd
    ; always_show_command_line
    ; promote_install_files
    ; file_watcher
    ; workspace_config =
        { x
        ; profile
        ; instrument_with
        ; workspace_file =
            Option.map workspace_file ~f:(fun p ->
              Path.Outside_build_dir.External (Arg.Path.External.path p))
        ; config_from_command_line
        ; config_from_config_file
        }
    ; report_errors_config
    ; separate_error_messages
    ; stop_on_first_error
    ; require_dune_project_file
    ; watch_exclusions
    ; build_dir = Option.value ~default:default_build_dir build_dir
    ; root
    ; trace_file =
        (match trace_file with
         | Some s -> Some (`User_specified s)
         | None -> if trace then Some `Default else None)
    ; allow_builds = true
    ; default_root_is_cwd = false
    ; target_exec
    }
  ;;

  let term_no_trace_no_pkg = make_term ~trace:false ~allow_pkg_flag:false
  let term = make_term ~trace:true ~allow_pkg_flag:true
  let default = Term.eval_no_args_empty_env term

  let equal
        t
        { no_build
        ; debug_dep_path
        ; debug_package_logs
        ; wait_for_filesystem_clock
        ; only_packages
        ; capture_outputs
        ; diff_command
        ; promote
        ; ignore_promoted_rules
        ; force
        ; no_print_directory
        ; store_orig_src_dir
        ; default_target
        ; watch
        ; dump_gc_stats
        ; always_show_command_line
        ; promote_install_files
        ; file_watcher
        ; workspace_config
        ; report_errors_config
        ; separate_error_messages
        ; stop_on_first_error
        ; require_dune_project_file
        ; watch_exclusions
        ; build_dir
        ; root
        ; trace_file
        ; allow_builds
        ; default_root_is_cwd
        ; target_exec
        }
    =
    No_build.equal t.no_build no_build
    && Bool.equal t.debug_dep_path debug_dep_path
    && Bool.equal t.debug_package_logs debug_package_logs
    && Bool.equal t.wait_for_filesystem_clock wait_for_filesystem_clock
    && Only_packages.Clflags.equal t.only_packages only_packages
    && Bool.equal t.capture_outputs capture_outputs
    && Option.equal String.equal t.diff_command diff_command
    && Option.equal Dune_engine.Clflags.Promote.equal t.promote promote
    && Bool.equal t.ignore_promoted_rules ignore_promoted_rules
    && Bool.equal t.force force
    && Bool.equal t.no_print_directory no_print_directory
    && Bool.equal t.store_orig_src_dir store_orig_src_dir
    && Arg.Dep.equal t.default_target default_target
    && Dune_rpc_impl.Watch_mode_config.equal t.watch watch
    && Option.equal Path.External.equal t.dump_gc_stats dump_gc_stats
    && Bool.equal t.always_show_command_line always_show_command_line
    && Bool.equal t.promote_install_files promote_install_files
    && Scheduler.Run.file_watcher_equal t.file_watcher file_watcher
    && Source.Workspace.Clflags.equal t.workspace_config workspace_config
    && Dune_engine.Report_errors_config.equal t.report_errors_config report_errors_config
    && Bool.equal t.separate_error_messages separate_error_messages
    && Bool.equal t.stop_on_first_error stop_on_first_error
    && Bool.equal t.require_dune_project_file require_dune_project_file
    && List.equal String.equal t.watch_exclusions watch_exclusions
    && String.equal t.build_dir build_dir
    && Option.equal String.equal t.root root
    && Option.equal
         (fun a b ->
            match a, b with
            | `Default, `Default -> true
            | `User_specified a, `User_specified b -> String.equal a b
            | _ -> false)
         t.trace_file
         trace_file
    && Bool.equal t.allow_builds allow_builds
    && Bool.equal t.default_root_is_cwd default_root_is_cwd
    && Option.equal String.equal t.target_exec target_exec
  ;;
end

type t =
  { builder : Builder.t
  ; root : Workspace_root.t
  ; rpc :
      [ `Allow of Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t Lazy.t | `Forbid_builds ]
  }

let capture_outputs t = t.builder.capture_outputs
let root t = t.root
let watch t = t.builder.watch
let x t = t.builder.workspace_config.x
let file_watcher t = t.builder.file_watcher
let prefix_target t s = t.root.reach_from_root_prefix ^ s

let rpc t =
  match t.rpc with
  | `Forbid_builds -> `Forbid_builds
  | `Allow rpc -> `Allow (Lazy.force rpc)
;;

let watch_exclusions t = t.builder.watch_exclusions

(* To avoid needless recompilations under Windows, where the case of
   [Sys.getcwd] can vary between different invocations of [dune], normalize to
   lowercase. *)
let normalize_path path =
  if Sys.win32
  then (
    let src = Path.External.to_string path in
    let is_letter = function
      | 'a' .. 'z' | 'A' .. 'Z' -> true
      | _ -> false
    in
    if String.length src >= 2 && is_letter src.[0] && src.[1] = ':'
    then (
      let dst = Bytes.create (String.length src) in
      Bytes.set dst 0 (Char.uppercase_ascii src.[0]);
      Bytes.blit_string ~src ~src_pos:1 ~dst ~dst_pos:1 ~len:(String.length src - 1);
      Path.External.of_string (Bytes.unsafe_to_string dst))
    else path)
  else path
;;

let print_entering_message c =
  let cwd = Path.to_absolute_filename Path.root in
  if cwd <> Fpath.initial_cwd && not c.builder.no_print_directory
  then (
    (* Editors such as Emacs parse the output of the build system and interpret
       filenames in error messages relative to where the build system was
       started.

       If the build system changes directory, the editor will not be able to
       correctly locate files. However, such editors also understand messages of
       the form "Entering directory '<dir>'" that the "make" command prints.

       This is why Dune also prints such a message; this way people running Dune
       through such an editor will be able to use the "jump to error" feature of
       their editor. *)
    let dir =
      match Execution_env.inside_dune with
      | false -> cwd
      | true ->
        let descendant_simple p ~of_ =
          match String.drop_prefix p ~prefix:of_ with
          | None | Some "" -> None
          | Some s -> Some (String.drop s 1)
        in
        (match descendant_simple cwd ~of_:Fpath.initial_cwd with
         | Some s -> s
         | None ->
           (match descendant_simple Fpath.initial_cwd ~of_:cwd with
            | None -> cwd
            | Some s ->
              let rec loop acc dir =
                if dir = Filename.current_dir_name
                then acc
                else loop (Filename.concat acc "..") (Filename.dirname dir)
              in
              loop ".." (Filename.dirname s)))
    in
    Console.set_directory dir)
;;

(* CR-someday rleshchinskiy: The split between `build` and `init` seems quite arbitrary,
   we should probably refactor that at some point. *)
let build (root : Workspace_root.t) (builder : Builder.t) =
  let rpc =
    if builder.allow_builds
    then
      `Allow
        (lazy
          (let registry =
             match builder.watch with
             | Yes _ -> `Add
             | No -> `Skip
           in
           let lock_timeout =
             match builder.watch with
             | Yes Passive -> Some (Time.Span.of_secs 1.0)
             | _ -> None
           in
           Dune_rpc_impl.Server.create ~lock_timeout ~registry ~root:root.dir))
    else `Forbid_builds
  in
  { builder; root; rpc }
;;

let maybe_init_cache (cache_config : Dune_cache.Config.t) =
  match cache_config with
  | Disabled -> cache_config
  | Enabled _ ->
    (match Dune_cache.Layout.create_cache_directories () with
     | Ok () -> cache_config
     | Error (path, exn) ->
       User_warning.emit
         ~hints:
           [ Pp.textf "Make sure the directory %s can be created" (Path.to_string path) ]
         [ Pp.textf
             "Cache directories could not be created: %s; disabling cache"
             (Unix.error_message exn)
         ];
       Disabled)
;;

let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) =
  let c = build root builder in
  No_build.set c.builder.no_build;
  if c.root.dir <> Filename.current_dir_name then Sys.chdir c.root.dir;
  Path.set_root (normalize_path (Path.External.cwd ()));
  Path.Build.set_build_dir (Path.Outside_build_dir.of_string c.builder.build_dir);
  let () =
    match builder.trace_file with
    | None -> Log.init No_log_file
    | Some trace_config ->
      (match
         (* For default location, try to acquire lock first to avoid corrupting
           an existing trace from another dune process *)
         match trace_config with
         | `Default ->
           (match Global_lock.lock ~timeout:None with
            | Ok () -> `Create
            | Error _ -> `Skip)
         | `User_specified _ -> `Create
       with
       | `Skip -> Log.init No_log_file
       | `Create ->
         let trace =
           match trace_config with
           | `Default -> Path.build (Path.Build.relative Path.Build.root trace_file_name)
           | `User_specified stats -> Path.of_filename_relative_to_initial_cwd stats
         in
         Path.parent trace |> Option.iter ~f:Path.mkdir_p;
         (match trace_config with
          | `Default ->
            let path = Path.to_string trace in
            (match Fpath.rename_exn path (path ^ ".old") with
             | () -> ()
             | exception Unix.Unix_error _ -> ())
          | `User_specified _ -> ());
         let stats = Dune_trace.Out.create trace in
         Dune_trace.set_global stats;
         Dune_trace.Event.init
           ~version:
             (Build_info.V1.version () |> Option.map ~f:Build_info.V1.Version.to_string)
         |> Dune_trace.always_emit;
         Log.init
           (Redirect (fun w -> Dune_trace.emit Log (fun () -> Dune_trace.Event.log w))))
  in
  (* We need to print this before reading the workspace file, so that the editor
     can interpret errors in the workspace file. *)
  print_entering_message c;
  Workspace.Clflags.set c.builder.workspace_config;
  let config =
    (* Here we make the assumption that this computation doesn't yield. *)
    Fiber.run (Memo.run (Workspace.workspace_config ())) ~iter:(fun () -> assert false)
  in
  let config =
    Dune_config.adapt_display
      config
      ~output_is_a_tty:(Lazy.force Ansi_color.output_is_a_tty)
  in
  Dune_config.init
    config
    ~watch:
      (match c.builder.watch with
       | No -> false
       | Yes _ -> true);
  Dune_engine.Execution_parameters.init
    (let open Memo.O in
     let+ w = Workspace.workspace () in
     Dune_engine.Execution_parameters.builtin_default
     |> Workspace.update_execution_parameters w);
  Dune_rules.Global.init ~capture_outputs:c.builder.capture_outputs;
  let cache_config =
    match config.cache_enabled with
    | Disabled -> Dune_cache.Config.Disabled
    | Enabled_except_user_rules | Enabled ->
      Enabled
        { storage_mode = Option.value config.cache_storage_mode ~default:Hardlink
        ; reproducibility_check = config.cache_reproducibility_check
        }
  in
  Log.info
    "Shared cache enabled"
    [ "cache_enabled", Dune_config.Cache.Toggle.to_dyn config.cache_enabled ];
  Log.info
    "Shared cache location"
    [ ( "root_dir"
      , Dyn.string (Path.to_string (Lazy.force Dune_cache.Layout.build_cache_dir)) )
    ];
  Dune_cache.Shared.config := maybe_init_cache cache_config;
  Dune_rules.Main.init ~sandboxing_preference:config.sandboxing_preference ();
  Only_packages.Clflags.set c.builder.only_packages;
  Report_error.print_memo_stacks := c.builder.debug_dep_path;
  Dune_engine.Clflags.report_errors_config := c.builder.report_errors_config;
  Dune_rules.Clflags.debug_package_logs := c.builder.debug_package_logs;
  Dune_engine.Clflags.wait_for_filesystem_clock := c.builder.wait_for_filesystem_clock;
  Dune_engine.Clflags.capture_outputs := c.builder.capture_outputs;
  Dune_engine.Clflags.diff_command := c.builder.diff_command;
  Dune_engine.Clflags.promote := c.builder.promote;
  Dune_engine.Clflags.force := c.builder.force;
  Dune_engine.Clflags.stop_on_first_error := c.builder.stop_on_first_error;
  Dune_rules.Clflags.store_orig_src_dir := c.builder.store_orig_src_dir;
  Dune_rules.Clflags.promote_install_files := c.builder.promote_install_files;
  Dune_engine.Clflags.always_show_command_line := c.builder.always_show_command_line;
  Dune_rules.Clflags.ignore_promoted_rules := c.builder.ignore_promoted_rules;
  Source.Clflags.on_missing_dune_project_file
  := if c.builder.require_dune_project_file then Error else Warn;
  (Dune_engine.Clflags.can_go_in_shared_cache_default
   := match config.cache_enabled with
      | Disabled | Enabled_except_user_rules -> false
      | Enabled -> true);
  (match c.builder.target_exec with
   | None -> Dune_engine.Clflags.target_exec := None
   | Some spec ->
     let toolchain, wrapper_cmd =
       match String.lsplit2 spec ~on:'=' with
       | Some (tc, cmd) -> tc, cmd
       | None -> User_error.raise [ Pp.textf "--target-exec: invalid format" ]
     in
     let parts =
       String.split wrapper_cmd ~on:' '
       |> List.filter ~f:(fun s -> not (String.is_empty s))
     in
     (match parts with
      | [] ->
        User_error.raise [ Pp.textf "--target-exec: wrapper command cannot be empty" ]
      | prog :: args -> Dune_engine.Clflags.target_exec := Some (toolchain, prog, args)));
  Log.info
    "Workspace root"
    [ "root", Dyn.string (Path.to_absolute_filename Path.root |> String.maybe_quoted) ];
  Console.separate_messages c.builder.separate_error_messages;
  (* Setup hook for printing GC stats to a file *)
  at_exit (fun () ->
    match c.builder.dump_gc_stats with
    | None -> ()
    | Some file ->
      Gc.full_major ();
      Gc.compact ();
      let stat = Gc.stat () in
      let path = Path.external_ file in
      Dune_util.Gc.serialize ~path stat);
  c, config
;;

let init (builder : Builder.t) =
  let root =
    Workspace_root.create_exn
      ~from:Filename.current_dir_name
      ~default_is_cwd:builder.default_root_is_cwd
      ~specified_by_user:builder.root
      ()
  in
  init_with_root ~root builder
;;

let footer =
  `Blocks [ `S "BUGS"; `P "Check bug reports at https://github.com/ocaml/dune/issues" ]
;;

let examples = function
  | [] -> `Blocks []
  | _ :: _ as examples ->
    let block_of_example index (intro, ex) =
      let prose = `I (Int.to_string (index + 1) ^ ".", String.trim intro ^ ":")
      and code_lines =
        ex
        |> String.trim
        |> String.split_lines
        |> List.concat_map ~f:(fun codeline -> [ `Noblank; `Pre ("      " ^ codeline) ])
        (* suppress initial blank *)
        |> List.tl
      in
      `Blocks (prose :: code_lines)
    in
    let example_blocks = examples |> List.mapi ~f:block_of_example in
    `Blocks (`S Cmdliner.Manpage.s_examples :: example_blocks)
;;

(* Short reminders for the most used and useful commands *)
let command_synopsis commands =
  let format_command c acc = `Noblank :: `P (Printf.sprintf "$(b,dune %s)" c) :: acc in
  [ `S "SYNOPSIS"; `Blocks (List.fold_right ~init:[] ~f:format_command commands) ]
;;

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."
  ; footer
  ]
;;

let envs =
  Cmd.Env.
    [ info
        ~doc:
          "If different than $(b,0), ANSI colors are supported and should be used when \
           the program isn't piped. If equal to $(b,0), don't output ANSI color escape \
           codes"
        "CLICOLOR"
    ; info
        ~doc:"If different than $(b,0), ANSI colors should be enabled no matter what."
        "CLICOLOR_FORCE"
    ; info
        ~doc:"If set, determines the location of all the different caches used by dune."
        "DUNE_CACHE_ROOT"
    ]
;;

let config_from_config_file = Options_implied_by_dash_p.config_term

let context_arg ~doc =
  Arg.(
    value
    & opt Arg.context_name Dune_engine.Context_name.default
    & info [ "context" ] ~docv:"CONTEXT" ~doc)
;;
