Conservative implementation of lockfile generation

Adds a command `dune pkg lock` which generates a lock directory.
Currently the user must specify a path to a local checkout of
opam-repository, there is no way to override opam variables (though it's
possible to clear them all), and only a subset of lockfile fields are
set.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

bin/dune

@@ -24,6 +24,7 @@
   dune_engine
   dune_util
   dune_upgrader
+  dune_pkg
   cmdliner
   threads
   ; Kept to keep implicit_transitive_deps false working in 4.x
@@ -37,7 +38,8 @@
   dune_rpc_impl
   dune_rpc_private
   dune_rpc_client
-  spawn)
+  spawn
+  opam_format)
  (bootstrap_info bootstrap-info))
 
 ; Installing the dune binary depends on the kind of build:

bin/main.ml

@@ -36,6 +36,7 @@ let all : _ Cmdliner.Cmd.t list =
     ; Internal.group
     ; Init.group
     ; Promotion.group
+    ; Pkg.group
     ]
   in
   terms @ groups

bin/pkg.ml

@@ -0,0 +1,115 @@
+open Stdune
+open Import
+module Lock_dir = Dune_pkg.Lock_dir
+
+module Lock = struct
+  module Repo = struct
+    open Dune_pkg.Opam.Repo
+
+    let term =
+      let+ opam_repository_path =
+        Arg.(
+          required
+          & opt (some string) None
+          & info [ "opam-repository-path" ] ~docv:"PATH"
+              ~doc:
+                "Path to a local opam repository. This should be a directory \
+                 containing a valid opam repository such as the one at \
+                 https://github.com/ocaml/opam-repository.")
+      in
+      of_opam_repo_dir_path opam_repository_path
+  end
+
+  module Env = struct
+    module Source = struct
+      type t =
+        | Global
+        | Pure
+
+      let to_string = function
+        | Global -> "global"
+        | Pure -> "pure"
+
+      let default = Global
+
+      let term =
+        let all = [ Global; Pure ] in
+        let all_with_strings = List.map all ~f:(fun t -> (to_string t, t)) in
+        let all_strings = List.map all_with_strings ~f:fst in
+        let doc =
+          sprintf
+            "How to initialize the opam environment. Possible values are %s. \
+             '%s' will use the environment associated with the current opam \
+             switch. '%s' will use an empty environment. The default is '%s'."
+            (String.enumerate_and all_strings)
+            (to_string Global) (to_string Pure) (to_string default)
+        in
+        Arg.(
+          value
+          & opt (some (enum all_with_strings)) None
+          & info [ "opam-env" ] ~doc)
+    end
+
+    open Dune_pkg.Opam.Env
+
+    let term =
+      let+ source = Source.term in
+      match Option.value source ~default:Source.default with
+      | Global -> global ()
+      | Pure -> empty
+  end
+
+  (* Converts the package table found inside a [Dune_project.t] into the
+     package table expected by the dependency solver *)
+  let opam_file_map_of_dune_package_map
+      (dune_package_map : Package.t Package.Name.Map.t) :
+      OpamFile.OPAM.t OpamTypes.name_map =
+    Package.Name.Map.to_list_map dune_package_map
+      ~f:(fun dune_package_name dune_package ->
+        let opam_package_name =
+          Package.Name.to_opam_package_name dune_package_name
+        in
+        let opam_file = Package.to_opam_file dune_package in
+        (opam_package_name, opam_file))
+    |> OpamPackage.Name.Map.of_list
+
+  let term =
+    let+ (common : Common.t) = Common.term
+    and+ env = Env.term
+    and+ repo = Repo.term in
+    let config = Common.init common in
+    Scheduler.go ~common ~config (fun () ->
+        let open Fiber.O in
+        let* source_dir = Memo.run (Source_tree.root ()) in
+        let project = Source_tree.Dir.project source_dir in
+        let dune_package_map = Dune_project.packages project in
+        let opam_file_map =
+          opam_file_map_of_dune_package_map dune_package_map
+        in
+        let lock_dir_path = Lock_dir.path in
+        let summary, lock_dir =
+          Dune_pkg.Opam.solve_lock_dir ~env ~repo ~lock_dir_path opam_file_map
+        in
+        Console.print_user_message
+          (Dune_pkg.Opam.Summary.selected_packages_message summary);
+        Lock_dir.write_disk ~lock_dir_path lock_dir;
+        Fiber.return ())
+
+  let info =
+    let doc = "Create a lockfile" in
+    Cmd.info "lock" ~doc
+
+  let command = Cmd.v info term
+end
+
+let info =
+  let doc = "Experimental package management" in
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P {|Commands for doing package management with dune|}
+    ; `Blocks Common.help_secs
+    ]
+  in
+  Cmd.info "pkg" ~doc ~man
+
+let group = Cmd.group info [ Lock.command ]

bin/pkg.mli

@@ -0,0 +1,3 @@
+open Import
+
+val group : unit Cmd.t

boot/libs.ml

@@ -58,6 +58,11 @@ let local_libraries =
   ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None)
   ; ("src/dune_engine", Some "Dune_engine", false, None)
   ; ("vendor/opam/src/repository", None, false, None)
+  ; ("vendor/opam/src/state", None, false, None)
+  ; ("vendor/0install-solver/src/solver", Some "Zeroinstall_solver", false,
+    None)
+  ; ("vendor/fmt/src", None, false, None)
+  ; ("vendor/opam-0install/lib", Some "Opam_0install", false, None)
   ; ("src/dune_pkg", Some "Dune_pkg", false, None)
   ; ("src/dune_vcs", Some "Dune_vcs", false, None)
   ; ("src/dune_threaded_console", Some "Dune_threaded_console", false, None)

doc/dune.inc

@@ -170,6 +170,15 @@
  (package dune)
  (files   dune-ocaml-merlin.1))
 
+(rule
+ (with-stdout-to dune-pkg.1
+  (run dune pkg --help=groff)))
+
+(install
+ (section man)
+ (package dune)
+ (files   dune-pkg.1))
+
 (rule
  (with-stdout-to dune-printenv.1
   (run dune printenv --help=groff)))

src/dune_pkg/dune

@@ -9,6 +9,8 @@
   dune_lang
   opam_core
   opam_repository
-  opam_format)
+  opam_format
+  opam_state
+  opam_0install)
  (instrumentation
   (backend bisect_ppx)))

src/dune_pkg/dune_pkg.ml

@@ -1,3 +1,4 @@
 module Fetch = Fetch
 module Checksum = Checksum
 module Lock_dir = Lock_dir
+module Opam = Opam

src/dune_pkg/lock_dir.ml

@@ -9,20 +9,30 @@ module Source = struct
         ; checksum : (Loc.t * Checksum.t) option
         }
 
+  module Fields = struct
+    let copy = "copy"
+
+    let fetch = "fetch"
+
+    let url = "url"
+
+    let checksum = "checksum"
+  end
+
   let decode =
     let open Dune_lang.Decoder in
     sum
-      [ ( "copy"
+      [ ( Fields.copy
         , located string >>| fun (loc, source) path ->
           External_copy
             ( loc
             , if Filename.is_relative source then
                 Path.External.relative path source
               else Path.External.of_string source ) )
-      ; ( "fetch"
+      ; ( Fields.fetch
         , enter @@ fields
-          @@ let+ url = field "url" (located string)
-             and+ checksum = field_o "checksum" (located string) in
+          @@ let+ url = field Fields.url (located string)
+             and+ checksum = field_o Fields.checksum (located string) in
              let checksum =
                match checksum with
                | None -> None
@@ -33,6 +43,18 @@ module Source = struct
              in
              fun _ -> Fetch { url; checksum } )
       ]
+
+  let encode t =
+    let open Dune_lang.Encoder in
+    match t with
+    | External_copy (_loc, path) ->
+      constr Fields.copy string (Path.External.to_string path)
+    | Fetch { url = _loc, url; checksum } ->
+      record
+        [ (Fields.url, string url)
+        ; ( Fields.checksum
+          , (option Checksum.encode) (Option.map checksum ~f:snd) )
+        ]
 end
 
 module Pkg_info = struct
@@ -51,20 +73,25 @@ module Env_update = struct
     ; value : 'a
     }
 
+  let op_by_string =
+    [ ("=", OpamParserTypes.Eq)
+    ; ("+=", PlusEq)
+    ; ("=+", EqPlus)
+    ; (":=", ColonEq)
+    ; ("=:", EqColon)
+    ; ("=+=", EqPlusEq)
+    ]
+
   let decode =
     let open Dune_lang.Decoder in
-    let env_update_op =
-      enum
-        [ ("=", OpamParserTypes.Eq)
-        ; ("+=", PlusEq)
-        ; ("=+", EqPlus)
-        ; (":=", ColonEq)
-        ; ("=:", EqColon)
-        ; ("=+=", EqPlusEq)
-        ]
-    in
+    let env_update_op = enum op_by_string in
     let+ op, var, value = triple env_update_op string String_with_vars.decode in
     { op; var; value }
+
+  let encode { op; var; value } =
+    let open Dune_lang.Encoder in
+    let env_update_op = enum op_by_string in
+    triple env_update_op string String_with_vars.encode (op, var, value)
 end
 
 module Pkg = struct
@@ -77,17 +104,33 @@ module Pkg = struct
     ; exported_env : String_with_vars.t Env_update.t list
     }
 
+  module Fields = struct
+    let version = "version"
+
+    let install = "install"
+
+    let build = "build"
+
+    let deps = "deps"
+
+    let source = "source"
+
+    let dev = "dev"
+
+    let exported_env = "exported_env"
+  end
+
   let decode =
     let open Dune_lang.Decoder in
     enter @@ fields
-    @@ let+ version = field ~default:"dev" "version" string
-       and+ install_command = field_o "install" Dune_lang.Action.decode_pkg
-       and+ build_command = field_o "build" Dune_lang.Action.decode_pkg
-       and+ deps = field ~default:[] "deps" (repeat Package_name.decode)
-       and+ source = field_o "source" Source.decode
-       and+ dev = field_b "dev"
+    @@ let+ version = field ~default:"dev" Fields.version string
+       and+ install_command = field_o Fields.install Dune_lang.Action.decode_pkg
+       and+ build_command = field_o Fields.build Dune_lang.Action.decode_pkg
+       and+ deps = field ~default:[] Fields.deps (repeat Package_name.decode)
+       and+ source = field_o Fields.source Source.decode
+       and+ dev = field_b Fields.dev
        and+ exported_env =
-         field "exported_env" ~default:[] (repeat Env_update.decode)
+         field Fields.exported_env ~default:[] (repeat Env_update.decode)
        in
        fun ~lock_dir name ->
          let info =
@@ -99,17 +142,67 @@ module Pkg = struct
            { Pkg_info.name; version; dev; source }
          in
          { build_command; deps; install_command; info; exported_env; lock_dir }
+
+  let encode
+      { build_command
+      ; install_command
+      ; deps
+      ; info = { Pkg_info.name = _; version; dev; source }
+      ; lock_dir = _
+      ; exported_env
+      } =
+    let open Dune_lang.Encoder in
+    record_fields
+      [ field Fields.version string version
+      ; field_o Fields.install Dune_lang.Action.encode install_command
+      ; field_o Fields.build Dune_lang.Action.encode build_command
+      ; field_l Fields.deps Package_name.encode deps
+      ; field_o Fields.source Source.encode source
+      ; field_b Fields.dev dev
+      ; field_l Fields.exported_env Env_update.encode exported_env
+      ]
 end
 
 type t =
   { version : Syntax.Version.t
   ; packages : Pkg.t Package_name.Map.t
   }
 
+let create_latest_version packages =
+  let version = Syntax.greatest_supported_version Dune_lang.Pkg.syntax in
+  { version; packages }
+
 let path = Path.Source.(relative root "dune.lock")
 
 let metadata = "lock.dune"
 
 module Metadata = Dune_sexp.Versioned_file.Make (Unit)
 
 let () = Metadata.Lang.register Dune_lang.Pkg.syntax ()
+
+let encode_metadata t =
+  let open Dune_lang.Encoder in
+  list sexp
+    [ string "lang"
+    ; string (Syntax.name Dune_lang.Pkg.syntax)
+    ; Dune_lang.Syntax.Version.encode t.version
+    ]
+
+let file_contents_by_path t =
+  (metadata, [ encode_metadata t ])
+  :: (Package_name.Map.to_list t.packages
+     |> List.map ~f:(fun (name, pkg) ->
+            (Package_name.to_string name, Pkg.encode pkg)))
+
+let write_disk ~lock_dir_path t =
+  let lock_dir_path = Path.source lock_dir_path in
+  Path.rm_rf lock_dir_path;
+  Path.mkdir_p lock_dir_path;
+  file_contents_by_path t
+  |> List.iter ~f:(fun (path_within_lock_dir, contents) ->
+         let path = Path.relative lock_dir_path path_within_lock_dir in
+         Option.iter (Path.parent path) ~f:Path.mkdir_p;
+         let contents_string =
+           List.map contents ~f:Dune_lang.to_string |> String.concat ~sep:"\n"
+         in
+         Io.write_file path contents_string)