Formalise the management of versions (#2224)

Formalise the management of versions

CHANGES.md

@@ -39,6 +39,12 @@
   [cinaps tool](https://github.com/janestreet/cinaps) tool (#2269,
   @diml)
 
+- Allow to embed build info in executables such as version and list
+  and version of statically linked libraries (#2224, @diml)
+
+- Set version in `META` and `dune-package` files to the one read from
+  the vcs when no other version is available (#2224, @diml)
+
 1.10.0 (04/06/2019)
 -------------------
 

bin/common.ml

@@ -115,6 +115,38 @@ let one_of term1 term2 =
               "Cannot use %s and %s simultaneously"
               arg1 arg2)
 
+let build_info =
+  let+ build_info =
+    Arg.(value
+         & flag
+         & info ["build-info"] ~docs:"OPTIONS" ~doc:"Show build information.")
+  in
+  if build_info then begin
+    let module B = Build_info.V1 in
+    let pr fmt = Printf.printf (fmt ^^ "\n") in
+    let ver_string v =
+      match v with
+      | None -> "n/a"
+      | Some v -> B.Version.to_string v
+    in
+    pr "version: %s" (ver_string B.version);
+    let libs =
+      List.map B.statically_linked_libraries ~f:(fun lib ->
+        B.Statically_linked_library.name lib,
+        ver_string (B.Statically_linked_library.version lib))
+      |> List.sort ~compare
+    in
+    begin match libs with
+    | [] -> ()
+    | _ ->
+      pr "statically linked libraries:";
+      let longest = String.longest_map libs ~f:fst in
+      List.iter libs ~f:(fun (name, v) ->
+        pr "- %-*s %s" longest name v)
+    end;
+    exit 0
+  end
+
 module Options_implied_by_dash_p = struct
   type t =
     { root : string option
@@ -408,6 +440,7 @@ let term =
          & info ["store-orig-source-dir"] ~docs
              ~env:(Arg.env_var ~doc "DUNE_STORE_ORIG_SOURCE_DIR")
              ~doc)
+  and+ () = build_info
   in
   let build_dir = Option.value ~default:default_build_dir build_dir in
   let root = Workspace_root.create ~specified_by_user:root in

bin/common.mli

@@ -55,6 +55,10 @@ val term : t Cmdliner.Term.t
 
 val context_arg : doc:string -> string Cmdliner.Term.t
 
+(** A [--build-info] command line argument that print build
+    informations (included in [term]) *)
+val build_info : unit Cmdliner.Term.t
+
 val default_build_dir : string
 
 module Let_syntax : sig

bin/dune

@@ -1,4 +1,4 @@
 (library
  (name      main)
- (libraries memo dune_lang wp fiber stdune unix dune cmdliner)
+ (libraries memo dune_lang wp fiber stdune unix dune cmdliner build_info)
  (preprocess future_syntax))

bin/help.ml

@@ -89,6 +89,7 @@ let term =
     Arg.(value
          & pos 0 (some (enum commands)) None
          & info [] ~docv:"TOPIC")
+  and+ () = Common.build_info
   in
   match what with
   | None ->

bin/install_uninstall.ml

@@ -44,25 +44,33 @@ let print_unix_error f =
     Format.eprintf "@{<error>Error@}: %s@."
       (Unix.error_message e)
 
-
 let set_executable_bits   x = x lor  0o111
 let clear_executable_bits x = x land (lnot 0o111)
 
 (** Operations that act on real files or just pretend to (for --dry-run) *)
-module type FILE_OPERATIONS = sig
-  val copy_file : src:Path.t -> dst:Path.t -> executable:bool -> unit
+module type File_operations = sig
+  val copy_file
+    :  src:Path.Build.t
+    -> dst:Path.t
+    -> executable:bool
+    -> unit Fiber.t
   val mkdir_p : Path.t -> unit
   val remove_if_exists : Path.t -> unit
   val remove_dir_if_empty : Path.t -> unit
 end
 
-module File_ops_dry_run : FILE_OPERATIONS = struct
+module type Workspace = sig
+  val workspace : Dune.Main.workspace
+end
+
+module File_ops_dry_run : File_operations = struct
   let copy_file ~src ~dst ~executable =
     Format.printf
       "Copying %a to %a (executable: %b)\n"
-      Path.pp src
+      Path.pp (Path.build src)
       Path.pp dst
-      executable
+      executable;
+    Fiber.return ()
 
   let mkdir_p path =
     Format.printf
@@ -83,15 +91,119 @@ module File_ops_dry_run : FILE_OPERATIONS = struct
       path
 end
 
-module File_ops_real : FILE_OPERATIONS = struct
+module File_ops_real(W : Workspace) : File_operations = struct
+  open W
+
+  let get_vcs p = Dune.File_tree.nearest_vcs workspace.conf.file_tree p
+
+  type 'a load_special_file_result =
+    | No_version_needed
+    | Need_version of (Format.formatter -> version:string -> unit)
+
+  let copy_special_file ~src ~package_name ~ic ~oc ~f =
+    let plain_copy () =
+      seek_in ic 0;
+      Io.copy_channels ic oc;
+      Fiber.return ()
+    in
+    match f ic with
+    | exception _ ->
+      Dune.Errors.warn (Loc.in_file (Path.build src))
+        "Failed to parse file, not adding version information.";
+      plain_copy ()
+    | No_version_needed ->
+      plain_copy ()
+    | Need_version print ->
+      match
+        let open Option.O in
+        let package_name = Package.Name.of_string package_name in
+        let* package =
+          Package.Name.Map.find workspace.conf.packages package_name
+        in
+        get_vcs package.path
+      with
+      | None ->
+        plain_copy ()
+      | Some vcs ->
+        let open Fiber.O in
+        let+ version = Dune.Vcs.describe vcs in
+        let ppf = Format.formatter_of_out_channel oc in
+        print ppf ~version;
+        Format.pp_print_flush ppf ()
+
+  let process_meta ic =
+    let lb = Lexing.from_channel ic in
+    let meta : Dune.Meta.t =
+      { name = None
+      ; entries = Dune.Meta.parse_entries lb
+      }
+    in
+    let need_more_versions =
+      try
+        let (_ : Dune.Meta.t) =
+          Dune.Meta.add_versions meta ~get_version:(fun _ -> raise_notrace Exit)
+        in
+        false
+      with Exit ->
+        true
+    in
+    if not need_more_versions then
+      No_version_needed
+    else
+      Need_version (fun ppf ~version ->
+        let meta =
+          Dune.Meta.add_versions meta ~get_version:(fun _ -> Some version)
+        in
+        Dune.Meta.pp ppf meta.entries)
+
+  let process_dune_package ic =
+    let lb = Lexing.from_channel ic in
+    let dp =
+      Dune_lang.Parser.parse ~mode:Many lb
+      |> List.map ~f:Dune_lang.Ast.remove_locs
+    in
+    if List.exists dp ~f:(function
+      | Dune_lang.List (Atom (A "version") :: _) -> true
+      | _ -> false) then
+      No_version_needed
+    else
+      Need_version (fun ppf ~version ->
+        let version =
+          Dune_lang.List [ Dune_lang.atom "version"
+                         ; Dune_lang.atom_or_quoted_string version
+                         ]
+        in
+        let dp =
+          match dp with
+          | lang :: name :: rest ->
+            lang :: name :: version :: rest
+          | [lang] -> [lang; version]
+          | [] -> [version]
+        in
+        Format.pp_open_vbox ppf 0;
+        List.iter dp ~f:(fun x ->
+          Dune_lang.pp Dune ppf x;
+          Format.pp_print_cut ppf ());
+        Format.pp_close_box ppf ())
+
   let copy_file ~src ~dst ~executable =
     let chmod =
       if executable then
         set_executable_bits
-     else
-       clear_executable_bits
+      else
+        clear_executable_bits
     in
-    Io.copy_file ~src ~dst ~chmod ()
+    let ic, oc = Io.setup_copy ~chmod ~src:(Path.build src) ~dst () in
+    Fiber.finalize ~finally:(fun () -> Io.close_both (ic, oc); Fiber.return ())
+      (fun () ->
+         match Path.Build.explode src with
+         | ["install"; _ctx; "lib"; package_name; "META"] ->
+           copy_special_file ~src ~package_name ~ic ~oc ~f:process_meta
+         | ["install"; _ctx; "lib"; package_name; "dune-package"] ->
+           copy_special_file ~src ~package_name ~ic ~oc ~f:process_dune_package
+         | _ ->
+           Dune.Artifact_substitution.copy ~get_vcs ~input:(input ic)
+             ~output:(output oc))
 
   let remove_if_exists dst =
     if Path.exists dst then begin
@@ -116,11 +228,13 @@ module File_ops_real : FILE_OPERATIONS = struct
   let mkdir_p = Path.mkdir_p
 end
 
-let file_operations ~dry_run : (module FILE_OPERATIONS) =
+let file_operations ~dry_run ~workspace : (module File_operations) =
   if dry_run then
     (module File_ops_dry_run)
   else
-    (module File_ops_real)
+    (module File_ops_real(struct
+         let workspace = workspace
+       end))
 
 let install_uninstall ~what =
   let doc =
@@ -211,64 +325,64 @@ let install_uninstall ~what =
         |> CMap.to_list
         |> List.map ~f:(fun (context, install_files) ->
           let entries_per_package =
-            Package.Name.Map.of_list_map_exn install_files
-              ~f:(fun (package, install_file) ->
-                let entries = Install.load_install_file install_file in
-                match
-                  List.filter_map entries ~f:(fun entry ->
-                    Option.some_if
-                      (not (Path.exists (Path.build entry.src)))
-                      entry.src)
-                with
-                | [] -> (package, entries)
-                | missing_files ->
-                  User_error.raise
-                    [ Pp.textf
-                        "The following files which are listed in %s \
-                         cannot be installed because they do not exist:"
-                        (Path.to_string_maybe_quoted install_file)
-                    ; Pp.enumerate missing_files ~f:(fun p ->
-                        Pp.verbatim (Path.Build.to_string_maybe_quoted p))
-                    ])
+            List.map install_files ~f:(fun (package, install_file) ->
+              let entries = Install.load_install_file install_file in
+              match
+                List.filter_map entries ~f:(fun entry ->
+                  Option.some_if
+                    (not (Path.exists (Path.build entry.src)))
+                    entry.src)
+              with
+              | [] -> (package, entries)
+              | missing_files ->
+                User_error.raise
+                  [ Pp.textf
+                      "The following files which are listed in %s \
+                       cannot be installed because they do not exist:"
+                      (Path.to_string_maybe_quoted install_file)
+                  ; Pp.enumerate missing_files ~f:(fun p ->
+                      Pp.verbatim (Path.Build.to_string_maybe_quoted p))
+                  ])
           in
           (context, entries_per_package))
       in
-      let (module Ops) = file_operations ~dry_run in
+      let (module Ops) = file_operations ~dry_run ~workspace in
       let files_deleted_in = ref Path.Set.empty in
       let+ () =
         Fiber.sequential_iter install_files_by_context
           ~f:(fun (context, entries_per_package) ->
-            let+ (prefix, libdir) =
+            let* (prefix, libdir) =
               get_dirs context ~prefix_from_command_line
                 ~libdir_from_command_line
             in
-            entries_per_package 
-            |> Package.Name.Map.iteri ~f:(fun package entries ->
-              let paths =
-                Install.Section.Paths.make
-                  ~package
-                  ~destdir:prefix
-                  ?libdir
-                  ()
-              in
-              List.iter entries ~f:(fun entry ->
-                let dst =
-                  Install.Entry.relative_installed_path entry ~paths
-                  |> interpret_destdir ~destdir
+            Fiber.sequential_iter entries_per_package
+              ~f:(fun (package, entries) ->
+                let paths =
+                  Install.Section.Paths.make
+                    ~package
+                    ~destdir:prefix
+                    ?libdir
+                    ()
                 in
-                let dir = Path.parent_exn dst in
-                if what = "install" then begin
-                  Printf.eprintf "Installing %s\n%!"
-                    (Path.to_string_maybe_quoted dst);
-                  Ops.mkdir_p dir;
-                  let executable =
-                    Install.Section.should_set_executable_bit entry.section
+                Fiber.sequential_iter entries ~f:(fun entry ->
+                  let dst =
+                    Install.Entry.relative_installed_path entry ~paths
+                    |> interpret_destdir ~destdir
                   in
-                  Ops.copy_file ~src:(Path.build entry.src) ~dst ~executable
-                end else begin
-                  Ops.remove_if_exists dst;
-                  files_deleted_in := Path.Set.add !files_deleted_in dir;
-                end)))
+                  let dir = Path.parent_exn dst in
+                  if what = "install" then begin
+                    Printf.eprintf "Installing %s\n%!"
+                      (Path.to_string_maybe_quoted dst);
+                    Ops.mkdir_p dir;
+                    let executable =
+                      Install.Section.should_set_executable_bit entry.section
+                    in
+                    Ops.copy_file ~src:entry.src ~dst ~executable
+                  end else begin
+                    Ops.remove_if_exists dst;
+                    files_deleted_in := Path.Set.add !files_deleted_in dir;
+                    Fiber.return ()
+                  end)))
       in
       Path.Set.to_list !files_deleted_in
       (* This [List.rev] is to ensure we process children

bin/installed_libraries.ml

@@ -37,7 +37,9 @@ let term =
           Lib_name.to_string (Dune_package.Lib.name n)) in
       List.iter pkgs ~f:(fun (pkg : _ Dune_package.Lib.t) ->
         let ver =
-          Option.value (Dune_package.Lib.version pkg) ~default:"n/a"
+          match Dune_package.Lib.version pkg with
+          | Some v -> v
+          | _ -> "n/a"
         in
         Printf.printf "%-*s (version: %s)\n" max_len
           (Lib_name.to_string (Dune_package.Lib.name pkg)) ver);

bin/main.ml

@@ -153,7 +153,10 @@ let default =
     `Help (`Pager, None)
   in
   (term,
-   Term.info "dune" ~doc ~version:"%%VERSION%%"
+   Term.info "dune" ~doc
+     ~version:(match Build_info.V1.version with
+       | None -> "n/a"
+       | Some v -> Build_info.V1.Version.to_string v)
      ~man:
        [ `S "DESCRIPTION"
        ; `P {|Dune is a build system designed for OCaml projects only. It