open! Import
open Pkg_common
module Package_universe = Dune_pkg.Package_universe
module Lock_dir = Dune_pkg.Lock_dir
module Opam_repo = Dune_pkg.Opam_repo
module Package_version = Dune_pkg.Package_version
module Opam_solver = Dune_pkg.Opam_solver

let info =
  let doc = "Validate that a lockdir contains a solution for local packages" in
  let man = [ `S "DESCRIPTION"; `P doc ] in
  Cmd.info "validate-lockdir" ~doc ~man
;;

(* CR-someday alizter: The logic here is a little more complicated than it needs
   to be and can be simplified. *)

let enumerate_lock_dirs_by_path ~lock_dirs () =
  let open Memo.O in
  let+ per_contexts =
    Workspace.workspace () >>| Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs
  in
  List.filter_map per_contexts ~f:(fun lock_dir_path ->
    if Path.exists (Path.source lock_dir_path)
    then (
      try Some (Ok (lock_dir_path, Lock_dir.read_disk_exn lock_dir_path)) with
      | User_error.E e -> Some (Error (lock_dir_path, `Parse_error e)))
    else None)
;;

let validate_lock_dirs ~lock_dirs () =
  let open Fiber.O in
  let* lock_dirs_by_path, local_packages =
    Memo.both (enumerate_lock_dirs_by_path ~lock_dirs ()) Pkg_common.find_local_packages
    |> Memo.run
  in
  if List.is_empty lock_dirs_by_path
  then
    let+ () = Fiber.return () in
    Console.print [ Pp.text "No lockdirs to validate." ]
  else
    let+ universes =
      Fiber.parallel_map lock_dirs_by_path ~f:(function
        | Error e -> Fiber.return (Some e)
        | Ok (lock_dir_path, lock_dir) ->
          let+ platform = solver_env_from_system_and_context ~lock_dir_path in
          (match Package_universe.create ~platform local_packages lock_dir with
           | Ok _ -> None
           | Error e -> Some (lock_dir_path, `Lock_dir_out_of_sync e)))
      >>| List.filter_opt
    in
    match universes with
    | [] -> ()
    | errors_by_path ->
      List.iter errors_by_path ~f:(fun (path, error) ->
        match error with
        | `Parse_error error ->
          User_message.prerr
            (User_message.make
               [ Pp.textf
                   "Failed to parse lockdir %s:"
                   (Path.Source.to_string_maybe_quoted path)
               ; User_message.pp error
               ])
        | `Lock_dir_out_of_sync error ->
          User_message.prerr
            (User_message.make
               [ Pp.textf
                   "Lockdir %s does not contain a solution for local packages:"
                   (Path.Source.to_string path)
               ]);
          User_message.prerr error);
      User_error.raise
        [ Pp.text "Some lockdirs do not contain solutions for local packages:"
        ; Pp.enumerate errors_by_path ~f:(fun (path, _) ->
            Pp.text (Path.Source.to_string path))
        ]
;;

let term =
  let+ builder = Common.Builder.term
  and+ lock_dirs = Pkg_common.Lock_dirs_arg.term in
  let builder = Common.Builder.forbid_builds builder in
  let common, config = Common.init builder in
  Scheduler.go_with_rpc_server ~common ~config @@ validate_lock_dirs ~lock_dirs
;;

let command = Cmd.v info term