dune/src/main.ml

open Import
open Fiber.O

let () = Inline_tests.linkme

type setup =
  { build_system : Build_system.t
  ; stanzas      : (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list String_map.t
  ; contexts     : Context.t list
  ; packages     : Package.t Package.Name.Map.t
  ; file_tree    : File_tree.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 ?(log=Log.no_log)
      ?filter_out_optional_stanzas_with_missing_deps
      ?workspace ?(workspace_file="jbuild-workspace")
      ?only_packages
      ?extra_ignored_subtrees
      ?x
      ?ignore_promoted_rules
      () =
  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 ->
      if Sys.file_exists workspace_file then
        Workspace.load ?x workspace_file
      else
        { merlin_context = Some "default"
        ; contexts = [Default [
            match x with
            | None -> Native
            | Some x -> Named x
          ]]
        }
  in

  Fiber.parallel_map workspace.contexts ~f:(fun ctx_def ->
    let name = Workspace.Context.name ctx_def in
    Context.create ctx_def ~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
    ?filter_out_optional_stanzas_with_missing_deps
  >>= fun stanzas ->
  Scheduler.set_status_line_generator gen_status_line
  >>>
  Fiber.return
    { build_system
    ; stanzas
    ; contexts
    ; packages = conf.packages
    ; file_tree = conf.file_tree
    }

let external_lib_deps ?log ~packages () =
  Scheduler.go ?log
    (setup () ~filter_out_optional_stanzas_with_missing_deps:false
     >>| fun setup ->
     let install_files =
       List.map packages ~f:(fun pkg ->
         match package_install_file setup pkg with
         | Ok path -> path
         | Error () -> die "Unknown package %S" (Package.Name.to_string pkg))
     in
     match String_map.find setup.stanzas "default" with
     | None -> die "You need to set a default context to use external-lib-deps"
     | Some stanzas ->
       let internals = Jbuild.Stanzas.lib_names stanzas 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.of_string
       [ "test"
       ; "example"
       ])

(* Called by the script generated by ../build.ml *)
let bootstrap () =
  Colors.setup_err_formatter_colors ();
  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:"jbuilder");
      exit 0
    in
    let display = ref None in
    let display_mode =
      Arg.Symbol
        (List.map Config.Display.all ~f:fst,
         fun s ->
           display := Some (List.assoc s Config.Display.all))
    in
    let concurrency = ref None in
    let set r x = r := Some x in
    Arg.parse
      [ "-j"           , Int (set concurrency), "JOBS concurrency"
      ; "--dev"        , Set Clflags.dev_mode , " 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 !Clflags.dev_mode 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
      (setup ~log ~workspace:{ merlin_context = Some "default"
                             ; contexts = [Default [Native]] }
         ~extra_ignored_subtrees:ignored_during_bootstrap
         ()
       >>= fun { build_system = bs; _ } ->
       Build_system.do_build bs
         ~request:(Build.path (Path.of_string "_build/default/jbuilder.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