include Stdune
include Dune_config_file
include Dune_vcs

include struct
  open Dune_engine
  module Build_config = Build_config
  module Build_system = Build_system
  module Build_system_error = Build_system_error
  module Load_rules = Load_rules
  module Hooks = Hooks
  module Action_builder = Dune_rules.Action_builder
  module Action = Action
  module Dep = Dep
  module Action_to_sh = Action_to_sh
  module Dpath = Dpath
  module Findlib = Dune_rules.Findlib
  module Diff_promotion = Diff_promotion
  module Targets = Targets
  module Context_name = Context_name
end

module Cached_digest = Dune_digest.Cached_digest

include struct
  open Source
  module Source_tree = Source_tree
  module Source_dir_status = Source_dir_status
  module Workspace = Workspace
end

include struct
  open Dune_rules
  module Super_context = Super_context
  module Context = Context
  module Dune_package = Dune_package
  module Resolve = Resolve
  module Dune_file = Dune_file
  module Library = Library
  module Melange = Melange
  module Melange_stanzas = Melange_stanzas
  module Executables = Executables
end

include struct
  open Cmdliner
  module Term = Term
  module Manpage = Manpage

  module Cmd = struct
    include Cmd

    let default_exits = List.map ~f:Exit_code.info Exit_code.all

    let info ?docs ?doc ?man ?envs ?version name =
      info ?docs ?doc ?man ?envs ?version ~exits:default_exits name
    ;;
  end
end

module Digest = Dune_digest
module Metrics = Dune_metrics
module Console = Dune_console

include struct
  open Dune_lang
  module Stanza = Stanza
  module Profile = Profile
  module Lib_name = Lib_name
  module Package_name = Package_name
  module Package = Package
  module Package_version = Package_version
  module Source_kind = Source_kind
  module Package_info = Package_info
  module Section = Section
  module Dune_project_name = Dune_project_name
  module Dune_project = Dune_project
end

module Log = Dune_util.Log
module Dune_rpc = Dune_rpc_private
module Graph = Dune_graph.Graph
include Common.Let_syntax

module Main : sig
  include module type of struct
    include Dune_rules.Main
  end

  val setup : unit -> build_system Memo.t Fiber.t
end = struct
  include Dune_rules.Main

  let setup () =
    let open Fiber.O in
    let* scheduler = Dune_engine.Scheduler.t () in
    Console.Status_line.set
      (Live
         (fun () ->
           match Fiber.Svar.read Build_system.state with
           | Initializing
           | Restarting_current_build
           | Build_succeeded__now_waiting_for_changes
           | Build_failed__now_waiting_for_changes -> Pp.nop
           | Building
               { Build_system.Progress.number_of_rules_executed = done_
               ; number_of_rules_discovered = total
               ; number_of_rules_failed = failed
               } ->
             Pp.verbatim
               (sprintf
                  "Done: %u%% (%u/%u, %u left%s) (jobs: %u)"
                  (if total = 0 then 0 else done_ * 100 / total)
                  done_
                  total
                  (total - done_)
                  (if failed = 0 then "" else sprintf ", %u failed" failed)
                  (Dune_engine.Scheduler.running_jobs_count scheduler))));
    Fiber.return (Memo.of_thunk get)
  ;;
end

module Scheduler = struct
  include Dune_engine.Scheduler

  let maybe_clear_screen ~details_hum (dune_config : Dune_config.t) =
    match Execution_env.inside_dune with
    | true -> (* Don't print anything here to make tests less verbose *) ()
    | false ->
      (match dune_config.terminal_persistence with
       | Clear_on_rebuild -> Console.reset ()
       | Clear_on_rebuild_and_flush_history -> Console.reset_flush_history ()
       | Preserve ->
         let message =
           sprintf
             "********** NEW BUILD (%s) **********"
             (String.concat ~sep:", " details_hum)
         in
         Console.print_user_message
           (User_message.make
              [ Pp.nop; Pp.tag User_message.Style.Success (Pp.verbatim message); Pp.nop ]))
  ;;

  let on_event dune_config _config = function
    | Run.Event.Tick -> Console.Status_line.refresh ()
    | Source_files_changed { details_hum } -> maybe_clear_screen ~details_hum dune_config
    | Build_interrupted ->
      Console.Status_line.set
        (Live
           (fun () ->
             let progression =
               match Fiber.Svar.read Build_system.state with
               | Initializing
               | Restarting_current_build
               | Build_succeeded__now_waiting_for_changes
               | Build_failed__now_waiting_for_changes -> Build_system.Progress.init
               | Building progress -> progress
             in
             Pp.seq
               (Pp.tag User_message.Style.Error (Pp.verbatim "Source files changed"))
               (Pp.verbatim
                  (sprintf
                     ", restarting current build... (%u/%u)"
                     progression.number_of_rules_executed
                     progression.number_of_rules_discovered))))
    | Build_finish build_result ->
      let message =
        match build_result with
        | Success -> Pp.tag User_message.Style.Success (Pp.verbatim "Success")
        | Failure ->
          let failure_message =
            match
              Build_system_error.(
                Id.Map.cardinal (Set.current (Fiber.Svar.read Build_system.errors)))
            with
            | 1 -> Pp.textf "Had 1 error"
            | n -> Pp.textf "Had %d errors" n
          in
          Pp.tag User_message.Style.Error failure_message
      in
      Console.Status_line.set
        (Constant (Pp.seq message (Pp.verbatim ", waiting for filesystem changes...")))
  ;;

  let rpc server =
    { Dune_engine.Rpc.run = Dune_rpc_impl.Server.run server
    ; stop = Dune_rpc_impl.Server.stop server
    ; ready = Dune_rpc_impl.Server.ready server
    }
  ;;

  let go_without_rpc_server ~(common : Common.t) ~config:dune_config f =
    let stats = Common.stats common in
    let config =
      let watch_exclusions = Common.watch_exclusions common in
      Dune_config.for_scheduler
        dune_config
        stats
        ~print_ctrl_c_warning:true
        ~watch_exclusions
    in
    Dune_rules.Clflags.concurrency := config.concurrency;
    Run.go config ~on_event:(on_event dune_config) f
  ;;

  let go_with_rpc_server ~common ~config f =
    let f =
      match Common.rpc common with
      | `Allow server -> fun () -> Dune_engine.Rpc.with_background_rpc (rpc server) f
      | `Forbid_builds -> f
    in
    go_without_rpc_server ~common ~config f
  ;;

  let go_with_rpc_server_and_console_status_reporting
        ~(common : Common.t)
        ~config:dune_config
        run
    =
    let server =
      match Common.rpc common with
      | `Allow server -> rpc server
      | `Forbid_builds -> Code_error.raise "rpc must be enabled in polling mode" []
    in
    let stats = Common.stats common in
    let config =
      let watch_exclusions = Common.watch_exclusions common in
      Dune_config.for_scheduler
        dune_config
        stats
        ~print_ctrl_c_warning:true
        ~watch_exclusions
    in
    Dune_rules.Clflags.concurrency := config.concurrency;
    let file_watcher = Common.file_watcher common in
    let run () =
      let open Fiber.O in
      Dune_engine.Rpc.with_background_rpc server
      @@ fun () ->
      let* () = Dune_engine.Rpc.ensure_ready () in
      run ()
    in
    Run.go config ~file_watcher ~on_event:(on_event dune_config) run
  ;;
end

let string_path_relative_to_specified_root (root : Workspace_root.t) path =
  if Filename.is_relative path then Filename.concat root.dir path else path
;;

let restore_cwd_and_execve root prog args env =
  let prog = string_path_relative_to_specified_root root prog in
  Proc.restore_cwd_and_execve prog args ~env
;;

(* Adapted from
   https://github.com/ocaml/opam/blob/fbbe93c3f67034da62d28c8666ec6b05e0a9b17c/src/client/opamArg.ml#L759 *)
let command_alias ?orig_name cmd term name =
  let orig =
    match orig_name with
    | Some s -> s
    | None -> Cmd.name cmd
  in
  let doc = Printf.sprintf "An alias for $(b,%s)." orig in
  let man =
    [ `S "DESCRIPTION"
    ; `P (Printf.sprintf "$(mname)$(b, %s) is an alias for $(mname)$(b, %s)." name orig)
    ; `P (Printf.sprintf "See $(mname)$(b, %s --help) for details." orig)
    ; `Blocks Common.help_secs
    ]
  in
  Cmd.v (Cmd.info name ~docs:"COMMAND ALIASES" ~doc ~man) term
;;

(* The build system has some global state which makes it unsafe for
   multiple instances of it to be executed concurrently, so we ensure
   serialization by holding this mutex while running the build system. *)
let build_system_mutex = Fiber.Mutex.create ()

let build f =
  Hooks.End_of_build.once Promote.Diff_promotion.finalize;
  Fiber.Mutex.with_lock build_system_mutex ~f:(fun () -> Build_system.run f)
;;

let build_exn f =
  Hooks.End_of_build.once Promote.Diff_promotion.finalize;
  Fiber.Mutex.with_lock build_system_mutex ~f:(fun () -> Build_system.run_exn f)
;;