Reuse dependencies between project and tools

bin/pkg/group.ml

@@ -13,6 +13,7 @@ let subcommands =
   ; Outdated.command
   ; Validate_lock_dir.command
   ; Pkg_enabled.command
+  ; Print_slug.command
   ]
 ;;
 

bin/pkg/print_slug.ml

@@ -0,0 +1,42 @@
+open Import
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ package_name =
+    Arg.(
+      required
+      & pos 0 (some string) None
+      & info [] ~doc:"The name of the package" ~docv:"PACKAGE")
+  in
+  let builder = Common.Builder.forbid_builds builder in
+  let common, config = Common.init builder in
+  let package_name = Package_name.of_string package_name in
+  let context_name = Context_name.default in
+  Scheduler.go_with_rpc_server ~common ~config (fun () ->
+    let open Fiber.O in
+    let* lock_dir_path_opt =
+      Memo.run (Dune_rules.Lock_dir.get_path_source context_name)
+    in
+    match lock_dir_path_opt with
+    | None -> User_error.raise [ Pp.textf "No lockdir found" ]
+    | Some lock_dir_path ->
+      let lock_dir = Dune_pkg.Lock_dir.read_disk_exn (Path.source lock_dir_path) in
+      let+ platform = Pkg_common.poll_solver_env_from_current_system () in
+      let packages_by_name =
+        Dune_pkg.Lock_dir.Packages.pkgs_on_platform_by_name lock_dir.packages ~platform
+      in
+      (match Package_name.Map.find packages_by_name package_name with
+       | None ->
+         User_error.raise
+           [ Pp.textf "No such package: %s" (Package_name.to_string package_name) ]
+       | Some package ->
+         let slug = Dune_pkg.Lock_dir.Pkg.slug package in
+         print_endline (Dune_pkg.Lock_dir.Pkg_slug.to_string slug)))
+;;
+
+let info =
+  let doc = "Print the slug of a package in the project's lockdir." in
+  Cmd.info "print-slug" ~doc
+;;
+
+let command = Cmd.v info term

bin/pkg/print_slug.mli

@@ -0,0 +1,4 @@
+open Import
+
+(** Command to print the slug of a given package within the current project. *)
+val command : unit Cmd.t

src/dune_digest/digest.ml

@@ -91,14 +91,16 @@ module Feed = struct
     feed_c hasher c
   ;;
 
-  let digest t x = Hasher.with_singleton (fun hasher -> t hasher x)
+  let digest hasher digest = contramap string ~f:to_string hasher digest
+  let compute_digest t x = Hasher.with_singleton (fun hasher -> t hasher x)
+  let compute_digest_with_hasher = Hasher.with_singleton
 end
 
-let string s = Feed.digest Feed.string s
+let string s = Feed.compute_digest Feed.string s
 let to_string_raw s = Blake3_mini.Digest.to_binary s
 
 let generic a =
-  Metrics.Timer.record "generic_digest" ~f:(fun () -> Feed.digest Feed.generic a)
+  Metrics.Timer.record "generic_digest" ~f:(fun () -> Feed.compute_digest Feed.generic a)
 ;;
 
 let path_with_executable_bit =

src/dune_digest/digest.mli

@@ -27,8 +27,15 @@ module Feed : sig
   val tuple2 : 'a t -> 'b t -> ('a * 'b) t
   val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
 
+  (** Feed a digest into a hasher. *)
+  val digest : digest t
+
   (** Compute the digest of a value given a feed for the type of that value. *)
-  val digest : 'a t -> 'a -> digest
+  val compute_digest : 'a t -> 'a -> digest
+
+  (** Takes a function which feeds values into a hasher and returns a digest of
+      all the values fed in this way. *)
+  val compute_digest_with_hasher : (hasher -> unit) -> digest
 end
 
 include Comparable_intf.S with type key := t

src/dune_lang/package_version.mli

@@ -7,6 +7,7 @@ val of_string_opt : string -> t option
 val of_string_user_error : Loc.t * string -> (t, User_message.t) result
 val to_string : t -> string
 val equal : t -> t -> bool
+val compare : t -> t -> ordering
 val hash : t -> int
 val digest_feed : t Dune_digest.Feed.t
 val to_dyn : t -> Dyn.t

src/dune_pkg/dune_pkg.ml

@@ -26,3 +26,4 @@ module Package_name = Package_name
 module Ocamlformat = Ocamlformat
 module Dev_tool = Dev_tool
 module Outdated = Outdated
+module Dune_dep = Dune_dep

src/dune_pkg/lock_dir.ml

@@ -534,6 +534,81 @@ let in_source_tree path =
       [ "path", Path.External.to_dyn e ]
 ;;
 
+module Pkg_slug = struct
+  module T = struct
+    type t =
+      { name : Package_name.t
+      ; version : Package_version.t
+      ; lockfile_and_dependency_digest : Dune_digest.t
+        (* A hash of the package's lockfile as well as of all lockfiles of the
+           dependency closure of the package. *)
+      }
+
+    let equal { name; version; lockfile_and_dependency_digest } t =
+      Package_name.equal name t.name
+      && Package_version.equal version t.version
+      && Dune_digest.equal lockfile_and_dependency_digest t.lockfile_and_dependency_digest
+    ;;
+
+    let compare { name; version; lockfile_and_dependency_digest } t =
+      let open Ordering.O in
+      let= () = Package_name.compare name t.name in
+      let= () = Package_version.compare version t.version in
+      Dune_digest.compare lockfile_and_dependency_digest t.lockfile_and_dependency_digest
+    ;;
+
+    let to_dyn { name; version; lockfile_and_dependency_digest } =
+      Dyn.record
+        [ "name", Package_name.to_dyn name
+        ; "version", Package_version.to_dyn version
+        ; ( "lockfile_and_dependency_digest"
+          , Dune_digest.to_dyn lockfile_and_dependency_digest )
+        ]
+    ;;
+
+    let hash { name; version; lockfile_and_dependency_digest } =
+      Tuple.T3.hash
+        Package_name.hash
+        Package_version.hash
+        Dune_digest.hash
+        (name, version, lockfile_and_dependency_digest)
+    ;;
+  end
+
+  include T
+  include Comparable.Make (T)
+
+  let to_string { name; version; lockfile_and_dependency_digest } =
+    sprintf
+      "%s.%s-%s"
+      (Package_name.to_string name)
+      (Package_version.to_string version)
+      (Dune_digest.to_string lockfile_and_dependency_digest)
+  ;;
+
+  let of_string s =
+    let parse_error msg =
+      User_error.raise [ Pp.textf "Failed to parse %S as a package slug." s; msg ]
+    in
+    match String.lsplit2 s ~on:'.' with
+    | Some (name, rest) ->
+      (match String.rsplit2 rest ~on:'-' with
+       | Some (version, lockfile_and_dependency_digest) ->
+         (match Dune_digest.from_hex lockfile_and_dependency_digest with
+          | Some lockfile_and_dependency_digest ->
+            let name = Package_name.of_string name in
+            let version = Package_version.of_string version in
+            { name; version; lockfile_and_dependency_digest }
+          | None ->
+            parse_error
+              (Pp.textf "Failed to parse %S as digest" lockfile_and_dependency_digest))
+       | None -> parse_error (Pp.text "Missing '-' between version and lockfile digest."))
+    | None -> parse_error (Pp.text "Missing '.' between name and version.")
+  ;;
+
+  let name t = t.name
+end
+
 module Pkg = struct
   type t =
     { build_command : Build_command.t Conditional_choice.t
@@ -543,6 +618,7 @@ module Pkg = struct
     ; info : Pkg_info.t
     ; exported_env : String_with_vars.t Action.Env_update.t list
     ; enabled_on_platforms : Solver_env_disjunction.t
+    ; slug : Pkg_slug.t Lazy.t option
     }
 
   let equal
@@ -553,6 +629,7 @@ module Pkg = struct
         ; info
         ; exported_env
         ; enabled_on_platforms
+        ; slug = _
         }
         t
     =
@@ -577,6 +654,7 @@ module Pkg = struct
         ; info
         ; exported_env
         ; enabled_on_platforms
+        ; slug = _
         }
     =
     Poly.hash
@@ -598,6 +676,7 @@ module Pkg = struct
         ; info
         ; exported_env
         ; enabled_on_platforms
+        ; slug = _
         }
     =
     Conditional_choice.digest_feed Digest_feed.generic hasher build_command;
@@ -617,6 +696,7 @@ module Pkg = struct
         ; info
         ; exported_env
         ; enabled_on_platforms
+        ; slug
         }
     =
     { info = Pkg_info.remove_locs info
@@ -627,6 +707,7 @@ module Pkg = struct
     ; build_command = Conditional_choice.map build_command ~f:Build_command.remove_locs
     ; install_command = Conditional_choice.map install_command ~f:Action.remove_locs
     ; enabled_on_platforms
+    ; slug
     }
   ;;
 
@@ -638,6 +719,7 @@ module Pkg = struct
         ; info
         ; exported_env
         ; enabled_on_platforms
+        ; slug
         }
     =
     Dyn.record
@@ -649,6 +731,7 @@ module Pkg = struct
       ; ( "exported_env"
         , Dyn.list (Action.Env_update.to_dyn String_with_vars.to_dyn) exported_env )
       ; "enabled_on_platforms", Solver_env_disjunction.to_dyn enabled_on_platforms
+      ; "slug", Dyn.option Dyn.opaque slug
       ]
   ;;
 
@@ -768,6 +851,7 @@ module Pkg = struct
          ; info
          ; exported_env
          ; enabled_on_platforms
+         ; slug = None
          }
   ;;
 
@@ -788,6 +872,7 @@ module Pkg = struct
         ; info = { Pkg_info.name = _; extra_sources; version; dev; avoid; source }
         ; exported_env
         ; enabled_on_platforms
+        ; slug = _
         }
     =
     let open Encoder in
@@ -941,6 +1026,8 @@ module Pkg = struct
     List.is_empty t.enabled_on_platforms
     || Solver_env_disjunction.matches_platform t.enabled_on_platforms ~platform
   ;;
+
+  let slug t = Lazy.force (Option.value_exn t.slug)
 end
 
 module Repositories = struct
@@ -991,6 +1078,7 @@ end
 module Packages = struct
   type t = Pkg.t Package_version.Map.t Package_name.Map.t
 
+  let empty = Package_name.Map.empty
   let remove_locs = Package_name.Map.map ~f:(Package_version.Map.map ~f:Pkg.remove_locs)
   let equal = Package_name.Map.equal ~equal:(Package_version.Map.equal ~equal:Pkg.equal)
   let to_dyn = Package_name.Map.to_dyn (Package_version.Map.to_dyn Pkg.to_dyn)
@@ -1039,6 +1127,85 @@ module Packages = struct
              | Some x, None | None, Some x -> Some x
              | Some a, Some b -> Some (Pkg.merge_conditionals a b))))
   ;;
+
+  exception
+    Dependency_cycle of
+      { at : Pkg.t
+      ; through : Pkg.t list
+      }
+
+  (* [compute_slug t pkg] computes the slug of the package [pkg] using [t] to
+     resolve dependencies of [pkg]. *)
+  let compute_slug (t : t) (pkg : Pkg.t) =
+    let iter_all_versions_of_non_dune_dependencies f =
+      List.iter pkg.depends ~f:(fun { Conditional.value = depends; _ } ->
+        List.iter depends ~f:(fun { Dependency.name = dep_name; _ } ->
+          (* Don't call [f] on a dependency on the dune package
+             itself as these aren't stored in the lockdir. *)
+          if not (Package_name.equal dep_name Dune_dep.name)
+          then (
+            let dep_version_map =
+              (* This is a map rather than a single package because when
+                 portable lockdirs are enabled there may be several different
+                 versions of a package in the lockdir. Since we don't know the
+                 user's platform here, err on the side of caution and hash all
+                 versions of the dependency. *)
+              Package_name.Map.find_exn t dep_name
+            in
+            Package_version.Map.iter dep_version_map ~f)))
+    in
+    (* Force the computation of the slugs of this package's
+       dependencies. This needs to happen before the call to
+       [Digest_feed.compute_digest_with_hasher] because the hasher is a
+       singleton. *)
+    (try
+       iter_all_versions_of_non_dune_dependencies (fun dep ->
+         try
+           let _ : Pkg_slug.t = Pkg.slug dep in
+           ()
+         with
+         | Lazy.Undefined ->
+           (* Forcing the computation of the slug of this dependency is was
+              already in progress, indicating a dependency cycle. Raise an
+              exception with information about the cycle so the ancestor of
+              [pkg] which is also [dep] can catch the exception and print an
+              error message with the sequence of dependencies which form the
+              cycle. *)
+           raise (Dependency_cycle { at = dep; through = [ dep ] }))
+     with
+     | Dependency_cycle { at; through } ->
+       let through = pkg :: through in
+       if Pkg.equal pkg at
+       then
+         User_error.raise
+           [ Pp.textf "Dependency cycle between packages:"
+           ; Pp.chain through ~f:(fun (pkg : Pkg.t) ->
+               Pp.textf
+                 "%s.%s"
+                 (Package_name.to_string pkg.info.name)
+                 (Package_version.to_string pkg.info.version))
+           ]
+       else raise (Dependency_cycle { at; through }));
+    let lockfile_and_dependency_digest =
+      Digest_feed.compute_digest_with_hasher (fun hasher ->
+        (* compute the digest of the lockfile. note that
+           [Pkg.digest_feed does not force the [slug] field. *)
+        Pkg.digest_feed hasher (Pkg.remove_locs pkg);
+        (* Evaluate the slugs for the transitive dependency closure
+           of this package, and feed the digests from the slugs of the
+           immediate dependencies into the current hasher. Because the digest
+           of one package is influenced by its dependencies, this will cause
+           the digest of the current package to be influenced by its entire
+           dependency closure. *)
+        iter_all_versions_of_non_dune_dependencies (fun dep ->
+          let dep_slug = Pkg.slug dep in
+          Digest_feed.digest hasher dep_slug.lockfile_and_dependency_digest))
+    in
+    { Pkg_slug.name = pkg.info.name
+    ; version = pkg.info.version
+    ; lockfile_and_dependency_digest
+    }
+  ;;
 end
 
 type t =
@@ -1610,6 +1777,11 @@ struct
       | Some x -> true, x
       | None -> false, (Loc.none, [])
     in
+    let packages_cell =
+      (* Cell to break the cycle between computing the table of packages and
+         computing the slugs of packages *)
+      ref Packages.empty
+    in
     let+ packages =
       Io.readdir_with_kinds lock_dir_path
       >>| List.filter_map ~f:(fun (name, (kind : Unix.file_kind)) ->
@@ -1629,9 +1801,11 @@ struct
             package_name
             maybe_package_version
         in
-        pkg)
+        let slug = lazy (Packages.compute_slug !packages_cell pkg) in
+        { pkg with slug = Some slug })
       >>| Packages.of_pkg_list
     in
+    packages_cell := packages;
     check_packages packages ~lock_dir_path
     |> Result.map ~f:(fun () ->
       { version