added install/uninstall commands

CHANGES.org

@@ -12,7 +12,10 @@
   You should now put =(jbuilder_version 1)= in a =jbuild= file at the
   root of your project to ensure forward compatibility
 
-- Added a =runtest= command
+- Added a few commands:
+  + =runtest=
+  + =install=
+  + =uninstall=
 
 - Added support for aliases
   (#7, Rudi Grinberg)

bin/main.ml

@@ -85,16 +85,17 @@ let common =
   let dev = Arg.(value & flag & info ["dev"] ~docs) in
   Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib $ dev)
 
+let resolve_package_install setup pkg =
+  match Main.package_install_file setup pkg with
+  | Ok path -> path
+  | Error () ->
+    die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages))
+
 let build_package pkg =
   Future.Scheduler.go ~log:(create_log ())
     (Main.setup () >>= fun setup ->
-     match Main.package_install_file setup pkg with
-     | Ok path ->
-       Build_system.do_build_exn setup.build_system
-         [path]
-     | Error () ->
-       die "Unknown package %s!%s" pkg (hint pkg (String_map.keys setup.packages))
-    )
+     Build_system.do_build_exn setup.build_system
+       [resolve_package_install setup pkg])
 
 let build_package =
   let doc = "build a package in release mode" in
@@ -207,11 +208,7 @@ let runtest =
     set_common common;
     Future.Scheduler.go ~log:(create_log ())
       (Main.setup () >>= fun setup ->
-       let dirs =
-         match dirs with
-         | [] -> [Path.root]
-         | _  -> List.map dirs ~f:Path.(relative root)
-       in
+       let dirs = List.map dirs ~f:Path.(relative root) in
        let targets =
          List.map dirs ~f:(fun dir ->
            let dir =
@@ -225,15 +222,75 @@ let runtest =
        Build_system.do_build_exn setup.build_system targets) in
   ( Term.(const go
           $ common
-          $ Arg.(value & pos_all string [] name_))
+          $ Arg.(value & pos_all string ["."] name_))
   , Term.info "runtest" ~doc ~man:help_secs)
 
+let opam_installer (setup : Main.setup) =
+  match Context.which setup.context "opam-installer" with
+  | None ->
+    die "\
+Sorry, you need the opam-installer tool to be able to install or
+uninstall packages.
+
+I couldn't find the opam-installer binary :-("
+  | Some fn -> fn
+
+let get_prefix (setup : Main.setup) ~from_command_line =
+  match from_command_line with
+  | Some p -> Future.return (Path.of_string p)
+  | None -> Context.install_prefix setup.context
+
+let install_uninstall ~what =
+  let doc = sprintf "%s packages" what in
+  let name_ = Arg.info [] ~docv:"PACKAGE" in
+  let go common prefix pkgs =
+    set_common common;
+    Future.Scheduler.go ~log:(create_log ())
+      (Main.setup () >>= fun setup ->
+       let opam_installer = opam_installer setup in
+       let install_files, missing_install_files =
+         List.partition_map pkgs ~f:(fun pkg ->
+           let fn = resolve_package_install setup pkg in
+           if Path.exists fn then
+             Inl fn
+           else
+             Inr pkg)
+       in
+       if missing_install_files <> [] then begin
+         die "The <package>.install files for these packages are missing:\n\
+              %s\n\
+              You need to run: jbuilder build %s"
+           (String.concat ~sep:"\n"
+              (List.map missing_install_files ~f:(sprintf "- %s")))
+           (String.concat ~sep:" " (List.map pkgs ~f:(sprintf "%s.install")))
+       end;
+       get_prefix setup ~from_command_line:prefix >>= fun prefix ->
+       Future.all_unit
+         (List.map install_files ~f:(fun path ->
+            Future.run (Path.to_string opam_installer)
+              [ sprintf "-%c" what.[0]
+              ; "--prefix"
+              ; Path.to_string prefix
+              ; Path.to_string path
+              ])))
+  in
+  ( Term.(const go
+          $ common
+          $ Arg.(value & opt (some dir) None & info ["prefix"])
+          $ Arg.(value & pos_all string [] name_))
+  , Term.info what ~doc ~man:help_secs)
+
+let install   = install_uninstall ~what:"install"
+let uninstall = install_uninstall ~what:"uninstall"
+
 let all =
   [ internal
   ; build_package
   ; external_lib_deps
   ; build_targets ~name:"build"
   ; runtest
+  ; install
+  ; uninstall
   ]
 
 let () =

src/ansi_color.ml

@@ -160,7 +160,10 @@ let setup_env_for_ocaml_colors = lazy(
       | exception Not_found -> "color=always,_"
       | s -> "color=always," ^ s
     in
-    Unix.putenv "OCAMLPARAM" value
+    Unix.putenv "OCAMLPARAM" value;
+    match Sys.getenv "OPAMCOLOR" with
+    | exception Not_found -> Unix.putenv "OPAMCOLOR" "always"
+    | _ -> ()
   end
 )
 

src/context.ml

@@ -21,6 +21,7 @@ type t =
   ; env                     : string array
   ; findlib_path            : Path.t list
   ; arch_sixtyfour          : bool
+  ; opam_var_cache : (string, string) Hashtbl.t
   ; version                 : string
   ; stdlib_dir              : Path.t
   ; ccomp_type              : string
@@ -64,7 +65,25 @@ let get_arch_sixtyfour stdlib_dir =
     | ["#define"; "ARCH_SIXTYFOUR"] -> true
     | _ -> false)
 
+let opam_config_var ~env ~cache var =
+  match Hashtbl.find cache var with
+  | Some _ as x -> return x
+  | None ->
+    match Bin.opam with
+    | None -> return None
+    | Some fn ->
+      Future.run_capture (Path.to_string fn) ~env ["config"; "var"; var]
+      >>| fun s ->
+      let s = String.trim s in
+      Hashtbl.add cache ~key:var ~data:s;
+      Some s
+
 let create ~(kind : Kind.t) ~path ~env =
+  let opam_var_cache = Hashtbl.create 128 in
+  (match kind with
+   | Opam { root; _ } ->
+     Hashtbl.add opam_var_cache ~key:"root" ~data:root
+   | Default -> ());
   let name =
     match kind with
     | Default -> "default"
@@ -99,13 +118,10 @@ let create ~(kind : Kind.t) ~path ~env =
   let ocamlc_config_cmd = sprintf "%s -config" (Path.to_string ocamlc) in
   both
     (both
-       (match Bin.opam with
-        | None ->
-          return []
-        | Some fn ->
-          Future.run_capture_line ~env (Path.to_string fn)
-            ["config"; "var"; "lib"]
-          >>| fun s -> [Path.absolute s])
+       (opam_config_var ~env ~cache:opam_var_cache "lib"
+        >>| function
+        | None -> []
+        | Some s -> [Path.absolute s])
        (match which "ocamlfind" with
         | None ->
           return []
@@ -172,6 +188,8 @@ let create ~(kind : Kind.t) ~path ~env =
     ; findlib_path
     ; arch_sixtyfour = get_arch_sixtyfour stdlib_dir
 
+    ; opam_var_cache
+
     ; stdlib_dir
     ; version                 = get       "version"
     ; ccomp_type              = get       "ccomp_type"
@@ -210,6 +228,8 @@ let create ~(kind : Kind.t) ~path ~env =
   all_known := String_map.add !all_known ~key:name ~data:t;
   return t
 
+let opam_config_var t var = opam_config_var ~env:t.env ~cache:t.opam_var_cache var
+
 let initial_env = lazy (
   Lazy.force Ansi_color.setup_env_for_ocaml_colors;
   Unix.environment ())
@@ -269,3 +289,8 @@ let create_for_opam ?root ~switch () =
     create ~kind:(Opam { root; switch }) ~path ~env:(extend_env ~vars ~env)
 
 let which t s = Bin.which ~path:t.path s
+
+let install_prefix t =
+  opam_config_var t "prefix" >>| function
+  | Some x -> Path.absolute x
+  | None   -> Path.parent t.ocaml_bin

src/context.mli

@@ -56,6 +56,8 @@ type t =
   ; (** Misc *)
     arch_sixtyfour : bool
 
+  ; opam_var_cache : (string, string) Hashtbl.t
+
   ; (** Output of [ocamlc -config] *)
     version                 : string
   ; stdlib_dir              : Path.t
@@ -100,3 +102,7 @@ val all : unit -> t String_map.t
 val which : t -> string -> Path.t option
 
 val extend_env : vars:string String_map.t -> env:string array -> string array
+
+val opam_config_var : t -> string -> string option Future.t
+
+val install_prefix : t -> Path.t Future.t

src/import.ml

@@ -68,6 +68,12 @@ module List = struct
     match l with
     | [] -> None
     | x :: l -> if f x then Some x else find l ~f
+
+  let longest_map l ~f =
+    fold_left l ~init:0 ~f:(fun acc x ->
+      max acc (String.length (f x)))
+
+  let longest l = longest_map l ~f:(fun x -> x)
 end
 
 module Hashtbl = struct

src/jbuild_types.ml

@@ -817,10 +817,7 @@ module Stanza = struct
     in
     let known_packages () =
       let visible_packages = String_map.bindings visible_packages in
-      let longest_pkg =
-        List.fold_left visible_packages ~init:0 ~f:(fun acc (pkg, _) ->
-          max (String.length pkg) acc)
-      in
+      let longest_pkg = List.longest_map visible_packages ~f:fst in
       String.concat ~sep:"\n"
         (List.map visible_packages ~f:(fun (pkg, dir) ->
            sprintf "- %-*s (because of %s)" longest_pkg pkg

src/path.ml

@@ -69,14 +69,16 @@ module Local = struct
       loop t [] len len
 
   let parent = function
-    | "" -> assert false
+    | "" ->
+      code_errorf "Path.Local.parent called on the root"
     | t ->
       match String.rindex_from t (String.length t - 1) '/' with
       | exception Not_found -> ""
       | i -> String.sub t ~pos:0 ~len:i
 
   let basename = function
-    | "" -> assert false
+    | "" ->
+      code_errorf "Path.Local.basename called on the root"
     | t ->
       let len = String.length t in
       match String.rindex_from t (len - 1) '/' with
@@ -174,6 +176,8 @@ let to_string = function
   | "" -> "."
   | t  -> t
 
+let sexp_of_t t = Sexp.Atom (to_string t)
+
 let root = ""
 
 let relative t fn =
@@ -198,7 +202,11 @@ let absolute =
 let reach t ~from =
   match is_local t, is_local from with
   | false, _ -> t
-  | true, false -> assert false
+  | true, false ->
+    Sexp.code_error "Path.reach called with invalid combination"
+      [ "t"   , sexp_of_t t
+      ; "from", sexp_of_t from
+      ]
   | true, true -> Local.reach t ~from
 
 let descendant t ~of_ =

src/sexp.ml

@@ -61,6 +61,13 @@ let rec to_string = function
   | Atom s -> if must_escape s then sprintf "%S" s else s
   | List l -> sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ")
 
+let code_error message vars =
+  code_errorf "%s"
+    (to_string
+       (List (Atom message
+              :: List.map vars ~f:(fun (name, value) ->
+                List [Atom name; value]))))
+
 module type Combinators = sig
   type 'a t
   val unit       : unit                      t

src/sexp.mli

@@ -9,6 +9,8 @@ exception Of_sexp_error of t * string
 val of_sexp_error : t -> string -> _
 val of_sexp_errorf : t -> ('a, unit, string, 'b) format4 -> 'a
 
+val code_error : string -> (string * t) list -> _
+
 module Locs : sig
   type t =
     | Atom of Loc.t