open Import
open Fiber.O

let () = Inline_tests.linkme

type setup =
  { build_system : Build_system.t
  ; contexts     : Context.t list
  ; scontexts    : Super_context.t String_map.t
  ; packages     : Package.t Package.Name.Map.t
  ; file_tree    : File_tree.t
  ; env          : Env.t
  }

let package_install_file { packages; _ } pkg =
  match Package.Name.Map.find packages pkg with
  | None -> Error ()
  | Some p ->
    Ok (Path.relative p.path
          (Utils.install_file ~package:p.name ~findlib_toolchain:None))

let setup_env ~capture_outputs =
  let env =
    if capture_outputs || not (Lazy.force Colors.stderr_supports_colors) then
      Env.initial
    else
      Colors.setup_env_for_colors Env.initial
  in
  Env.add env ~var:"INSIDE_DUNE" ~value:"1"

let setup ?(log=Log.no_log)
      ?external_lib_deps_mode
      ?workspace ?workspace_file
      ?only_packages
      ?extra_ignored_subtrees
      ?x
      ?ignore_promoted_rules
      ?(capture_outputs=true)
      ?profile
      () =
  let env = setup_env ~capture_outputs in
  let conf =
    Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules ()
  in
  Option.iter only_packages ~f:(fun set ->
    Package.Name.Set.iter set ~f:(fun pkg ->
      if not (Package.Name.Map.mem conf.packages pkg) then
        let pkg_name = Package.Name.to_string pkg in
        die "@{<error>Error@}: I don't know about package %s \
             (passed through --only-packages/--release)%s"
          pkg_name
          (hint pkg_name
             (Package.Name.Map.keys conf.packages
             |> List.map ~f:Package.Name.to_string))));
  let workspace =
    match workspace with
    | Some w -> w
    | None ->
      match workspace_file with
      | Some p ->
        Workspace.load ?x ?profile p
      | _ ->
        match
          List.find_map ["dune-workspace"; "jbuild-workspace"] ~f:(fun fn ->
            let p = Path.of_string fn in
            if Path.exists p then
              Some p
            else
              None)
        with
        | Some p -> Workspace.load ?x ?profile p
        | None ->
          { merlin_context = Some "default"
          ; contexts = [Default
                          { targets = [
                              match x with
                              | None   -> Native
                              | Some x -> Named x
                            ]
                          ; profile = Option.value profile ~default:"default"
                          }]
          }
  in

  Fiber.parallel_map workspace.contexts ~f:(fun ctx_def ->
    let name = Workspace.Context.name ctx_def in
    Context.create ctx_def ~env ~merlin:(workspace.merlin_context = Some name))
  >>= fun contexts ->
  let contexts = List.concat contexts in
  List.iter contexts ~f:(fun (ctx : Context.t) ->
    Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp
      (Context.sexp_of_t ctx));
  let rule_done  = ref 0 in
  let rule_total = ref 0 in
  let gen_status_line () =
    Some (sprintf "Done: %u/%u" !rule_done !rule_total)
  in
  let hook (hook : Build_system.hook) =
    match hook with
    | Rule_started   -> incr rule_total
    | Rule_completed -> incr rule_done
  in
  let build_system =
    Build_system.create ~contexts ~file_tree:conf.file_tree ~hook
  in
  Gen_rules.gen conf
    ~build_system
    ~contexts
    ?only_packages
    ?external_lib_deps_mode
  >>= fun scontexts ->
  Scheduler.set_status_line_generator gen_status_line
  >>>
  Fiber.return
    { build_system
    ; scontexts
    ; contexts
    ; packages = conf.packages
    ; file_tree = conf.file_tree
    ; env
    }

let find_context_exn t ~name =
  match List.find t.contexts ~f:(fun c -> c.name = name) with
  | Some ctx -> ctx
  | None ->
    die "@{<Error>Error@}: Context %S not found!@." name

let external_lib_deps ?log ~packages () =
  Scheduler.go ?log
    (setup () ~external_lib_deps_mode:true
     >>| fun setup ->
     let context = find_context_exn setup ~name:"default" in
     let install_files =
       List.map packages ~f:(fun pkg ->
         match package_install_file setup pkg with
         | Ok path -> Path.append context.build_dir path
         | Error () -> die "Unknown package %S" (Package.Name.to_string pkg))
     in
     let sctx = Option.value_exn (String.Map.find setup.scontexts "default") in
     let internals = Super_context.internal_lib_names sctx in
     Path.Map.map
       (Build_system.all_lib_deps setup.build_system
          ~request:(Build.paths install_files))
       ~f:(String.Map.filteri ~f:(fun name _ ->
         not (String.Set.mem internals name))))

let ignored_during_bootstrap =
  Path.Set.of_list
    (List.map ~f:Path.in_source
       [ "test"
       ; "example"
       ])

let auto_concurrency =
  let v = ref None in
  fun ?(log=Log.no_log) () ->
    match !v with
    | Some n -> Fiber.return n
    | None ->
      (if Sys.win32 then
         match Env.get Env.initial "NUMBER_OF_PROCESSORS" with
         | None -> Fiber.return 1
         | Some s ->
           match int_of_string s with
           | exception _ -> Fiber.return 1
           | n -> Fiber.return n
       else
         let commands =
           [ "nproc", []
           ; "getconf", ["_NPROCESSORS_ONLN"]
           ; "getconf", ["NPROCESSORS_ONLN"]
           ]
         in
         let rec loop = function
           | [] -> Fiber.return 1
           | (prog, args) :: rest ->
             match Bin.which prog with
             | None -> loop rest
             | Some prog ->
               Process.run_capture (Accept All) prog args ~env:Env.initial
               >>= function
               | Error _ -> loop rest
               | Ok s ->
                 match int_of_string (String.trim s) with
                 | n -> Fiber.return n
                 | exception _ -> loop rest
         in
         loop commands)
      >>| fun n ->
      Log.infof log "Auto-detected concurrency: %d" n;
      v := Some n;
      n

let set_concurrency ?log (config : Config.t) =
  (match config.concurrency with
   | Fixed n -> Fiber.return n
   | Auto    -> auto_concurrency ?log ())
  >>= fun n ->
  if n >= 1 then
    Scheduler.set_concurrency n
  else
    Fiber.return ()

(* Called by the script generated by ../build.ml *)
let bootstrap () =
  Colors.setup_err_formatter_colors ();
  Path.set_root Path.External.initial_cwd;
  Path.set_build_dir (Path.Kind.of_string "_build");
  let main () =
    let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
    let subst () =
      Scheduler.go (Watermarks.subst () ~name:"dune");
      exit 0
    in
    let display = ref None in
    let display_mode =
      Arg.Symbol
        (List.map Config.Display.all ~f:fst,
         fun s ->
           display := List.assoc Config.Display.all s)
    in
    let concurrency = ref None in
    let concurrency_arg x =
      match Config.Concurrency.of_string x with
      | Error msg -> raise (Arg.Bad msg)
      | Ok c -> concurrency := Some c
    in
    let profile = ref None in
    Arg.parse
      [ "-j"           , String concurrency_arg, "JOBS concurrency"
      ; "--dev"        , Unit (fun () -> profile := Some "dev"),
        " set development mode"
      ; "--display"    , display_mode          , " set the display mode"
      ; "--subst"      , Unit subst            ,
        " substitute watermarks in source files"
      ; "--debug-backtraces",
        Set Clflags.debug_backtraces,
        " always print exception backtraces"
      ]
      anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
    Clflags.debug_dep_path := true;
    let config =
      (* Only load the configuration with --dev *)
      if !profile = Some "dev" then
        Config.load_user_config_file ()
      else
        Config.default
    in
    let config =
      Config.merge config
        { display     = !display
        ; concurrency = !concurrency
        }
    in
    let config =
      Config.adapt_display config
        ~output_is_a_tty:(Lazy.force Colors.stderr_supports_colors)
    in
    let log = Log.create ~display:config.display () in
    Scheduler.go ~log ~config
      (set_concurrency config
       >>= fun () ->
       setup ~log ~workspace:{ merlin_context = Some "default"
                             ; contexts = [Default { targets = [Native]
                                                   ; profile =
                                                       Option.value !profile
                                                         ~default:"default"
                                                   }
                                          ]
                             }
         ?profile:!profile
         ~extra_ignored_subtrees:ignored_during_bootstrap
         ()
       >>= fun { build_system = bs; _ } ->
       Build_system.do_build bs
         ~request:(Build.path (
           Path.relative Path.build_dir "default/dune.install")))
  in
  try
    main ()
  with
  | Fiber.Never -> exit 1
  | exn ->
    Report_error.report exn;
    exit 1

let setup = setup ~extra_ignored_subtrees:Path.Set.empty

let find_context_exn t ~name =
  match List.find t.contexts ~f:(fun c -> c.name = name) with
  | Some ctx -> ctx
  | None ->
    die "@{<Error>Error@}: Context %S not found!@." name